diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -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 diff --git a/src/CLaSH/Core/Term.hs b/src/CLaSH/Core/Term.hs --- a/src/CLaSH/Core/Term.hs +++ b/src/CLaSH/Core/Term.hs @@ -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 diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -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 diff --git a/src/CLaSH/Driver/TestbenchGen.hs b/src/CLaSH/Driver/TestbenchGen.hs --- a/src/CLaSH/Driver/TestbenchGen.hs +++ b/src/CLaSH/Driver/TestbenchGen.hs @@ -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) diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -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 diff --git a/src/CLaSH/Netlist/Types.hs b/src/CLaSH/Netlist/Types.hs --- a/src/CLaSH/Netlist/Types.hs +++ b/src/CLaSH/Netlist/Types.hs @@ -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 diff --git a/src/CLaSH/Netlist/Util.hs b/src/CLaSH/Netlist/Util.hs --- a/src/CLaSH/Netlist/Util.hs +++ b/src/CLaSH/Netlist/Util.hs @@ -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) diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs --- a/src/CLaSH/Normalize.hs +++ b/src/CLaSH/Normalize.hs @@ -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 diff --git a/src/CLaSH/Normalize/DEC.hs b/src/CLaSH/Normalize/DEC.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Normalize/DEC.hs @@ -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 diff --git a/src/CLaSH/Normalize/PrimitiveReductions.hs b/src/CLaSH/Normalize/PrimitiveReductions.hs --- a/src/CLaSH/Normalize/PrimitiveReductions.hs +++ b/src/CLaSH/Normalize/PrimitiveReductions.hs @@ -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 diff --git a/src/CLaSH/Normalize/Strategy.hs b/src/CLaSH/Normalize/Strategy.hs --- a/src/CLaSH/Normalize/Strategy.hs +++ b/src/CLaSH/Normalize/Strategy.hs @@ -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) ] diff --git a/src/CLaSH/Normalize/Transformations.hs b/src/CLaSH/Normalize/Transformations.hs --- a/src/CLaSH/Normalize/Transformations.hs +++ b/src/CLaSH/Normalize/Transformations.hs @@ -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 diff --git a/src/CLaSH/Rewrite/Types.hs b/src/CLaSH/Rewrite/Types.hs --- a/src/CLaSH/Rewrite/Types.hs +++ b/src/CLaSH/Rewrite/Types.hs @@ -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)} } diff --git a/src/CLaSH/Rewrite/Util.hs b/src/CLaSH/Rewrite/Util.hs --- a/src/CLaSH/Rewrite/Util.hs +++ b/src/CLaSH/Rewrite/Util.hs @@ -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