clash-lib 0.3.0.3 → 0.3.0.4
raw patch · 8 files changed
+75/−31 lines, 8 files
Files
- clash-lib.cabal +1/−1
- src/CLaSH/Netlist.hs +20/−22
- src/CLaSH/Netlist/BlackBox.hs +17/−1
- src/CLaSH/Netlist/Types.hs +1/−0
- src/CLaSH/Netlist/Util.hs +2/−2
- src/CLaSH/Netlist/VHDL.hs +19/−0
- src/CLaSH/Normalize/Transformations.hs +4/−5
- src/CLaSH/Rewrite/Combinators.hs +11/−0
clash-lib.cabal view
@@ -1,5 +1,5 @@ Name: clash-lib-Version: 0.3.0.3+Version: 0.3.0.4 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that
src/CLaSH/Netlist.hs view
@@ -26,8 +26,8 @@ import CLaSH.Core.Pretty (showDoc) import CLaSH.Core.Term (Pat (..), Term (..), TmName) import qualified CLaSH.Core.Term as Core-import CLaSH.Core.Type (Type (..), ConstTy (..))-import CLaSH.Core.TyCon (TyConName, TyCon, tyConDataCons)+import CLaSH.Core.Type (Type (..))+import CLaSH.Core.TyCon (TyConName, TyCon) import CLaSH.Core.Util (collectArgs, isVar, termType) import CLaSH.Core.Var (Id, Var (..)) import CLaSH.Netlist.BlackBox@@ -154,10 +154,13 @@ mkDeclarations bndr (Var _ v) = mkFunApp bndr v [] mkDeclarations _ e@(Case _ []) =- error $ $(curLoc) ++ "Case-decompositions with an empty list of alternatives not supported: " ++ showDoc e+ error $ $(curLoc) ++ "Not in normal form: Case-decompositions with an empty list of alternatives not supported: " ++ showDoc e mkDeclarations bndr e@(Case (Var scrutTy scrutNm) [alt]) = do- (pat,Var varTy varTm) <- unbind alt+ (pat,v) <- unbind alt+ (varTy,varTm) <- case v of+ (Var t n) -> return (t,n)+ _ -> error $ $(curLoc) ++ "Not in normal form: RHS of case-projection is not a variable: " ++ showDoc e typeTrans <- Lens.use typeTranslator tcm <- Lens.use tcCache let dstId = mkBasicId . Text.pack . name2String $ varName bndr@@ -168,7 +171,7 @@ in case elemIndex (Id varTm (Embed varTy)) tms of Nothing -> Nothing Just fI -> Just (Indexed (unsafeCoreTypeToHWType $(curLoc) typeTrans tcm scrutTy,dcTag dc - 1,fI))- _ -> error $ $(curLoc) ++ "unexpected pattern in extractor: " ++ showDoc e+ _ -> error $ $(curLoc) ++ "Not in normal form: Unexpected pattern in case-projection: " ++ showDoc e extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier return [Assignment dstId extractExpr] @@ -263,33 +266,28 @@ | all (\e -> isConstant e || isVar e) args' -> mkDcApplication hwTy dc args' | otherwise -> error $ $(curLoc) ++ "Not in normal form: DataCon-application with non-Simple arguments" Prim nm _+ -- TODO: Optimize the tagToEnum and dataToTag translations so that in+ -- general:+ -- - tagToEnum is translated to 'to_unsigned'+ -- - dataToTag is translated to 'to_integer' | nm == TextS.pack "GHC.Prim.tagToEnum#" -> do i <- varCount <<%= (+1) scrutTy <- termType tcm (head args) (scrutExpr,scrutDecls) <- mkExpr scrutTy (head args)- let ConstTy (TyCon tcN) = ty- dcs = tyConDataCons (tcm HashMap.! tcN)- tags = map dcTag dcs- altLhs = map (Just . HW.Literal Nothing . NumLit . (subtract 1)) tags- altRhs = map (dcToLiteral hwTy) tags- tmpNm = "tmp_" ++ show i+ let tmpNm = "tmp_tte_" ++ show i tmpS = Text.pack tmpNm netDecl = NetDecl tmpS hwTy Nothing- netAssign = CondAssignment tmpS scrutExpr (zip altLhs altRhs)+ netAssign = Assignment tmpS (DataTag hwTy (Left scrutExpr)) return (Identifier tmpS Nothing,netDecl:netAssign:scrutDecls) | nm == TextS.pack "GHC.Prim.dataToTag#" -> do i <- varCount <<%= (+1) scrutTy <- termType tcm (head args)+ scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy (scrutExpr,scrutDecls) <- mkExpr scrutTy (head args)- let ConstTy (TyCon tcN) = scrutTy- dcs = tyConDataCons (tcm HashMap.! tcN)- tags = map dcTag dcs- altLhs = map (Just . dcToLiteral hwTy) tags- altRhs = map (HW.Literal Nothing . NumLit . (subtract 1)) tags- tmpNm = "tmp_" ++ show i+ let tmpNm = "tmp_dtt_" ++ show i tmpS = Text.pack tmpNm netDecl = NetDecl tmpS hwTy Nothing- netAssign = CondAssignment tmpS scrutExpr (zip altLhs altRhs)+ netAssign = Assignment tmpS (DataTag scrutHTy (Right scrutExpr)) return (Identifier tmpS Nothing,netDecl:netAssign:scrutDecls) | otherwise -> do bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives@@ -345,14 +343,14 @@ return (HW.DataCon dstHType (Just $ DC (dstHType,dcTag dc - 1)) []) Bool -> let dc' = case dcTag dc of- 2 -> HW.Literal Nothing (BoolLit True) 1 -> HW.Literal Nothing (BoolLit False)+ 2 -> HW.Literal Nothing (BoolLit True) tg -> error $ $(curLoc) ++ "unknown bool literal: " ++ showDoc dc ++ "(tag: " ++ show tg ++ ")" in return dc' Bit -> let dc' = case dcTag dc of- 1 -> HW.Literal Nothing (BitLit H)- 2 -> HW.Literal Nothing (BitLit L)+ 1 -> HW.Literal Nothing (BitLit L)+ 2 -> HW.Literal Nothing (BitLit H) tg -> error $ $(curLoc) ++ "unknown bit literal: " ++ showDoc dc ++ "(tag: " ++ show tg ++ ")" in return dc' Vector 0 _ -> return (HW.DataCon dstHType Nothing [])
src/CLaSH/Netlist/BlackBox.hs view
@@ -24,9 +24,12 @@ import Unbound.LocallyNameless (embed, name2String, string2Name, unembed) +import CLaSH.Core.DataCon as D (dcTag) import CLaSH.Core.Literal as L (Literal (..)) import CLaSH.Core.Pretty (showDoc) import CLaSH.Core.Term as C (Term (..), TmName)+import CLaSH.Core.Type as C (Type (..), ConstTy (..))+import CLaSH.Core.TyCon as C (tyConDataCons) import CLaSH.Core.Util (collectArgs, isFun, termType) import CLaSH.Core.Var as V (Id, Var (..)) import {-# SOURCE #-} CLaSH.Netlist (genComponent, mkDcApplication)@@ -124,7 +127,20 @@ bb <- lift $ mkBlackBox tempE bbCtx let bb' = mconcat [pack "(",bb,pack ")"] return ((Left bb', hwTy),ctxDecls)- Just _ -> mzero+ Just (P.Primitive pNm _)+ | pNm == "GHC.Prim.tagToEnum#" -> case collectArgs (head $ fst $ partitionEithers args) of+ (C.Literal (IntegerLiteral i), _) -> do+ tcm <- Lens.use tcCache+ let ConstTy (TyCon tcN) = head . snd $ partitionEithers args+ dcs = tyConDataCons (tcm HashMap.! tcN)+ dc = dcs !! (fromInteger $ i - 1)+ ((id_,hwTy),decs) <- mkLitInput (Data dc)+ return ((Left id_,hwTy),decs)+ _ -> error $ $(curLoc) ++ "tagToEnum: " ++ showDoc e+ | pNm == "GHC.Prim.dataToTag#" -> case collectArgs (head $ fst $ partitionEithers args) of+ (Data dc, _) -> return ((Left . pack . show . subtract 1 $ dcTag dc,Integer),[])+ _ -> error $ $(curLoc) ++ "dataToTag: " ++ showDoc e+ | otherwise -> mzero Nothing -> error $ $(curLoc) ++ "No blackbox found: " ++ unpack nm -- | Create an template instantiation text for an argument term, given that
src/CLaSH/Netlist/Types.hs view
@@ -142,6 +142,7 @@ = Literal (Maybe Size) Literal -- ^ Literal expression | DataCon HWType (Maybe Modifier) [Expr] -- ^ DataCon application | Identifier Identifier (Maybe Modifier) -- ^ Signal reference+ | DataTag HWType (Either Expr Expr) -- ^ @Left e@: tagToEnum#, @Right e@: dataToTag# | BlackBoxE Text (Maybe Modifier) -- ^ Instantiation of a BlackBox expression deriving Show
src/CLaSH/Netlist/Util.hs view
@@ -273,6 +273,6 @@ dcToLiteral :: HWType -> Int -> Expr dcToLiteral Bool 1 = HW.Literal Nothing (BoolLit False) dcToLiteral Bool 2 = HW.Literal Nothing (BoolLit True)-dcToLiteral Bit 1 = HW.Literal Nothing (BitLit H)-dcToLiteral Bit 2 = HW.Literal Nothing (BitLit L)+dcToLiteral Bit 1 = HW.Literal Nothing (BitLit L)+dcToLiteral Bit 2 = HW.Literal Nothing (BitLit H) dcToLiteral t i = HW.Literal (Just $ conSize t) (NumLit (i-1))
src/CLaSH/Netlist/VHDL.hs view
@@ -414,6 +414,25 @@ end = typeSize ty - conSize ty expr b (BlackBoxE bs _) = parenIf b $ string bs +expr _ (DataTag Bool (Left e)) = "false when" <+> expr False e <+> "= 0 else true"+expr _ (DataTag Bool (Right e)) = "1 when" <+> expr False e <+> "else 0"+expr _ (DataTag Bit (Left e)) = "'0' when" <+> expr False e <+> "= 0 else '1'"+expr _ (DataTag Bit (Right e)) = "0 when" <+> expr False e <+> "= '0' else 1"+expr _ (DataTag hty@(Sum _ _) (Left e)) = "to_unsigned" <> tupled (sequence [expr False e,int (typeSize hty)])+expr _ (DataTag (Sum _ _) (Right e)) = "to_integer" <> parens (expr False e)++expr _ (DataTag (Product _ _) (Right _)) = int 0+expr _ (DataTag hty@(SP _ _) (Right e)) = "to_integer" <> parens+ ("unsigned" <> parens+ (expr False e <> parens+ (int start <+> "downto" <+> int end)))+ where+ start = typeSize hty - 1+ end = typeSize hty - conSize hty++expr _ (DataTag (Vector 0 _) (Right _)) = int 0+expr _ (DataTag (Vector _ _) (Right _)) = int 1+ expr _ _ = empty otherSize :: [HWType] -> Int -> Int
src/CLaSH/Normalize/Transformations.hs view
@@ -461,11 +461,10 @@ makeANF ctx e = R $ do (e',bndrs) <- runR $ runWriterT $- bottomupR (whenR (\ctx' tm -> fmap not $- liftNormR $- untranslatableFVs (ctx' ++ ctx) tm- ) collectANF- ) ctx e+ bottomupWhenR (\ctx' tm -> fmap not $+ liftNormR $+ untranslatableFVs (ctx' ++ ctx) tm+ ) collectANF ctx e case bndrs of [] -> return e _ -> changed . Letrec $ bind (rec bndrs) e'
src/CLaSH/Rewrite/Combinators.hs view
@@ -121,3 +121,14 @@ if b then r1 ctx expr else return expr++-- | Only traverse downwards when the assertion evaluates to true+bottomupWhenR :: (Monad m, Fresh m, Functor m)+ => ([CoreContext] -> Term -> m Bool)+ -> Transform m+ -> Transform m+bottomupWhenR f r ctx expr = do+ b <- f ctx expr+ if b+ then (allR True (bottomupWhenR f r) >-> r) ctx expr+ else r ctx expr