diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -1,5 +1,5 @@ Name: clash-lib -Version: 0.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 diff --git a/src/CLaSH/Core/Pretty.hs b/src/CLaSH/Core/Pretty.hs --- a/src/CLaSH/Core/Pretty.hs +++ b/src/CLaSH/Core/Pretty.hs @@ -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 diff --git a/src/CLaSH/Core/Type.hs b/src/CLaSH/Core/Type.hs --- a/src/CLaSH/Core/Type.hs +++ b/src/CLaSH/Core/Type.hs @@ -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 diff --git a/src/CLaSH/Core/Util.hs b/src/CLaSH/Core/Util.hs --- a/src/CLaSH/Core/Util.hs +++ b/src/CLaSH/Core/Util.hs @@ -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) diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -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 diff --git a/src/CLaSH/Driver/TestbenchGen.hs b/src/CLaSH/Driver/TestbenchGen.hs --- a/src/CLaSH/Driver/TestbenchGen.hs +++ b/src/CLaSH/Driver/TestbenchGen.hs @@ -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'') diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -26,8 +26,8 @@ import CLaSH.Core.Pretty (showDoc) import CLaSH.Core.Term (Pat (..), Term (..), TmName) import qualified CLaSH.Core.Term as Core -import CLaSH.Core.Type (Type) -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 diff --git a/src/CLaSH/Netlist/BlackBox.hs b/src/CLaSH/Netlist/BlackBox.hs --- a/src/CLaSH/Netlist/BlackBox.hs +++ b/src/CLaSH/Netlist/BlackBox.hs @@ -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 diff --git a/src/CLaSH/Netlist/BlackBox/Parser.hs b/src/CLaSH/Netlist/BlackBox/Parser.hs --- a/src/CLaSH/Netlist/BlackBox/Parser.hs +++ b/src/CLaSH/Netlist/BlackBox/Parser.hs @@ -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 diff --git a/src/CLaSH/Netlist/BlackBox/Types.hs b/src/CLaSH/Netlist/BlackBox/Types.hs --- a/src/CLaSH/Netlist/BlackBox/Types.hs +++ b/src/CLaSH/Netlist/BlackBox/Types.hs @@ -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 diff --git a/src/CLaSH/Netlist/BlackBox/Util.hs b/src/CLaSH/Netlist/BlackBox/Util.hs --- a/src/CLaSH/Netlist/BlackBox/Util.hs +++ b/src/CLaSH/Netlist/BlackBox/Util.hs @@ -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" diff --git a/src/CLaSH/Netlist/Util.hs b/src/CLaSH/Netlist/Util.hs --- a/src/CLaSH/Netlist/Util.hs +++ b/src/CLaSH/Netlist/Util.hs @@ -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)) diff --git a/src/CLaSH/Netlist/VHDL.hs b/src/CLaSH/Netlist/VHDL.hs --- a/src/CLaSH/Netlist/VHDL.hs +++ b/src/CLaSH/Netlist/VHDL.hs @@ -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 diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs --- a/src/CLaSH/Normalize.hs +++ b/src/CLaSH/Normalize.hs @@ -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 diff --git a/src/CLaSH/Normalize/Strategy.hs b/src/CLaSH/Normalize/Strategy.hs --- a/src/CLaSH/Normalize/Strategy.hs +++ b/src/CLaSH/Normalize/Strategy.hs @@ -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) ] diff --git a/src/CLaSH/Normalize/Transformations.hs b/src/CLaSH/Normalize/Transformations.hs --- a/src/CLaSH/Normalize/Transformations.hs +++ b/src/CLaSH/Normalize/Transformations.hs @@ -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 diff --git a/src/CLaSH/Normalize/Util.hs b/src/CLaSH/Normalize/Util.hs --- a/src/CLaSH/Normalize/Util.hs +++ b/src/CLaSH/Normalize/Util.hs @@ -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 diff --git a/src/CLaSH/Rewrite/Types.hs b/src/CLaSH/Rewrite/Types.hs --- a/src/CLaSH/Rewrite/Types.hs +++ b/src/CLaSH/Rewrite/Types.hs @@ -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 diff --git a/src/CLaSH/Rewrite/Util.hs b/src/CLaSH/Rewrite/Util.hs --- a/src/CLaSH/Rewrite/Util.hs +++ b/src/CLaSH/Rewrite/Util.hs @@ -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) diff --git a/src/CLaSH/Util.hs b/src/CLaSH/Util.hs --- a/src/CLaSH/Util.hs +++ b/src/CLaSH/Util.hs @@ -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