Add concurrent normalization

Co-authored-by: Vanessa McHale <[email protected]>

Author: 2 people

.ci/bindist/linux/debian/focal/buildinfo.json

@@ -26,6 +26,16 @@
       "src": {"type": "hackage", "version": "0.7.0.12"},
       "cabal_debian_options": ["--disable-tests"]
     },
+    {
+      "name": "atomic-primops",
+      "src": {"type": "hackage", "version": "0.8.4"},
+      "cabal_debian_options": ["--disable-tests"]
+    },
+    {
+      "name": "lockfree-queue",
+      "src": {"type": "hackage", "version": "0.2.3.1"},
+      "cabal_debian_options": ["--disable-tests"]
+    },
     {
       "name": "ghc-tcplugins-extra",
       "src": {"type": "hackage"}

benchmark/benchmark-normalization.hs

@@ -15,6 +15,7 @@ import           Clash.Netlist.Types          (TopEntityT(topId))
 
 import           Criterion.Main
 
+import qualified Control.Concurrent.MVar      as MVar
 import qualified Control.Concurrent.Supply    as Supply
 import           Control.DeepSeq              (NFData(..), rwhnf)
 import           Data.List                    (isPrefixOf, partition)
@@ -42,7 +43,7 @@ main = do
 benchFile :: [FilePath] -> FilePath -> Benchmark
 benchFile idirs src =
   env (setupEnv idirs src) $
-    \ ~(clashEnv, clashDesign, supplyN) -> do
+    \ ~(clashEnv, clashDesign, supplyN, lock) -> do
       bench ("normalization of " ++ src)
             (nfIO
               (normalizeEntity
@@ -51,18 +52,20 @@ benchFile idirs src =
                  (ghcTypeToHWType (opt_intWidth (envOpts clashEnv)))
                  ghcEvaluator
                  evaluator
+                 lock
                  (fmap topId (designEntities clashDesign))
                  supplyN
                  (topId (head (designEntities clashDesign)))))
 
 setupEnv
   :: [FilePath]
   -> FilePath
-  -> IO (ClashEnv, ClashDesign, Supply.Supply)
+  -> IO (ClashEnv, ClashDesign, Supply.Supply, MVar.MVar ())
 setupEnv idirs src = do
   (clashEnv, clashDesign) <- runInputStage idirs src
   supplyN <- Supply.newSupply
-  return (clashEnv, clashDesign ,supplyN)
+  lock <- MVar.newMVar ()
+  return (clashEnv, clashDesign ,supplyN, lock)
 
 instance NFData Supply.Supply where
   rnf = rwhnf

benchmark/common/BenchmarkCommon.hs

@@ -15,6 +15,7 @@ import Clash.GHC.Evaluator
 import Clash.GHC.GenerateBindings
 import Clash.GHC.NetlistTypes
 
+import qualified Control.Concurrent.MVar as MVar
 import qualified Control.Concurrent.Supply as Supply
 
 defaultTests :: [FilePath]
@@ -57,6 +58,7 @@ runNormalisationStage
   -> IO (ClashEnv, ClashDesign, Id)
 runNormalisationStage idirs src = do
   supplyN <- Supply.newSupply
+  lock <- MVar.newMVar ()
   (env, design) <- runInputStage idirs src
   let topEntityNames = fmap topId (designEntities design)
   let topEntity = head topEntityNames
@@ -65,5 +67,6 @@ runNormalisationStage idirs src = do
           (ghcTypeToHWType (opt_intWidth (opts idirs)))
           ghcEvaluator
           evaluator
+          lock
           topEntityNames supplyN topEntity
   return (env, design{designBindings=transformedBindings},topEntity)

benchmark/profiling/run/profile-normalization-run.hs

@@ -7,6 +7,7 @@ import           Clash.GHC.PartialEval
 import           Clash.GHC.Evaluator
 import           Clash.GHC.NetlistTypes       (ghcTypeToHWType)
 
+import qualified Control.Concurrent.MVar      as MVar
 import qualified Control.Concurrent.Supply    as Supply
 import           Control.DeepSeq              (deepseq)
 import           Data.Binary                  (decode)
@@ -32,6 +33,7 @@ main = do
 benchFile :: [FilePath] -> FilePath -> IO ()
 benchFile idirs src = do
   supplyN <- Supply.newSupply
+  lock <- MVar.newMVar ()
   (bindingsMap,tcm,tupTcm,primMap,reprs,topEntityNames,topEntity) <- setupEnv src
   putStrLn $ "Doing normalization of " ++ src
 
@@ -47,6 +49,7 @@ benchFile idirs src = do
                    (ghcTypeToHWType (opt_intWidth (envOpts clashEnv)))
                    ghcEvaluator
                    evaluator
+                   lock
                    topEntityNames supplyN topEntity
   res `deepseq` putStrLn ".. done\n"
 

changelog/2022-03-21T11_09_46-05_00_concurrent_normalization

@@ -0,0 +1 @@
+CHANGED: Add concurrent normalization flag [#2074](https://github.com/clash-lang/clash-compiler/pull/2074)

clash-ghc/clash-ghc.cabal

@@ -77,7 +77,7 @@ executable clash
 executable clashi
   Main-Is:            src-ghc/Interactive.hs
   Build-Depends:      base, clash-ghc
-  GHC-Options:        -Wall -Wcompat -rtsopts -with-rtsopts=-A128m
+  GHC-Options:        -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-A128m
   if flag(dynamic)
     GHC-Options: -dynamic
   extra-libraries:    pthread

clash-ghc/src-ghc/Clash/GHC/ClashFlags.hs

@@ -89,6 +89,7 @@ flagsClash r = [
   , defFlag "fclash-inline-workfree-limit"       $ IntSuffix (liftEwM . setInlineWFLimit r)
   , defFlag "fclash-edalize"                     $ NoArg (liftEwM (setEdalize r))
   , defFlag "fclash-no-render-enums"             $ NoArg (liftEwM (setNoRenderEnums r))
+  , defFlag "fclash-concurrent-normalization"    $ NoArg (liftEwM (setConcurrentNormalization r))
   ]
 
 -- | Print deprecated flag warning
@@ -313,6 +314,9 @@ setAggressiveXOptBB r = modifyIORef r (\c -> c { opt_aggressiveXOptBB = True })
 setEdalize :: IORef ClashOpts -> IO ()
 setEdalize r = modifyIORef r (\c -> c { opt_edalize = True })
 
+setConcurrentNormalization :: IORef ClashOpts -> IO ()
+setConcurrentNormalization r = modifyIORef r (\c -> c { opt_concurrentNormalization = True })
+
 setRewriteHistoryFile :: IORef ClashOpts -> String -> IO ()
 setRewriteHistoryFile r arg = do
   let fileNm = case drop (length "-fclash-debug-history=") arg of

clash-lib/clash-lib.cabal

@@ -130,7 +130,6 @@ Library
                       aeson-pretty            >= 0.8      && < 0.9,
                       ansi-terminal           >= 0.8.0.0  && < 0.12,
                       array,
-                      async                   >= 2.2.0    && < 2.3,
                       attoparsec              >= 0.10.4.0 && < 0.15,
                       base                    >= 4.11     && < 5,
                       base16-bytestring       >= 0.1.1    && < 1.1,
@@ -155,6 +154,10 @@ Library
                       hint                    >= 0.7      && < 0.10,
                       interpolate             >= 0.2.0    && < 1.0,
                       lens                    >= 4.10     && < 5.1.0,
+                      lifted-async            >=0.10      && <0.11,
+                      lifted-base             >=0.2       && <0.3,
+                      lockfree-queue          >=0.2       && <0.3,
+                      monad-control           >=1.0       && <1.1,
                       mtl                     >= 2.1.2    && < 2.3,
                       ordered-containers      >= 0.2      && < 0.3,
                       prettyprinter           >= 1.2.0.1  && < 1.8,
@@ -166,6 +169,7 @@ Library
                       text                    >= 1.2.2    && < 2.1,
                       time                    >= 1.4.0.1  && < 1.14,
                       transformers            >= 0.5.2.0  && < 0.7,
+                      transformers-base,
                       trifecta                >= 1.7.1.1  && < 2.2,
                       vector                  >= 0.11     && < 1.0,
                       vector-binary-instances >= 0.2.3.5  && < 0.3,

clash-lib/src/Clash/Core/PartialEval/Monad.hs

@@ -1,5 +1,5 @@
 {-|
-Copyright   : (C) 2020-2021, QBayLogic B.V.
+Copyright   : (C) 2020-2022, QBayLogic B.V.
 License     : BSD2 (see the file LICENSE)
 Maintainer  : QBayLogic B.V. <[email protected]>
 
@@ -84,7 +84,7 @@ import           Clash.Core.Util (mkUniqSystemId, mkUniqSystemTyVar)
 import           Clash.Core.Var (Id, TyVar, Var)
 import           Clash.Core.VarEnv
 import           Clash.Driver.Types (Binding(..))
-import           Clash.Rewrite.WorkFree (isWorkFree)
+import           Clash.Rewrite.WorkFree (isWorkFreePure)
 
 {-
 NOTE [RWS monad]
@@ -311,7 +311,11 @@ workFreeValue :: Value -> Eval Bool
 workFreeValue = \case
   VNeutral _ -> pure False
   VThunk x _ -> do
-    bindings <- fmap (fmap asTerm) . genvBindings <$> getGlobalEnv
-    isWorkFree workFreeCache bindings x
+    env <- getGlobalEnv
+    let bindings = fmap (fmap asTerm) (genvBindings env)
+    let (cache, wf) = isWorkFreePure (genvWorkCache env) bindings x
+
+    modifyGlobalEnv (\genv -> genv { genvWorkCache = cache })
+    pure wf
 
   _ -> pure True

clash-lib/src/Clash/Core/PartialEval/NormalForm.hs

@@ -1,6 +1,5 @@
 {-|
-Copyright   : (C) 2020-2021, QBayLogic B.V.,
-                  2022     , Google Inc.
+Copyright   : (C) 2020-2022, QBayLogic B.V.
 License     : BSD2 (see the file LICENSE)
 Maintainer  : QBayLogic B.V. <[email protected]>
 
@@ -29,11 +28,9 @@ module Clash.Core.PartialEval.NormalForm
   , Normal(..)
   , LocalEnv(..)
   , GlobalEnv(..)
-  , workFreeCache
   ) where
 
 import Control.Concurrent.Supply (Supply)
-import Control.Lens (Lens', lens)
 import Data.IntMap.Strict (IntMap)
 import Data.Map.Strict (Map)
 
@@ -201,6 +198,3 @@ data GlobalEnv = GlobalEnv
     -- ^ Cache for the results of isWorkFree. This is required to use
     -- Clash.Rewrite.WorkFree.isWorkFree.
   }
-
-workFreeCache :: Lens' GlobalEnv (VarEnv Bool)
-workFreeCache = lens genvWorkCache (\env x -> env { genvWorkCache = x })

clash-lib/src/Clash/Core/VarEnv.hs

@@ -38,12 +38,15 @@ module Clash.Core.VarEnv
     -- ** Conversions
     -- *** Lists
   , eltsVarEnv
+  , toListVarEnv
+  , listToVarEnv
     -- * Sets of variables
   , VarSet
     -- ** Construction
   , emptyVarSet
   , unitVarSet
     -- ** Modification
+  , extendVarSet
   , delVarSetByKey
   , unionVarSet
   , differenceVarSet
@@ -260,6 +263,15 @@ eltsVarEnv
   -> [a]
 eltsVarEnv = eltsUniqMap
 
+toListVarEnv :: VarEnv a -> [(Unique, a)]
+toListVarEnv = toListUniqMap
+
+listToVarEnv
+  :: Uniquable a
+  => [(a, b)]
+  -> VarEnv b
+listToVarEnv = listToUniqMap
+
 -- | Does the variable exist in the environment
 elemVarEnv
   :: Var a

clash-lib/src/Clash/Debug.hs

@@ -3,6 +3,7 @@
 module Clash.Debug
   ( debugIsOn
   , traceIf
+  , traceWhen
   , module Debug.Trace
   ) where
 
@@ -19,4 +20,9 @@ debugIsOn = False
 traceIf :: Bool -> String -> a -> a
 traceIf True  msg = trace msg
 traceIf False _   = id
+
+traceWhen :: Monad m => Bool -> String -> m ()
+traceWhen True = traceM
+traceWhen False = const (pure ())
+
 {-# INLINE traceIf #-}

clash-lib/src/Clash/Driver.hs

@@ -22,7 +22,7 @@
 module Clash.Driver where
 
 import           Control.Concurrent               (MVar, modifyMVar, modifyMVar_, newMVar, withMVar)
-import           Control.Concurrent.Async         (mapConcurrently_)
+import           Control.Concurrent.Async.Lifted  (mapConcurrently_)
 import qualified Control.Concurrent.Supply        as Supply
 import           Control.DeepSeq
 import           Control.Exception                (throw)
@@ -443,7 +443,7 @@ generateHDL env design hdlState typeTrans peEval eval mainTopEntity startTime =
       -- 2. Normalize topEntity
       supplyN <- Supply.newSupply
       transformedBindings <- normalizeEntity env bindingsMap typeTrans peEval
-                               eval topEntityNames supplyN topEntity
+                               eval ioLockV topEntityNames supplyN topEntity
 
       normTime <- transformedBindings `deepseq` Clock.getCurrentTime
       let prepNormDiff = reportTimeDiff normTime prevTime
@@ -1063,21 +1063,23 @@ normalizeEntity
   -- ^ Hardcoded evaluator for partial evaluation
   -> WHNF.Evaluator
   -- ^ Hardcoded evaluator for WHNF (old evaluator)
+  -> MVar ()
+  -- ^ Synchronization for stdout
   -> [Id]
   -- ^ TopEntities
   -> Supply.Supply
   -- ^ Unique supply
   -> Id
   -- ^ root of the hierarchy
   -> IO BindingMap
-normalizeEntity env bindingsMap typeTrans peEval eval topEntities supply tm = transformedBindings
+normalizeEntity env bindingsMap typeTrans peEval eval lock topEntities supply tm = transformedBindings
   where
     doNorm = do norm <- normalize [tm]
                 let normChecked = checkNonRecursive norm
                 cleaned <- cleanupGraph tm normChecked
                 return cleaned
     transformedBindings = runNormalization env supply bindingsMap
-                            typeTrans peEval eval emptyVarEnv
+                            typeTrans peEval eval emptyVarEnv lock
                             topEntities doNorm
 
 -- | topologically sort the top entities