Merge pull request #86 from clash-lang/DSE

Disjoint expression consolidation

CLaSH.hs

@@ -29,8 +29,8 @@ doHDL :: Backend s
 doHDL b src = do
   pd      <- primDir b
   primMap <- generatePrimMap [pd,"."]
-  (bindingsMap,tcm,topEntM) <- generateBindings primMap src Nothing
-  generateHDL bindingsMap (Just b) primMap tcm ghcTypeToHWType reduceConstant topEntM (CLaSHOpts 20 20 15 DebugName)
+  (bindingsMap,tcm,tupTcm,topEntM) <- generateBindings primMap src Nothing
+  generateHDL bindingsMap (Just b) primMap tcm tupTcm ghcTypeToHWType reduceConstant topEntM (CLaSHOpts 20 20 15 DebugName)
 
 main :: IO ()
 main = genVHDL "./examples/FIR.hs"

clash-ghc/CHANGELOG.md

@@ -3,6 +3,26 @@
 ## 0.6.1
 * New features:
   * Support for `clash-prelude` 0.10.1
+  * Transformation that lifts applications of the same function out of alternatives of case-statements. e.g.
+
+    ```haskell
+    case x of
+      A -> f 3 y
+      B -> f x x
+      C -> h x
+    ```
+
+    is transformed into:
+
+    ```haskell
+    let f_arg0 = case x of {A -> 3; B -> x}
+        f_arg1 = case x of {A -> y; B -> x}
+        f_out  = f f_arg0 f_arg1
+    in  case x of
+          A -> f_out
+          B -> f_out
+          C -> h x
+    ```
 
 * Fixes bugs:
   * clash won't run when not compiled with usual ghc [#82](https://github.com/clash-lang/clash-compiler/issues/82)

clash-ghc/src-bin/InteractiveUI.hs

@@ -1584,9 +1584,9 @@ makeHDL backend optsRef srcs = do
               primDir <- CLaSH.Backend.primDir backend
               primMap <- CLaSH.Primitives.Util.generatePrimMap [primDir,"."]
               forM_ srcs $ \src -> do
-                (bindingsMap,tcm,topEntM) <- generateBindings primMap src (Just dflags)
+                (bindingsMap,tcm,tupTcm,topEntM) <- generateBindings primMap src (Just dflags)
                 CLaSH.Driver.generateHDL bindingsMap (Just backend) primMap tcm
-                  ghcTypeToHWType reduceConstant topEntM opts
+                  tupTcm ghcTypeToHWType reduceConstant topEntM opts
 
 makeVHDL :: IORef CLaSHOpts -> [FilePath] -> InputT GHCi ()
 makeVHDL = makeHDL' (CLaSH.Backend.initBackend :: VHDLState)

clash-ghc/src-ghc/CLaSH/GHC/GHC2Core.hs

@@ -8,8 +8,11 @@
 
 module CLaSH.GHC.GHC2Core
   ( GHC2CoreState
+  , tyConMap
   , coreToTerm
   , coreToId
+  , coreToName
+  , qualfiedNameString
   , makeAllTyCons
   , emptyGHC2CoreState
   )

clash-ghc/src-ghc/CLaSH/GHC/GenerateBindings.hs

@@ -2,18 +2,24 @@ module CLaSH.GHC.GenerateBindings
   (generateBindings)
 where
 
+import           Control.Lens            ((%~),(&))
 import           Control.Monad.State     (State)
 import qualified Control.Monad.State     as State
 import           Data.Either             (lefts, rights)
 import           Data.HashMap.Strict     (HashMap)
 import qualified Data.HashMap.Strict     as HashMap
+import           Data.IntMap.Strict      (IntMap)
+import qualified Data.IntMap.Strict      as IM
 import           Data.List               (isSuffixOf)
 import qualified Data.Set                as Set
 import qualified Data.Set.Lens           as Lens
 import           Unbound.Generics.LocallyNameless (name2String, runFreshM, unembed)
 
+import qualified BasicTypes              as GHC
 import qualified CoreSyn                 as GHC
 import qualified DynFlags                as GHC
+import qualified TyCon                   as GHC
+import qualified TysWiredIn              as GHC
 
 import           CLaSH.Annotations.TopEntity (TopEntity)
 import           CLaSH.Core.FreeVars     (termFreeIds)
@@ -25,8 +31,8 @@ import           CLaSH.Core.Subst        (substTms)
 import           CLaSH.Core.Util         (mkLams, mkTyLams, termType)
 import           CLaSH.Core.Var          (Var (..))
 import           CLaSH.Driver.Types      (BindingMap)
-import           CLaSH.GHC.GHC2Core      (GHC2CoreState, coreToId, coreToTerm,
-                                          makeAllTyCons, emptyGHC2CoreState)
+import           CLaSH.GHC.GHC2Core      (GHC2CoreState, tyConMap, coreToId, coreToName, coreToTerm,
+                                          makeAllTyCons, qualfiedNameString, emptyGHC2CoreState)
 import           CLaSH.GHC.LoadModules   (loadModules)
 import           CLaSH.Normalize.Util
 import           CLaSH.Primitives.Types  (PrimMap)
@@ -37,16 +43,17 @@ generateBindings ::
   PrimMap
   -> String
   -> Maybe  (GHC.DynFlags)
-  -> IO (BindingMap,HashMap TyConName TyCon,Maybe TopEntity)
+  -> IO (BindingMap,HashMap TyConName TyCon,IntMap TyConName,Maybe TopEntity)
 generateBindings primMap modName dflagsM = do
   (bindings,clsOps,unlocatable,fiEnvs,topEntM) <- loadModules modName dflagsM
   let ((bindingsMap,clsVMap),tcMap) = State.runState (mkBindings primMap bindings clsOps unlocatable) emptyGHC2CoreState
-      tcCache                       = makeAllTyCons tcMap fiEnvs
+      (tcMap',tupTcCache)           = mkTupTyCons tcMap
+      tcCache                       = makeAllTyCons tcMap' fiEnvs
       allTcCache                    = tysPrimMap `HashMap.union` tcCache
       clsMap                        = HashMap.map (\(ty,i) -> (ty,mkClassSelector allTcCache ty i)) clsVMap
       allBindings                   = bindingsMap `HashMap.union` clsMap
       droppedAndRetypedBindings     = dropAndRetypeBindings allTcCache allBindings
-  return (droppedAndRetypedBindings,allTcCache,topEntM)
+  return (droppedAndRetypedBindings,allTcCache,tupTcCache,topEntM)
 
 dropAndRetypeBindings :: HashMap TyConName TyCon -> BindingMap -> BindingMap
 dropAndRetypeBindings allTcCache allBindings = oBindings
@@ -131,11 +138,20 @@ mkClassSelector tcm ty sel = newExpr
     newExpr = case coreView tcm dictTy of
       (TyConApp _ _) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do
                           (dcId,dcVar) <- mkInternalVar "dict" dictTy
-                          selE         <- mkSelectorCase "mkClassSelector" tcm [] dcVar 1 sel
+                          selE         <- mkSelectorCase "mkClassSelector" tcm dcVar 1 sel
                           return (mkTyLams (mkLams selE [dcId]) tvs)
       (FunTy arg res) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do
                            (dcId,dcVar) <- mkInternalVar "dict" (mkFunTy arg res)
                            return (mkTyLams (mkLams dcVar [dcId]) tvs)
       (OtherType oTy) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do
                            (dcId,dcVar) <- mkInternalVar "dict" oTy
                            return (mkTyLams (mkLams dcVar [dcId]) tvs)
+
+mkTupTyCons :: GHC2CoreState -> (GHC2CoreState,IntMap TyConName)
+mkTupTyCons tcMap = (tcMap'',tupTcCache)
+  where
+    tupTyCons        = map (GHC.tupleTyCon GHC.BoxedTuple) [2..62]
+    (tcNames,tcMap') = State.runState (mapM (\tc -> coreToName GHC.tyConName GHC.tyConUnique qualfiedNameString tc) tupTyCons) tcMap
+    tupTcCache       = IM.fromList (zip [2..62] tcNames)
+    tupHM            = HashMap.fromList (zip tcNames tupTyCons)
+    tcMap''          = tcMap' & tyConMap %~ (`HashMap.union` tupHM)

clash-lib/CHANGELOG.md

@@ -3,6 +3,26 @@
 ## 0.6.1
 * New features:
   * Support for `clash-prelude` 0.10.1
+  * Transformation that lifts applications of the same function out of alternatives of case-statements. e.g.
+
+    ```haskell
+    case x of
+      A -> f 3 y
+      B -> f x x
+      C -> h x
+    ```
+
+    is transformed into:
+
+    ```haskell
+    let f_arg0 = case x of {A -> 3; B -> x}
+        f_arg1 = case x of {A -> y; B -> x}
+        f_out  = f f_arg0 f_arg1
+    in  case x of
+          A -> f_out
+          B -> f_out
+          C -> h x
+    ```
 
 * Fixes bugs:
   * Case-statements acting like normal decoder circuits are erroneously synthesised to priority decoder circuits.

clash-lib/clash-lib.cabal

@@ -72,6 +72,8 @@ Library
   other-extensions:   CPP
                       DeriveAnyClass
                       DeriveGeneric
+                      DeriveFoldable
+                      DeriveFunctor
                       FlexibleContexts
                       FlexibleInstances
                       GeneralizedNewtypeDeriving
@@ -140,6 +142,7 @@ Library
                       CLaSH.Netlist.Util
 
                       CLaSH.Normalize
+                      CLaSH.Normalize.DEC
                       CLaSH.Normalize.PrimitiveReductions
                       CLaSH.Normalize.Strategy
                       CLaSH.Normalize.Transformations

clash-lib/src/CLaSH/Core/Term.hs

@@ -57,7 +57,7 @@ data Pat
   -- ^ Literal pattern
   | DefaultPat
   -- ^ Default pattern
-  deriving (Show,Generic,NFData,Alpha)
+  deriving (Eq,Show,Generic,NFData,Alpha)
 
 instance Eq Term where
   (==) = aeq

clash-lib/src/CLaSH/Driver.hs

@@ -10,6 +10,7 @@ import           Control.Monad.State              (evalState, get)
 import           Data.HashMap.Strict              (HashMap)
 import qualified Data.HashMap.Strict              as HashMap
 import qualified Data.HashSet                     as HashSet
+import           Data.IntMap                      (IntMap)
 import           Data.List                        (isSuffixOf)
 import           Data.Maybe                       (fromMaybe, listToMaybe)
 import qualified Data.Text.Lazy                   as Text
@@ -41,12 +42,13 @@ generateHDL :: forall backend . Backend backend
             -> Maybe backend
             -> PrimMap -- ^ Primitive / BlackBox Definitions
             -> HashMap TyConName TyCon -- ^ TyCon cache
+            -> IntMap TyConName -- ^ Tuple TyCon cache
             -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator
             -> (HashMap TyConName TyCon -> Bool -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction)
             -> Maybe TopEntity
             -> CLaSHOpts -- ^ Debug information level for the normalization process
             -> IO ()
-generateHDL bindingsMap hdlState primMap tcm typeTrans eval teM opts = do
+generateHDL bindingsMap hdlState primMap tcm tupTcm typeTrans eval teM opts = do
   start <- Clock.getCurrentTime
   prepTime <- start `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime
   let prepStartDiff = Clock.diffUTCTime prepTime start
@@ -75,7 +77,7 @@ generateHDL bindingsMap hdlState primMap tcm typeTrans eval teM opts = do
       let doNorm     = do norm <- normalize [fst topEntity]
                           let normChecked = checkNonRecursive (fst topEntity) norm
                           cleanupGraph (fst topEntity) normChecked
-          transformedBindings = runNormalization opts supplyN bindingsMap typeTrans tcm eval doNorm
+          transformedBindings = runNormalization opts supplyN bindingsMap typeTrans tcm tupTcm eval doNorm
 
       normTime <- transformedBindings `deepseq` Clock.getCurrentTime
       let prepNormDiff = Clock.diffUTCTime normTime prepTime
@@ -96,7 +98,7 @@ generateHDL bindingsMap hdlState primMap tcm typeTrans eval teM opts = do
                                 netlist
 
       (testBench,dfiles') <- genTestBench opts supplyTB primMap
-                                 typeTrans tcm eval cmpCnt bindingsMap
+                                 typeTrans tcm tupTcm eval cmpCnt bindingsMap
                                  (listToMaybe $ map fst $ HashMap.toList testInputs)
                                  (listToMaybe $ map fst $ HashMap.toList expectedOutputs)
                                  modName

clash-lib/src/CLaSH/Driver/TestbenchGen.hs

@@ -11,6 +11,7 @@ import           Control.Concurrent.Supply        (Supply)
 import           Control.Lens                     ((.=))
 import           Data.HashMap.Lazy                (HashMap)
 import qualified Data.HashMap.Lazy                as HashMap
+import           Data.IntMap.Strict               (IntMap)
 import           Data.List                        (find,nub)
 import           Data.Maybe                       (catMaybes,mapMaybe)
 import           Data.Text.Lazy                   (append,pack,splitOn)
@@ -40,6 +41,7 @@ genTestBench :: CLaSHOpts
              -> PrimMap                      -- ^ Primitives
              -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))
              -> HashMap TyConName TyCon
+             -> IntMap TyConName
              -> (HashMap TyConName TyCon -> Bool -> Term -> Term)
              -> Int
              -> HashMap TmName (Type,Term)   -- ^ Global binders
@@ -49,7 +51,7 @@ genTestBench :: CLaSHOpts
              -> [(String,FilePath)]          -- ^ Set of collected data-files
              -> Component                    -- ^ Component to generate TB for
              -> IO ([Component],[(String,FilePath)])
-genTestBench opts supply primMap typeTrans tcm eval cmpCnt globals stimuliNmM expectedNmM modName dfiles
+genTestBench opts supply primMap typeTrans tcm tupTcm eval cmpCnt globals stimuliNmM expectedNmM modName dfiles
   (Component cName hidden [inp] [outp] _) = do
   let ioDecl  = [ uncurry NetDecl inp
                 , uncurry NetDecl outp
@@ -99,9 +101,9 @@ genTestBench opts supply primMap typeTrans tcm eval cmpCnt globals stimuliNmM ex
                     -> TmName
                     -> HashMap TmName (Type,Term)
     normalizeSignal glbls bndr =
-      runNormalization opts supply glbls typeTrans tcm eval (normalize [bndr] >>= cleanupGraph bndr)
+      runNormalization opts supply glbls typeTrans tcm tupTcm eval (normalize [bndr] >>= cleanupGraph bndr)
 
-genTestBench opts _ _ _ _ _ _ _ _ _ _ dfiles c = traceIf (opt_dbgLevel opts > DebugNone) ("Can't make testbench for: " ++ show c) $ return ([],dfiles)
+genTestBench opts _ _ _ _ _ _ _ _ _ _ _ dfiles c = traceIf (opt_dbgLevel opts > DebugNone) ("Can't make testbench for: " ++ show c) $ return ([],dfiles)
 
 genClock :: PrimMap
          -> (Identifier,HWType)

clash-lib/src/CLaSH/Netlist.hs

@@ -199,7 +199,7 @@ mkDeclarations bndr e@(Case scrut _ [alt]) = do
                                         -- When element and subject have the same HW-type,
                                         -- then the projections is just the identity
                                         | otherwise      -> Just (DC (Void,0))
-        _                      -> error $ $(curLoc) ++ "Not in normal form: Unexpected pattern in case-projection: " ++ showDoc e
+        _ -> Nothing
       extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier
   return (decls ++ [Assignment dstId extractExpr])
 

clash-lib/src/CLaSH/Normalize.hs

@@ -9,6 +9,7 @@ import qualified Control.Lens                     as Lens
 import           Data.Either                      (partitionEithers)
 import           Data.HashMap.Strict              (HashMap)
 import qualified Data.HashMap.Strict              as HashMap
+import           Data.IntMap.Strict               (IntMap)
 import           Data.List                        (mapAccumL,intersect)
 import qualified Data.Map                         as Map
 import qualified Data.Maybe                       as Maybe
@@ -52,18 +53,21 @@ runNormalization :: CLaSHOpts
                  -- ^ Hardcoded Type -> HWType translator
                  -> HashMap TyConName TyCon
                  -- ^ TyCon cache
+                 -> IntMap TyConName
+                 -- ^ Tuple TyCon cache
                  -> (HashMap TyConName TyCon -> Bool -> Term -> Term)
                  -- ^ Hardcoded evaluator (delta-reduction)
                  -> NormalizeSession a
                  -- ^ NormalizeSession to run
                  -> a
-runNormalization opts supply globals typeTrans tcm eval
+runNormalization opts supply globals typeTrans tcm tupTcm eval
   = runRewriteSession rwEnv rwState
   where
     rwEnv     = RewriteEnv
                   (opt_dbgLevel opts)
                   typeTrans
                   tcm
+                  tupTcm
                   eval
 
     rwState   = RewriteState