clash-lib 0.6.19 → 0.6.20
raw patch · 4 files changed
+34/−22 lines, 4 files
Files
- CHANGELOG.md +5/−0
- clash-lib.cabal +1/−1
- src/CLaSH/Normalize/DEC.hs +25/−18
- src/CLaSH/Normalize/Transformations.hs +3/−3
CHANGELOG.md view
@@ -1,5 +1,10 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.6.20 *August 3rd 2016*+* Fixes bugs:+ * Bug in DEC transformation overwrites case-alternatives+ * Bug in DEC transformation creates non-representable let-binders+ ## 0.6.19 *July 19th 2016* * Fixes bugs: * Rounding error in `logBase` calculation
clash-lib.cabal view
@@ -1,5 +1,5 @@ Name: clash-lib-Version: 0.6.19+Version: 0.6.20 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that
src/CLaSH/Normalize/DEC.hs view
@@ -121,7 +121,7 @@ -> [Term] -- ^ List of already seen global binders -> Term -- ^ The expression -> RewriteMonad NormalizeState- (Term,[(Term,CaseTree [(Either Term Type)])])+ (Term,[(Term,([Term],CaseTree [(Either Term Type)]))]) collectGlobals inScope substitution seen (Case scrut ty alts) = do rec (alts' ,collected) <- collectGlobalsAlts inScope substitution seen scrut' alts@@ -134,13 +134,20 @@ 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+ untran <- isUntranslatableType eTy+ case untran of+ -- Don't lift out non-representable values, because they cannot be let-bound+ -- in our desired normal form.+ False -> 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 (mkApps fun' args') (List.lookup fun' substitution)- return (e',(fun',Leaf args'):collected)+ -- This function is lifted out an environment with the currently 'seen'+ -- binders. When we later apply substitution, we need to start with this+ -- environment, otherwise we perform incorrect substitutions in the+ -- arguments.+ return (e',(fun',(seen,Leaf args')):collected) _ -> do (args',collected) <- collectGlobalsArgs inScope substitution seen args return (mkApps fun args',collected)@@ -157,7 +164,7 @@ (map fst collected ++ seen) lbs return (Letrec (bind (Unbound.rec lbs') body')- ,map (second (LB lbs')) (collected ++ collected')+ ,map (second (second (LB lbs'))) (collected ++ collected') ) collectGlobals _ _ _ e = return (e,[])@@ -173,7 +180,7 @@ -> [Either Term Type] -- ^ The list of arguments -> RewriteMonad NormalizeState ([Either Term Type]- ,[(Term,CaseTree [(Either Term Type)])]+ ,[(Term,([Term],CaseTree [(Either Term Type)]))] ) collectGlobalsArgs inScope substitution seen args = do (_,(args',collected)) <- second unzip <$> mapAccumLM go seen args@@ -196,18 +203,18 @@ -> [Bind Pat Term] -- ^ The list of alternatives -> RewriteMonad NormalizeState ([Bind Pat Term]- ,[(Term,CaseTree [(Either Term Type)])]+ ,[(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)+ let collectedM = map (Map.fromList . map (second (second (:[])))) collected+ collectedUN = Map.unionsWith (\(l1,r1) (l2,r2) -> (List.nub (l1 ++ l2),r1 ++ r2)) collectedM+ collected' = map (second (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)+ return (bind p e',map (second (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@@ -220,7 +227,7 @@ -> [LetBinding] -- ^ The list let-bindings -> RewriteMonad NormalizeState ([LetBinding]- ,[(Term,CaseTree [(Either Term Type)])]+ ,[(Term,([Term],CaseTree [(Either Term Type)]))] ) collectGlobalsLbs inScope substitution seen lbs = do (_,(lbs',collected)) <- second unzip <$> mapAccumLM go seen lbs@@ -230,7 +237,7 @@ -> RewriteMonad NormalizeState ([Term] ,(LetBinding- ,[(Term,CaseTree [(Either Term Type)])]+ ,[(Term,([Term],CaseTree [(Either Term Type)]))] ) ) go s (id_,unembed -> e) = do@@ -244,10 +251,10 @@ -- 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)])+ -> (Term,([Term],CaseTree [(Either Term Type)])) -- ^ Case-tree of arguments belonging to the applied term.- -> RewriteMonad NormalizeState Term-mkDisjointGroup fvs (fun,cs) = do+ -> RewriteMonad NormalizeState (Term,[Term])+mkDisjointGroup fvs (fun,(seen,cs)) = do let argss = Foldable.toList cs argssT = zip [0..] (List.transpose argss) (commonT,uncommonT) = List.partition (isCommon fvs . snd) argssT@@ -269,8 +276,8 @@ disJointSelProj argTys cs'' let newArgs = mkDJArgs 0 common uncommonProjections case uncommonCaseM of- Just lb -> return (Letrec (bind (Unbound.rec [lb]) (mkApps fun newArgs)))- Nothing -> return (mkApps fun newArgs)+ Just lb -> return (Letrec (bind (Unbound.rec [lb]) (mkApps fun newArgs)), seen)+ Nothing -> return (mkApps fun newArgs, seen) -- | Create a single selector for all the representable uncommon arguments by -- selecting between tuples. This selector is only ('Just') created when the
src/CLaSH/Normalize/Transformations.hs view
@@ -1109,7 +1109,7 @@ disjointExpressionConsolidation ctx e@(Case _scrut _ty _alts@(_:_:_)) = do let eFreeIds = Lens.setOf termFreeIds e (_,collected) <- collectGlobals eFreeIds [] [] e- let disJoint = filter (isDisjoint . snd) collected+ let disJoint = filter (isDisjoint . snd. snd) collected if null disJoint then return e else do@@ -1118,7 +1118,7 @@ (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')+ (exprs',_) <- unzip <$> Monad.zipWithM (\s (e',seen) -> collectGlobals eFreeIds s seen e') subsMatrix exprs (e',_) <- collectGlobals eFreeIds substitution [] e@@ -1126,7 +1126,7 @@ lb' <- bottomupR deadCode ctx lb changed lb' where- mkFunOut tcm (fun,_) e' = do+ mkFunOut tcm (fun,_) (e',_) = do ty <- termType tcm e' let nm = case collectArgs fun of (Var _ nm',_) -> name2String nm'