WIP - concurrent normalization

Author: Alex McKenna

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"
 

clash-ghc/clash-ghc.cabal

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

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,
@@ -156,6 +155,7 @@ Library
                       interpolate             >= 0.2.0    && < 1.0,
                       lens                    >= 4.10     && < 5.1.0,
                       -- TODO bounds
+                      lifted-async,
                       lifted-base,
                       monad-control,
                       mtl                     >= 2.1.2    && < 2.3,

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)
@@ -442,7 +442,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
@@ -1062,21 +1062,23 @@ normalizeEntity
   -- ^ Hardcoded evaluator for partial evaluation
   -> WHNF.Evaluator
   -- ^ Hardcoded evaluator for WHNF (old evaluator)
+  -> MVar ()
+  -- ^ Synchroniztion 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

clash-lib/src/Clash/Normalize.hs

@@ -10,17 +10,21 @@
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Clash.Normalize where
 
+import qualified Control.Concurrent.Async.Lifted as Async
+import           Control.Concurrent.MVar.Lifted (MVar)
 import qualified Control.Concurrent.MVar.Lifted as MVar
 import           Control.Concurrent.Supply        (Supply)
 import           Control.Exception                (throw)
 import qualified Control.Lens                     as Lens
 import           Control.Monad                    (when)
+import qualified Control.Monad.IO.Class as Monad  (liftIO)
 import           Control.Monad.State.Strict       (State)
 import           Data.Default                     (def)
 import           Data.Either                      (lefts,partitionEithers)
@@ -79,7 +83,7 @@ import           Clash.Normalize.Util
 import           Clash.Rewrite.Combinators        ((>->),(!->),repeatR,topdownR)
 import           Clash.Rewrite.Types
   (RewriteEnv (..), RewriteState (..), bindings, debugOpts, extra,
-   tcCache, topEntities, newInlineStrategy)
+   tcCache, topEntities, newInlineStrategy, ioLock)
 import           Clash.Rewrite.Util
   (apply, isUntranslatableType, runRewriteSession)
 import           Clash.Util
@@ -89,9 +93,9 @@ import           Data.Binary                      (encode)
 import qualified Data.ByteString                  as BS
 import qualified Data.ByteString.Lazy             as BL
 
-import           System.IO.Unsafe                 (unsafePerformIO)
 import           Clash.Rewrite.Types (RewriteStep(..))
 
+import Clash.Debug -- TODO
 
 -- | Run a NormalizeSession in a given environment
 runNormalization
@@ -109,12 +113,14 @@ runNormalization
   -- ^ Hardcoded evaluator for WHNF (old evaluator)
   -> VarEnv Bool
   -- ^ Map telling whether a components is part of a recursive group
+  -> MVar ()
+  -- ^ Synchronization on stdout
   -> [Id]
   -- ^ topEntities
   -> NormalizeSession a
   -- ^ NormalizeSession to run
   -> IO a
-runNormalization env supply globals typeTrans peEval eval rcsMap entities session = do
+runNormalization env supply globals typeTrans peEval eval rcsMap lock entities session = do
   normState <- NormalizeState
     <$> MVar.newMVar emptyVarEnv
     <*> MVar.newMVar Map.empty
@@ -131,6 +137,7 @@ runNormalization env supply globals typeTrans peEval eval rcsMap entities sessio
     <*> MVar.newMVar 0
     <*> MVar.newMVar (mempty, 0)
     <*> MVar.newMVar emptyVarEnv
+    <*> pure lock
     <*> pure normState
 
   runRewriteSession rwEnv rwState session
@@ -143,20 +150,17 @@ runNormalization env supply globals typeTrans peEval eval rcsMap entities sessio
     , _topEntities = mkVarSet entities
     }
 
-normalize
-  :: [Id]
-  -> NormalizeSession BindingMap
-normalize []  = return emptyVarEnv
-normalize top = do
-  (new,topNormalized) <- unzip <$> mapM normalize' top
-  newNormalized <- normalize (concat new)
-  return (unionVarEnv (mkVarEnv topNormalized) newNormalized)
+normalize :: [Id] -> NormalizeSession BindingMap
+normalize tops = do
+  normBinds <- Async.mapConcurrently normalize' tops
+  pure (mkVarEnv (concat normBinds))
 
-normalize' :: Id -> NormalizeSession ([Id], (Id, Binding Term))
+normalize' :: Id -> NormalizeSession [(Id, Binding Term)]
 normalize' nm = do
   bndrsV <- Lens.use bindings
   exprM <- MVar.withMVar bndrsV (pure . lookupVarEnv nm)
   let nmS = showPpr (varName nm)
+  -- traceM ("normalize: start " <> nmS)
   case exprM of
     Just (Binding nm' sp inl pr tm r) -> do
       tcm <- Lens.view tcCache
@@ -196,11 +200,17 @@ normalize' nm = do
 
             normV <- Lens.use (extra.normalized)
 
-            MVar.withMVar normV $ \norm ->
-              let prevNorm = mapVarEnv bindingId norm
-                  toNormalize = filter (`notElemVarSet` topEnts)
-                              $ filter (`notElemVarEnv` extendVarEnv nm nm prevNorm) usedBndrs
-               in return (toNormalize,(nm,tmNorm))
+            toNormalize <-
+              MVar.withMVar normV $ \norm ->
+                let prevNorm = mapVarEnv bindingId norm
+                    toNormalize = filter (`notElemVarSet` topEnts)
+                                $ filter (`notElemVarEnv` extendVarEnv nm nm prevNorm) usedBndrs
+                 in pure toNormalize
+
+            -- traceM ("normalize: end: " <> nmS)
+
+            normChildren <- Async.mapConcurrently normalize' toNormalize
+            return ((nm, tmNorm) : concat normChildren)
          else
            do
             -- Throw an error for unrepresentable topEntities and functions
@@ -222,7 +232,7 @@ normalize' nm = do
                             , showPpr (coreTypeOf nm')
                             , ") has a non-representable return type."
                             , " Not normalising:\n", showPpr tm] )
-                    (return ([],(nm,(Binding nm' sp inl pr tm r))))
+                    (return [(nm,(Binding nm' sp inl pr tm r))])
 
 
     Nothing -> error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " not found"
@@ -354,18 +364,22 @@ flattenCallTree (CBranch (nm,(Binding nm' sp inl pr tm r)) used) = do
       -- NB: When -fclash-debug-history is on, emit binary data holding the recorded rewrite steps
       opts <- Lens.view debugOpts
       let rewriteHistFile = dbg_historyFile opts
-      when (Maybe.isJust rewriteHistFile) $
-        let !_ = unsafePerformIO
-             $ BS.appendFile (Maybe.fromJust rewriteHistFile)
-             $ BL.toStrict
-             $ encode RewriteStep
-                 { t_ctx    = []
-                 , t_name   = "INLINE"
-                 , t_bndrS  = showPpr (varName nm')
-                 , t_before = tm
-                 , t_after  = tm1
-                 }
-        in pure ()
+
+      when (Maybe.isJust rewriteHistFile) $ do
+        lock <- Lens.use ioLock
+
+        MVar.withMVar lock $ \() ->
+          Monad.liftIO
+            . BS.appendFile (Maybe.fromJust rewriteHistFile)
+            . BL.toStrict
+            $ encode RewriteStep
+                { t_ctx    = []
+                , t_name   = "INLINE"
+                , t_bndrS  = showPpr (varName nm')
+                , t_before = tm
+                , t_after  = tm1
+                }
+
       rewriteExpr ("flattenExpr",flatten) (showPpr nm, tm1) (nm', sp)
   let allUsed = newUsed ++ concat il_used
   -- inline all components when the resulting expression after flattening

clash-lib/src/Clash/Normalize/Transformations/Case.hs

@@ -76,7 +76,7 @@ import Clash.Normalize.Types (NormRewrite, NormalizeSession)
 import Clash.Rewrite.Combinators ((>-!))
 import Clash.Rewrite.Types
   ( TransformContext(..), bindings, customReprs, debugOpts, tcCache
-  , typeTranslator, workFreeBinders)
+  , typeTranslator, workFreeBinders, ioLock)
 import Clash.Rewrite.Util (changed, isFromInt, whnfRW)
 import Clash.Rewrite.WorkFree
 import Clash.Util (curLoc)
@@ -309,14 +309,16 @@ caseCon' ctx@(TransformContext is0 _) e@(Case subj ty alts) = do
             -> caseCon ctx1 (Case (Literal (IntegerLiteral 0)) ty alts)
           _ -> do
             opts <- Lens.view debugOpts
+            ioLockV <- Lens.use ioLock
             -- When invariants are being checked, report missing evaluation
             -- rules for the primitive evaluator.
-            traceIf (dbg_invariants opts && isConstant subj)
-              ("Unmatchable constant as case subject: " ++ showPpr subj ++
-                 "\nWHNF is: " ++ showPpr subj1)
-              -- Otherwise check whether the entire case-expression has a
-              -- single alternative, and pick that one.
-              (caseOneAlt e)
+            MVar.withMVar ioLockV $ \() ->
+              traceIf (dbg_invariants opts && isConstant subj)
+                ("Unmatchable constant as case subject: " ++ showPpr subj ++
+                   "\nWHNF is: " ++ showPpr subj1)
+                -- Otherwise check whether the entire case-expression has a
+                -- single alternative, and pick that one.
+                (caseOneAlt e)
 
   -- The subject is a variable
   (Var v, [], _) | isNum0 (coreTypeOf v) ->