diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.5.7 *June 25th 2015* +* New features: + * Support for copying string literals from Haskell to generated code + * Collect and copy data-files + +* Fixes bugs: + * Signals declared twice when not using a clock-generating component [#60](https://github.com/clash-lang/clash-compiler/issues/60) + * This piece of code eat up all CPU when generating verilog [#62](https://github.com/clash-lang/clash-compiler/issues/60) + ## 0.5.6 *June 3rd 2015* * New features: * Support Verilog backend 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.5.6 +Version: 0.5.7 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/Literal.hs b/src/CLaSH/Core/Literal.hs --- a/src/CLaSH/Core/Literal.hs +++ b/src/CLaSH/Core/Literal.hs @@ -16,7 +16,7 @@ import Unbound.Generics.LocallyNameless (Alpha (..), Subst (..)) import {-# SOURCE #-} CLaSH.Core.Type (Type) -import CLaSH.Core.TysPrim (intPrimTy, voidPrimTy) +import CLaSH.Core.TysPrim (intPrimTy, stringPrimTy, voidPrimTy) -- | Term Literal data Literal @@ -37,4 +37,4 @@ -> Type literalType (IntegerLiteral _) = intPrimTy literalType (RationalLiteral _) = voidPrimTy -literalType (StringLiteral _) = voidPrimTy +literalType (StringLiteral _) = stringPrimTy diff --git a/src/CLaSH/Core/TysPrim.hs b/src/CLaSH/Core/TysPrim.hs --- a/src/CLaSH/Core/TysPrim.hs +++ b/src/CLaSH/Core/TysPrim.hs @@ -4,6 +4,7 @@ , typeNatKind , typeSymbolKind , intPrimTy + , stringPrimTy , voidPrimTy , tysPrimMap ) @@ -37,22 +38,25 @@ typeSymbolKind = mkTyConTy typeSymbolKindTyConName -intPrimTyConName, voidPrimTyConName :: TyConName -intPrimTyConName = string2Name "Int" -voidPrimTyConName = string2Name "VOID" +intPrimTyConName, stringPrimTyConName, voidPrimTyConName :: TyConName +intPrimTyConName = string2Name "Int" +stringPrimTyConName = string2Name "String" +voidPrimTyConName = string2Name "VOID" liftedPrimTC :: TyConName -> TyCon liftedPrimTC name = PrimTyCon name liftedTypeKind 0 -- | Builtin Type -intPrimTc, voidPrimTc :: TyCon -intPrimTc = (liftedPrimTC intPrimTyConName ) -voidPrimTc = (liftedPrimTC voidPrimTyConName) +intPrimTc, stringPrimTc, voidPrimTc :: TyCon +intPrimTc = (liftedPrimTC intPrimTyConName ) +stringPrimTc = (liftedPrimTC stringPrimTyConName) +voidPrimTc = (liftedPrimTC voidPrimTyConName) -intPrimTy, voidPrimTy :: Type -intPrimTy = mkTyConTy intPrimTyConName -voidPrimTy = mkTyConTy voidPrimTyConName +intPrimTy, stringPrimTy, voidPrimTy :: Type +intPrimTy = mkTyConTy intPrimTyConName +stringPrimTy = mkTyConTy stringPrimTyConName +voidPrimTy = mkTyConTy voidPrimTyConName tysPrimMap :: HashMap TyConName TyCon tysPrimMap = HashMap.fromList @@ -61,5 +65,6 @@ , (typeNatKindTyConName,typeNatKindtc) , (typeSymbolKindTyConName,typeSymbolKindtc) , (intPrimTyConName,intPrimTc) + , (stringPrimTyConName,stringPrimTc) , (voidPrimTyConName,voidPrimTc) ] diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -82,8 +82,8 @@ putStrLn $ "Normalisation took " ++ show prepNormDiff let modName = takeWhile (/= '.') (name2String $ fst topEntity) - (netlist,cmpCnt) <- genNetlist Nothing transformedBindings primMap tcm - typeTrans Nothing modName (fst topEntity) + (netlist,dfiles,cmpCnt) <- genNetlist Nothing transformedBindings primMap tcm + typeTrans Nothing modName [] (fst topEntity) netlistTime <- netlist `deepseq` Clock.getCurrentTime let normNetDiff = Clock.diffUTCTime netlistTime normTime @@ -95,11 +95,12 @@ cName) netlist - testBench <- genTestBench opts supplyTB primMap + (testBench,dfiles') <- genTestBench opts supplyTB primMap typeTrans tcm eval cmpCnt bindingsMap (listToMaybe $ map fst $ HashMap.toList testInputs) (listToMaybe $ map fst $ HashMap.toList expectedOutputs) modName + dfiles topComponent @@ -116,6 +117,7 @@ ] prepareDir dir mapM_ (writeHDL hdlState' dir) hdlDocs + copyDataFiles dir dfiles' end <- hdlDocs `seq` Clock.getCurrentTime let startEndDiff = Clock.diffUTCTime end start @@ -159,3 +161,8 @@ hPutDoc handle hdl IO.hPutStr handle "\n" IO.hClose handle + +copyDataFiles :: FilePath -> [(String,FilePath)] -> IO () +copyDataFiles dir = mapM_ copyFile' + where + copyFile' (nm,old) = Directory.copyFile old (dir FilePath. nm) 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 @@ -46,19 +46,20 @@ -> Maybe TmName -- ^ Stimuli -> Maybe TmName -- ^ Expected output -> String -- ^ Name of the module containing the @topEntity@ + -> [(String,FilePath)] -- ^ Set of collected data-files -> Component -- ^ Component to generate TB for - -> IO ([Component]) -genTestBench opts supply primMap typeTrans tcm eval cmpCnt globals stimuliNmM expectedNmM modName + -> IO ([Component],[(String,FilePath)]) +genTestBench opts supply primMap typeTrans tcm eval cmpCnt globals stimuliNmM expectedNmM modName dfiles (Component cName hidden [inp] [outp] _) = do let ioDecl = [ uncurry NetDecl inp , uncurry NetDecl outp ] inpExpr = Assignment (fst inp) (BlackBoxE "" [Err Nothing] (emptyBBContext {bbResult = (undefined,snd inp)}) False) - (inpInst,inpComps,cmpCnt',hidden') <- maybe (return (inpExpr,[],cmpCnt,hidden)) - (genStimuli cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp modName) - stimuliNmM + (inpInst,inpComps,cmpCnt',hidden',dfiles') <- maybe (return (inpExpr,[],cmpCnt,hidden,dfiles)) + (genStimuli cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp modName dfiles) + stimuliNmM - ((finDecl,finExpr),s) <- runNetlistMonad (Just cmpCnt') globals primMap tcm typeTrans modName $ do + ((finDecl,finExpr),s) <- runNetlistMonad (Just cmpCnt') globals primMap tcm typeTrans modName dfiles' $ do done <- genDone primMap let finDecl' = [ NetDecl "finished" Bool , done @@ -66,14 +67,14 @@ finExpr' <- genFinish primMap return (finDecl',finExpr') - (expInst,expComps,cmpCnt'',hidden'') <- maybe (return (finExpr,[],cmpCnt',hidden')) - (genVerifier cmpCnt' primMap globals typeTrans tcm normalizeSignal hidden' outp modName) - expectedNmM + (expInst,expComps,cmpCnt'',hidden'',dfiles'') <- maybe (return (finExpr,[],cmpCnt',hidden',dfiles')) + (genVerifier cmpCnt' primMap globals typeTrans tcm normalizeSignal hidden' outp modName dfiles') + 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,rsts),_) <- runNetlistMonad (Just cmpCnt'') globals primMap tcm typeTrans modName $ do + ((clks,rsts),_) <- runNetlistMonad (Just cmpCnt'') globals primMap tcm typeTrans modName dfiles'' $ do varCount .= (_varCount s) clks' <- catMaybes <$> mapM (genClock primMap) hidden'' rsts' <- catMaybes <$> mapM (genReset primMap) hidden'' @@ -92,7 +93,7 @@ , [instDecl,inpInst,expInst] ]) - return (tbComp:(inpComps++expComps)) + return (tbComp:(inpComps++expComps),dfiles'') where normalizeSignal :: HashMap TmName (Type,Term) -> TmName @@ -100,7 +101,7 @@ normalizeSignal glbls bndr = runNormalization opts supply glbls typeTrans tcm eval (normalize [bndr] >>= cleanupGraph bndr) -genTestBench opts _ _ _ _ _ _ _ _ _ _ c = traceIf (opt_dbgLevel opts > DebugNone) ("Can't make testbench for: " ++ show c) $ return [] +genTestBench opts _ _ _ _ _ _ _ _ _ _ dfiles c = traceIf (opt_dbgLevel opts > DebugNone) ("Can't make testbench for: " ++ show c) $ return ([],dfiles) genClock :: PrimMap -> (Identifier,HWType) @@ -183,11 +184,12 @@ -> [(Identifier,HWType)] -> (Identifier,HWType) -> String + -> [(String,FilePath)] -> TmName - -> IO (Declaration,[Component],Int,[(Identifier,HWType)]) -genStimuli cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp modName signalNm = do + -> IO (Declaration,[Component],Int,[(Identifier,HWType)],[(String,FilePath)]) +genStimuli cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp modName dfiles signalNm = do let stimNormal = normalizeSignal globals signalNm - (comps,cmpCnt') <- genNetlist (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing modName signalNm + (comps,dfiles',cmpCnt') <- genNetlist (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing modName dfiles signalNm let sigNm = pack (modName ++ "_") `append` last (splitOn (pack ".") (pack (name2String signalNm))) `append` pack "_" sigComp = case find ((isPrefixOf sigNm) . componentName) comps of Just c -> c @@ -204,7 +206,7 @@ (concat [ clkNms, rstNms ]) ++ [(outp,Identifier (fst inp) Nothing)] ) - return (decl,comps,cmpCnt',hidden'') + return (decl,comps,cmpCnt',hidden'',dfiles') genVerifier :: Int -> PrimMap @@ -217,11 +219,12 @@ -> [(Identifier,HWType)] -> (Identifier,HWType) -> String + -> [(String,FilePath)] -> TmName - -> IO (Declaration,[Component],Int,[(Identifier,HWType)]) -genVerifier cmpCnt primMap globals typeTrans tcm normalizeSignal hidden outp modName signalNm = do + -> IO (Declaration,[Component],Int,[(Identifier,HWType)],[(String,FilePath)]) +genVerifier cmpCnt primMap globals typeTrans tcm normalizeSignal hidden outp modName dfiles signalNm = do let stimNormal = normalizeSignal globals signalNm - (comps,cmpCnt') <- genNetlist (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing modName signalNm + (comps,dfiles',cmpCnt') <- genNetlist (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing modName dfiles signalNm let sigNm = pack (modName ++ "_") `append` last (splitOn (pack ".") (pack (name2String signalNm))) `append` "_" sigComp = case find ((isPrefixOf sigNm) . componentName) comps of Just c -> c @@ -237,4 +240,4 @@ (concat [ clkNms, rstNms ]) ++ [(inp,Identifier (fst outp) Nothing),(fin,Identifier "finished" Nothing)] ) - return (decl,comps,cmpCnt',hidden'') + return (decl,comps,cmpCnt',hidden'',dfiles') diff --git a/src/CLaSH/Driver/TopWrapper.hs b/src/CLaSH/Driver/TopWrapper.hs --- a/src/CLaSH/Driver/TopWrapper.hs +++ b/src/CLaSH/Driver/TopWrapper.hs @@ -12,9 +12,10 @@ -} module CLaSH.Driver.TopWrapper where - +import Data.Char (isDigit) import qualified Data.HashMap.Lazy as HashMap import Data.List (mapAccumL) +import Data.Maybe (mapMaybe) import Data.Text.Lazy (Text, append, pack, unpack) import System.IO.Unsafe (unsafePerformIO) @@ -42,8 +43,9 @@ , outputs = outputs'' ++ extraOut teM , hiddenPorts = case maybe [] t_clocks teM of [] -> originalHidden - _ -> [] - , declarations = concat [ mkClocks primMap originalHidden teM + _ -> filter (`notElem` (mapMaybe isNetDecl clkDecls)) + originalHidden + , declarations = concat [ clkDecls , wrappers , instDecl:unwrappers ] @@ -52,6 +54,8 @@ iNameSupply = maybe [] (map pack . t_inputs) teM originalHidden = hiddenPorts topComponent + clkDecls = mkClocks primMap originalHidden teM + inputs' = map (first (const "input")) (inputs topComponent) (inputs'',(wrappers,idsI)) = (concat *** (first concat . unzip)) @@ -84,6 +88,9 @@ (outputs topComponent) idsO) + isNetDecl (NetDecl nm ty) = Just (nm,ty) + isNetDecl _ = Nothing + -- | Create extra input ports for the wrapper extraIn :: Maybe TopEntity -> [(Identifier,HWType)] extraIn = maybe [] ((map (pack *** BitVector)) . t_extraIn) @@ -198,12 +205,10 @@ -- | Create clock generators mkClocks :: PrimMap -> [(Identifier,HWType)] -> Maybe TopEntity -> [Declaration] mkClocks primMap hidden teM = concat - [ hiddenSigDecs - , clockGens + [ clockGens , resets ] where - hiddenSigDecs = maybe [] (const (map (uncurry NetDecl) hidden)) teM (clockGens,clkLocks) = maybe ([],[]) (first concat . unzip . map mkClock . t_clocks) teM @@ -214,12 +219,13 @@ -- | Create a single clock generator mkClock :: ClockSource -> ([Declaration],(Identifier,[String],Bool)) -mkClock (ClockSource {..}) = ([lockedDecl,instDecl],(lockedName,clks,c_sync)) +mkClock (ClockSource {..}) = (clkDecls ++ [lockedDecl,instDecl],(lockedName,clks,c_sync)) where c_nameT = pack c_name lockedName = append c_nameT "_locked" lockedDecl = NetDecl lockedName (Reset lockedName 0) (ports,clks) = clockPorts c_inp c_outp + clkDecls = map mkClockDecl clks instDecl = InstDecl c_nameT (append c_nameT "_inst") $ concat [ ports , maybe [] ((:[]) . (pack *** stringToVar)) @@ -227,6 +233,12 @@ , [(pack c_lock,Identifier lockedName Nothing)] ] +mkClockDecl :: String -> Declaration +mkClockDecl s = NetDecl (pack s) (Clock (pack name) (read rate)) + where + (name,rate) = span (not . isDigit) s + + -- | Create a single clock path clockPorts :: Maybe (String,String) -> [(String,String)] -> ([(Identifier,Expr)],[String]) @@ -250,7 +262,7 @@ match _ = False connectReset (rst,(Reset nm r)) = if doSync - then return [Assignment rst (Identifier lock Nothing)] + then return [NetDecl rst (Reset nm r), Assignment rst (Identifier lock Nothing)] else genSyncReset primMap lock rst nm r connectReset _ = return [] @@ -275,7 +287,7 @@ return (BlackBoxD bbName templ' ctx) pM -> error $ $(curLoc) ++ ("Can't make reset sync for: " ++ show pM) - return [resetGenDecl] + return [NetDecl rst (Reset nm r),resetGenDecl] -- | The 'NetListMonad' is an transformer stack with 'IO' at the bottom. -- So we must use 'unsafePerformIO'. @@ -284,4 +296,4 @@ unsafeRunNetlist = unsafePerformIO . fmap fst . runNetlistMonad Nothing HashMap.empty HashMap.empty - HashMap.empty (\_ _ -> Nothing) "" + HashMap.empty (\_ _ -> Nothing) "" [] diff --git a/src/CLaSH/Driver/Types.hs b/src/CLaSH/Driver/Types.hs --- a/src/CLaSH/Driver/Types.hs +++ b/src/CLaSH/Driver/Types.hs @@ -13,5 +13,6 @@ data CLaSHOpts = CLaSHOpts { opt_inlineLimit :: Int , opt_specLimit :: Int + , opt_inlineBelow :: Int , opt_dbgLevel :: DebugLevel } diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -52,12 +52,14 @@ -- ^ Symbol count -> String -- ^ Name of the module containing the @topEntity@ + -> [(String,FilePath)] + -- ^ Set of collected data-files -> TmName -- ^ Name of the @topEntity@ - -> IO ([Component],Int) -genNetlist compCntM globals primMap tcm typeTrans mStart modName topEntity = do - (_,s) <- runNetlistMonad compCntM globals primMap tcm typeTrans modName $ genComponent topEntity mStart - return (HashMap.elems $ _components s, _cmpCount s) + -> IO ([Component],[(String,FilePath)],Int) +genNetlist compCntM globals primMap tcm typeTrans mStart modName dfiles topEntity = do + (_,s) <- runNetlistMonad compCntM globals primMap tcm typeTrans modName dfiles $ genComponent topEntity mStart + return (HashMap.elems $ _components s, _dataFiles s, _cmpCount s) -- | Run a NetlistMonad action in a given environment runNetlistMonad :: Maybe Int @@ -72,16 +74,18 @@ -- ^ Hardcode Type -> HWType translator -> String -- ^ Name of the module containing the @topEntity@ + -> [(String,FilePath)] + -- ^ Set of collected data-files -> NetlistMonad a -- ^ Action to run -> IO (a, NetlistState) -runNetlistMonad compCntM s p tcm typeTrans modName +runNetlistMonad compCntM s p tcm typeTrans modName dfiles = runFreshMT . flip runStateT s' . (fmap fst . runWriterT) . runNetlist where - s' = NetlistState s HashMap.empty 0 (fromMaybe 0 compCntM) HashMap.empty p typeTrans tcm modName Text.empty + s' = NetlistState s HashMap.empty 0 (fromMaybe 0 compCntM) HashMap.empty p typeTrans tcm modName Text.empty dfiles -- | Generate a component for a given function (caching) genComponent :: TmName -- ^ Name of the function 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 @@ -75,11 +75,10 @@ prepareBlackBox pNm t bbCtx = let (templ,err) = runParse t in if null err && verifyBlackBoxContext bbCtx templ - then do - templ' <- instantiateSym templ - templ'' <- setClocks bbCtx templ' - templ3 <- instantiateCompName templ'' - return $! templ3 + then instantiateSym >=> + setClocks bbCtx >=> + collectFilePaths bbCtx >=> + instantiateCompName $ templ else error $ $(curLoc) ++ "\nCan't match template for " ++ show pNm ++ " :\n" ++ show t ++ "\nwith context:\n" ++ show bbCtx ++ "\ngiven errors:\n" ++ @@ -99,6 +98,7 @@ (Var _ v,[]) -> let vT = Identifier (mkBasicId . pack $ name2String v) Nothing in return ((vT,hwTy,False),[]) (C.Literal (IntegerLiteral i),[]) -> return ((N.Literal Nothing (N.NumLit i),hwTy,True),[]) + (C.Literal (StringLiteral s),[]) -> return ((N.Literal Nothing (N.StringLit s),hwTy,True),[]) (Prim f _,args) -> do (e',d) <- mkPrimitive True False f args ty case e' of @@ -266,3 +266,12 @@ instantiateCompName l = do nm <- Lens.use curCompNm return (setCompName nm l) + +collectFilePaths :: BlackBoxContext + -> BlackBoxTemplate + -> NetlistMonad BlackBoxTemplate +collectFilePaths bbCtx l = do + fs <- Lens.use dataFiles + let (fs',l') = findAndSetDataFiles bbCtx fs l + dataFiles .= fs' + return l' 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 @@ -72,6 +72,7 @@ <|> CompName <$ pToken "~COMPNAME" <|> Size <$> (pToken "~SIZE" *> pBrackets pTagE) <|> Length <$> (pToken "~LENGTH" *> pBrackets pTagE) + <|> FilePath <$> (pToken "~FILE" *> pBrackets pTagE) <|> SigD <$> (pToken "~SIGD" *> pBrackets pTagE) <*> (Just <$> (pBrackets pNatural)) <|> (`SigD` Nothing) <$> (pToken "~SIGDO" *> pBrackets pTagE) 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,6 +24,7 @@ -- the blackbox is instantiated | Size Element -- ^ Size of a type hole | Length Element -- ^ Length of a vector hole + | FilePath Element -- ^ Hole containing a filepath for a data file | SigD Element (Maybe Int) deriving Show 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 @@ -13,9 +13,13 @@ import Control.Monad.Writer (MonadWriter, tell) import Data.Foldable (foldrM) import qualified Data.IntMap as IntMap +import Data.List (mapAccumL) import Data.Set (Set,singleton) import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as Text +import System.FilePath (replaceBaseName, + takeBaseName, + takeFileName) import Text.PrettyPrint.Leijen.Text.Monadic (displayT, renderCompact, renderOneLine) @@ -24,7 +28,8 @@ import CLaSH.Netlist.BlackBox.Types import CLaSH.Netlist.Types (HWType (..), Identifier, BlackBoxContext (..), - SyncExpr, Expr(Identifier)) + SyncExpr, Expr (..), + Literal (..)) import CLaSH.Netlist.Util (typeSize) import CLaSH.Util @@ -113,6 +118,32 @@ setClocks' e = return e +findAndSetDataFiles :: BlackBoxContext -> [(String,FilePath)] -> BlackBoxTemplate -> ([(String,FilePath)],BlackBoxTemplate) +findAndSetDataFiles bbCtx fs = mapAccumL findAndSet fs + where + findAndSet fs' (FilePath e) = case e of + (L n) -> + let (s,_,_) = bbInputs bbCtx !! n + e' = either id fst s + in case e' of + BlackBoxE "GHC.CString.unpackCString#" _ bbCtx' _ -> case bbInputs bbCtx' of + [(Left (Literal Nothing (StringLit s')),_,_)] -> renderFilePath fs s' + _ -> (fs',FilePath e) + _ -> (fs',FilePath e) + _ -> (fs',FilePath e) + findAndSet fs' l = (fs',l) + +renderFilePath :: [(String,FilePath)] -> String -> ([(String,FilePath)],Element) +renderFilePath fs f = ((f'',f):fs,C (Text.pack $ show f'')) + where + f' = takeFileName f + f'' = selectNewName (map fst fs) f' + + selectNewName as a + | elem a as = selectNewName as (replaceBaseName a (takeBaseName a ++ "_")) + | otherwise = a + + -- | Get the name of the clock of an identifier clkSyncId :: SyncExpr -> (Identifier,Int) clkSyncId (Right (_,clk)) = clk @@ -226,3 +257,4 @@ renderTag _ (Clk _) = error $ $(curLoc) ++ "Unexpected clock" renderTag _ (Rst _) = error $ $(curLoc) ++ "Unexpected reset" renderTag _ CompName = error $ $(curLoc) ++ "Unexpected component name" +renderTag _ (FilePath _) = error $ $(curLoc) ++ "Unexpected file name" diff --git a/src/CLaSH/Netlist/Types.hs b/src/CLaSH/Netlist/Types.hs --- a/src/CLaSH/Netlist/Types.hs +++ b/src/CLaSH/Netlist/Types.hs @@ -49,6 +49,7 @@ , _tcCache :: HashMap TyConName TyCon -- ^ TyCon cache , _modNm :: String -- ^ Name of the module containing the @topEntity@ , _curCompNm :: Identifier + , _dataFiles :: [(String,FilePath)] } -- | Signal reference @@ -137,10 +138,11 @@ -- | Literals used in an expression data Literal - = NumLit Integer -- ^ Number literal - | BitLit Bit -- ^ Bit literal - | BoolLit Bool -- ^ Boolean literal - | VecLit [Literal] -- ^ Vector literal + = NumLit Integer -- ^ Number literal + | BitLit Bit -- ^ Bit literal + | BoolLit Bool -- ^ Boolean literal + | VecLit [Literal] -- ^ Vector literal + | StringLit String -- ^ String literal deriving Show -- | Bit literal diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs --- a/src/CLaSH/Normalize.hs +++ b/src/CLaSH/Normalize.hs @@ -68,6 +68,7 @@ (opt_specLimit opts) HashMap.empty (opt_inlineLimit opts) + (opt_inlineBelow opts) (error $ $(curLoc) ++ "Report as bug: no curFun") 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 @@ -332,12 +332,13 @@ if untranslatable then return e else do - bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings - case bodyMaybe of + bndrs <- Lens.use bindings + case HashMap.lookup f bndrs of -- Don't inline recursive expressions - Just (_,body) -> if f `elem` (Lens.toListOf termFreeIds body) - then return e - else changed (mkApps body args) + Just (_,body) -> let cg = callGraph [] bndrs f + in if null (recursiveComponents cg) + then changed (mkApps body args) + else return e _ -> return e inlineClosed _ e@(Var _ f) = R $ do @@ -346,12 +347,13 @@ untranslatable <- isUntranslatable e if closed && not untranslatable then do - bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings - case bodyMaybe of + bndrs <- Lens.use bindings + case HashMap.lookup f bndrs of -- Don't inline recursive expressions - Just (_,body) -> if f `elem` (Lens.toListOf termFreeIds body) - then return e - else changed body + Just (_,body) -> let cg = callGraph [] bndrs f + in if null (recursiveComponents cg) + then changed body + else return e _ -> return e else return e @@ -364,20 +366,16 @@ 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 -> do liftR $ addNewInline f - changed (mkApps body args) - _ -> return e + bndrs <- Lens.use bindings + sizeLimit <- liftR $ Lens.use inlineBelow + case HashMap.lookup f bndrs of + -- Don't inline recursive expressions + Just (_,body) -> let cg = callGraph [] bndrs f + in if null (recursiveComponents cg) && + termSize body < sizeLimit + then changed (mkApps body args) + else return e + _ -> return e inlineSmall _ e = return e diff --git a/src/CLaSH/Normalize/Types.hs b/src/CLaSH/Normalize/Types.hs --- a/src/CLaSH/Normalize/Types.hs +++ b/src/CLaSH/Normalize/Types.hs @@ -34,6 +34,9 @@ -- * Elem: (functions which were inlined, number of times inlined) , _inlineLimit :: Int -- ^ Number of times a function 'f' can be inlined in a function 'g' + , _inlineBelow :: Int + -- ^ Size of a function below which it is always inlined if it is not + -- recursive , _curFun :: TmName -- ^ Function which is currently normalized } 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 @@ -6,10 +6,12 @@ import Control.Lens ((%=)) import qualified Control.Lens as Lens +import Data.Function (on) import qualified Data.Graph as Graph import Data.Graph.Inductive (Gr,LNode,lsuc,mkGraph,iDom) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap +import qualified Data.List as List import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Data.Set.Lens as Lens @@ -78,10 +80,13 @@ -- | Determine the sets of recursive components given the edges of a callgraph recursiveComponents :: [(TmName,[TmName])] -- ^ [(calling function,[called function])] -> [[TmName]] -recursiveComponents = Maybe.catMaybes - . map (\case {Graph.CyclicSCC vs -> Just vs; _ -> Nothing}) - . Graph.stronglyConnComp - . map (\(n,es) -> (n,n,es)) +recursiveComponents cg = map (List.sortBy (compare `on` (`List.elemIndex` fs))) + . Maybe.catMaybes + . map (\case {Graph.CyclicSCC vs -> Just vs; _ -> Nothing}) + . Graph.stronglyConnComp + $ map (\(n,es) -> (n,n,es)) cg + where + fs = map fst cg lambdaDropPrep :: HashMap TmName (Type,Term) -> TmName