clash-lib 0.5.6 → 0.5.7

raw patch · 18 files changed

+182/−89 lines, 18 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• clash-lib.cabal +1/−1
• src/CLaSH/Core/Literal.hs +2/−2
• src/CLaSH/Core/TysPrim.hs +14/−9
• src/CLaSH/Driver.hs +10/−3
• src/CLaSH/Driver/TestbenchGen.hs +23/−20
• src/CLaSH/Driver/TopWrapper.hs +22/−10
• src/CLaSH/Driver/Types.hs +1/−0
• src/CLaSH/Netlist.hs +10/−6
• src/CLaSH/Netlist/BlackBox.hs +14/−5
• src/CLaSH/Netlist/BlackBox/Parser.hs +1/−0
• src/CLaSH/Netlist/BlackBox/Types.hs +1/−0
• src/CLaSH/Netlist/BlackBox/Util.hs +33/−1
• src/CLaSH/Netlist/Types.hs +6/−4
• src/CLaSH/Normalize.hs +1/−0
• src/CLaSH/Normalize/Transformations.hs +22/−24
• src/CLaSH/Normalize/Types.hs +3/−0
• src/CLaSH/Normalize/Util.hs +9/−4

@@ -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

@@ -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

@@ -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

@@ -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)   ]

@@ -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)

@@ -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')

@@ -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) "" []

@@ -13,5 +13,6 @@  data CLaSHOpts = CLaSHOpts { opt_inlineLimit :: Int                            , opt_specLimit   :: Int+                           , opt_inlineBelow :: Int                            , opt_dbgLevel    :: DebugLevel                            }

@@ -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

@@ -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'

@@ -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) 

@@ -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 

@@ -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"

@@ -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

@@ -68,6 +68,7 @@                   (opt_specLimit opts)                   HashMap.empty                   (opt_inlineLimit opts)+                  (opt_inlineBelow opts)                   (error $ $(curLoc) ++ "Report as bug: no curFun")  

@@ -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 

@@ -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   }

@@ -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