clash-lib 0.2.2.1 → 0.3
raw patch · 20 files changed
+573/−405 lines, 20 files
Files
- clash-lib.cabal +1/−1
- src/CLaSH/Core/Pretty.hs +1/−1
- src/CLaSH/Core/Type.hs +27/−14
- src/CLaSH/Core/Util.hs +27/−3
- src/CLaSH/Driver.hs +7/−7
- src/CLaSH/Driver/TestbenchGen.hs +146/−230
- src/CLaSH/Netlist.hs +61/−35
- src/CLaSH/Netlist/BlackBox.hs +4/−1
- src/CLaSH/Netlist/BlackBox/Parser.hs +5/−4
- src/CLaSH/Netlist/BlackBox/Types.hs +6/−2
- src/CLaSH/Netlist/BlackBox/Util.hs +33/−23
- src/CLaSH/Netlist/Util.hs +23/−10
- src/CLaSH/Netlist/VHDL.hs +80/−29
- src/CLaSH/Normalize.hs +4/−2
- src/CLaSH/Normalize/Strategy.hs +11/−7
- src/CLaSH/Normalize/Transformations.hs +117/−24
- src/CLaSH/Normalize/Util.hs +1/−1
- src/CLaSH/Rewrite/Types.hs +1/−0
- src/CLaSH/Rewrite/Util.hs +11/−11
- src/CLaSH/Util.hs +7/−0
clash-lib.cabal view
@@ -1,5 +1,5 @@ Name: clash-lib-Version: 0.2.2.1+Version: 0.3 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that
src/CLaSH/Core/Pretty.hs view
@@ -262,7 +262,7 @@ pprTcApp :: (Applicative m, LFresh m) => TypePrec -> (TypePrec -> Type -> m Doc) -> TyConName -> [Type] -> m Doc pprTcApp _ _ tc []- = ppr tc+ = return . text $ name2String tc pprTcApp p pp tc tys | isTupleTyConLike tc
src/CLaSH/Core/Type.hs view
@@ -160,9 +160,14 @@ transparentTy :: Type -> Type transparentTy (AppTy (ConstTy (TyCon tc)) ty) = case name2String tc of- "CLaSH.Signal.Signal" -> transparentTy ty- "CLaSH.Signal.SignalP" -> transparentTy ty+ "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)+ = 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)) transparentTy (AppTy ty1 ty2) = AppTy (transparentTy ty1) (transparentTy ty2) transparentTy (ForAllTy b) = ForAllTy (uncurry bind $ second transparentTy $ unsafeUnbind b) transparentTy ty = ty@@ -172,13 +177,19 @@ 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 ((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.Signal" -> coreView tcMap (head args)- "CLaSH.Signal.SignalP" -> coreView tcMap (head args)- _ -> tView+ "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)+ _ -> case (tcMap HashMap.! tc) of+ (AlgTyCon {algTcRhs = (NewTyCon _ nt)})+ | length (fst nt) == length args -> coreView tcMap (newTyConInstRhs nt args)+ | otherwise -> tView+ _ -> tView _ -> tView -- | Instantiate and Apply the RHS/Original of a NewType with the given@@ -271,9 +282,10 @@ isPolyFunCoreTy :: HashMap TyConName TyCon -> Type -> Bool-isPolyFunCoreTy _ (ForAllTy _) = True-isPolyFunCoreTy m (coreView m -> FunTy _ _) = True-isPolyFunCoreTy _ _ = False+isPolyFunCoreTy m ty = case coreView m ty of+ (FunTy _ _) -> True+ (OtherType (ForAllTy _)) -> True+ _ -> False -- | Is a type a function type? isFunTy :: HashMap TyConName TyCon@@ -291,13 +303,14 @@ -- | Substitute the type variable of a type ('ForAllTy') with another type applyTy :: Fresh m- => Type+ => HashMap TyConName TyCon+ -> Type -> KindOrType -> m Type-applyTy (ForAllTy b) arg = do+applyTy tcm (coreView tcm -> OtherType (ForAllTy b)) arg = do (tv,ty) <- unbind b return (substTy (varName tv) arg ty)-applyTy _ _ = error ($(curLoc) ++ "applyTy: not a forall type")+applyTy _ ty arg = error ($(curLoc) ++ "applyTy: not a forall type:\n" ++ show ty ++ "\nArg:\n" ++ show arg) -- | Split a type application in the applied type and the argument types splitTyAppM :: Type
src/CLaSH/Core/Util.hs view
@@ -1,10 +1,14 @@ {-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS_GHC -fcontext-stack=21 #-}+ -- | Smart constructor and destructor functions for CoreHW module CLaSH.Core.Util where import Data.HashMap.Lazy (HashMap) import Unbound.LocallyNameless (Fresh, bind, embed, unbind, unembed,- unrebind)+ unrebind, unrec)+import Unbound.LocallyNameless.Ops (unsafeUnbind) import CLaSH.Core.DataCon (dcType) import CLaSH.Core.Literal (literalType)@@ -39,7 +43,7 @@ App _ _ -> case collectArgs e of (fun, args) -> termType m fun >>= (flip (applyTypeToArgs m) args)- TyApp e' ty -> termType m e' >>= (`applyTy` ty)+ TyApp e' ty -> termType m e' >>= (\f -> applyTy m f ty) Letrec b -> do (_,e') <- unbind b termType m e' Case _ (alt:_) -> do (_,e') <- unbind alt@@ -76,7 +80,7 @@ -> [Either Term Type] -> m Type applyTypeToArgs _ opTy [] = return opTy-applyTypeToArgs m opTy (Right ty:args) = applyTy opTy ty >>=+applyTypeToArgs m opTy (Right ty:args) = applyTy m opTy ty >>= (flip (applyTypeToArgs m) args) applyTypeToArgs m opTy (Left e:args) = case splitFunTy m opTy of Just (_,resTy) -> applyTypeToArgs m resTy args@@ -199,3 +203,23 @@ -> Id varToId (Var ty nm) = Id nm (embed ty) varToId e = error $ $(curLoc) ++ "varToId: not a var: " ++ showDoc e++termSize :: Term+ -> Int+termSize (Var _ _) = 1+termSize (Data _) = 1+termSize (Literal _) = 1+termSize (Prim _ _) = 1+termSize (Lam b) = let (_,e) = unsafeUnbind b+ in termSize e + 1+termSize (TyLam b) = let (_,e) = unsafeUnbind b+ in termSize e+termSize (App e1 e2) = termSize e1 + termSize e2+termSize (TyApp e _) = termSize e+termSize (Letrec b) = let (bndrsR,body) = unsafeUnbind b+ bndrSzs = map (termSize . unembed . snd) (unrec bndrsR)+ bodySz = termSize body+ in sum (bodySz:bndrSzs)+termSize (Case subj alts) = let subjSz = termSize subj+ altSzs = map (termSize . snd . unsafeUnbind) alts+ in sum (subjSz:altSzs)
src/CLaSH/Driver.hs view
@@ -19,6 +19,7 @@ import Text.PrettyPrint.Leijen.Text (Doc, hPutDoc) import Unbound.LocallyNameless (name2String) +import CLaSH.Core.Term (Term) import CLaSH.Core.Type (Type) import CLaSH.Core.TyCon (TyCon, TyConName) import CLaSH.Driver.TestbenchGen@@ -29,7 +30,6 @@ import CLaSH.Netlist.VHDL (genVHDL, mkTyPackage) import CLaSH.Normalize (checkNonRecursive, cleanupGraph, normalize, runNormalization)-import CLaSH.Normalize.Util (lambdaDropPrep) import CLaSH.Primitives.Types import CLaSH.Rewrite.Types (DebugLevel (..)) import CLaSH.Util@@ -41,9 +41,10 @@ -> PrimMap -- ^ Primitive / BlackBox Definitions -> HashMap TyConName TyCon -- ^ TyCon cache -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator+ -> (HashMap TyConName TyCon -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction) -> DebugLevel -- ^ Debug information level for the normalization process -> IO ()-generateVHDL bindingsMap primMap tcm typeTrans dbgLevel = do+generateVHDL bindingsMap primMap tcm typeTrans eval dbgLevel = do start <- Clock.getCurrentTime prepTime <- start `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime let prepStartDiff = Clock.diffUTCTime prepTime start@@ -69,17 +70,16 @@ . Supply.freshId <$> Supply.newSupply - let preppedMap = lambdaDropPrep bindingsMap (fst topEntity)- doNorm = do norm <- normalize [fst topEntity]+ let doNorm = do norm <- normalize [fst topEntity] let normChecked = checkNonRecursive (fst topEntity) norm cleanupGraph (fst topEntity) normChecked- transformedBindings = runNormalization dbgLevel supplyN preppedMap typeTrans tcm doNorm+ transformedBindings = runNormalization dbgLevel supplyN bindingsMap typeTrans tcm eval doNorm normTime <- transformedBindings `deepseq` Clock.getCurrentTime let prepNormDiff = Clock.diffUTCTime normTime prepTime putStrLn $ "Normalisation took " ++ show prepNormDiff - (netlist,vhdlState) <- genNetlist Nothing+ (netlist,vhdlState,cmpCnt) <- genNetlist Nothing Nothing transformedBindings primMap tcm typeTrans Nothing (fst topEntity) @@ -94,7 +94,7 @@ netlist (testBench,vhdlState') <- genTestBench dbgLevel supplyTB primMap- typeTrans tcm vhdlState preppedMap+ typeTrans tcm eval vhdlState cmpCnt bindingsMap (listToMaybe $ map fst $ HashMap.toList testInputs) (listToMaybe $ map fst $ HashMap.toList expectedOutputs) topComponent
src/CLaSH/Driver/TestbenchGen.hs view
@@ -10,44 +10,28 @@ where import Control.Concurrent.Supply (Supply)-import Control.Error (EitherT, eitherT,- hoistEither, left, note,- right)-import Control.Monad (forM)-import Control.Monad.State (State,runState)-import Control.Monad.Trans.Class (lift)-import Data.Either (lefts)+import Control.Monad.State (evalState) import Data.HashMap.Lazy (HashMap)-import qualified Data.HashMap.Lazy as HashMap-import Data.List (intersperse)+import Data.List (find,nub) import Data.Maybe (mapMaybe)-import Data.Text.Lazy (Text)+import Data.Text.Lazy (isPrefixOf,pack,splitOn) import qualified Data.Text.Lazy.Builder as Builder import qualified Data.Text.Lazy.Builder.RealFloat as Builder import Text.PrettyPrint.Leijen.Text ((<+>), (<>)) import qualified Text.PrettyPrint.Leijen.Text as PP-import Text.PrettyPrint.Leijen.Text.Monadic ()-import qualified Text.PrettyPrint.Leijen.Text.Monadic as PPM-import Unbound.LocallyNameless (bind, makeName, name2Integer,- name2String, rec, runFreshM,- unbind, unrec)+import Unbound.LocallyNameless (name2String) -import CLaSH.Core.DataCon-import CLaSH.Core.Pretty import CLaSH.Core.Term import CLaSH.Core.TyCon import CLaSH.Core.Type-import CLaSH.Core.Util import CLaSH.Netlist import CLaSH.Netlist.Types as N-import CLaSH.Netlist.Util (typeSize)-import CLaSH.Netlist.VHDL (vhdlType,vhdlTypeMark)+import CLaSH.Netlist.VHDL (vhdlTypeDefault) import CLaSH.Normalize (cleanupGraph, normalize, runNormalization) import CLaSH.Primitives.Types import CLaSH.Rewrite.Types-import CLaSH.Rewrite.Util (substituteBinders) import CLaSH.Util @@ -59,244 +43,176 @@ -> PrimMap -- ^ Primitives -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -> HashMap TyConName TyCon+ -> (HashMap TyConName TyCon -> Term -> Term) -> VHDLState+ -> Int -> HashMap TmName (Type,Term) -- ^ Global binders -> Maybe TmName -- ^ Stimuli -> Maybe TmName -- ^ Expected output -> Component -- ^ Component to generate TB for -> IO ([Component],VHDLState)-genTestBench dbgLvl supply primMap typeTrans tcm vhdlState globals stimuliNmM expectedNmM- (Component cName [(clkName,Clock rate),(rstName,Reset reset)] [inp] outp _)- = eitherT error return $ do- let rateF = fromIntegral rate :: Float- resetF = fromIntegral reset :: Float- emptyStimuli = right ([],[],vhdlState,0)- (inpDecls,inpComps,vhdlState',inpCnt) <- flip (maybe emptyStimuli) stimuliNmM $ \stimuliNm -> do- (decls,sigVs,comps,vhdlState') <- prepareSignals vhdlState primMap globals- typeTrans tcm normalizeSignal Nothing- stimuliNm-- let sigAs = zipWith delayedSignal sigVs- (0.0:iterate (+rateF) (0.6 * rateF))- sigAs' = BlackBoxE ( PP.displayT . PP.renderPretty 0.4 80 . PP.vsep- $ PP.punctuate PP.comma sigAs ) Nothing- inpAssign = Assignment (fst inp) sigAs'-- return (inpAssign:decls,comps,vhdlState',length sigVs)-- let emptyExpected = right ([],[],vhdlState',0)- (expDecls,expComps,vhdlState'',expCnt) <- flip (maybe emptyExpected) expectedNmM $ \expectedNm -> do- (decls,sigVs,comps,vhdlState'') <- prepareSignals vhdlState' primMap globals typeTrans tcm normalizeSignal (Just inpCnt) expectedNm- let asserts = map (genAssert (fst outp)) sigVs- (toStrDecls,vhdlState3) = runState (mkToStringDecls (snd outp)) vhdlState''- procDecl = PP.vsep- [ "process is"- , PP.indent 2 toStrDecls- , "begin"- , PP.indent 2 ( PP.vsep $- map (<> PP.semi) $- concat [ ["wait for" <+> renderFloat2Dec (rateF * 0.4) <+> "ns" ]- , intersperse ("wait for" <+> renderFloat2Dec rateF <+> "ns") asserts- , ["wait"]- ]- )- , "end process" <> PP.semi- ]- procDecl' = BlackBoxD (PP.displayT $ PP.renderPretty 0.4 80 procDecl)- return (procDecl':decls,comps,vhdlState3,length sigVs)-- let finExpr = "'1' after" <+> renderFloat2Dec (rateF * (fromIntegral (max inpCnt expCnt) - 0.5)) <+> "ns"- finDecl = [ NetDecl "finished" Bit (Just (N.Literal Nothing (BitLit L)))- , Assignment "finished" (BlackBoxE (PP.displayT $ PP.renderCompact finExpr) Nothing)- , Assignment "done" (Identifier "finished" Nothing)- ]-- clkExpr = "not" <+> PP.text clkName <+> "after" <+> renderFloat2Dec (rateF * 0.5) <+> "ns when finished = '0'"- clkDecl = [ NetDecl clkName (Clock rate) (Just (N.Literal Nothing (BitLit L)))- , Assignment clkName (BlackBoxE (PP.displayT $ PP.renderCompact clkExpr) Nothing)+genTestBench dbgLvl supply primMap typeTrans tcm eval vhdlState cmpCnt globals stimuliNmM expectedNmM+ (Component cName hidden [inp] outp _) = do+ let ioDecl = [ uncurry NetDecl inp Nothing+ , uncurry NetDecl outp Nothing ]+ inpAssg = evalState (vhdlTypeDefault (snd inp)) vhdlState+ inpExpr = Assignment (fst inp) (BlackBoxE (PP.displayT $ PP.renderCompact inpAssg) Nothing)+ (inpInst,inpComps,vhdlState',cmpCnt',hidden') <- maybe (return (inpExpr,[],vhdlState,cmpCnt,hidden))+ (genStimuli vhdlState cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp)+ stimuliNmM - retExpr = PP.vcat $ PP.punctuate PP.comma- [ "'0' after 0 ns"- , "'1' after" <+> renderFloat2Dec (0.24 * resetF) <+> "ns"- ]- retDecl = [ NetDecl rstName Bit Nothing- , Assignment rstName (BlackBoxE (PP.displayT $ PP.renderCompact retExpr) Nothing)- ]- ioDecl = [ uncurry NetDecl inp Nothing- , uncurry NetDecl outp Nothing+ let finDecl = [ NetDecl "finished" Bool (Just (N.Literal Nothing (BoolLit False)))+ , Assignment "done" (Identifier "finished" Nothing) ]+ finAssg = "true after 100 ns"+ finExpr = Assignment "finished" (BlackBoxE (PP.displayT $ PP.renderCompact finAssg) Nothing)+ (expInst,expComps,vhdlState'',hidden'') <- maybe (return (finExpr,[],vhdlState',hidden'))+ (genVerifier vhdlState' cmpCnt' primMap globals typeTrans tcm normalizeSignal hidden' outp)+ expectedNmM+ let clkNms = mapMaybe (\hd -> case hd of (clkNm,Clock _) -> Just clkNm ; _ -> Nothing) hidden+ rstNms = mapMaybe (\hd -> case hd of (clkNm,Reset _) -> Just clkNm ; _ -> Nothing) hidden+ clks = mapMaybe genClock hidden''+ rsts = mapMaybe genReset hidden'' - instDecl = InstDecl cName "totest"- (map (\i -> (i,Identifier i Nothing))- [ clkName, rstName, fst inp, fst outp ]- )+ let instDecl = InstDecl cName "totest"+ (map (\i -> (i,Identifier i Nothing))+ (concat [ clkNms, rstNms, [fst inp], [fst outp] ])+ ) - tbComp = Component "testbench" [] [] ("done",Bit)+ tbComp = Component "testbench" [] [] ("done",Bool) (concat [ finDecl- , clkDecl- , retDecl+ , concat clks+ , concat rsts , ioDecl- , [instDecl]- , inpDecls- , expDecls+ , [instDecl,inpInst,expInst] ]) - return (tbComp:inpComps ++ expComps,vhdlState'')-+ return (tbComp:(inpComps++expComps),vhdlState'') where normalizeSignal :: HashMap TmName (Type,Term) -> TmName -> HashMap TmName (Type,Term) normalizeSignal glbls bndr =- runNormalization dbgLvl supply glbls typeTrans tcm (normalize [bndr] >>= cleanupGraph bndr)--genTestBench _ _ _ _ _ v _ _ _ c = traceIf True ("Can't make testbench for: " ++ show c) $ return ([],v)--delayedSignal :: Text- -> Float- -> PP.Doc-delayedSignal s t =- PP.hsep- [ PP.text s- , "after"- , renderFloat2Dec t- , "ns"- ]--renderFloat2Dec :: Float -> PP.Doc-renderFloat2Dec = PP.text . Builder.toLazyText . Builder.formatRealFloat Builder.Fixed (Just 2)+ runNormalization dbgLvl supply glbls typeTrans tcm eval (normalize [bndr] >>= cleanupGraph bndr) -genAssert :: Identifier -> Identifier -> PP.Doc-genAssert compO expV = PP.hsep- [ PP.text "assert"- , PP.parens $ PP.hsep [ PP.text compO- , PP.equals- , PP.text expV- ]- , PP.text "report"- , PP.parens (PP.hsep [ "\"expected: \" &"- , "to_string" <+> PP.parens (PP.text expV)- , "& \", actual: \" &"- , "to_string" <+> PP.parens (PP.text compO)- ])- , PP.text "severity error"- ]+genTestBench _ _ _ _ _ _ v _ _ _ _ c = traceIf True ("Can't make testbench for: " ++ show c) $ return ([],v) -mkToStringDecls :: HWType -> State VHDLState PP.Doc-mkToStringDecls t@(Product _ elTys) =- PPM.vcat (mapM mkToStringDecls elTys) PPM.<$>- "function to_string" PPM.<+> PPM.parens ("value :" PPM.<+> vhdlType t) PPM.<+> "return STRING is" PPM.<$>- "begin" PPM.<$>- PPM.indent 2 ("return" PPM.<+> PPM.parens (PPM.hcat (PPM.punctuate " & " elTyPrint)) PPM.<> PPM.semi) PPM.<$>- "end function to_string;"+genClock :: (Identifier,HWType)+ -> Maybe [Declaration]+genClock (clkName,Clock rate) = Just clkDecls where- elTyPrint = forM [0..(length elTys - 1)]- (\i -> "to_string" PPM.<>- PPM.parens ("value." PPM.<> vhdlType t PPM.<> "_sel" PPM.<> PPM.int i))-mkToStringDecls (Vector _ Bit) = PPM.empty-mkToStringDecls t@(Vector _ elTy) =- mkToStringDecls elTy PPM.<$>- "function to_string" PPM.<+> PPM.parens ("value : " PPM.<+> vhdlTypeMark t) PPM.<+> "return STRING is" PPM.<$>- PPM.indent 2- ( "alias ivalue : " PPM.<+> vhdlTypeMark t PPM.<> "(1 to value'length) is value;" PPM.<$>- "variable result : STRING" PPM.<> PPM.parens ("1 to value'length * " PPM.<> PPM.int (typeSize elTy)) PPM.<> PPM.semi- ) PPM.<$>- "begin" PPM.<$>- PPM.indent 2- ("for i in ivalue'range loop" PPM.<$>- PPM.indent 2- ( "result" PPM.<> PPM.parens (PPM.parens ("(i - 1) * " PPM.<> PPM.int (typeSize elTy)) PPM.<+> "+ 1" PPM.<+>- "to i*" PPM.<> PPM.int (typeSize elTy)) PPM.<+>- ":= to_string" PPM.<> PPM.parens (if elTy == Bool then "toSLV(ivalue(i))" else "ivalue(i)") PPM.<> PPM.semi- ) PPM.<$>- "end loop;" PPM.<$>- "return result;"- ) PPM.<$>- "end function to_string;"-mkToStringDecls _ = PPM.empty--prepareSignals :: VHDLState- -> PrimMap- -> HashMap TmName (Type,Term)- -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))- -> HashMap TyConName TyCon- -> ( HashMap TmName (Type,Term)- -> TmName- -> HashMap TmName (Type,Term) )- -> Maybe Int- -> TmName- -> EitherT String IO- ([Declaration],[Identifier],[Component],VHDLState)-prepareSignals vhdlState primMap globals typeTrans tcm normalizeSignal mStart signalNm = do- let signalS = name2String signalNm- (signalTy,signalTm) <- hoistEither $ note ($(curLoc) ++ "Unable to find: " ++ signalS)- (HashMap.lookup signalNm globals)- signalList <- termToList signalTm- elemTy <- stimuliElemTy signalTy+ clkGenDecl = PP.vsep+ [ "-- pragma translate_off"+ , "process is"+ , "begin"+ , PP.indent 2+ (PP.vsep [ "wait for 2 ns;"+ , "while (not finished) loop"+ , PP.indent 2+ (PP.vsep [PP.text clkName <+> "<= not" <+> PP.text clkName <> PP.semi+ ,"wait for" <+> renderFloat2Dec (fromIntegral rate * 0.5) <+> "ns;"+ ,PP.text clkName <+> "<= not" <+> PP.text clkName <> PP.semi+ ,"wait for" <+> renderFloat2Dec (fromIntegral rate * 0.5) <+> "ns;"+ ])+ , "end loop;"+ , "wait;"+ ])+ , "end process;"+ , "-- pragma translate_on"+ ] - let signalK = name2Integer signalNm- elemNms = map (\i -> makeName (signalS ++ show i) signalK) [(0::Int)..]- elemBnds = zipWith (\nm e -> (nm,(elemTy,e))) elemNms signalList- signalList_normalized = map (normalizeSignal (HashMap.fromList elemBnds `HashMap.union` globals)- . fst- ) elemBnds+ clkDecls = [ NetDecl clkName (Clock rate) (Just (N.Literal Nothing (BitLit L)))+ , BlackBoxD (PP.displayT $ PP.renderPretty 0.4 80 clkGenDecl)+ ] - lift $ createSignal vhdlState primMap typeTrans tcm mStart signalList_normalized+genClock _ = Nothing -termToList :: Monad m => Term -> EitherT String m [Term]-termToList e = case second lefts $ collectArgs e of- (Data dc,[])- | name2String (dcName dc) == "GHC.Types.[]" -> pure []- | name2String (dcName dc) == "Prelude.List.Nil" -> pure []- | otherwise -> errNoConstruct $(curLoc)- (Data dc,[hdArg,tlArg])- | name2String (dcName dc) == "GHC.Types.:" -> (hdArg:) <$> termToList tlArg- | name2String (dcName dc) == "Prelude.List.::" -> (hdArg:) <$> termToList tlArg- | otherwise -> errNoConstruct $(curLoc)- (Letrec b,[]) -> case (runFreshM $ unbind b) of- (bndrs,body) -> case substituteBinders (unrec bndrs) [] body of- ([],bodyS) -> termToList bodyS- _ -> errNoConstruct $(curLoc)- _ -> errNoConstruct $(curLoc)+genReset :: (Identifier,HWType)+ -> Maybe [Declaration]+genReset (rstName,Reset _) = Just rstDecls where- errNoConstruct l = left $ l ++ "Can't deconstruct list literal: " ++ show (second lefts $ collectArgs e)+ rstExpr = PP.vsep+ [ "-- pragma translate_off"+ , PP.text rstName <+> "<=" <+> PP.align (PP.vsep (PP.punctuate PP.comma+ [ "'0' after 0 ns"+ , "'1' after 1 ns;"+ ]))+ , "-- pragma translate_on"+ ] -stimuliElemTy :: Monad m => Type -> EitherT String m Type-stimuliElemTy ty = case splitTyConAppM ty of- (Just (tc,[arg]))- | name2String tc == "GHC.Types.[]" -> return arg- | name2String tc == "Prelude.List.List" -> return arg- | otherwise -> left $ $(curLoc) ++ "Not a List TyCon: " ++ showDoc ty- _ -> left $ $(curLoc) ++ "Not a List TyCon: " ++ showDoc ty+ rstDecls = [ NetDecl rstName Bit Nothing+ , BlackBoxD (PP.displayT $ PP.renderCompact rstExpr)+ ] -createSignal :: VHDLState- -> PrimMap- -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))- -> HashMap TyConName TyCon- -> Maybe Int- -> [HashMap TmName (Type,Term)]- -> IO ([Declaration],[Identifier],[Component],VHDLState)-createSignal vhdlState primMap typeTrans tcm mStart normalizedSignals = do- let (signalHds,signalTls) = unzip $ map ((\(l:ls) -> (l,ls)) . HashMap.toList) normalizedSignals- sigEs = runFreshM $ mapM (\(_,(_,Letrec b)) -> (unrec . fst) <$> unbind b) signalHds- newExpr = Letrec $ bind (rec $ concat sigEs)- (Var (fst . snd $ head signalHds)- (fst $ head signalHds))- newBndr = (fst $ head signalHds, (fst . snd $ head signalHds, newExpr))+genReset _ = Nothing - (Component _ _ _ _ decls:comps,vhdlState') <- genNetlist (Just vhdlState)- (HashMap.fromList $ newBndr : concat signalTls)- primMap- tcm- typeTrans- mStart- (fst $ head signalHds)+renderFloat2Dec :: Float -> PP.Doc+renderFloat2Dec = PP.text . Builder.toLazyText . Builder.formatRealFloat Builder.Fixed (Just 2) - let sigVs = mapMaybe (\d -> case d of- NetDecl i _ _ -> Just i- _ -> Nothing- )- decls+genStimuli :: VHDLState+ -> Int+ -> PrimMap+ -> HashMap TmName (Type,Term)+ -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))+ -> HashMap TyConName TyCon+ -> ( HashMap TmName (Type,Term)+ -> TmName+ -> HashMap TmName (Type,Term) )+ -> [(Identifier,HWType)]+ -> (Identifier,HWType)+ -> TmName+ -> IO (Declaration,[Component],VHDLState,Int,[(Identifier,HWType)])+genStimuli vhdlState cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp signalNm = do+ let stimNormal = normalizeSignal globals signalNm+ (comps,vhdlState',cmpCnt') <- genNetlist (Just vhdlState) (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing signalNm+ let sigNm = last (splitOn (pack ".") (pack (name2String signalNm)))+ sigComp = case find ((isPrefixOf sigNm) . componentName) comps of+ Just c -> c+ Nothing -> error $ $(curLoc) ++ "Can't locate component for stimuli gen: " ++ (show $ pack $ name2String signalNm) ++ show (map (componentName) comps) - return (decls,sigVs,comps,vhdlState')+ (cName,hidden',outp) = case sigComp of+ (Component a b [] (c,_) _) -> (a,b,c)+ (Component a _ is _ _) -> error $ $(curLoc) ++ "Stimuli gen " ++ show a ++ " has unexpected inputs: " ++ show is+ hidden'' = nub (hidden ++ hidden')+ clkNms = mapMaybe (\hd -> case hd of (clkNm,Clock _) -> Just clkNm ; _ -> Nothing) hidden'+ rstNms = mapMaybe (\hd -> case hd of (clkNm,Reset _) -> Just clkNm ; _ -> Nothing) hidden'+ decl = InstDecl cName "stimuli"+ (map (\i -> (i,Identifier i Nothing))+ (concat [ clkNms, rstNms ]) +++ [(outp,Identifier (fst inp) Nothing)]+ )+ return (decl,comps,vhdlState',cmpCnt',hidden'')++genVerifier :: VHDLState+ -> Int+ -> PrimMap+ -> HashMap TmName (Type,Term)+ -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))+ -> HashMap TyConName TyCon+ -> ( HashMap TmName (Type,Term)+ -> TmName+ -> HashMap TmName (Type,Term) )+ -> [(Identifier,HWType)]+ -> (Identifier,HWType)+ -> TmName+ -> IO (Declaration,[Component],VHDLState,[(Identifier,HWType)])+genVerifier vhdlState cmpCnt primMap globals typeTrans tcm normalizeSignal hidden outp signalNm = do+ let stimNormal = normalizeSignal globals signalNm+ (comps,vhdlState',_) <- genNetlist (Just vhdlState) (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing signalNm+ let sigNm = last (splitOn (pack ".") (pack (name2String signalNm)))+ sigComp = case find ((isPrefixOf sigNm) . componentName) comps of+ Just c -> c+ Nothing -> error $ $(curLoc) ++ "Can't locate component for Verifier: " ++ (show $ pack $ name2String signalNm) ++ show (map (componentName) comps)+ (cName,hidden',inp,fin) = case sigComp of+ (Component a b [(c,_)] (d,_) _) -> (a,b,c,d)+ (Component a _ is _ _) -> error $ $(curLoc) ++ "Verifier " ++ show a ++ " has unexpected inputs: " ++ show is+ hidden'' = nub (hidden ++ hidden')+ clkNms = mapMaybe (\hd -> case hd of (clkNm,Clock _) -> Just clkNm ; _ -> Nothing) hidden'+ rstNms = mapMaybe (\hd -> case hd of (clkNm,Reset _) -> Just clkNm ; _ -> Nothing) hidden'+ decl = InstDecl cName "verify"+ (map (\i -> (i,Identifier i Nothing))+ (concat [ clkNms, rstNms ]) +++ [(inp,Identifier (fst outp) Nothing),(fin,Identifier "finished" Nothing)]+ )+ return (decl,comps,vhdlState',hidden'')
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)-import CLaSH.Core.TyCon (TyConName, TyCon)+import CLaSH.Core.Type (Type (..), ConstTy (..))+import CLaSH.Core.TyCon (TyConName, TyCon, tyConDataCons) import CLaSH.Core.Util (collectArgs, isVar, termType) import CLaSH.Core.Var (Id, Var (..)) import CLaSH.Netlist.BlackBox@@ -42,6 +42,8 @@ -- @topEntity@ at the top. genNetlist :: Maybe VHDLState -- ^ State for the 'CLaSH.Netlist.VHDL.VHDLM' Monad+ -> Maybe Int+ -- ^ Starting number of the component counter -> HashMap TmName (Type,Term) -- ^ Global binders -> PrimMap@@ -54,14 +56,16 @@ -- ^ Symbol count -> TmName -- ^ Name of the @topEntity@- -> IO ([Component],VHDLState)-genNetlist vhdlStateM globals primMap tcm typeTrans mStart topEntity = do- (_,s) <- runNetlistMonad vhdlStateM globals primMap tcm typeTrans $ genComponent topEntity mStart- return (HashMap.elems $ _components s, _vhdlMState s)+ -> IO ([Component],VHDLState,Int)+genNetlist vhdlStateM compCntM globals primMap tcm typeTrans mStart topEntity = do+ (_,s) <- runNetlistMonad vhdlStateM compCntM globals primMap tcm typeTrans $ genComponent topEntity mStart+ return (HashMap.elems $ _components s, _vhdlMState s, _cmpCount s) -- | Run a NetlistMonad action in a given environment runNetlistMonad :: Maybe VHDLState -- ^ State for the 'CLaSH.Netlist.VHDL.VHDLM' Monad+ -> Maybe Int+ -- ^ Starting number of the component counter -> HashMap TmName (Type,Term) -- ^ Global binders -> PrimMap@@ -73,13 +77,13 @@ -> NetlistMonad a -- ^ Action to run -> IO (a,NetlistState)-runNetlistMonad vhdlStateM s p tcm typeTrans+runNetlistMonad vhdlStateM compCntM s p tcm typeTrans = runFreshMT . flip runStateT s' . (fmap fst . runWriterT) . runNetlist where- s' = NetlistState s HashMap.empty 0 0 HashMap.empty p (fromMaybe (HashSet.empty,0,HashMap.empty) vhdlStateM) typeTrans tcm+ s' = NetlistState s HashMap.empty 0 (fromMaybe 0 compCntM) HashMap.empty p (fromMaybe (HashSet.empty,0,HashMap.empty) vhdlStateM) typeTrans tcm -- | Generate a component for a given function (caching) genComponent :: TmName -- ^ Name of the function@@ -199,13 +203,6 @@ _ -> error $ $(curLoc) ++ "Not in normal form: Not a variable reference or primitive as subject of a case-statement" _ -> scrutE - 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 t i = HW.Literal (Just $ conSize t) (NumLit (i-1))- mkDeclarations bndr app = do let (appF,(args,tyArgs)) = second partitionEithers $ collectArgs app tcm <- Lens.use tcCache@@ -258,32 +255,61 @@ mkExpr ty app = do let (appF,(args,_)) = second partitionEithers $ collectArgs app- hwTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty+ hwTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty tcm <- Lens.use tcCache args' <- Monad.filterM (Monad.liftM3 representableType (Lens.use typeTranslator) (pure tcm) . termType tcm) args case appF of Data dc | 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 _ -> do- bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives- case bbM of- Just p@(P.BlackBox {}) ->- case template p of- Left templD -> do- i <- varCount <<%= (+1)- let tmpNm = "tmp_" ++ show i- tmpId = Id (string2Name tmpNm) (Embed ty)- tmpS = Text.pack tmpNm- netDecl = NetDecl tmpS hwTy Nothing- (bbCtx,ctxDcls) <- mkBlackBoxContext tmpId args- bb <- fmap BlackBoxD $! mkBlackBox templD bbCtx- return (Identifier tmpS Nothing, ctxDcls ++ [netDecl,bb])- Right templE -> do- (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (Embed ty)) args- bb <- fmap (`BlackBoxE` Nothing) $! mkBlackBox templE bbCtx- return (bb,ctxDcls)- _ -> error $ $(curLoc) ++ "No blackbox found: " ++ TextS.unpack nm+ Prim nm _+ | 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+ tmpS = Text.pack tmpNm+ netDecl = NetDecl tmpS hwTy Nothing+ netAssign = CondAssignment tmpS scrutExpr (zip altLhs altRhs)+ return (Identifier tmpS Nothing,netDecl:netAssign:scrutDecls)+ | nm == TextS.pack "GHC.Prim.dataToTag#" -> do+ i <- varCount <<%= (+1)+ scrutTy <- termType tcm (head args)+ (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+ tmpS = Text.pack tmpNm+ netDecl = NetDecl tmpS hwTy Nothing+ netAssign = CondAssignment tmpS scrutExpr (zip altLhs altRhs)+ return (Identifier tmpS Nothing,netDecl:netAssign:scrutDecls)+ | otherwise -> do+ bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives+ case bbM of+ Just p@(P.BlackBox {}) ->+ case template p of+ Left templD -> do+ i <- varCount <<%= (+1)+ let tmpNm = "tmp_" ++ show i+ tmpId = Id (string2Name tmpNm) (Embed ty)+ tmpS = Text.pack tmpNm+ netDecl = NetDecl tmpS hwTy Nothing+ (bbCtx,ctxDcls) <- mkBlackBoxContext tmpId args+ bb <- fmap BlackBoxD $! mkBlackBox templD bbCtx+ return (Identifier tmpS Nothing, ctxDcls ++ [netDecl,bb])+ Right templE -> do+ (bbCtx,ctxDcls) <- mkBlackBoxContext (Id (string2Name "_ERROR_") (Embed ty)) args+ bb <- fmap (`BlackBoxE` Nothing) $! mkBlackBox templE bbCtx+ return (bb,ctxDcls)+ _ -> error $ $(curLoc) ++ "No blackbox found: " ++ TextS.unpack nm Var _ f | null args -> return (Identifier (mkBasicId . Text.pack $ name2String f) Nothing,[]) | otherwise -> error $ $(curLoc) ++ "Not in normal form: top-level binder in argument position: " ++ showDoc app
src/CLaSH/Netlist/BlackBox.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -- | Functions to create BlackBox Contexts and fill in BlackBox templates@@ -55,7 +56,9 @@ (funInps,declssF) <- fmap (unzip . catMaybes) $ mapM (runMaybeT . mkFunInput resId . fst) funArgs -- Make context result- let res = Left . mkBasicId . pack $ name2String (V.varName resId)+ let res = case synchronizedClk (unembed $ V.varType resId) of+ Just clk -> Right . (,clk) . mkBasicId . pack $ name2String (V.varName resId)+ Nothing -> Left . mkBasicId . pack $ name2String (V.varName resId) resTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) (unembed $ V.varType resId) return ( Context (res,resTy) varInps (map fst litInps) funInps
src/CLaSH/Netlist/BlackBox/Parser.hs view
@@ -45,12 +45,12 @@ ((:) <$> pOutput <*> pList pInput) <* pToken "~INST" -- | Parse the output tag of Declaration-pOutput :: Parser BlackBoxTemplate-pOutput = pTokenWS "~OUTPUT" *> pTokenWS "<=" *> pBlackBoxE <* pTokenWS "~"+pOutput :: Parser (BlackBoxTemplate,BlackBoxTemplate)+pOutput = pTokenWS "~OUTPUT" *> pTokenWS "<=" *> ((,) <$> (pBlackBoxE <* pTokenWS "~") <*> pBlackBoxE) <* pTokenWS "~" -- | Parse the input tag of Declaration-pInput :: Parser BlackBoxTemplate-pInput = pTokenWS "~INPUT" *> pTokenWS "<=" *> pBlackBoxE <* pTokenWS "~"+pInput :: Parser (BlackBoxTemplate,BlackBoxTemplate)+pInput = pTokenWS "~INPUT" *> pTokenWS "<=" *> ((,) <$> (pBlackBoxE <* pTokenWS "~") <*> pBlackBoxE) <* pTokenWS "~" -- | Parse an Expression element pTagE :: Parser Element@@ -68,6 +68,7 @@ <|> (TypM . Just) <$> (pToken "~TYPM" *> pBrackets pNatural) <|> Def Nothing <$ pToken "~DEFAULTO" <|> (Def . Just) <$> (pToken "~DEFAULT" *> pBrackets pNatural)+ <|> TypElem <$> (pToken "~TYPEL" *> pBrackets pTagE) -- | Parse a bracketed text pBrackets :: Parser a -> Parser a
src/CLaSH/Netlist/BlackBox/Types.hs view
@@ -24,7 +24,7 @@ -- | Either the name of the identifier, or a tuple of the identifier and the -- corresponding clock-type SyncIdentifier = Either Identifier (Identifier,Identifier)+type SyncIdentifier = Either Identifier (Identifier,(Identifier,Int)) -- | A BlackBox Template is a List of Elements type BlackBoxTemplate = [Element]@@ -42,13 +42,17 @@ | Typ (Maybe Int) -- ^ Type declaration hole | TypM (Maybe Int) -- ^ Type root hole | Def (Maybe Int) -- ^ Default value hole+ | TypElem Element -- ^ Select element type from a vector type deriving Show -- | Component instantiation hole. First argument indicates which function argument -- to instantiate. Second argument corresponds to output and input assignments, -- where the first element is the output assignment, and the subsequent elements -- are the consecutive input assignments.-data Decl = Decl Int [BlackBoxTemplate]+--+-- The LHS of the tuple is the name of the signal, while the RHS of the tuple+-- is the type of the signal+data Decl = Decl Int [(BlackBoxTemplate,BlackBoxTemplate)] deriving Show -- | Monad that caches VHDL information and remembers hidden inputs of
src/CLaSH/Netlist/BlackBox/Util.hs view
@@ -40,7 +40,7 @@ countArgs l = maximum $ map (\e -> case e of I n -> n- D (Decl _ l') -> maximum $ map countArgs l'+ D (Decl _ l') -> maximum $ map (countArgs . fst) l' _ -> -1 ) l @@ -50,7 +50,7 @@ countLits l = maximum $ map (\e -> case e of L n -> n- D (Decl _ l') -> maximum $ map countLits l'+ D (Decl _ l') -> maximum $ map (countLits . fst) l' _ -> -1 ) l @@ -75,12 +75,12 @@ _2 %= IntMap.insert i' k return (Sym k) Just k -> return (Sym k)- D (Decl n l') -> D <$> (Decl n <$> mapM setSym' l')+ D (Decl n l') -> D <$> (Decl n <$> mapM (combineM setSym' setSym') l') _ -> pure e ) -- | Get the name of the clock of an identifier-clkSyncId :: SyncIdentifier -> Identifier+clkSyncId :: SyncIdentifier -> (Identifier,Int) clkSyncId (Right (_,clk)) = clk clkSyncId (Left i) = error $ $(curLoc) ++ "No clock for: " ++ show i @@ -102,8 +102,8 @@ -> Element -> BlackBoxMonad Text renderElem b (D (Decl n (l:ls))) = do- o <- lineToIdentifier b l- is <- mapM (lineToIdentifier b) ls+ o <- combineM (lineToIdentifier b) (lineToType b) l+ is <- mapM (combineM (lineToIdentifier b) (lineToType b)) ls let (templ,pCtx) = indexNote ($(curLoc) ++ "No function argument " ++ show n) (funInputs b) n let b' = pCtx { result = o, inputs = inputs pCtx ++ is } if verifyBlackBoxContext templ b'@@ -117,18 +117,27 @@ -- be used for a new blackbox context. lineToIdentifier :: BlackBoxContext -> BlackBoxTemplate- -> BlackBoxMonad (SyncIdentifier,HWType)-lineToIdentifier b = foldrM (\e (a,_) -> do+ -> BlackBoxMonad SyncIdentifier+lineToIdentifier b = foldrM (\e a -> do e' <- mkSyncIdentifier b e case (e', a) of- (Left t, Left t') -> return (Left (t `Text.append` t'), ty)- (Left t, Right (t',clk)) -> return (Right (t `Text.append` t',clk), ty)- (Right (t,clk), Left t') -> return (Right (t `Text.append` t',clk), ty)- (Right (t,clk), Right (t',_)) -> return (Right (t `Text.append` t',clk), ty)- ) (Left Text.empty,ty)- where- ty = Void+ (Left t, Left t') -> return (Left (t `Text.append` t'))+ (Left t, Right (t',clk)) -> return (Right (t `Text.append` t',clk))+ (Right (t,clk), Left t') -> return (Right (t `Text.append` t',clk))+ (Right (t,clk), Right (t',_)) -> return (Right (t `Text.append` t',clk))+ ) (Left Text.empty) +lineToType :: BlackBoxContext+ -> BlackBoxTemplate+ -> BlackBoxMonad HWType+lineToType b [(Typ Nothing)] = return (snd $ result b)+lineToType b [(Typ (Just n))] = return (snd $ inputs b !! n)+lineToType b [(TypElem t)] = do hwty' <- lineToType b [t]+ case hwty' of+ Vector _ elTy -> return elTy+ _ -> error $ $(curLoc) ++ "Element type selection of a non-vector type"+lineToType _ _ = error $ $(curLoc) ++ "Unexpected type manipulation"+ -- | Give a context and a tagged hole (of a template), returns part of the -- context that matches the tag of the hole. mkSyncIdentifier :: BlackBoxContext@@ -139,14 +148,14 @@ mkSyncIdentifier b (I n) = return $ fst $ inputs b !! n mkSyncIdentifier b (L n) = return $ Left $ litInputs b !! n mkSyncIdentifier _ (Sym n) = return $ Left $ Text.pack ("n_" ++ show n)-mkSyncIdentifier b (Clk Nothing) = let t = clkSyncId $ fst $ result b- in tell [(t,Clock 10)] >> return (Left t)-mkSyncIdentifier b (Clk (Just n)) = let t = clkSyncId $ fst $ inputs b !! n- in tell [(t,Clock 10)] >> return (Left t)-mkSyncIdentifier b (Rst Nothing) = let t = (`Text.append` Text.pack "_rst") . clkSyncId $ fst $ result b- in tell [(t,Reset 10)] >> return (Left t)-mkSyncIdentifier b (Rst (Just n)) = let t = (`Text.append` Text.pack "_rst") . clkSyncId $ fst $ inputs b !! n- in tell [(t,Reset 10)] >> return (Left t)+mkSyncIdentifier b (Clk Nothing) = let (clk,rate) = clkSyncId $ fst $ result b+ in tell [(clk,Clock rate)] >> return (Left clk)+mkSyncIdentifier b (Clk (Just n)) = let (clk,rate) = clkSyncId $ fst $ inputs b !! n+ in tell [(clk,Clock rate)] >> return (Left clk)+mkSyncIdentifier b (Rst Nothing) = let (rst,rate) = (first (`Text.append` Text.pack "_rst")) . clkSyncId $ fst $ result b+ in tell [(rst,Reset rate)] >> return (Left rst)+mkSyncIdentifier b (Rst (Just n)) = let (rst,rate) = (first (`Text.append` Text.pack "_rst")) . clkSyncId $ fst $ inputs b !! n+ in tell [(rst,Reset rate)] >> return (Left rst) mkSyncIdentifier b (Typ Nothing) = fmap (Left . displayT . renderOneLine) . B . lift . vhdlType . snd $ result b mkSyncIdentifier b (Typ (Just n)) = fmap (Left . displayT . renderOneLine) . B . lift . vhdlType . snd $ inputs b !! n mkSyncIdentifier b (TypM Nothing) = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeMark . snd $ result b@@ -154,3 +163,4 @@ mkSyncIdentifier b (Def Nothing) = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeDefault . snd $ result b mkSyncIdentifier b (Def (Just n)) = fmap (Left . displayT . renderOneLine) . B . lift . vhdlTypeDefault . snd $ inputs b !! n mkSyncIdentifier _ (D _) = error $ $(curLoc) ++ "Unexpected component declaration"+mkSyncIdentifier _ (TypElem _) = error $ $(curLoc) ++ "Unexpected type element selector"
src/CLaSH/Netlist/Util.hs view
@@ -26,12 +26,12 @@ import CLaSH.Core.Subst (substTys) import CLaSH.Core.Term (LetBinding, Term (..), TmName) import CLaSH.Core.TyCon (TyCon (..), TyConName, tyConDataCons)-import CLaSH.Core.Type (Type (..), TypeView (..),+import CLaSH.Core.Type (Type (..), TypeView (..), LitTy (..), splitTyConAppM, tyView) import CLaSH.Core.Util (collectBndrs, termType) import CLaSH.Core.Var (Id, Var (..), modifyVarName) import CLaSH.Netlist.Id-import CLaSH.Netlist.Types+import CLaSH.Netlist.Types as HW import CLaSH.Util -- | Split a normalized term into: a list of arguments, a list of let-bindings,@@ -72,17 +72,23 @@ -> NetlistMonad (Maybe HWType) coreTypeToHWTypeM ty = hush <$> (coreTypeToHWType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure ty) --- | Returns the name of the clock corresponding to a type+-- | Returns the name and period of the clock corresponding to a type synchronizedClk :: Type- -> Maybe Identifier+ -> Maybe (Identifier,Int) synchronizedClk ty | not . null . typeFreeVars $ ty = Nothing | Just (tyCon,args) <- splitTyConAppM ty = case name2String tyCon of- "CLaSH.Signal.Signal" -> Just (pack "clk")- "CLaSH.Sized.Vector.Vec" -> synchronizedClk (args!!1)- "CLaSH.Signal.SignalP" -> Just (pack "clk")- _ -> Nothing+ "CLaSH.Signal.Types.Signal" -> Just (pack "clk1000",1000)+ "CLaSH.Sized.Vector.Vec" -> synchronizedClk (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.Types.CSignalP" -> case (head args) of+ (LitTy (NumTy i)) -> Just (pack ("clk" ++ show i),i)+ _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty+ _ -> Nothing | otherwise = Nothing @@ -150,7 +156,7 @@ -- | Determines the bitsize of a type typeSize :: HWType -> Int-typeSize Void = 0+typeSize Void = 1 typeSize Bool = 1 typeSize Bit = 1 typeSize (Clock _) = 1@@ -161,7 +167,7 @@ typeSize (Vector n el) = n * typeSize el typeSize t@(SP _ cons) = conSize t + maximum (map (sum . map typeSize . snd) cons)-typeSize (Sum _ dcs) = ceiling . logBase (2 :: Float) . fromIntegral $ length dcs+typeSize (Sum _ dcs) = max 1 (ceiling . logBase (2 :: Float) . fromIntegral $ length dcs) typeSize (Product _ tys) = sum $ map typeSize tys -- | Determines the bitsize of the constructor of a type@@ -254,3 +260,10 @@ varCount .= vCnt varEnv .= vEnv return val++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 t i = HW.Literal (Just $ conSize t) (NumLit (i-1))
src/CLaSH/Netlist/VHDL.hs view
@@ -18,7 +18,7 @@ import qualified Control.Applicative as A import Control.Lens hiding (Indexed)-import Control.Monad (join,liftM,when,zipWithM)+import Control.Monad (forM,join,liftM,when,zipWithM) import Control.Monad.State (State) import Data.Graph.Inductive (Gr, mkGraph, topsort') import qualified Data.HashMap.Lazy as HashMap@@ -54,20 +54,32 @@ "package" <+> "types" <+> "is" <$> indent 2 ( packageDec <$> vcat (sequence funDecs)- ) <$>+ ) <>+ (case showDecs of+ [] -> empty+ _ -> linebreak <$>+ "-- pragma translate_off" <$>+ indent 2 (vcat (sequence showDecs)) <$>+ "-- pragma translate_on"+ ) <$> "end" <> semi <> packageBodyDec where hwTysSorted = topSortHWTys hwtys usedTys = nub $ concatMap mkUsedTys hwtys packageDec = vcat $ mapM tyDec hwTysSorted- (funDecs,funBodys) = unzip . catMaybes $ map funDec usedTys+ (funDecs,funBodies) = unzip . catMaybes $ map funDec usedTys+ (showDecs,showBodies) = unzip $ map mkToStringDecls hwTysSorted packageBodyDec :: VHDLM Doc- packageBodyDec = case funBodys of- [] -> empty+ packageBodyDec = case (funBodies,showBodies) of+ ([],[]) -> empty _ -> linebreak <$> "package" <+> "body" <+> "types" <+> "is" <$>- indent 2 (vcat (sequence funBodys)) <$>+ indent 2 (vcat (sequence funBodies)) <$>+ linebreak <>+ "-- pragma translate_off" <$>+ indent 2 (vcat (sequence showBodies)) <$>+ "-- pragma translate_on" <$> "end" <> semi mkUsedTys :: HWType@@ -109,7 +121,7 @@ needsTyDec _ = False tyDec :: HWType -> VHDLM Doc-tyDec (Vector _ elTy) = "type" <+> "array_of_" <> tyName elTy <+> "is array (natural range <>) of" <+> vhdlType elTy <> semi+tyDec (Vector _ elTy) = "type" <+> "array_of_" <> tyName elTy <+> "is array (integer range <>) of" <+> vhdlType elTy <> semi tyDec ty@(Product _ tys) = prodDec where@@ -157,6 +169,41 @@ funDec _ = Nothing +mkToStringDecls :: HWType -> (VHDLM Doc, VHDLM Doc)+mkToStringDecls t@(Product _ elTys) =+ ( "function to_string" <+> parens ("value :" <+> vhdlType t) <+> "return STRING" <> semi+ , "function to_string" <+> parens ("value :" <+> vhdlType t) <+> "return STRING is" <$>+ "begin" <$>+ indent 2 ("return" <+> parens (hcat (punctuate " & " elTyPrint)) <> semi) <$>+ "end function to_string;"+ )+ where+ 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" <$>+ indent 2+ ( "alias ivalue : " <+> vhdlTypeMark t <> "(1 to value'length) is value;" <$>+ "variable result : STRING" <> parens ("1 to value'length * " <> int (typeSize elTy)) <> semi+ ) <$>+ "begin" <$>+ indent 2+ ("for i in ivalue'range loop" <$>+ indent 2+ ( "result" <> parens (parens ("(i - 1) * " <> int (typeSize elTy)) <+> "+ 1" <+>+ "to i*" <> int (typeSize elTy)) <+>+ ":= to_string" <> parens (if elTy == Bool then "toSLV(ivalue(i))" else "ivalue(i)") <> semi+ ) <$>+ "end loop;" <$>+ "return result;"+ ) <$>+ "end function to_string;"+ )+mkToStringDecls _ = (empty,empty)+ tyImports :: VHDLM Doc tyImports = punctuate' semi $ sequence@@ -181,13 +228,16 @@ "end" <> semi where ports l = sequence- $ [ (,fromIntegral $ T.length i) A.<$> (fill l (text i) <+> colon <+> "in" <+> vhdlType ty <+> ":=" <+> vhdlTypeDefault ty)+ $ [ (,fromIntegral $ T.length i) A.<$> (fill l (text i) <+> colon <+> "in" <+> vhdlType ty <> optionalDefault ty) -- <+> ":=" <+> vhdlTypeDefault ty) | (i,ty) <- inputs c ] ++- [ (,fromIntegral $ T.length i) A.<$> (fill l (text i) <+> colon <+> "in" <+> vhdlType ty <+> ":=" <+> vhdlTypeDefault ty)+ [ (,fromIntegral $ T.length i) A.<$> (fill l (text i) <+> colon <+> "in" <+> vhdlType ty <> optionalDefault ty) -- <+> ":=" <+> vhdlTypeDefault ty) | (i,ty) <- hiddenPorts c ] ++- [ (,fromIntegral $ T.length (fst $ output c)) A.<$> (fill l (text (fst $ output c)) <+> colon <+> "out" <+> vhdlType (snd $ output c) <+> ":=" <+> vhdlTypeDefault (snd $ output c))+ [ (,fromIntegral $ T.length (fst $ output c)) A.<$> (fill l (text (fst $ output c)) <+> colon <+> "out" <+> vhdlType (snd $ output c) <> optionalDefault (snd $ output c)) -- <+> ":=" <+> vhdlTypeDefault (snd $ output c)) ] + optionalDefault ty@Integer = " :=" <+> vhdlTypeDefault ty+ optionalDefault _ = empty+ architecture :: Component -> VHDLM Doc architecture c = nest 2@@ -205,25 +255,23 @@ 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' (Signed n) = "signed" <>- parens ( int (n-1) <+> "downto 0")-vhdlType' (Unsigned n) = "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' t@(SP _ _) = "std_logic_vector" <>- parens ( int (typeSize t - 1) <+>- "downto 0" )-vhdlType' t@(Sum _ _) = "unsigned" <>- parens ( int (typeSize t -1) <+>- "downto 0")+vhdlType' Bit = "std_logic"+vhdlType' Bool = "boolean"+vhdlType' (Clock _) = "std_logic"+vhdlType' (Reset _) = "std_logic"+vhdlType' Integer = "integer"+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' t@(SP _ _) = "std_logic_vector" <> parens (int (typeSize t - 1) <+> "downto 0")+vhdlType' t@(Sum _ _) = case typeSize t of+ 0 -> "unsigned (0 downto 1)"+ n -> "unsigned" <> parens (int (n -1) <+> "downto 0") vhdlType' t@(Product _ _) = tyName t-vhdlType' Void = "std_logic_vector" <> parens (int (-1) <+> "downto 0")+vhdlType' Void = "std_logic_vector" <> parens (int (-1) <+> "downto 0") -- | Convert a Netlist HWType to the root of a VHDL type vhdlTypeMark :: HWType -> VHDLM Doc@@ -281,8 +329,11 @@ _ -> vcat (punctuate semi (A.pure dsDoc)) <> semi decl :: Int -> Declaration -> VHDLM (Maybe (Doc,Int))-decl l (NetDecl id_ ty netInit) = Just A.<$> (,fromIntegral (T.length id_)) A.<$>+decl l (NetDecl id_ ty@Integer netInit) = Just A.<$> (,fromIntegral (T.length id_)) A.<$> "signal" <+> fill l (text id_) <+> colon <+> vhdlType ty <+> ":=" <+> maybe (vhdlTypeDefault ty) (expr False) netInit++decl l (NetDecl id_ ty netInit) = Just A.<$> (,fromIntegral (T.length id_)) A.<$>+ "signal" <+> fill l (text id_) <+> colon <+> vhdlType ty <> (maybe empty (\e -> " :=" <+> expr False e) netInit) decl _ _ = return Nothing
src/CLaSH/Normalize.hs view
@@ -48,14 +48,16 @@ -- ^ Hardcoded Type -> HWType translator -> HashMap TyConName TyCon -- ^ TyCon cache+ -> (HashMap TyConName TyCon -> Term -> Term)+ -- ^ Hardcoded evaluator (delta-reduction) -> NormalizeSession a -- ^ NormalizeSession to run -> a-runNormalization lvl supply globals typeTrans tcm+runNormalization lvl supply globals typeTrans tcm eval = flip State.evalState normState . runRewriteSession lvl rwState where- rwState = RewriteState 0 globals supply typeTrans tcm+ rwState = RewriteState 0 globals supply typeTrans tcm eval normState = NormalizeState HashMap.empty Map.empty
src/CLaSH/Normalize/Strategy.hs view
@@ -9,7 +9,7 @@ -- | Normalisation transformation normalization :: NormRewrite-normalization = etaTL >-> constantPropgation >-> anf >-> rmDeadcode >-> bindConst >-> letTL >-> recLetRec+normalization = etaTL >-> constantPropgation >-> anf >-> rmDeadcode >-> bindConst >-> letTL >-> cse >-> recLetRec where etaTL = apply "etaTL" etaExpansionTL anf = topdownR (apply "nonRepANF" nonRepANF) >-> apply "ANF" makeANF@@ -17,18 +17,20 @@ recLetRec = apply "recToLetRec" recToLetRec rmDeadcode = topdownR (apply "deadcode" deadCode) bindConst = topdownR (apply "bindConstantVar" bindConstantVar)+ cse = topdownSucR (apply "CSE" simpleCSE) constantPropgation :: NormRewrite-constantPropgation = propagate >-> lifting >-> spec+constantPropgation = propagate >-> repeatR inlineAndPropagate >-> lifting >-> spec where- propagate = innerMost (applyMany transInner) >-> inlining- inlining = topdownR (applyMany transBUP !-> propagate)+ inlineAndPropagate = inlining >-> propagate+ propagateAndInline = propagate >-> inlining+ propagate = innerMost (applyMany transInner)+ inlining = topdownR (applyMany transBUP !-> propagateAndInline) lifting = bottomupR (apply "liftNonRep" liftNonRep) spec = bottomupR (applyMany specRws) transInner :: [(String,NormRewrite)]- transInner = [ ("inlineClosed" , inlineClosed )- , ("applicationPropagation", appProp )+ transInner = [ ("applicationPropagation", appProp ) , ("bindConstantVar" , bindConstantVar) , ("caseLet" , caseLet ) , ("caseCase" , caseCase )@@ -36,7 +38,9 @@ ] transBUP :: [(String,NormRewrite)]- transBUP = [ ("inlineNonRep", inlineNonRep)+ transBUP = [ ("inlineClosed", inlineClosed)+ , ("inlineSmall" , inlineSmall)+ , ("inlineNonRep", inlineNonRep) , ("bindNonRep" , bindNonRep) ]
src/CLaSH/Normalize/Transformations.hs view
@@ -25,6 +25,8 @@ , recToLetRec , inlineClosed , inlineHO+ , inlineSmall+ , simpleCSE ) where @@ -37,7 +39,7 @@ import qualified Data.Maybe as Maybe import Unbound.LocallyNameless (Bind, Embed (..), bind, embed, rec, unbind, unembed, unrebind,- unrec)+ unrec, name2String) import Unbound.LocallyNameless.Ops (unsafeUnbind) import CLaSH.Core.DataCon (DataCon, dcTag, dcUnivTyVars)@@ -47,11 +49,11 @@ import CLaSH.Core.Subst (substTm, substTms, substTyInTm, substTysinTm) import CLaSH.Core.Term (LetBinding, Pat (..), Term (..))-import CLaSH.Core.Type (splitFunTy)+import CLaSH.Core.Type (TypeView (..), splitFunTy, tyView) import CLaSH.Core.Util (collectArgs, idToVar, isCon, isFun, isLet, isPolyFun, isPrim, isVar, mkApps, mkLams, mkTmApps,- termType)+ termSize,termType) import CLaSH.Core.Var (Id, Var (..)) import CLaSH.Netlist.Util (representableType, splitNormalized)@@ -88,7 +90,7 @@ | (Var _ _, args) <- collectArgs e1 , null $ typeFreeVars ty , (_, []) <- Either.partitionEithers args- = specializeNorm ctx e+ = specializeNorm False ctx e typeSpec _ e = return e @@ -103,7 +105,7 @@ localVar <- isLocalVar e2 nonRepE2 <- not <$> (representableType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure e2Ty) if nonRepE2 && not localVar- then runR $ specializeNorm ctx e+ then runR $ specializeNorm True ctx e else return e nonRepSpec _ e = return e@@ -144,21 +146,38 @@ isInlined <- liftR $ alreadyInlined f limit <- liftR $ Lens.use inlineLimit tcm <- Lens.use tcCache- if (Maybe.fromMaybe 0 isInlined) > limit+ scrutTy <- termType tcm scrut+ let noException = not (exception scrutTy)+ if noException && (Maybe.fromMaybe 0 isInlined) > limit then do cf <- liftR $ Lens.use curFun ty <- termType tcm scrut error $ $(curLoc) ++ "InlineNonRep: " ++ show f ++ " already inlined " ++ show limit ++ " times in:" ++ show cf ++ ", " ++ showDoc ty else do- scrutTy <- termType tcm scrut bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings nonRepScrut <- not <$> (representableType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure scrutTy) case (nonRepScrut, bodyMaybe) of (True,Just (_, scrutBody)) -> do- liftR $ addNewInline f+ Monad.when noException (liftR $ addNewInline f) changed $ Case (mkApps scrutBody args) alts _ -> return e+ where+ exception (tyView -> TyConApp (name2String -> "GHC.Num.Num") [arg]) = numDictArg arg+ 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@@ -213,6 +232,16 @@ ([],[]) -> changed altE _ -> return e +caseCon ctx e@(Case subj alts)+ | isConstant subj = do+ tcm <- Lens.use tcCache+ lvl <- Lens.view dbgLevel+ reduceConstant <- Lens.use evaluator+ case reduceConstant tcm subj of+ Data dc -> caseCon ctx (Case (Data dc) alts)+ Literal l -> caseCon ctx (Case (Literal l) alts)+ subj' -> traceIf (lvl > DebugNone) ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj') (return e)+ caseCon _ e = return e -- | Bring an application of a DataCon or Primitive in ANF, when the argument is@@ -226,8 +255,8 @@ case (untranslatable,arg) of (True,Letrec b) -> do (binds,body) <- unbind b changed . Letrec $ bind binds (App appConPrim body)- (True,Case {}) -> runR $ specializeNorm ctx e- (True,Lam _) -> runR $ specializeNorm ctx e+ (True,Case {}) -> runR $ specializeNorm True ctx e+ (True,Lam _) -> runR $ specializeNorm True ctx e _ -> return e nonRepANF _ e = return e@@ -297,20 +326,55 @@ -- | Inline nullary/closed functions inlineClosed :: NormRewrite+inlineClosed _ e@(collectArgs -> (Var _ f,args))+ | all (either isConstant (const True)) args+ = R $ do+ untranslatable <- isUntranslatable e+ if untranslatable+ then return e+ else do+ bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings+ case bodyMaybe of+ Just (_,body) -> changed (mkApps body args)+ _ -> return e+ inlineClosed _ e@(Var _ f) = R $ do- bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings- case bodyMaybe of- Just (_,body) -> do- tcm <- Lens.use tcCache- closed <- isClosed tcm body- untranslatable <- isUntranslatable e- if closed && not untranslatable- then changed body- else return e- _ -> return e+ tcm <- Lens.use tcCache+ closed <- isClosed tcm e+ untranslatable <- isUntranslatable e+ if closed && not untranslatable+ then do+ bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings+ case bodyMaybe of+ Just (_,body) -> changed body+ _ -> return e+ else return e inlineClosed _ e = return e +-- | Inline small functions+inlineSmall :: NormRewrite+inlineSmall _ e@(collectArgs -> (Var _ f,args)) = R $ do+ untranslatable <- isUntranslatable e+ if untranslatable+ then return e+ else do+ isInlined <- liftR $ alreadyInlined f+ limit <- liftR $ Lens.use inlineLimit+ if (Maybe.fromMaybe 0 isInlined) > limit+ then do+ cf <- liftR $ Lens.use curFun+ lvl <- Lens.view dbgLevel+ traceIf (lvl > DebugNone) ($(curLoc) ++ "InlineSmall: " ++ show f ++ " already inlined " ++ show limit ++ " times in:" ++ show cf) (return e)+ else do+ bodyMaybe <- HashMap.lookup f <$> Lens.use bindings+ case bodyMaybe of+ (Just (_,body))+ | termSize body < 5 -> changed (mkApps body args)+ _ -> return e++inlineSmall _ e = return e+ -- | Specialise functions on arguments which are constant constantSpec :: NormRewrite constantSpec ctx e@(App e1 e2)@@ -318,7 +382,7 @@ , (_, []) <- Either.partitionEithers args , null $ termFreeTyVars e2 , isConstant e2- = specializeNorm ctx e+ = specializeNorm False ctx e constantSpec _ e = return e @@ -462,7 +526,9 @@ doAlt' subj' alt@(DataPat dc pxs@(unrebind -> ([],xs)),altExpr) = do lv <- isLocalVar altExpr patSels <- Monad.zipWithM (doPatBndr subj' (unembed dc)) xs [0..]- if lv || isConstant altExpr+ let usesXs (Var _ n) = any ((== n) . varName) xs+ usesXs _ = False+ if (lv && not (usesXs altExpr)) || isConstant altExpr then return (patSels,alt) else do tcm <- Lens.use tcCache (altId,altVar) <- mkTmBinderFor tcm "altLet" altExpr@@ -544,8 +610,9 @@ limit <- liftR $ Lens.use inlineLimit if (Maybe.fromMaybe 0 isInlined) > limit then do- cf <- liftR $ Lens.use curFun- error $ $(curLoc) ++ "InlineHO: " ++ show f ++ " already inlined " ++ show limit ++ " times in:" ++ show cf+ cf <- liftR $ Lens.use curFun+ lvl <- Lens.view dbgLevel+ traceIf (lvl > DebugNone) ($(curLoc) ++ "InlineHO: " ++ show f ++ " already inlined " ++ show limit ++ " times in:" ++ show cf) (return e) else do bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings case bodyMaybe of@@ -556,3 +623,29 @@ else return e inlineHO _ e = return e++-- | Simplified CSE, only works on let-bindings, works from top to bottom+simpleCSE :: NormRewrite+simpleCSE _ e@(Letrec b) = R $ do+ (binders,body) <- first unrec <$> unbind b+ let (reducedBindings,body') = reduceBinders [] body binders+ if length binders /= length reducedBindings+ then changed (Letrec (bind (rec reducedBindings) body'))+ else return e++simpleCSE _ e = return e++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
src/CLaSH/Normalize/Util.hs view
@@ -45,7 +45,7 @@ (HashMap.singleton f 1) -- | Specialize under the Normalization Monad-specializeNorm :: NormRewrite+specializeNorm :: Bool -> NormRewrite specializeNorm = specialise specialisationCache specialisationHistory specialisationLimit -- | Determine if a term is closed
src/CLaSH/Rewrite/Types.hs view
@@ -42,6 +42,7 @@ , _uniqSupply :: Supply -- ^ Supply of unique numbers , _typeTranslator :: HashMap TyConName TyCon -> Type -> Maybe (Either String HWType) -- ^ Hardcode Type -> HWType translator , _tcCache :: HashMap TyConName TyCon -- ^ TyCon cache+ , _evaluator :: HashMap TyConName TyCon -> Term -> Term -- ^ Hardcoded evaluator (delta-reduction) } makeLenses ''RewriteState
src/CLaSH/Rewrite/Util.hs view
@@ -427,32 +427,32 @@ let pat = DataPat (embed dc) (rebind [] bndrs) let retVal = Case scrut [ bind pat (snd selBndr) ] return retVal- FunTy _ _ -> do- (id_,var) <- mkInternalVar "selector" scrutTy- return (mkLams var [id_])- (OtherType oTy) -> cantCreate $(curLoc) ("Type of subject is not a datatype: " ++ showDoc oTy)+ _ -> cantCreate $(curLoc) ("Type of subject is not a datatype: " ++ showDoc scrutTy) -- | Specialise an application on its argument specialise :: (Functor m, State.MonadState s m) => Lens' s (Map.Map (TmName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations -> Lens' s (HashMap TmName Int) -- ^ Lens into the specialisation history -> Lens' s Int -- ^ Lens into the specialisation limit+ -> Bool -> Rewrite m-specialise specMapLbl specHistLbl specLimitLbl ctx e@(TyApp e1 ty) = specialise' specMapLbl specHistLbl specLimitLbl ctx e (collectArgs e1) (Right ty)-specialise specMapLbl specHistLbl specLimitLbl ctx e@(App e1 e2) = specialise' specMapLbl specHistLbl specLimitLbl ctx e (collectArgs e1) (Left e2)-specialise _ _ _ _ e = return e+specialise specMapLbl specHistLbl specLimitLbl doCheck ctx e = case e of+ (TyApp e1 ty) -> specialise' specMapLbl specHistLbl specLimitLbl False ctx e (collectArgs e1) (Right ty)+ (App e1 e2) -> specialise' specMapLbl specHistLbl specLimitLbl doCheck ctx e (collectArgs e1) (Left e2)+ _ -> return e -- | Specialise an application on its argument specialise' :: (Functor m, State.MonadState s m) => Lens' s (Map.Map (TmName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations -> Lens' s (HashMap TmName Int) -- ^ Lens into specialisation history -> Lens' s Int -- ^ Lens into the specialisation limit+ -> Bool -- ^ Perform specialisation limit check -> [CoreContext] -- Transformation context -> Term -- ^ Original term -> (Term, [Either Term Type]) -- ^ Function part of the term, split into root and applied arguments -> Either Term Type -- ^ Argument to specialize on -> R m Term-specialise' specMapLbl specHistLbl specLimitLbl ctx e (Var _ f, args) specArg = R $ do+specialise' specMapLbl specHistLbl specLimitLbl doCheck ctx e (Var _ f, args) specArg = R $ do lvl <- Lens.view dbgLevel -- Create binders and variable references for free variables in 'specArg' (specBndrs,specVars) <- specArgBndrsAndVars ctx specArg@@ -475,7 +475,7 @@ -- Determine if we see a sequence of specialisations on a growing argument specHistM <- liftR $ fmap (HML.lookup f) (Lens.use specHistLbl) specLim <- liftR $ Lens.use specLimitLbl- if maybe False (> specLim) specHistM+ if doCheck && maybe False (> specLim) specHistM then fail $ unlines [ "Hit specialisation limit on function `" ++ showDoc f ++ "'.\n" , "The function `" ++ showDoc f ++ "' is most likely recursive, and looks like it is being indefinitely specialized on a growing argument.\n" , "Body of `" ++ showDoc f ++ "':\n" ++ showDoc bodyTm ++ "\n"@@ -497,7 +497,7 @@ newf `deepseq` changed newExpr Nothing -> return e -specialise' _ _ _ ctx _ (appE,args) (Left specArg) = R $ do+specialise' _ _ _ _ ctx _ (appE,args) (Left specArg) = R $ do -- Create binders and variable references for free variables in 'specArg' (specBndrs,specVars) <- specArgBndrsAndVars ctx (Left specArg) -- Create specialized function@@ -509,7 +509,7 @@ let newExpr = mkApps appE (args ++ [newArg]) changed newExpr -specialise' _ _ _ _ e _ _ = return e+specialise' _ _ _ _ _ e _ _ = return e -- | Create binders and variable references for free variables in 'specArg' specArgBndrsAndVars :: (Functor m, Monad m)
src/CLaSH/Util.hs view
@@ -135,6 +135,13 @@ -> f (a, c) secondM f (x,y) = (x,) <$> f y +combineM :: (Applicative f)+ => (a -> f b)+ -> (c -> f d)+ -> (a,c)+ -> f (b,d)+combineM f g (x,y) = (,) <$> f x <*> g y+ -- | Performs trace when first argument evaluates to 'True' traceIf :: Bool -> String -> a -> a traceIf True msg = trace msg