clash-lib 0.6 → 0.6.1

raw patch · 15 files changed

+720/−50 lines, 15 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +27/−0
• clash-lib.cabal +4/−1
• src/CLaSH/Core/Term.hs +1/−1
• src/CLaSH/Driver.hs +5/−3
• src/CLaSH/Driver/TestbenchGen.hs +5/−3
• src/CLaSH/Netlist.hs +4/−4
• src/CLaSH/Netlist/Types.hs +4/−1
• src/CLaSH/Netlist/Util.hs +5/−4
• src/CLaSH/Normalize.hs +5/−1
• src/CLaSH/Normalize/DEC.hs +434/−0
• src/CLaSH/Normalize/PrimitiveReductions.hs +29/−15
• src/CLaSH/Normalize/Strategy.hs +7/−2
• src/CLaSH/Normalize/Transformations.hs +169/−7
• src/CLaSH/Rewrite/Types.hs +3/−0
• src/CLaSH/Rewrite/Util.hs +18/−8

@@ -1,5 +1,32 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.6.1 *October 16th 2015*+* 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.+ ## 0.6 *October 3rd 2015* * New features:   * Support for `clash-prelude` 0.10

@@ -1,5 +1,5 @@ Name:                 clash-lib-Version:              0.6+Version:              0.6.1 Synopsis:             CAES Language for Synchronous Hardware - As a Library Description:   CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -72,6 +72,8 @@   other-extensions:   CPP                       DeriveAnyClass                       DeriveGeneric+                      DeriveFoldable+                      DeriveFunctor                       FlexibleContexts                       FlexibleInstances                       GeneralizedNewtypeDeriving@@ -140,6 +142,7 @@                       CLaSH.Netlist.Util                        CLaSH.Normalize+                      CLaSH.Normalize.DEC                       CLaSH.Normalize.PrimitiveReductions                       CLaSH.Normalize.Strategy                       CLaSH.Normalize.Transformations

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

@@ -10,6 +10,7 @@ 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 @@             -> 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 @@       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 @@                                 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

@@ -11,6 +11,7 @@ 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 @@              -> 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 @@              -> [(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 @@                     -> 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)

@@ -199,7 +199,7 @@                                         -- 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]) @@ -213,15 +213,15 @@   (exprs,altsDecls)      <- (second concat . unzip) <$> mapM (mkCondExpr scrutHTy) alts'    let dstId = mkBasicId . Text.pack . name2String $ varName bndr-  return $! scrutDecls ++ altsDecls ++ [CondAssignment dstId altHTy scrutExpr (reverse exprs)]+  return $! scrutDecls ++ altsDecls ++ [CondAssignment dstId altHTy scrutExpr scrutHTy (reverse exprs)]   where-    mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe Expr,Expr),[Declaration])+    mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe HW.Literal,Expr),[Declaration])     mkCondExpr scrutHTy (pat,alt) = do       (altExpr,altDecls) <- mkExpr False altTy alt       (,altDecls) <$> case pat of         DefaultPat           -> return (Nothing,altExpr)         DataPat (Embed dc) _ -> return (Just (dcToLiteral scrutHTy (dcTag dc)),altExpr)-        LitPat  (Embed (IntegerLiteral i)) -> return (Just (HW.Literal Nothing (NumLit $ fromInteger i)),altExpr)+        LitPat  (Embed (IntegerLiteral i)) -> return (Just (NumLit $ fromInteger i),altExpr)         _                    -> error $ $(curLoc) ++ "Not an integer literal in LitPat"      mkScrutExpr :: HWType -> Pat -> Expr -> Expr

@@ -77,6 +77,7 @@ -- | Representable hardware types data HWType   = Void -- ^ Empty type+  | String -- ^ String type   | Bool -- ^ Boolean type   | Integer -- ^ Integer type   | BitVector !Size -- ^ BitVector of a specified size@@ -102,7 +103,7 @@   -- * Signal to assign   --   -- * Assigned expression-  | CondAssignment !Identifier !HWType !Expr [(Maybe Expr,Expr)]+  | CondAssignment !Identifier !HWType !Expr !HWType [(Maybe Literal,Expr)]   -- ^ Conditional signal assignment:   --   -- * Signal to assign@@ -110,6 +111,8 @@   -- * Type of the result/alternatives   --   -- * Scrutinized expression+  --+  -- * Type of the scrutinee   --   -- * List of: (Maybe expression scrutinized expression is compared with,RHS of alternative)   | InstDecl !Identifier !Identifier [(Identifier,Expr)] -- ^ Instantiation of another component

@@ -164,6 +164,7 @@ typeSize :: HWType          -> Int typeSize Void = 0+typeSize String = 2^(32::Integer) typeSize Bool = 1 typeSize (Clock _ _) = 1 typeSize (Reset _ _) = 1@@ -286,7 +287,7 @@   curCompNm .= vComp   return val -dcToLiteral :: HWType -> Int -> Expr-dcToLiteral Bool 1 = HW.Literal Nothing (BoolLit False)-dcToLiteral Bool 2 = HW.Literal Nothing (BoolLit True)-dcToLiteral t i    = HW.Literal (Just  (t,conSize t)) (NumLit (toInteger i-1))+dcToLiteral :: HWType -> Int -> Literal+dcToLiteral Bool 1 = BoolLit False+dcToLiteral Bool 2 = BoolLit True+dcToLiteral _ i    = NumLit (toInteger i-1)

@@ -9,6 +9,7 @@ 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 @@                  -- ^ 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

@@ -0,0 +1,434 @@+{-# LANGUAGE DeriveFoldable    #-}+{-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE ViewPatterns      #-}++-- | Helper functions for the 'disjointExpressionConsolidation' transformation+--+-- The 'disjointExpressionConsolidation' transformation lifts applications of+-- global binders out of alternatives of case-statements.+--+-- e.g. It converts:+--+-- @+-- case x of+--   A -> f 3 y+--   B -> f x x+--   C -> h x+-- @+--+-- into:+--+-- @+-- 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+-- @+module CLaSH.Normalize.DEC+  (collectGlobals+  ,isDisjoint+  ,mkDisjointGroup+  )+where++-- external+import qualified Control.Lens                     as Lens+import           Data.Bits                        ((.&.),complement)+import qualified Data.Either                      as Either+import qualified Data.Foldable                    as Foldable+import qualified Data.HashMap.Strict              as HashMap+import qualified Data.IntMap.Strict               as IM+import qualified Data.List                        as List+import qualified Data.Map.Strict                  as Map+import qualified Data.Maybe                       as Maybe+import           Data.Set                         (Set)+import qualified Data.Set                         as Set+import qualified Data.Set.Lens                    as Lens++import           Unbound.Generics.LocallyNameless (Bind, bind, embed, rec,+                                                   unbind, unembed, unrec)++-- internal+import CLaSH.Core.DataCon    (DataCon, dcTag)+import CLaSH.Core.FreeVars   (termFreeIds, typeFreeVars)+import CLaSH.Core.Literal    (Literal (..))+import CLaSH.Core.Term       (LetBinding, Pat (..), Term (..), TmName)+import CLaSH.Core.TyCon      (tyConDataCons)+import CLaSH.Core.Type       (Type, mkTyConApp, splitFunForallTy)+import CLaSH.Core.Util       (collectArgs, mkApps, termType)+import CLaSH.Normalize.Types (NormalizeState)+import CLaSH.Normalize.Util  (isConstant)+import CLaSH.Rewrite.Types   (RewriteMonad, evaluator, tcCache, tupleTcCache)+import CLaSH.Rewrite.Util    (mkInternalVar, mkSelectorCase,+                              isUntranslatableType)+import CLaSH.Util++data CaseTree a+  = Leaf a+  | LB [LetBinding] (CaseTree a)+  | Branch Term [(Pat,CaseTree a)]+  deriving (Eq,Show,Functor,Foldable)++-- | Test if a 'CaseTree' collected from an expression indicates that+-- application of a global binder is disjoint: occur in separate branches of a+-- case-expression.+isDisjoint :: CaseTree ([Either Term Type])+           -> Bool+isDisjoint (Leaf _)             = False+isDisjoint (LB _ ct)            = isDisjoint ct+isDisjoint (Branch _ [])        = False+isDisjoint (Branch _ [(_,x)])   = isDisjoint x+isDisjoint b@(Branch _ (_:_:_)) = allEqual (map Either.rights+                                                (Foldable.toList b))++-- Remove empty branches from a 'CaseTree'+removeEmpty :: Eq a => CaseTree [a] -> CaseTree [a]+removeEmpty l@(Leaf _) = l+removeEmpty (LB lb ct) =+  case removeEmpty ct of+    Leaf [] -> Leaf []+    ct'     -> LB lb ct'+removeEmpty (Branch s bs) =+  case filter ((/= (Leaf [])) . snd) (map (second removeEmpty) bs) of+    []  -> Leaf []+    bs' -> Branch s bs'++-- | Test if all elements in a list are equal to each other.+allEqual :: Eq a => [a] -> Bool+allEqual []     = True+allEqual (x:xs) = all (== x) xs++-- | Collect 'CaseTree's for (potentially) disjoint applications of globals out+-- of an expression. Also substitute truly disjoint applications of globals by a+-- reference to a lifted out application.+collectGlobals ::+     Set TmName+  -> [(Term,Term)] -- ^ Substitution of (applications of) a global+                   -- binder by a reference to a lifted term.+  -> [Term] -- ^ List of already seen global binders+  -> Term -- ^ The expression+  -> RewriteMonad NormalizeState+                  (Term,[(Term,CaseTree [(Either Term Type)])])+collectGlobals inScope substitution seen (Case scrut ty alts) = do+  (scrut',collected)  <- collectGlobals     inScope substitution seen scrut+  (alts' ,collected') <- collectGlobalsAlts inScope substitution seen scrut'+                                            alts+  return (Case scrut' ty alts',collected ++ collected')++collectGlobals inScope substitution seen e@(collectArgs -> (fun, args@(_:_)))+  | not (isConstant e) = do+    tcm <- Lens.view tcCache+    eval <- Lens.view evaluator+    eTy <- termType tcm e+    case splitFunForallTy eTy of+      ([],_) -> case interestingToLift inScope (eval tcm False) fun args of+        Just fun' | fun' `notElem` seen -> do+          (args',collected) <- collectGlobalsArgs inScope substitution+                                                  (fun':seen) args+          let e' = Maybe.fromMaybe e (List.lookup fun' substitution)+          return (e',(fun',Leaf args'):collected)+        _ -> do (args',collected) <- collectGlobalsArgs inScope substitution+                                                        seen args+                return (mkApps fun args',collected)+      _ -> return (e,[])++-- FIXME: This duplicates A LOT of let-bindings, where I just pray that after+-- the ANF, CSE, and DeadCodeRemoval pass all duplicates are removed.+--+-- I think we should be able to do better, but perhaps we cannot fix it here.+collectGlobals inScope substitution seen (Letrec b) = do+  (unrec -> lbs,body) <- unbind b+  (body',collected)   <- collectGlobals    inScope substitution seen body+  (lbs',collected')   <- collectGlobalsLbs inScope substitution+                                           (map fst collected ++ seen)+                                           lbs+  return (Letrec (bind (rec lbs') body')+         ,map (second (LB lbs')) (collected ++ collected')+         )++collectGlobals _ _ _ e = return (e,[])++-- | Collect 'CaseTree's for (potentially) disjoint applications of globals out+-- of a list of application arguments. Also substitute truly disjoint+-- applications of globals by a reference to a lifted out application.+collectGlobalsArgs ::+     Set TmName+  -> [(Term,Term)] -- ^ Substitution of (applications of) a global+                   -- binder by a reference to a lifted term.+  -> [Term] -- ^ List of already seen global binders+  -> [Either Term Type] -- ^ The list of arguments+  -> RewriteMonad NormalizeState+                  ([Either Term Type]+                  ,[(Term,CaseTree [(Either Term Type)])]+                  )+collectGlobalsArgs inScope substitution seen args = do+    (_,(args',collected)) <- second unzip <$> mapAccumLM go seen args+    return (args',concat collected)+  where+    go s (Left tm) = do+      (tm',collected) <- collectGlobals inScope substitution s tm+      return (map fst collected ++ s,(Left tm',collected))+    go s (Right ty) = return (s,(Right ty,[]))++-- | Collect 'CaseTree's for (potentially) disjoint applications of globals out+-- of a list of alternatives. Also substitute truly disjoint applications of+-- globals by a reference to a lifted out application.+collectGlobalsAlts ::+     Set TmName+  -> [(Term,Term)] -- ^ Substitution of (applications of) a global+                   -- binder by a reference to a lifted term.+  -> [Term] -- ^ List of already seen global binders+  -> Term -- ^ The subject term+  -> [Bind Pat Term] -- ^ The list of alternatives+  -> RewriteMonad NormalizeState+                  ([Bind Pat Term]+                  ,[(Term,CaseTree [(Either Term Type)])]+                  )+collectGlobalsAlts inScope substitution seen scrut alts = do+    (alts',collected) <- unzip <$> mapM go alts+    let collectedM  = map (Map.fromList . map (second (:[]))) collected+        collectedUN = Map.unionsWith (++) collectedM+        collected'  = map (second (Branch scrut)) (Map.toList collectedUN)+    return (alts',collected')+  where+    go pe = do (p,e) <- unbind pe+               (e',collected) <- collectGlobals inScope substitution seen e+               return (bind p e',map (second (p,)) collected)++-- | Collect 'CaseTree's for (potentially) disjoint applications of globals out+-- of a list of let-bindings. Also substitute truly disjoint applications of+-- globals by a reference to a lifted out application.+collectGlobalsLbs ::+     Set TmName+  -> [(Term,Term)] -- ^ Substitution of (applications of) a global+                   -- binder by a reference to a lifted term.+  -> [Term] -- ^ List of already seen global binders+  -> [LetBinding] -- ^ The list let-bindings+  -> RewriteMonad NormalizeState+                  ([LetBinding]+                  ,[(Term,CaseTree [(Either Term Type)])]+                  )+collectGlobalsLbs inScope substitution seen lbs = do+    (_,(lbs',collected)) <- second unzip <$> mapAccumLM go seen lbs+    return (lbs',concat collected)+  where+    go :: [Term] -> LetBinding+       -> RewriteMonad NormalizeState+                  ([Term]+                  ,(LetBinding+                   ,[(Term,CaseTree [(Either Term Type)])]+                   )+                  )+    go s (id_,unembed -> e) = do+      (e',collected) <- collectGlobals inScope substitution s e+      return (map fst collected ++ s,((id_,embed e'),collected))++-- | Given a case-tree corresponding to a disjoint interesting \"term-in-a-+-- function-position\", return a let-expression: where the let-binding holds+-- a case-expression selecting between the uncommon arguments of the case-tree,+-- and the body is an application of the term applied to the common arguments of+-- the case tree, and projections of let-binding corresponding to the uncommon+-- argument positions.+mkDisjointGroup :: Set TmName -- ^ Current free variables.+                -> (Term,CaseTree [(Either Term Type)])+                   -- ^ Case-tree of arguments belonging to the applied term.+                -> RewriteMonad NormalizeState Term+mkDisjointGroup fvs (fun,cs) = do+    let argss    = Foldable.toList cs+        argssT   = zip [0..] (List.transpose argss)+        (commonT,uncommonT) = List.partition (isCommon fvs . snd) argssT+        common   = map (second head) commonT+        uncommon = map (Either.lefts) (List.transpose (map snd uncommonT))+        cs'      = fmap (zip [0..]) cs+        cs''     = removeEmpty+                 $ fmap (Either.lefts . map snd)+                        (if null common+                           then cs'+                           else fmap (filter (`notElem` common)) cs')+    tcm <- Lens.view tcCache+    (uncommonCaseM,uncommonProjections) <- case uncommon of+      -- only common arguments: do nothing.+      [] -> return (Nothing,[])+      -- Create selectors and projections+      (uc:_) -> do+        argTys <- mapM (termType tcm) uc+        disJointSelProj argTys cs''+    let newArgs = mkDJArgs 0 common uncommonProjections+    case uncommonCaseM of+      Just lb -> return (Letrec (bind (rec [lb]) (mkApps fun newArgs)))+      Nothing -> return (mkApps fun newArgs)++-- | Create a single selector for all the representable uncommon arguments by+-- selecting between tuples. This selector is only ('Just') created when the+-- number of representable uncommmon arguments is larger than one, otherwise it+-- is not ('Nothing').+--+-- It also returns:+--+-- * For all the non-representable uncommon arguments: a selector+-- * For all the representable uncommon arguments: a projection out of the tuple+--   created by the larger selector. If this larger selector does not exist, a+--   single selector is created for the single representable uncommon argument.+disJointSelProj :: [Type] -- ^ Types of the arguments+                -> CaseTree [Term] -- The case-tree of arguments+                -> RewriteMonad NormalizeState (Maybe LetBinding,[Term])+disJointSelProj _ (Leaf []) = return (Nothing,[])+disJointSelProj argTys cs = do+    let maxIndex = length argTys - 1+        css = map (\i -> fmap ((:[]) . (!!i)) cs) [0..maxIndex]+    (untran,tran) <- partitionM (isUntranslatableType . snd) (zip [0..] argTys)+    let untranCs   = map (css!!) (map fst untran)+        untranSels = zipWith (\(_,ty) cs' -> genCase ty Nothing []  cs')+                             untran untranCs+    (lbM,projs) <- case tran of+      []       -> return (Nothing,[])+      [(i,ty)] -> return (Nothing,[genCase ty Nothing [] (css!!i)])+      tys      -> do+        tcm    <- Lens.view tcCache+        tupTcm <- Lens.view tupleTcCache+        let m            = length tys+            Just tupTcNm = IM.lookup m tupTcm+            Just tupTc   = HashMap.lookup tupTcNm tcm+            [tupDc]      = tyConDataCons tupTc+            (tyIxs,tys') = unzip tys+            tupTy        = mkTyConApp tupTcNm tys'+            cs'          = fmap (\es -> map (es !!) tyIxs) cs+            djCase       = genCase tupTy (Just tupDc) tys' cs'+        (scrutId,scrutVar) <- mkInternalVar "tupIn" tupTy+        projections <- mapM (mkSelectorCase ($(curLoc) ++ "disJointSelProj")+                                            tcm scrutVar (dcTag tupDc)) [0..m-1]+        return (Just (scrutId,embed djCase),projections)+    let selProjs = tranOrUnTran 0 (zip (map fst untran) untranSels) projs++    return (lbM,selProjs)+  where+    tranOrUnTran _ []       projs     = projs+    tranOrUnTran _ sels     []        = map snd sels+    tranOrUnTran n ((ut,s):uts) (p:projs)+      | n == ut   = s : tranOrUnTran (n+1) uts          (p:projs)+      | otherwise = p : tranOrUnTran (n+1) ((ut,s):uts) projs+++isCommon :: Set TmName -> [Either Term Type] -> Bool+isCommon _   []             = True+isCommon _   (Right ty:tys) = Set.null (Lens.setOf typeFreeVars ty) &&+                              allEqual (Right ty:tys)+isCommon fvs (Left tm:tms)  = Set.null (Lens.setOf termFreeIds tm Set.\\ fvs) &&+                              allEqual (Left tm:tms)++-- | Create a list of arguments given a map of positions to common arguments,+-- and a list of arguments+mkDJArgs :: Int -- ^ Current position+         -> [(Int,Either Term Type)] -- ^ map from position to common argument+         -> [Term] -- ^ (projections for) uncommon arguments+         -> [Either Term Type]+mkDJArgs _ cms []   = map snd cms+mkDJArgs _ [] uncms = map Left uncms+mkDJArgs n ((m,x):cms) (y:uncms)+  | n == m    = x       : mkDJArgs (n+1) cms (y:uncms)+  | otherwise = Left y  : mkDJArgs (n+1) ((m,x):cms) uncms++-- | Create a case-expression that selects between the uncommon arguments given+-- a case-tree+genCase :: Type -- ^ Type of the alternatives+        -> Maybe DataCon -- ^ DataCon to pack multiple arguments+        -> [Type] -- ^ Types of the arguments+        -> CaseTree [Term] -- ^ CaseTree of arguments+        -> Term+genCase ty dcM argTys = go+  where+    go (Leaf tms) =+      case dcM of+        Just dc -> mkApps (Data dc) (map Right argTys ++ map Left tms)+        _ -> head tms++    go (LB lb ct) =+      Letrec (bind (rec lb) (go ct))++    go (Branch scrut pats) =+      Case scrut ty (map (\(p,ct) -> bind p (go ct)) pats)++-- | Determine if a term in a function position is interesting to lift out of+-- of a case-expression.+--+-- This holds for all global functions, and certain primitives. Currently those+-- primitives are:+--+-- * All non-power-of-two multiplications+-- * All division-like operations with a non-power-of-two divisor+interestingToLift :: Set TmName -- ^ in scope+                  -> (Term -> Term) -- ^ Evaluator+                  -> Term -- ^ Term in function position+                  -> [Either Term Type] -- ^ Arguments+                  -> Maybe Term+interestingToLift inScope _ e@(Var _ nm) _ =+  if nm `Set.member` inScope+     then Just e+     else Nothing+interestingToLift _ eval e@(Prim nm _) args =+    case List.lookup nm interestingPrims of+      Just t | t || not (all isConstant lArgs) -> Just e+      _ -> Nothing+  where+    interestingPrims =+      [("CLaSH.Sized.Internal.BitVector.*#",tailNonPow2)+      ,("CLaSH.Sized.Internal.BitVector.times#",tailNonPow2)+      ,("CLaSH.Sized.Internal.BitVector.quot#",lastNotPow2)+      ,("CLaSH.Sized.Internal.BitVector.rem#",lastNotPow2)+      ,("CLaSH.Sized.Internal.Index.*#",tailNonPow2)+      ,("CLaSH.Sized.Internal.Index.quot#",lastNotPow2)+      ,("CLaSH.Sized.Internal.Index.rem#",lastNotPow2)+      ,("CLaSH.Sized.Internal.Signed.*#",tailNonPow2)+      ,("CLaSH.Sized.Internal.Signed.times#",tailNonPow2)+      ,("CLaSH.Sized.Internal.Signed.rem#",lastNotPow2)+      ,("CLaSH.Sized.Internal.Signed.quot#",lastNotPow2)+      ,("CLaSH.Sized.Internal.Signed.div#",lastNotPow2)+      ,("CLaSH.Sized.Internal.Signed.mod#",lastNotPow2)+      ,("CLaSH.Sized.Internal.Unsigned.*#",tailNonPow2)+      ,("CLaSH.Sized.Internal.Unsigned.times#",tailNonPow2)+      ,("CLaSH.Sized.Internal.Unsigned.quot#",lastNotPow2)+      ,("CLaSH.Sized.Internal.Unsigned.rem#",lastNotPow2)+      ,("GHC.Base.quotInt",lastNotPow2)+      ,("GHC.Base.remInt",lastNotPow2)+      ,("GHC.Base.divInt",lastNotPow2)+      ,("GHC.Base.modInt",lastNotPow2)+      ,("GHC.Classes.divInt#",lastNotPow2)+      ,("GHC.Classes.modInt#",lastNotPow2)+      ,("GHC.Integer.Type.timesInteger",allNonPow2)+      ,("GHC.Integer.Type.divInteger",lastNotPow2)+      ,("GHC.Integer.Type.modInteger",lastNotPow2)+      ,("GHC.Integer.Type.quotInteger",lastNotPow2)+      ,("GHC.Integer.Type.remInteger",lastNotPow2)+      ,("GHC.Prim.*#",allNonPow2)+      ,("GHC.Prim.quotInt#",lastNotPow2)+      ,("GHC.Prim.remInt#",lastNotPow2)+      ]++    lArgs          = Either.lefts args++    allNonPow2  = all (not . termIsPow2) lArgs+    tailNonPow2 = all (not . termIsPow2) (tail lArgs)+    lastNotPow2 = not (termIsPow2 (last lArgs))++    termIsPow2 e' = case eval e' of+      Literal (IntegerLiteral n) -> isPow2 n+      a -> case collectArgs a of+        (Prim nm' _,[Right _,Left _,Left (Literal (IntegerLiteral n))])+          | isFromInteger nm' -> isPow2 n+        _ -> False++    isPow2 x = x /= 0 && (x .&. (complement x + 1)) == x++    isFromInteger x = x `elem` ["CLaSH.Sized.Internal.BitVector.fromInteger#"+                               ,"CLaSH.Sized.Integer.Index.fromInteger"+                               ,"CLaSH.Sized.Internal.Signed.fromInteger#"+                               ,"CLaSH.Sized.Internal.Unsigned.fromInteger#"+                               ]++interestingToLift _ _ _ _ = Nothing

@@ -25,10 +25,13 @@ import qualified Control.Lens                     as Lens import qualified Data.HashMap.Lazy                as HashMap import qualified Data.Maybe                       as Maybe+import           Data.Text                        (pack) import           Unbound.Generics.LocallyNameless (bind, embed, rec, rebind,-                                                   string2Name)+                                                   string2Name, name2String) -import           CLaSH.Core.DataCon               (DataCon, dataConInstArgTys)+import           CLaSH.Core.DataCon               (DataCon, dataConInstArgTys,+                                                   dcName, dcType)+import           CLaSH.Core.Literal               (Literal (..)) import           CLaSH.Core.Term                  (Term (..), Pat (..)) import           CLaSH.Core.Type                  (LitTy (..), Type (..),                                                    TypeView (..), mkFunTy,@@ -46,8 +49,6 @@ import           CLaSH.Rewrite.Util import           CLaSH.Util --- import CLaSH.Core.Pretty- -- | Replace an application of the @CLaSH.Sized.Vector.zipWith@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @CLaSH.Sized.Vector.zipWith@@@ -275,21 +276,34 @@         [_,consCon]      = tyConDataCons vecTc         (vars,elems)     = second concat . unzip                          $ extractElems consCon aTy 'D' n arg-    ([_ltv,Right dsTy,_etaTy,_eta1Ty],_) <- splitFunForallTy <$> termType tcm fun-    let (TyConApp proxyTcNm _) = tyView dsTy-        (Just proxyTc) = HashMap.lookup proxyTcNm tcm-        [proxyDc]      = tyConDataCons proxyTc-        lbody          = doFold (Data proxyDc) (n-1) vars-        lb             = Letrec (bind (rec (init elems)) lbody)+    ([_ltv,Right snTy,_etaTy,_eta1Ty],_) <- splitFunForallTy <$> termType tcm fun+    let (TyConApp snatTcNm _) = tyView snTy+        (Just snatTc)         = HashMap.lookup snatTcNm tcm+        [snatDc]              = tyConDataCons snatTc++        ([_nTv,_kn,Right pTy],_) = splitFunForallTy (dcType snatDc)+        (TyConApp proxyTcNm _)   = tyView pTy+        (Just proxyTc)           = HashMap.lookup proxyTcNm tcm+        [proxyDc]                = tyConDataCons proxyTc++        buildSNat i = mkApps (Prim (pack (name2String (dcName snatDc)))+                                   (dcType snatDc))+                             [Right (LitTy (NumTy i))+                             ,Left (Literal (IntegerLiteral (toInteger i)))+                             ,Left (mkApps (Data proxyDc)+                                           [Right typeNatKind+                                           ,Right (LitTy (NumTy i))])+                             ]+        lbody = doFold buildSNat (n-1) vars+        lb    = Letrec (bind (rec (init elems)) lbody)     changed lb   where-    doFold _   _ []     = start-    doFold pDc k (x:xs) = mkApps fun+    doFold _    _ []     = start+    doFold snDc k (x:xs) = mkApps fun                                  [Right (LitTy (NumTy k))-                                 ,Left (mkApps pDc [Right typeNatKind-                                                   ,Right (LitTy (NumTy k))])+                                 ,Left (snDc k)                                  ,Left x-                                 ,Left (doFold pDc (k-1) xs)+                                 ,Left (doFold snDc (k-1) xs)                                  ]  -- | Replace an application of the @CLaSH.Sized.Vector.head@ primitive on

@@ -21,13 +21,19 @@     evalConst  = topdownR (apply "evalConst" reduceConst)     cse        = topdownR (apply "CSE" simpleCSE) + constantPropgation :: NormRewrite-constantPropgation = propagate >-> repeatR inlineAndPropagate >-> lifting >-> spec+constantPropgation = propagate >-> repeatR inlineAndPropagate >->+                     caseFlattening >-> dec >-> lifting >-> spec >-> dec >->+                     conSpec   where     propagate = innerMost (applyMany transInner)     inlineAndPropagate = bottomupR (applyMany transBUP) !-> propagate     lifting   = bottomupR (apply "liftNonRep" liftNonRep) -- See: [Note] bottom-up traversal for liftNonRep     spec      = bottomupR (applyMany specRws)+    caseFlattening = repeatR (topdownR (apply "caseFlat" caseFlat))+    dec = repeatR (topdownR (apply "DEC" disjointExpressionConsolidation))+    conSpec = bottomupR (apply "constantSpec" constantSpec)      transInner :: [(String,NormRewrite)]     transInner = [ ("applicationPropagation", appProp        )@@ -47,7 +53,6 @@      specRws :: [(String,NormRewrite)]     specRws = [ ("typeSpec"    , typeSpec)-              , ("constantSpec", constantSpec)               , ("nonRepSpec"  , nonRepSpec)               ] 

@@ -27,6 +27,8 @@   , simpleCSE   , reduceConst   , reduceNonRepPrim+  , caseFlat+  , disjointExpressionConsolidation   ) where @@ -38,6 +40,8 @@ import qualified Data.HashMap.Lazy           as HashMap import qualified Data.List                   as List import qualified Data.Maybe                  as Maybe+import qualified Data.Set.Lens               as Lens+import           Data.Text                   (Text, unpack) import           Unbound.Generics.LocallyNameless (Bind, Embed (..), bind, embed,                                               rec, unbind, unembed, unrebind,                                               unrec, name2String)@@ -64,6 +68,7 @@ import           CLaSH.Core.Var              (Id, Var (..)) import           CLaSH.Netlist.Util          (representableType,                                               splitNormalized)+import           CLaSH.Normalize.DEC import           CLaSH.Normalize.PrimitiveReductions import           CLaSH.Normalize.Types import           CLaSH.Normalize.Util@@ -469,6 +474,105 @@  appProp _ e = return e +-- | Flatten ridiculous case-statements generated by GHC+--+-- For case-statements in haskell of the form:+--+-- @+-- f :: Unsigned 4 -> Unsigned 4+-- f x = case x of+--   0 -> 3+--   1 -> 2+--   2 -> 1+--   3 -> 0+-- @+--+-- GHC generates Core that looks like:+--+-- @+-- f = \(x :: Unsigned 4) -> case x == fromInteger 3 of+--                             False -> case x == fromInteger 2 of+--                               False -> case x == fromInteger 1 of+--                                 False -> case x == fromInteger 0 of+--                                   False -> error "incomplete case"+--                                   True  -> fromInteger 3+--                                 True -> fromInteger 2+--                               True -> fromInteger 1+--                             True -> fromInteger 0+-- @+--+-- Which would result in a priority decoder circuit where a normal decoder+-- circuit was desired.+--+-- This transformation transforms the above Core to the saner:+--+-- @+-- f = \(x :: Unsigned 4) -> case x of+--        _ -> error "incomplete case"+--        0 -> fromInteger 3+--        1 -> fromInteger 2+--        2 -> fromInteger 1+--        3 -> fromInteger 0+-- @+caseFlat :: NormRewrite+caseFlat _ e@(Case (collectArgs -> (Prim nm _,args)) ty _)+  | isEq nm+  = do let (Left scrut') = args !! 1+       case collectFlat scrut' e of+         Just alts' -> changed (Case scrut' ty (last alts' : init alts'))+         Nothing    -> return e++caseFlat _ e = return e++collectFlat :: Term -> Term -> Maybe [Bind Pat Term]+collectFlat scrut (Case (collectArgs -> (Prim nm _,args)) _ty [lAlt,rAlt])+  | isEq nm+  , scrut' == scrut+  = case collectArgs val of+      (Prim nm' _,args') | isFromInt nm'+        -> case last args' of+            Left (Literal i) -> case (unsafeUnbind lAlt,unsafeUnbind rAlt) of+              ((pl,el),(pr,er))+                | isFalseDcPat pl || isTrueDcPat pr ->+                   case collectFlat scrut el of+                     Just alts' -> Just (bind (LitPat (embed i)) er : alts')+                     Nothing    -> Just [bind (LitPat (embed i)) er+                                        ,bind DefaultPat el+                                        ]+                | otherwise ->+                   case collectFlat scrut er of+                     Just alts' -> Just (bind (LitPat (embed i)) el : alts')+                     Nothing    -> Just [bind (LitPat (embed i)) el+                                        ,bind DefaultPat er+                                        ]+            _ -> Nothing+      _ -> Nothing+  where+    (Left scrut') = args !! 1+    (Left val)    = args !! 2++    isFalseDcPat (DataPat p _)+      = ((== "GHC.Types.False") . name2String . dcName . unembed) p+    isFalseDcPat _ = False++    isTrueDcPat (DataPat p _)+      = ((== "GHC.Types.True") . name2String . dcName . unembed) p+    isTrueDcPat _ = False++collectFlat _ _ = Nothing++isEq :: Text -> Bool+isEq nm = nm == "CLaSH.Sized.Internal.BitVector.eq#" ||+          nm == "CLaSH.Sized.Internal.Index.eq#" ||+          nm == "CLaSH.Sized.Internal.Signed.eq#" ||+          nm == "CLaSH.Sized.Internal.Unsigned.eq#"++isFromInt :: Text -> Bool+isFromInt nm = nm == "CLaSH.Sized.Internal.BitVector.fromInteger#" ||+               nm == "CLaSH.Sized.Internal.Index.fromInteger#" ||+               nm == "CLaSH.Sized.Internal.Signed.fromInteger#" ||+               nm == "CLaSH.Sized.Internal.Unsigned.fromInteger#"+ type NormRewriteW = Transform (WriterT [LetBinding] (RewriteMonad NormalizeState))  -- NOTE [unsafeUnbind]: Use unsafeUnbind (which doesn't freshen pattern@@ -543,7 +647,7 @@ collectANF _ e@(Case _ _ [unsafeUnbind -> (DataPat dc _,_)])   | name2String (dcName $ unembed dc) == "CLaSH.Signal.Internal.:-" = return e -collectANF ctx (Case subj ty alts) = do+collectANF _ (Case subj ty alts) = do     localVar     <- lift (isLocalVar subj)     (bndr,subj') <- if localVar || isConstant subj       then return ([],subj)@@ -583,7 +687,7 @@     doPatBndr :: Term -> DataCon -> Id -> Int -> RewriteMonad NormalizeState LetBinding     doPatBndr subj' dc pId i       = do tcm <- Lens.view tcCache-           patExpr <- mkSelectorCase ($(curLoc) ++ "doPatBndr") tcm ctx subj' (dcTag dc) i+           patExpr <- mkSelectorCase ($(curLoc) ++ "doPatBndr") tcm subj' (dcTag dc) i            return (pId,embed patExpr)  collectANF _ e = return e@@ -802,12 +906,10 @@                    in  reduceFoldr n aTy bTy fun start arg               else return e           _ -> return e-      "CLaSH.Sized.Vector.dfold" | length args == 7 ->-        let [_mTy,nTy,aTy] = Either.rights args+      "CLaSH.Sized.Vector.dfold" | length args == 8 ->+        let ([_kn,_motive,fun,start,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args         in  case nTy of-          (LitTy (NumTy n)) ->-            let [_motive,fun,start,arg] = Either.lefts args-            in  reduceDFold n aTy fun start arg+          (LitTy (NumTy n)) -> reduceDFold n aTy fun start arg           _ -> return e       "CLaSH.Sized.Vector.++" | length args == 5 ->         let [nTy,aTy,mTy] = Either.rights args@@ -855,3 +957,63 @@       _ -> return e  reduceNonRepPrim _ e = return e++-- | This transformation lifts applications of global binders out of+-- alternatives of case-statements.+--+-- e.g. It converts:+--+-- @+-- case x of+--   A -> f 3 y+--   B -> f x x+--   C -> h x+-- @+--+-- into:+--+-- @+-- 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+-- @+disjointExpressionConsolidation :: NormRewrite+disjointExpressionConsolidation ctx e@(Case _scrut _ty _alts) = do+    let eFreeIds = Lens.setOf termFreeIds e+    (_,collected) <- collectGlobals eFreeIds [] [] e+    let disJoint = filter (isDisjoint . snd) collected+    if null disJoint+       then return e+       else do+         exprs <- mapM (mkDisjointGroup eFreeIds) disJoint+         tcm <- Lens.view tcCache+         (lids,lvs) <- unzip <$> Monad.zipWithM (mkFunOut tcm) disJoint exprs+         let substitution = zip (map fst disJoint) lvs+             subsMatrix   = l2m substitution+         (exprs',_) <- unzip <$> Monad.zipWithM (\s e' -> collectGlobals eFreeIds s [] e')+                                                subsMatrix+                                                exprs+         (e',_) <- collectGlobals eFreeIds substitution [] e+         let lb = Letrec (bind (rec (zip lids (map embed exprs'))) e')+         lb' <- bottomupR deadCode ctx lb+         changed lb'+  where+    mkFunOut tcm (fun,_) e' = do+      ty <- termType tcm e'+      let nm  = case collectArgs fun of+                   (Var _ nm',_)  -> name2String nm'+                   (Prim nm' _,_) -> unpack nm'+                   _             -> "complex_expression_"+          nm'' = (reverse . List.takeWhile (/='.') . reverse) nm ++ "Out"+      mkInternalVar nm'' ty++    l2m = go []+      where+        go _  []     = []+        go xs (y:ys) = (xs ++ ys) : go (xs ++ [y]) ys++disjointExpressionConsolidation _ e = return e

@@ -13,6 +13,7 @@ import Control.Monad.State                   (MonadState (..)) import Control.Monad.Writer                  (MonadWriter (..)) import Data.HashMap.Strict                   (HashMap)+import Data.IntMap.Strict                    (IntMap) import Data.Monoid                           (Any) import Unbound.Generics.LocallyNameless      (Fresh (..)) import Unbound.Generics.LocallyNameless.Name (Name (..))@@ -77,6 +78,8 @@   -- ^ Hardcode Type -> HWType translator   , _tcCache        :: HashMap TyConName TyCon   -- ^ TyCon cache+  , _tupleTcCache   :: IntMap TyConName+  -- ^ Tuple TyCon cache   , _evaluator      :: HashMap TyConName TyCon -> Bool -> Term -> Term   -- ^ Hardcoded evaluator (delta-reduction)}   }

@@ -340,8 +340,7 @@             -> LetBinding             -> RewriteMonad extra LetBinding liftBinding gamma delta (Id idName tyE,eE) = do-  let ty = unembed tyE-      e  = unembed eE+  let e  = unembed eE   -- Get all local FVs, excluding the 'idName' from the let-binding   let localFTVs = List.nub $ Lens.toListOf termFreeTyVars e   localFVs <- List.nub <$> (Lens.toListOf <$> localFreeIds <*> pure e)@@ -366,11 +365,23 @@       e' = substTm idName newExpr e   -- Create a new body that abstracts over the free variables       newBody = mkTyLams (mkLams e' boundFVs) boundFTVs-  -- Add the created function to the list of global bindings-  bindings %= HMS.insert newBodyId (newBodyTy,newBody)-  -- Return the new binder-  return (Id idName (embed ty), embed newExpr) +  -- Check if an alpha-equivalent global binder already exists+  aeqExisting <- (HMS.toList . HMS.filter ((== newBody) . snd)) <$> Lens.use bindings+  case aeqExisting of+    -- If it doesn't, create a new binder+    [] -> do -- Add the created function to the list of global bindings+             bindings %= HMS.insert newBodyId (newBodyTy,newBody)+             -- Return the new binder+             return (Id idName tyE, embed newExpr)+    -- If it does, use the existing binder+    ((k,(aeqTy,_)):_) ->+      let newExpr' = mkTmApps+                      (mkTyApps (Var aeqTy k)+                                (zipWith VarTy localFTVkinds localFTVs))+                      (zipWith Var localFVtys' localFVs')+      in  return (Id idName tyE, embed newExpr')+ liftBinding _ _ _ = error $ $(curLoc) ++ "liftBinding: invalid core, expr bound to tyvar"  -- | Make a global function for a name-term tuple@@ -440,12 +451,11 @@ mkSelectorCase :: (Functor m, Monad m, MonadUnique m, Fresh m)                => String -- ^ Name of the caller of this function                -> HashMap TyConName TyCon -- ^ TyCon cache-               -> [CoreContext] -- ^ Transformation Context in which this function is called                -> Term -- ^ Subject of the case-composition                -> Int -- n'th DataCon                -> Int -- n'th field                -> m Term-mkSelectorCase caller tcm _ scrut dcI fieldI = do+mkSelectorCase caller tcm scrut dcI fieldI = do   scrutTy <- termType tcm scrut   let cantCreate loc info = error $ loc ++ "Can't create selector " ++ show (caller,dcI,fieldI) ++ " for: (" ++ showDoc scrut ++ " :: " ++ showDoc scrutTy ++ ")\nAdditional info: " ++ info   case coreView tcm scrutTy of