clash-lib 0.3.2 → 0.4
raw patch · 15 files changed
+283/−136 lines, 15 files
Files
- CHANGELOG.md +7/−0
- clash-lib.cabal +1/−1
- src/CLaSH/Core/Type.hs +43/−17
- src/CLaSH/Driver.hs +5/−8
- src/CLaSH/Driver/TestbenchGen.hs +2/−2
- src/CLaSH/Netlist.hs +18/−11
- src/CLaSH/Netlist/BlackBox.hs +28/−14
- src/CLaSH/Netlist/Id.hs +63/−5
- src/CLaSH/Netlist/Types.hs +6/−4
- src/CLaSH/Netlist/Util.hs +10/−13
- src/CLaSH/Netlist/VHDL.hs +57/−34
- src/CLaSH/Normalize.hs +3/−3
- src/CLaSH/Normalize/Strategy.hs +1/−1
- src/CLaSH/Normalize/Transformations.hs +35/−23
- src/CLaSH/Util.hs +4/−0
CHANGELOG.md view
@@ -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:
clash-lib.cabal view
@@ -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
src/CLaSH/Core/Type.hs view
@@ -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
src/CLaSH/Driver.hs view
@@ -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.
src/CLaSH/Driver/TestbenchGen.hs view
@@ -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) ]
src/CLaSH/Netlist.hs view
@@ -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:
src/CLaSH/Netlist/BlackBox.hs view
@@ -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
src/CLaSH/Netlist/Id.hs view
@@ -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)
src/CLaSH/Netlist/Types.hs view
@@ -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
src/CLaSH/Netlist/Util.hs view
@@ -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))
src/CLaSH/Netlist/VHDL.hs view
@@ -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 = "<="
src/CLaSH/Normalize.hs view
@@ -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]
src/CLaSH/Normalize/Strategy.hs view
@@ -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
src/CLaSH/Normalize/Transformations.hs view
@@ -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
src/CLaSH/Util.hs view
@@ -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