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.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 diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -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 []) diff --git a/src/CLaSH/Netlist/BlackBox.hs b/src/CLaSH/Netlist/BlackBox.hs --- a/src/CLaSH/Netlist/BlackBox.hs +++ b/src/CLaSH/Netlist/BlackBox.hs @@ -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 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 @@ -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 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 @@ -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)) diff --git a/src/CLaSH/Netlist/VHDL.hs b/src/CLaSH/Netlist/VHDL.hs --- a/src/CLaSH/Netlist/VHDL.hs +++ b/src/CLaSH/Netlist/VHDL.hs @@ -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 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 @@ -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' diff --git a/src/CLaSH/Rewrite/Combinators.hs b/src/CLaSH/Rewrite/Combinators.hs --- a/src/CLaSH/Rewrite/Combinators.hs +++ b/src/CLaSH/Rewrite/Combinators.hs @@ -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