diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.4 *November 17th 2014* +* New features: + * Support for clash-prelude 0.6 + +* Fixes bugs: + * Ambiguous type: 'std_logic_vector' or 'std_ulogic_vector' [#33](https://github.com/christiaanb/clash2/issues/33) + ## 0.3.2 *June 5th 2014* * Fixes bugs: 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.2 +Version: 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/Core/Type.hs b/src/CLaSH/Core/Type.hs --- a/src/CLaSH/Core/Type.hs +++ b/src/CLaSH/Core/Type.hs @@ -38,11 +38,13 @@ , isFunTy , applyFunTy , applyTy + , findFunSubst ) where -- External import import Control.DeepSeq as DS +import Control.Monad (zipWithM) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Maybe (isJust) @@ -159,37 +161,29 @@ -- | A transformation that renders 'Signal' types transparent transparentTy :: Type -> Type -transparentTy (AppTy (ConstTy (TyCon tc)) ty) - = case name2String tc of - "CLaSH.Signal.Types.Signal" -> transparentTy ty - "CLaSH.Signal.Implicit.SignalP" -> transparentTy ty - _ -> AppTy (ConstTy (TyCon tc)) (transparentTy ty) -transparentTy (AppTy (AppTy (ConstTy (TyCon tc)) clkTy) elTy) +transparentTy ty@(AppTy (AppTy (ConstTy (TyCon tc)) _) elTy) = case name2String tc of - "CLaSH.Signal.Types.CSignal" -> transparentTy elTy - "CLaSH.Signal.Explicit.SignalP" -> transparentTy elTy - _ -> (AppTy (AppTy (ConstTy (TyCon tc)) (transparentTy clkTy)) (transparentTy elTy)) + "CLaSH.Signal.Internal.CSignal" -> transparentTy elTy + _ -> ty transparentTy (AppTy ty1 ty2) = AppTy (transparentTy ty1) (transparentTy ty2) transparentTy (ForAllTy b) = ForAllTy (uncurry bind $ second transparentTy $ unsafeUnbind b) transparentTy ty = ty --- | A view on types in which 'Signal' types and newtypes are transparent +-- | A view on types in which 'Signal' types and newtypes are transparent, and +-- type functions are evaluated when possible. coreView :: HashMap TyConName TyCon -> Type -> TypeView coreView tcMap ty = let tView = tyView ty in case tView of - -- TyConApp ((tcMap HashMap.!) -> AlgTyCon {algTcRhs = (NewTyCon _ nt)}) args - -- | length (fst nt) == length args -> coreView tcMap (newTyConInstRhs nt args) - -- | otherwise -> tView TyConApp tc args -> case name2String tc of - "CLaSH.Signal.Types.Signal" -> coreView tcMap (head args) - "CLaSH.Signal.Implicit.SignalP" -> coreView tcMap (head args) - "CLaSH.Signal.Types.CSignal" -> coreView tcMap (args !! 1) - "CLaSH.Signal.Explicit.CSignalP" -> coreView tcMap (args !! 1) + "CLaSH.Signal.Internal.CSignal" -> coreView tcMap (args !! 1) _ -> case (tcMap HashMap.! tc) of (AlgTyCon {algTcRhs = (NewTyCon _ nt)}) | length (fst nt) == length args -> coreView tcMap (newTyConInstRhs nt args) | otherwise -> tView + FunTyCon {tyConSubst = tcSubst} -> case findFunSubst tcSubst args of + Just ty' -> coreView tcMap ty' + _ -> tView _ -> tView _ -> tView @@ -331,3 +325,35 @@ Nothing -> Just (ty1,ty2:args) Just (ty1',ty1args) -> Just (ty1',ty2:ty1args ) go _ _ = Nothing + +-- Type function substitutions + +-- Given a set of type functions, and list of argument types, get the first +-- type function that matches, and return its substituted RHS type. +findFunSubst :: [([Type],Type)] -> [Type] -> Maybe Type +findFunSubst [] _ = Nothing +findFunSubst (tcSubst:rest) args = case funSubsts tcSubst args of + Just ty -> Just ty + Nothing -> findFunSubst rest args + +-- Given a ([LHS match type], RHS type) representing a type function, and +-- a set of applied types. Match LHS with args, and when successful, return +-- a substituted RHS +funSubsts :: ([Type],Type) -> [Type] -> Maybe Type +funSubsts (tcSubstLhs,tcSubstRhs) args = do + tySubts <- concat <$> zipWithM funSubst tcSubstLhs args + let tyRhs = substTys tySubts tcSubstRhs + return tyRhs + +-- Given a LHS matching type, and a RHS to-match type, check if LHS and RHS +-- are a match. If they do match, and the LHS is a variable, return a +-- substitution +funSubst :: Type -> Type -> Maybe [(TyName,Type)] +funSubst (VarTy _ nmF) ty = Just [(nmF,ty)] +funSubst tyL@(LitTy _) tyR = if tyL == tyR then Just [] else Nothing +funSubst (tyView -> TyConApp tc argTys) (tyView -> TyConApp tc' argTys') + | tc == tc' + = do + tySubts <- zipWithM funSubst argTys argTys' + return (concat tySubts) +funSubst _ _ = Nothing diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -51,15 +51,15 @@ putStrLn $ "Loading dependencies took " ++ show prepStartDiff let topEntities = HashMap.filterWithKey - (\var _ -> isSuffixOf "topEntity" $ name2String var) + (\var _ -> isSuffixOf ".topEntity" $ name2String var) bindingsMap testInputs = HashMap.filterWithKey - (\var _ -> isSuffixOf "testInput" $ name2String var) + (\var _ -> isSuffixOf ".testInput" $ name2String var) bindingsMap expectedOutputs = HashMap.filterWithKey - (\var _ -> isSuffixOf "expectedOutput" $ name2String var) + (\var _ -> isSuffixOf ".expectedOutput" $ name2String var) bindingsMap case HashMap.toList topEntities of @@ -127,11 +127,8 @@ (vhdlNms,vhdlDocs) <- unzip <$> mapM genVHDL components let vhdlNmDocs = zip vhdlNms vhdlDocs hwtys <- HashSet.toList <$> use _1 - typesPkgM <- case hwtys of - [] -> return Nothing - _ -> Just <$> mkTyPackage hwtys - - return $ maybe vhdlNmDocs (\t -> ("types",t):vhdlNmDocs) typesPkgM + typesPkg <- mkTyPackage hwtys + return (("types",typesPkg):vhdlNmDocs) -- | Prepares the directory for writing VHDL files. This means creating the -- dir if it does not exist and removing all existing .vhdl files from it. 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 @@ -130,7 +130,7 @@ genReset :: (Identifier,HWType) -> Maybe [Declaration] -genReset (rstName,Reset _) = Just rstDecls +genReset (rstName,Reset clk) = Just rstDecls where rstExpr = PP.vsep [ "-- pragma translate_off" @@ -141,7 +141,7 @@ , "-- pragma translate_on" ] - rstDecls = [ NetDecl rstName Bit Nothing + rstDecls = [ NetDecl rstName (Reset clk) Nothing , BlackBoxD (PP.displayT $ PP.renderCompact rstExpr) ] diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -107,7 +107,8 @@ . ifThenElse Text.null (`Text.append` Text.pack "Component_") (`Text.append` Text.pack "_") - . mkBasicId + . mkBasicId' True + . stripDollarPrefixes . last . Text.splitOn (Text.pack ".") . Text.pack @@ -154,16 +155,27 @@ mkDeclarations _ e@(Case _ _ []) = 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 +mkDeclarations bndr e@(Case scrut _ [alt]) = do (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 + scrutTy <- termType tcm scrut + let sHwTy = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm scrutTy + (selId,decls) <- case scrut of + (Var _ scrutNm) -> return (mkBasicId . Text.pack $ name2String scrutNm,[]) + _ -> do + (newExpr, newDecls) <- mkExpr scrutTy scrut + i <- varCount <<%= (+1) + let tmpNm = "tmp_" ++ show i + tmpNmT = Text.pack tmpNm + tmpDecl = NetDecl tmpNmT sHwTy Nothing + tmpAssn = Assignment tmpNmT newExpr + return (tmpNmT,newDecls ++ [tmpDecl,tmpAssn]) let dstId = mkBasicId . Text.pack . name2String $ varName bndr altVarId = mkBasicId . Text.pack $ name2String varTm - selId = mkBasicId . Text.pack $ name2String scrutNm modifier = case pat of DataPat (Embed dc) ids -> let (_,tms) = unrebind ids in case elemIndex (Id varTm (Embed varTy)) tms of @@ -171,7 +183,7 @@ Just fI -> Just (Indexed (unsafeCoreTypeToHWType $(curLoc) typeTrans tcm scrutTy,dcTag dc - 1,fI)) _ -> 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] + return (decls ++ [Assignment dstId extractExpr]) mkDeclarations bndr (Case scrut altTy alts) = do alts' <- mapM unbind alts @@ -231,7 +243,8 @@ hiddenAssigns = map (\(i,_) -> (i,Identifier i Nothing)) hidden inpAssigns = zip (map fst compInps) argExprs outpAssign = (fst compOutp,Identifier dstId Nothing) - instDecl = InstDecl compName dstId (outpAssign:hiddenAssigns ++ inpAssigns) + instLabel = Text.concat [compName, Text.pack "_", dstId] + instDecl = InstDecl compName instLabel (outpAssign:hiddenAssigns ++ inpAssigns) return (argDecls ++ [instDecl]) else error $ $(curLoc) ++ "under-applied normalized function" Nothing -> case args of @@ -298,12 +311,6 @@ 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 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 []) -- Note [Vector Wrapper] -- The Vector type has two versions of the cons constructor: 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 @@ -20,6 +20,7 @@ import Data.Maybe (catMaybes, fromJust) import Data.Monoid (mconcat) import Data.Text.Lazy (Text, fromStrict, pack) +import qualified Data.Text.Lazy as Text import Data.Text (unpack) import qualified Data.Text as TextS import Unbound.LocallyNameless (embed, name2String, string2Name, @@ -157,7 +158,7 @@ return ((Identifier tmpS Nothing,hwTy),netDecl:netAssign:scrutDecls) _ -> error $ $(curLoc) ++ "tagToEnum: " ++ show (map (either showDoc showDoc) args) | pNm == "GHC.Prim.dataToTag#" -> case args of - [Right _,Left (Data dc)] -> return ((N.Literal Nothing (NumLit $ dcTag dc - 1),Integer),[]) + [Right _,Left (Data dc)] -> return ((N.Literal Nothing (NumLit $ toInteger $ dcTag dc - 1),Integer),[]) [Right _,Left scrut] -> do i <- varCount <<%= (+1) tcm <- Lens.use tcCache @@ -170,28 +171,39 @@ netAssign = Assignment tmpS (DataTag scrutHTy (Right scrutExpr)) return ((Identifier tmpS Nothing,Integer),netDecl:netAssign:scrutDecls) _ -> error $ $(curLoc) ++ "tagToEnum: " ++ show (map (either showDoc showDoc) args) - | pNm == "CLaSH.Sized.Signed.fromIntegerS" -> case lefts args of - [C.Literal (IntegerLiteral i),arg] -> + | pNm == "CLaSH.Sized.Internal.BitVector.fromInteger#" -> case lefts args of + largs@[C.Literal (IntegerLiteral i),arg] -> let sz = fromInteger i in case arg of + C.Literal (IntegerLiteral j) -> + return ((N.Literal (Just (BitVector sz,sz)) (NumLit $ fromInteger j), BitVector sz),[]) + _ -> do + (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (embed ty)) largs + bb <- mkBlackBox (pack "std_logic_vector(to_unsigned(~ARG[1],~LIT[0]))") bbCtx + return ((BlackBoxE bb Nothing,BitVector sz),ctxDcls) + _ -> error $ $(curLoc) ++ "CLaSH.Sized.Internal.Signed.fromInteger#: " ++ show (map (either showDoc showDoc) args) + | pNm == "CLaSH.Sized.Internal.Signed.fromInteger#" -> case lefts args of + largs@[C.Literal (IntegerLiteral i),arg] -> + let sz = fromInteger i + in case arg of C.Literal (IntegerLiteral j) - | i > 32 -> return ((N.Literal (Just sz) (NumLit $ fromInteger j), Signed sz),[]) + | i > 32 -> return ((N.Literal (Just (Signed sz,sz)) (NumLit $ fromInteger j), Signed sz),[]) _ -> do - (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (embed ty)) (lefts args) + (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (embed ty)) largs bb <- mkBlackBox (pack "to_signed(~ARG[1],~LIT[0])") bbCtx return ((BlackBoxE bb Nothing,Signed sz),ctxDcls) - _ -> error $ $(curLoc) ++ "CLaSH.Sized.Signed.fromIntegerS: " ++ show (map (either showDoc showDoc) args) - | pNm == "CLaSH.Sized.Unsigned.fromIntegerU" -> case lefts args of - [C.Literal (IntegerLiteral i),arg] -> + _ -> error $ $(curLoc) ++ "CLaSH.Sized.Internal.Signed.fromInteger#: " ++ show (map (either showDoc showDoc) args) + | pNm == "CLaSH.Sized.Internal.Unsigned.fromInteger#" -> case lefts args of + largs@[C.Literal (IntegerLiteral i),arg] -> let sz = fromInteger i in case arg of C.Literal (IntegerLiteral j) - | i > 31 -> return ((N.Literal (Just sz) (NumLit $ fromInteger j), Unsigned sz),[]) + | i > 31 -> return ((N.Literal (Just (Unsigned sz,sz)) (NumLit $ fromInteger j), Unsigned sz),[]) _ -> do - (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (embed ty)) (lefts args) + (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (embed ty)) largs bb <- mkBlackBox (pack "to_unsigned(~ARG[1],~LIT[0])") bbCtx return ((BlackBoxE bb Nothing,Unsigned sz),ctxDcls) - _ -> error $ $(curLoc) ++ "CLaSH.Sized.Unsigned.fromIntegerU: " ++ show (map (either showDoc showDoc) args) + _ -> error $ $(curLoc) ++ "CLaSH.Sized.Internal.Unsigned.fromInteger#: " ++ show (map (either showDoc showDoc) args) | otherwise -> return ((BlackBoxE (mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]) Nothing,Void),[]) _ -> error $ $(curLoc) ++ "No blackbox found for: " ++ unpack nm @@ -225,8 +237,9 @@ let templ = case bbM of Just p@(P.BlackBox {}) -> template p Just (P.Primitive pNm _) - | pNm == "CLaSH.Sized.Signed.fromIntegerS" -> Right "to_signed(~ARG[1],~LIT[0])" - | pNm == "CLaSH.Sized.Unsigned.fromIntegerU" -> Right "to_unsigned(~ARG[1],~LIT[0])" + | pNm == "CLaSH.Sized.Internal.BitVector.fromInteger#" -> Right "std_logic_vector(to_unsigned(~ARG[1],~LIT[0]))" + | pNm == "CLaSH.Sized.Internal.Signed.fromInteger#" -> Right "to_signed(~ARG[1],~LIT[0])" + | pNm == "CLaSH.Sized.Internal.Unsigned.fromInteger#" -> Right "to_unsigned(~ARG[1],~LIT[0])" _ -> error $ $(curLoc) ++ "No blackbox found for: " ++ unpack nm return templ Data dc -> do @@ -259,7 +272,8 @@ inpAssigns = zip (map fst compInps) [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..] ] outpAssign = (fst compOutp,Identifier (pack "~RESULT") Nothing) i <- varCount <<%= (+1) - let instDecl = InstDecl compName (pack ("comp_inst_" ++ show i)) (outpAssign:hiddenAssigns ++ inpAssigns) + let instLabel = Text.concat [compName,pack ("_" ++ show i)] + instDecl = InstDecl compName instLabel (outpAssign:hiddenAssigns ++ inpAssigns) templ <- fmap (pack . show . fromJust) $ liftState vhdlMState $ inst instDecl return (Left templ) Nothing -> return $ error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e diff --git a/src/CLaSH/Netlist/Id.hs b/src/CLaSH/Netlist/Id.hs --- a/src/CLaSH/Netlist/Id.hs +++ b/src/CLaSH/Netlist/Id.hs @@ -1,7 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} -- | Transform/format a Netlist Identifier so that it is acceptable as a VHDL identifier module CLaSH.Netlist.Id - (mkBasicId) + ( mkBasicId + , mkBasicId' + , stripDollarPrefixes + ) where import Data.Char (isAsciiLower,isAsciiUpper,isDigit,ord) @@ -11,9 +15,14 @@ -- | Transform/format a text so that it is acceptable as a VHDL identifier mkBasicId :: Text -> Text -mkBasicId = stripMultiscore . stripLeading . zEncode +mkBasicId = mkBasicId' False + +mkBasicId' :: Bool + -> Text + -> Text +mkBasicId' tupEncode = stripMultiscore . stripLeading . zEncode tupEncode where - stripLeading = Text.dropWhile (`elem` ['0'..'9']) + stripLeading = Text.dropWhile (`elem` ('_':['0'..'9'])) stripMultiscore = Text.concat . Prelude.map (\cs -> case Text.head cs of '_' -> "_" @@ -21,17 +30,49 @@ ) . Text.group +stripDollarPrefixes :: Text -> Text +stripDollarPrefixes = stripSpecPrefix . stripConPrefix + . stripWorkerPrefix . stripDictFunPrefix + where + stripDictFunPrefix t = case Text.stripPrefix "$f" t of + Just k -> takeWhileEnd (/= '_') k + Nothing -> t + + takeWhileEnd p = Text.reverse . Text.takeWhile p . Text.reverse + + stripWorkerPrefix t = case Text.stripPrefix "$w" t of + Just k -> k + Nothing -> t + + stripConPrefix t = case Text.stripPrefix "$c" t of + Just k -> k + Nothing -> t + + stripSpecPrefix t = snd (Text.breakOnEnd "$s" t) + + type UserString = Text -- As the user typed it type EncodedString = Text -- Encoded form -zEncode :: UserString -> EncodedString -zEncode cs = go (uncons cs) +zEncode :: Bool -> UserString -> EncodedString +zEncode False cs = go (uncons cs) where go Nothing = empty go (Just (c,cs')) = append (encodeDigitCh c) (go' $ uncons cs') go' Nothing = empty go' (Just (c,cs')) = append (encodeCh c) (go' $ uncons cs') +zEncode True cs = case maybeTuple cs of + Just (n,cs') -> append n (go' (uncons cs')) + Nothing -> go (uncons cs) + where + go Nothing = empty + go (Just (c,cs')) = append (encodeDigitCh c) (go' $ uncons cs') + go' Nothing = empty + go' (Just (c,cs')) = case maybeTuple (cons c cs') of + Just (n,cs2) -> append n (go' $ uncons cs2) + Nothing -> append (encodeCh c) (go' $ uncons cs') + encodeDigitCh :: Char -> EncodedString encodeDigitCh c | isDigit c = encodeAsUnicodeChar c encodeDigitCh c = encodeCh c @@ -75,3 +116,20 @@ , isAsciiUpper c , isDigit c , c == '_'] + +maybeTuple :: UserString -> Maybe (EncodedString,UserString) +maybeTuple "(# #)" = Just ("Z1H",empty) +maybeTuple "()" = Just ("Z0T",empty) +maybeTuple (uncons -> Just ('(',uncons -> Just ('#',cs))) = + case countCommas 0 cs of + (n,uncons -> Just ('#',uncons -> Just (')',cs'))) -> Just (pack ('Z':shows (n+1) "H"),cs') + _ -> Nothing +maybeTuple (uncons -> Just ('(',cs)) = + case countCommas 0 cs of + (n,uncons -> Just (')',cs')) -> Just (pack ('Z':shows (n+1) "T"),cs') + _ -> Nothing +maybeTuple _ = Nothing + +countCommas :: Int -> UserString -> (Int,UserString) +countCommas n (uncons -> Just (',',cs)) = countCommas (n+1) cs +countCommas n cs = (n,cs) 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,9 +77,10 @@ -- | Representable hardware types data HWType = Void -- ^ Empty type - | Bit -- ^ Bit type | Bool -- ^ Boolean type | Integer -- ^ Integer type + | BitVector Size -- ^ BitVector of a specified size + | Index Size -- ^ Unsigned integer with specified (exclusive) upper bounder | Signed Size -- ^ Signed integer of a specified size | Unsigned Size -- ^ Unsigned integer of a specified size | Vector Size HWType -- ^ Vector type @@ -94,9 +95,10 @@ instance NFData HWType where rnf hwty = case hwty of Void -> () - Bit -> () Bool -> () Integer -> () + BitVector s -> rnf s + Index u -> rnf u Signed s -> rnf s Unsigned s -> rnf s Vector s el -> rnf s `seq` rnf el @@ -139,7 +141,7 @@ -- | Expression used in RHS of a declaration data Expr - = Literal (Maybe Size) Literal -- ^ Literal expression + = Literal (Maybe (HWType,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# @@ -148,7 +150,7 @@ -- | Literals used in an expression data Literal - = NumLit Int -- ^ Number literal + = NumLit Integer -- ^ Number literal | BitLit Bit -- ^ Bit literal | BoolLit Bool -- ^ Boolean literal | VecLit [Literal] -- ^ Vector literal 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 @@ -83,14 +83,12 @@ | not . null . typeFreeVars $ ty = Nothing | Just (tyCon,args) <- splitTyConAppM ty = case name2String tyCon of - "CLaSH.Signal.Types.Signal" -> Just (pack "clk1000",1000) "CLaSH.Sized.Vector.Vec" -> synchronizedClk tcm (args!!1) - "CLaSH.Signal.Implicit.SignalP" -> Just (pack "clk1000",1000) - "CLaSH.Signal.Types.CSignal" -> case (head args) of - (LitTy (NumTy i)) -> Just (pack ("clk" ++ show i),i) - _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty - "CLaSH.Signal.Explicit.CSignalP" -> case (head args) of - (LitTy (NumTy i)) -> Just (pack ("clk" ++ show i),i) + "CLaSH.Signal.Internal.SClock" -> case splitTyConAppM (head args) of + Just (_,[LitTy (SymTy s),LitTy (NumTy i)]) -> Just (pack (s ++ show i),i) + _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty + "CLaSH.Signal.Internal.CSignal" -> case splitTyConAppM (head args) of + Just (_,[LitTy (SymTy s),LitTy (NumTy i)]) -> Just (pack (s ++ show i),i) _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty _ -> case tyConDataCons (tcm HashMap.! tyCon) of [dc] -> let argTys = dcArgTys dc @@ -170,22 +168,23 @@ -> Int typeSize Void = 1 typeSize Bool = 1 -typeSize Bit = 1 typeSize (Clock _) = 1 typeSize (Reset _) = 1 typeSize Integer = 32 +typeSize (BitVector i) = i +typeSize (Index u) = clog2 (max 2 u) typeSize (Signed i) = i typeSize (Unsigned i) = i typeSize (Vector n el) = n * typeSize el typeSize t@(SP _ cons) = conSize t + maximum (map (sum . map typeSize . snd) cons) -typeSize (Sum _ dcs) = max 1 (ceiling . logBase (2 :: Float) . fromIntegral $ length dcs) +typeSize (Sum _ dcs) = max 1 (clog2 $ length dcs) typeSize (Product _ tys) = sum $ map typeSize tys -- | Determines the bitsize of the constructor of a type conSize :: HWType -> Int -conSize (SP _ cons) = ceiling . logBase (2 :: Float) . fromIntegral $ length cons +conSize (SP _ cons) = clog2 $ length cons conSize t = typeSize t -- | Gives the length of length-indexed types @@ -277,6 +276,4 @@ 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 L) -dcToLiteral Bit 2 = HW.Literal Nothing (BitLit H) -dcToLiteral t i = HW.Literal (Just $ conSize t) (NumLit (i-1)) +dcToLiteral t i = HW.Literal (Just (t,conSize t)) (NumLit (toInteger 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 @@ -31,7 +31,7 @@ import CLaSH.Netlist.Types import CLaSH.Netlist.Util -import CLaSH.Util (curLoc, makeCached, (<:>)) +import CLaSH.Util (clog2, curLoc, makeCached, (<:>)) type VHDLM a = State VHDLState a @@ -68,7 +68,7 @@ needsDec = nubBy eqHWTy (hwtys ++ filter needsTyDec usedTys) hwTysSorted = topSortHWTys needsDec packageDec = vcat $ mapM tyDec hwTysSorted - (funDecs,funBodies) = unzip . catMaybes $ map funDec usedTys + (funDecs,funBodies) = unzip . catMaybes $ map funDec (nubBy eqIndexTy usedTys) (showDecs,showBodies) = unzip $ map mkToStringDecls hwTysSorted packageBodyDec :: VHDLM Doc @@ -83,11 +83,17 @@ "-- pragma translate_on" <$> "end" <> semi + eqIndexTy :: HWType -> HWType -> Bool + eqIndexTy (Index _) (Index _) = True + eqIndexTy _ _ = False + eqHWTy :: HWType -> HWType -> Bool eqHWTy (Vector _ elTy1) (Vector _ elTy2) = case (elTy1,elTy2) of (Sum _ _,Sum _ _) -> typeSize elTy1 == typeSize elTy2 (Unsigned n,Sum _ _) -> n == typeSize elTy2 (Sum _ _,Unsigned n) -> typeSize elTy1 == n + (Index u,Unsigned n) -> clog2 (max 2 u) == n + (Unsigned n,Index u) -> clog2 (max 2 u) == n _ -> elTy1 == elTy2 eqHWTy ty1 ty2 = ty1 == ty2 @@ -121,7 +127,6 @@ mkVecZ t = t needsTyDec :: HWType -> Bool -needsTyDec (Vector _ Bit) = False needsTyDec (Vector _ _) = True needsTyDec (Product _ _) = True needsTyDec (SP _ _) = True @@ -147,7 +152,7 @@ funDec :: HWType -> Maybe (VHDLM Doc,VHDLM Doc) funDec Bool = Just ( "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <> semi <$> - "function" <+> "fromSL" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic") <+> "return" <+> "boolean" <> semi + "function" <+> "fromSL" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "boolean" <> semi , "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <+> "is" <$> "begin" <$> indent 2 (vcat $ sequence ["if" <+> "b" <+> "then" @@ -157,9 +162,9 @@ ,"end" <+> "if" <> semi ]) <$> "end" <> semi <$> - "function" <+> "fromSL" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic") <+> "return" <+> "boolean" <+> "is" <$> + "function" <+> "fromSL" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "boolean" <+> "is" <$> "begin" <$> - indent 2 (vcat $ sequence ["if" <+> "sl" <+> "=" <+> squotes (int 1) <+> "then" + indent 2 (vcat $ sequence ["if" <+> "sl" <+> "=" <+> dquotes (int 1) <+> "then" , indent 2 ("return" <+> "true" <> semi) ,"else" , indent 2 ("return" <+> "false" <> semi) @@ -176,6 +181,17 @@ "end" <> semi ) +funDec (Index _) = Just + ( "function" <+> "max" <+> parens ("left, right: in integer") <+> "return integer" <> semi + , "function" <+> "max" <+> parens ("left, right: in integer") <+> "return integer" <+> "is" <$> + "begin" <$> + indent 2 (vcat $ sequence [ "if" <+> "left > right" <+> "then return left" <> semi + , "else return right" <> semi + , "end if" <> semi + ]) <$> + "end" <> semi + ) + funDec _ = Nothing mkToStringDecls :: HWType -> (VHDLM Doc, VHDLM Doc) @@ -190,7 +206,6 @@ elTyPrint = forM [0..(length elTys - 1)] (\i -> "to_string" <> parens ("value." <> vhdlType t <> "_sel" <> int i)) -mkToStringDecls (Vector _ Bit) = (empty,empty) mkToStringDecls t@(Vector _ elTy) = ( "function to_string" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return STRING" <> semi , "function to_string" <+> parens ("value : " <+> vhdlTypeMark t) <+> "return STRING is" <$> @@ -219,6 +234,7 @@ [ "library IEEE" , "use IEEE.STD_LOGIC_1164.ALL" , "use IEEE.NUMERIC_STD.ALL" + , "use IEEE.MATH_REAL.ALL" , "use work.all" , "use work.types.all" ] @@ -261,17 +277,19 @@ vhdlType' hwty vhdlType' :: HWType -> VHDLM Doc -vhdlType' Bit = "std_logic" vhdlType' Bool = "boolean" vhdlType' (Clock _) = "std_logic" vhdlType' (Reset _) = "std_logic" vhdlType' Integer = "integer" +vhdlType' (BitVector n) = case n of + 0 -> "std_logic_vector (0 downto 1)" + _ -> "std_logic_vector" <> parens (int (n-1) <+> "downto 0") +vhdlType' (Index u) = "unsigned" <> parens (int (clog2 (max 2 u) - 1) <+> "downto 0") vhdlType' (Signed n) = if n == 0 then "signed (0 downto 1)" else "signed" <> parens (int (n-1) <+> "downto 0") vhdlType' (Unsigned n) = if n == 0 then "unsigned (0 downto 1)" else "unsigned" <> parens ( int (n-1) <+> "downto 0") -vhdlType' (Vector n Bit) = "std_logic_vector" <> parens (int (n-1) <+> "downto 0") -vhdlType' (Vector n elTy) = "array_of_" <> tyName elTy <> parens (int (n-1) <+> "downto 0") +vhdlType' (Vector n elTy) = "array_of_" <> tyName elTy <> parens ("0 to " <> int (n-1)) vhdlType' t@(SP _ _) = "std_logic_vector" <> parens (int (typeSize t - 1) <+> "downto 0") vhdlType' t@(Sum _ _) = case typeSize t of 0 -> "unsigned (0 downto 1)" @@ -285,14 +303,14 @@ when (needsTyDec hwty) (_1 %= HashSet.insert (mkVecZ hwty)) vhdlTypeMark' hwty where - vhdlTypeMark' Bit = "std_logic" vhdlTypeMark' Bool = "boolean" vhdlTypeMark' (Clock _) = "std_logic" vhdlTypeMark' (Reset _) = "std_logic" vhdlTypeMark' Integer = "integer" + vhdlTypeMark' (BitVector _) = "std_logic_vector" + vhdlTypeMark' (Index _) = "unsigned" vhdlTypeMark' (Signed _) = "signed" vhdlTypeMark' (Unsigned _) = "unsigned" - vhdlTypeMark' (Vector _ Bit) = "std_logic_vector" vhdlTypeMark' (Vector _ elTy) = "array_of_" <> tyName elTy vhdlTypeMark' (SP _ _) = "std_logic_vector" vhdlTypeMark' (Sum _ _) = "unsigned" @@ -301,10 +319,10 @@ tyName :: HWType -> VHDLM Doc tyName Integer = "integer" -tyName Bit = "std_logic" tyName Bool = "boolean" -tyName (Vector n Bit) = "std_logic_vector_" <> int n tyName (Vector n elTy) = "array_of_" <> int n <> "_" <> tyName elTy +tyName (BitVector n) = "std_logic_vector_" <> int n +tyName t@(Index _) = "unsigned_" <> int (typeSize t) tyName (Signed n) = "signed_" <> int n tyName (Unsigned n) = "unsigned_" <> int n tyName t@(Sum _ _) = "unsigned_" <> int (typeSize t) @@ -317,9 +335,10 @@ -- | Convert a Netlist HWType to an error VHDL value for that type vhdlTypeErrValue :: HWType -> VHDLM Doc -vhdlTypeErrValue Bit = "'1'" vhdlTypeErrValue Bool = "true" vhdlTypeErrValue Integer = "integer'high" +vhdlTypeErrValue (BitVector _) = "(others => 'X')" +vhdlTypeErrValue (Index _) = "(others => 'X')" vhdlTypeErrValue (Signed _) = "(others => 'X')" vhdlTypeErrValue (Unsigned _) = "(others => 'X')" vhdlTypeErrValue (Vector _ elTy) = parens ("others" <+> rarrow <+> vhdlTypeErrValue elTy) @@ -363,7 +382,7 @@ conds ((Just c ,e):es') = (expr False e <+> "when" <+> parens (expr True scrut <+> "=" <+> expr True c) <+> "else") <:> conds es' inst (InstDecl nm lbl pms) = fmap Just $ - nest 2 $ text lbl <> "_comp_inst" <+> colon <+> "entity" + nest 2 $ text lbl <+> colon <+> "entity" <+> text nm <$$> pms' <> semi where pms' = do @@ -397,9 +416,9 @@ expr _ (Identifier id_ (Just _)) = text id_ expr _ (DataCon ty@(Vector 1 _) _ [e]) = vhdlTypeMark ty <> "'" <> parens (int 0 <+> rarrow <+> expr False e) -expr _ e@(DataCon ty@(Vector _ _) _ [e1,e2]) = vhdlTypeMark ty <> "'" <> case vectorChain e of +expr _ e@(DataCon ty@(Vector _ elTy) _ [e1,e2]) = vhdlTypeMark ty <> "'" <> case vectorChain e of Just es -> tupled (mapM (expr False) es) - Nothing -> parens (expr False e1 <+> "&" <+> expr False e2) + Nothing -> parens (vhdlTypeMark elTy <> "'" <> parens (expr False e1) <+> "&" <+> expr False e2) expr _ (DataCon ty@(SP _ args) (Just (DC (_,i))) es) = assignExpr where argTys = snd $ args !! i @@ -408,7 +427,7 @@ argExprs = zipWith toSLV argTys es -- (map (expr False) es) extraArg = case typeSize ty - dcSize of 0 -> [] - n -> [exprLit (Just n) (NumLit 0)] + n -> [exprLit (Just (ty,n)) (NumLit 0)] assignExpr = "std_logic_vector'" <> parens (hcat $ punctuate " & " $ sequence (dcExpr:argExprs ++ extraArg)) expr _ (DataCon ty@(Sum _ _) (Just (DC (_,i))) []) = "to_unsigned" <> tupled (sequence [int i,int (typeSize ty)]) @@ -424,8 +443,6 @@ 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) @@ -454,13 +471,20 @@ vectorChain (DataCon (Vector _ _) (Just _) [e1,e2]) = Just e1 <:> vectorChain e2 vectorChain _ = Nothing -exprLit :: Maybe Size -> Literal -> VHDLM Doc -exprLit Nothing (NumLit i) = int i -exprLit (Just sz) (NumLit i) = bits (toBits sz i) -exprLit _ (BoolLit t) = if t then "true" else "false" -exprLit _ (BitLit b) = squotes $ bit_char b -exprLit _ l = error $ $(curLoc) ++ "exprLit: " ++ show l +exprLit :: Maybe (HWType,Size) -> Literal -> VHDLM Doc +exprLit Nothing (NumLit i) = integer i +exprLit (Just (hty,sz)) (NumLit i) = case hty of + Unsigned _ -> "unsigned'" <> parens blit + Signed _ -> "signed'" <> parens blit + BitVector _ -> "std_logic_vector'" <> parens blit + _ -> blit + where + blit = bits (toBits sz i) +exprLit _ (BoolLit t) = if t then "true" else "false" +exprLit _ (BitLit b) = squotes $ bit_char b +exprLit _ l = error $ $(curLoc) ++ "exprLit: " ++ show l + toBits :: Integral a => Int -> a -> [Bit] toBits size val = map (\x -> if odd x then H else L) $ reverse @@ -478,9 +502,9 @@ bit_char Z = char 'Z' toSLV :: HWType -> Expr -> VHDLM Doc -toSLV Bit e = parens (int 0 <+> rarrow <+> expr False e) toSLV Bool e = "toSLV" <> parens (expr False e) toSLV Integer e = "std_logic_vector" <> parens ("to_signed" <> tupled (sequence [expr False e,int 32])) +toSLV (BitVector _) e = expr False e toSLV (Signed _) e = "std_logic_vector" <> parens (expr False e) toSLV (Unsigned _) e = "std_logic_vector" <> parens (expr False e) toSLV (Sum _ _) e = "std_logic_vector" <> parens (expr False e) @@ -493,9 +517,8 @@ selIds = map (fmap (\n -> Identifier n Nothing)) selNames toSLV (Product _ tys) (DataCon _ _ es) = encloseSep lparen rparen " & " (zipWithM toSLV tys es) toSLV (SP _ _) e = expr False e -toSLV (Vector _ Bit) e = expr False e toSLV (Vector n elTy) (Identifier id_ Nothing) = do - selIds' <- sequence selIds + selIds' <- sequence (reverse selIds) parens (encloseSep lparen rparen " & " (mapM (toSLV elTy) selIds')) where selNames = map (fmap (displayT . renderOneLine) ) $ reverse [text id_ <> parens (int i) | i <- [0 .. (n-1)]] @@ -504,9 +527,10 @@ toSLV hty e = error $ $(curLoc) ++ "toSLV: ty:" ++ show hty ++ "\n expr: " ++ show e fromSLV :: HWType -> Identifier -> Int -> Int -> VHDLM Doc -fromSLV Bit id_ start _ = text id_ <> parens (int start) fromSLV Bool id_ start _ = "fromSL" <> parens (text id_ <> parens (int start)) fromSLV Integer id_ start end = "to_integer" <> parens (fromSLV (Signed 32) id_ start end) +fromSLV (BitVector _) id_ start end = text id_ <> parens (int start <+> "downto" <+> int end) +fromSLV (Index _) id_ start end = "unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end)) fromSLV (Signed _) id_ start end = "signed" <> parens (text id_ <> parens (int start <+> "downto" <+> int end)) fromSLV (Unsigned _) id_ start end = "unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end)) fromSLV (Sum _ _) id_ start end = "unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end)) @@ -520,8 +544,7 @@ args = zipWith3 (`fromSLV` id_) tys starts ends fromSLV (SP _ _) id_ start end = text id_ <> parens (int start <+> "downto" <+> int end) -fromSLV (Vector _ Bit) id_ start end = text id_ <> parens (int start <+> "downto" <+> int end) -fromSLV (Vector n elTy) id_ start _ = tupled args +fromSLV (Vector n elTy) id_ start _ = tupled (fmap reverse args) where argLength = typeSize elTy starts = take (n + 1) $ iterate (subtract argLength) start @@ -530,7 +553,7 @@ fromSLV hty _ _ _ = error $ $(curLoc) ++ "fromSLV: " ++ show hty dcToExpr :: HWType -> Int -> Expr -dcToExpr ty i = Literal (Just $ conSize ty) (NumLit i) +dcToExpr ty i = Literal (Just (ty,conSize ty)) (NumLit (toInteger i)) larrow :: VHDLM Doc larrow = "<=" diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs --- a/src/CLaSH/Normalize.hs +++ b/src/CLaSH/Normalize.hs @@ -27,10 +27,10 @@ import CLaSH.Netlist.Types (HWType) import CLaSH.Netlist.Util (splitNormalized) import CLaSH.Normalize.Strategy -import CLaSH.Normalize.Transformations ( bindConstantVar, topLet ) +import CLaSH.Normalize.Transformations ( bindConstantVar, caseCon, reduceConst, topLet ) import CLaSH.Normalize.Types import CLaSH.Normalize.Util -import CLaSH.Rewrite.Combinators ((!->),repeatR,topdownR) +import CLaSH.Rewrite.Combinators ((>->),(!->),repeatR,topdownR) import CLaSH.Rewrite.Types (DebugLevel (..), RewriteState (..), bindings, dbgLevel, tcCache) import CLaSH.Rewrite.Util (liftRS, runRewrite, @@ -204,7 +204,7 @@ let (toInline,il_used) = unzip il_ct newExpr <- case toInline of [] -> return tm - _ -> rewriteExpr ("bindConstants",(topdownR (repeatR $ bindConstantVar)) !-> topLet) (showDoc nm, substTms toInline tm) + _ -> rewriteExpr ("bindConstants",(repeatR (topdownR $ (bindConstantVar >-> caseCon >-> reduceConst))) !-> topLet) (showDoc nm, substTms toInline tm) return (CBranch (nm,(ty,newExpr)) (newUsed ++ (concat il_used))) callTreeToList :: [TmName] 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 @@ -17,7 +17,7 @@ recLetRec = apply "recToLetRec" recToLetRec rmDeadcode = topdownR (apply "deadcode" deadCode) bindConst = topdownR (apply "bindConstantVar" bindConstantVar) - cse = topdownSucR (apply "CSE" simpleCSE) + cse = topdownR (apply "CSE" simpleCSE) constantPropgation :: NormRewrite constantPropgation = propagate >-> repeatR inlineAndPropagate >-> lifting >-> spec 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,7 @@ , inlineHO , inlineSmall , simpleCSE + , reduceConst ) where @@ -161,22 +162,9 @@ changed $ Case (mkApps scrutBody args) altsTy alts _ -> return e where - exception (tyView -> TyConApp (name2String -> "GHC.Num.Num") [arg]) = numDictArg arg + exception (tyView -> TyConApp (name2String -> "GHC.Num.Num") _) = True exception _ = False - numDictArg arg = case tyView arg of - TyConApp tcNm arg' -> case name2String tcNm of - "CLaSH.Sized.Signed.Signed" -> True - "CLaSH.Sized.Unsigned.Unsigned" -> True - "CLaSH.Sized.Fixed.Fixed" -> True - "CLaSH.Signal.Types.Signal" -> numDictArg (head arg') - "CLaSH.Signal.Types.CSignal" -> numDictArg (arg'!!1) - "GHC.Integer.Type.Integer" -> True - "GHC.Types.Int" -> True - _ -> False - _ -> False - - inlineNonRep _ e = return e -- | Specialize a Case-decomposition (replace by the RHS of an alternative) if @@ -644,24 +632,48 @@ simpleCSE :: NormRewrite simpleCSE _ e@(Letrec b) = R $ do (binders,body) <- first unrec <$> unbind b - let (reducedBindings,body') = reduceBinders [] body binders + let (reducedBindings,body') = reduceBindersFix binders body if length binders /= length reducedBindings then changed (Letrec (bind (rec reducedBindings) body')) else return e simpleCSE _ e = return e +reduceBindersFix :: [LetBinding] + -> Term + -> ([LetBinding],Term) +reduceBindersFix binders body = if length binders /= length reduced + then reduceBindersFix reduced body' + else (binders,body) + where + (reduced,body') = reduceBinders [] body binders + reduceBinders :: [LetBinding] -> Term -> [LetBinding] -> ([LetBinding],Term) reduceBinders processed body [] = (processed,body) reduceBinders processed body ((id_,expr):binders) = case List.find ((== expr) . snd) processed of - Just (id2,_) -> - let var = Var (unembed (varType id2)) (varName id2) - idName = varName id_ - processed' = map (second (Embed . (substTm idName var) . unembed)) processed - binders' = map (second (Embed . (substTm idName var) . unembed)) binders - body' = substTm idName var body - in reduceBinders processed' body' binders' - Nothing -> reduceBinders ((id_,expr):processed) body binders + Just (id2,_) -> + let var = Var (unembed (varType id2)) (varName id2) + idName = varName id_ + processed' = map (second (Embed . (substTm idName var) . unembed)) processed + binders' = map (second (Embed . (substTm idName var) . unembed)) binders + body' = substTm idName var body + in reduceBinders processed' body' binders' + Nothing -> reduceBinders ((id_,expr):processed) body binders + +reduceConst :: NormRewrite +reduceConst _ e@(App _ _) + | isConstant e + , (conPrim, _) <- collectArgs e + , isPrim conPrim + = R $ do + tcm <- Lens.use tcCache + reduceConstant <- Lens.use evaluator + case reduceConstant tcm e of + e'@(Data _) -> changed e' + e'@(Literal _) -> changed e' + _ -> return e + +reduceConst _ e = return e diff --git a/src/CLaSH/Util.hs b/src/CLaSH/Util.hs --- a/src/CLaSH/Util.hs +++ b/src/CLaSH/Util.hs @@ -225,3 +225,7 @@ #else clashLibVersion = error "development version" #endif + +-- | ceiling (log_2(c)) +clog2 :: (Integral a, Integral c) => a -> c +clog2 = ceiling . logBase (2 :: Float) . fromIntegral