Propagate -Werror to ClashOpts

When running GHC with -Werror, that option is now propagated to
the ClashOpts. This means that warnings on primitive instantiation
will be promoted to errors. This is necessary to test #2046.

changelog/2022-01-31T16_53_31+01_00_werror_clash.md

@@ -0,0 +1 @@
+CHANGED: Clash now respects the -Werror option from GHC

clash-ghc/src-bin-8.10/Clash/Main.hs

@@ -52,6 +52,7 @@ import Packages         ( pprPackages, pprPackagesSimple )
 import DriverPhases
 import BasicTypes       ( failed )
 import DynFlags hiding (WarnReason(..))
+import EnumSet as EnumSet
 import ErrUtils
 import FastString
 import Outputable
@@ -88,7 +89,7 @@ import Data.Maybe
 import           Paths_clash_ghc
 import           Clash.GHCi.UI (makeHDL)
 import           Exception (gcatch)
-import           Data.IORef (IORef, newIORef, readIORef)
+import           Data.IORef (IORef, newIORef, readIORef, modifyIORef')
 import qualified Data.Version (showVersion)
 
 import           Clash.Backend (Backend)
@@ -236,6 +237,10 @@ main' postLoadMode dflags0 args flagWarnings startAction clashOpts = do
   (dflags3, fileish_args, dynamicFlagWarnings) <-
       GHC.parseDynamicFlags dflags2 args
 
+  -- Propagate -Werror to Clash
+  liftIO . modifyIORef' clashOpts $ \opts ->
+    opts { opt_werror = EnumSet.member Opt_WarnIsError (generalFlags dflags3) }
+
   let dflags4 = case lang of
                 HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->
                     let platform = targetPlatform dflags3

clash-ghc/src-bin-861/Clash/Main.hs

@@ -53,6 +53,7 @@ import Packages         ( pprPackages, pprPackagesSimple )
 import DriverPhases
 import BasicTypes       ( failed )
 import DynFlags hiding (WarnReason(..))
+import EnumSet as EnumSet
 import ErrUtils
 import FastString
 import Outputable
@@ -86,7 +87,7 @@ import Data.Maybe
 import           Paths_clash_ghc
 import           Clash.GHCi.UI (makeHDL)
 import           Exception (gcatch)
-import           Data.IORef (IORef, newIORef, readIORef)
+import           Data.IORef (IORef, newIORef, readIORef, modifyIORef')
 import qualified Data.Version (showVersion)
 
 import           Clash.Backend (Backend)
@@ -235,6 +236,10 @@ main' postLoadMode dflags0 args flagWarnings startAction clashOpts = do
   (dflags3, fileish_args, dynamicFlagWarnings) <-
       GHC.parseDynamicFlags dflags2 args
 
+  -- Propagate -Werror to Clash
+  liftIO . modifyIORef' clashOpts $ \opts ->
+    opts { opt_werror = EnumSet.member Opt_WarnIsError (generalFlags dflags3) }
+
   let dflags4 = case lang of
                 HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->
                     let platform = targetPlatform dflags3

clash-ghc/src-bin-881/Clash/Main.hs

@@ -50,6 +50,7 @@ import Packages         ( pprPackages, pprPackagesSimple )
 import DriverPhases
 import BasicTypes       ( failed )
 import DynFlags hiding (WarnReason(..))
+import EnumSet as EnumSet
 import ErrUtils
 import FastString
 import Outputable
@@ -83,7 +84,7 @@ import Data.Maybe
 import           Paths_clash_ghc
 import           Clash.GHCi.UI (makeHDL)
 import           Exception (gcatch)
-import           Data.IORef (IORef, newIORef, readIORef)
+import           Data.IORef (IORef, newIORef, readIORef, modifyIORef')
 import qualified Data.Version (showVersion)
 
 import           Clash.Backend (Backend)
@@ -230,6 +231,10 @@ main' postLoadMode dflags0 args flagWarnings startAction clashOpts = do
   (dflags3, fileish_args, dynamicFlagWarnings) <-
       GHC.parseDynamicFlags dflags2 args
 
+  -- Propagate -Werror to Clash
+  liftIO . modifyIORef' clashOpts $ \opts ->
+    opts { opt_werror = EnumSet.member Opt_WarnIsError (generalFlags dflags3) }
+
   let dflags4 = case lang of
                 HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->
                     let platform = targetPlatform dflags3

clash-ghc/src-bin-9.0/Clash/Main.hs

@@ -54,6 +54,7 @@ import GHC.Driver.Phases
 import GHC.Types.Basic     ( failed )
 import GHC.Driver.Session as DynFlags hiding (WarnReason(..))
 import GHC.Utils.Error
+import GHC.Data.EnumSet as EnumSet
 import GHC.Data.FastString
 import GHC.Utils.Outputable as Outputable
 import GHC.SysTools.BaseDir
@@ -90,7 +91,7 @@ import Prelude
 import           Paths_clash_ghc
 import           Clash.GHCi.UI (makeHDL)
 import           Control.Monad.Catch (catch)
-import           Data.IORef (IORef, newIORef, readIORef)
+import           Data.IORef (IORef, newIORef, readIORef, modifyIORef')
 import qualified Data.Version (showVersion)
 
 import           Clash.Backend (Backend)
@@ -237,6 +238,10 @@ main' postLoadMode dflags0 args flagWarnings startAction clashOpts = do
   (dflags3, fileish_args, dynamicFlagWarnings) <-
       GHC.parseDynamicFlags dflags2 args
 
+  -- Propagate -Werror to Clash
+  liftIO . modifyIORef' clashOpts $ \opts ->
+    opts { opt_werror = EnumSet.member Opt_WarnIsError (generalFlags dflags3) }
+
   let dflags4 = case lang of
                 HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->
                     let platform = targetPlatform dflags3

clash-lib/src/Clash/Driver/Types.hs

@@ -288,7 +288,11 @@ debugAll = debugApplied { dbg_transformationInfo = TryTerm }
 
 -- | Options passed to Clash compiler
 data ClashOpts = ClashOpts
-  { opt_inlineLimit :: Int
+  { opt_werror :: Bool
+  -- ^ Are warnings treated as errors.
+  --
+  -- Command line flag: -Werror
+  , opt_inlineLimit :: Int
   -- ^ Change the number of times a function f can undergo inlining inside
   -- some other function g. This prevents the size of g growing dramatically.
   --
@@ -392,6 +396,7 @@ data ClashOpts = ClashOpts
 
 instance NFData ClashOpts where
   rnf o =
+    opt_werror o `deepseq`
     opt_inlineLimit o `deepseq`
     opt_specLimit o `deepseq`
     opt_inlineFunctionLimit o `deepseq`
@@ -422,6 +427,7 @@ instance NFData ClashOpts where
 
 instance Eq ClashOpts where
   s0 == s1 =
+    opt_werror s0 == opt_werror s1 &&
     opt_inlineLimit s0 == opt_inlineLimit s1 &&
     opt_specLimit s0 == opt_specLimit s1 &&
     opt_inlineFunctionLimit s0 == opt_inlineFunctionLimit s1 &&
@@ -459,6 +465,7 @@ instance Eq ClashOpts where
 instance Hashable ClashOpts where
   hashWithSalt s ClashOpts {..} =
     s `hashWithSalt`
+    opt_werror `hashWithSalt`
     opt_inlineLimit `hashWithSalt`
     opt_specLimit `hashWithSalt`
     opt_inlineFunctionLimit `hashWithSalt`
@@ -495,7 +502,8 @@ instance Hashable ClashOpts where
 defClashOpts :: ClashOpts
 defClashOpts
   = ClashOpts
-  { opt_inlineLimit         = 20
+  { opt_werror              = False
+  , opt_inlineLimit         = 20
   , opt_specLimit           = 20
   , opt_inlineFunctionLimit = 15
   , opt_inlineConstantLimit = 0

clash-lib/src/Clash/Netlist/BlackBox.hs

@@ -46,7 +46,7 @@ import           GHC.Stack
   (HasCallStack, callStack, prettyCallStack)
 import qualified System.Console.ANSI           as ANSI
 import           System.Console.ANSI
-  ( hSetSGR, SGR(SetConsoleIntensity, SetColor), Color(Magenta)
+  ( hSetSGR, SGR(SetConsoleIntensity, SetColor), Color(Magenta, Red)
   , ConsoleIntensity(BoldIntensity), ConsoleLayer(Foreground), ColorIntensity(Vivid))
 import           System.IO
   (hPutStrLn, stderr, hFlush, hIsTerminalDevice)
@@ -88,7 +88,7 @@ import {-# SOURCE #-} Clash.Netlist
 import qualified Clash.Backend                 as Backend
 import           Clash.Debug                   (debugIsOn)
 import           Clash.Driver.Types
-  (opt_primWarn, opt_color, ClashOpts)
+  (ClashOpts(opt_primWarn, opt_color, opt_werror))
 import           Clash.Netlist.BlackBox.Types  as B
 import           Clash.Netlist.BlackBox.Util   as B
 import           Clash.Netlist.Types           as N
@@ -115,10 +115,17 @@ warn opts msg = do
       Auto   -> hIsTerminalDevice stderr
 
   hSetSGR stderr [SetConsoleIntensity BoldIntensity]
-  when useColor $ hSetSGR stderr [SetColor Foreground Vivid Magenta]
-  hPutStrLn stderr $ "[WARNING] " ++ msg
-  hSetSGR stderr [ANSI.Reset]
-  hFlush stderr
+
+  case opt_werror opts of
+    True -> do
+      when useColor $ hSetSGR stderr [SetColor Foreground Vivid Red]
+      throw (ClashException noSrcSpan msg Nothing)
+
+    False -> do
+      when useColor $ hSetSGR stderr [SetColor Foreground Vivid Magenta]
+      hPutStrLn stderr $ "[WARNING] " ++ msg
+      hSetSGR stderr [ANSI.Reset]
+      hFlush stderr
 
 -- | Generate the context for a BlackBox instantiation.
 mkBlackBoxContext