clash-lib 0.6.10 → 0.6.11
raw patch · 21 files changed
+563/−374 lines, 21 files
Files
- CHANGELOG.md +6/−1
- clash-lib.cabal +1/−1
- src/CLaSH/Backend.hs +10/−1
- src/CLaSH/Driver.hs +16/−9
- src/CLaSH/Driver/TestbenchGen.hs +42/−38
- src/CLaSH/Driver/TopWrapper.hs +15/−13
- src/CLaSH/Driver/Types.hs +2/−0
- src/CLaSH/Netlist.hs +110/−76
- src/CLaSH/Netlist.hs-boot +4/−1
- src/CLaSH/Netlist/BlackBox.hs +82/−64
- src/CLaSH/Netlist/BlackBox/Parser.hs +16/−12
- src/CLaSH/Netlist/BlackBox/Types.hs +12/−2
- src/CLaSH/Netlist/BlackBox/Util.hs +125/−59
- src/CLaSH/Netlist/Id.hs +8/−45
- src/CLaSH/Netlist/Types.hs +8/−3
- src/CLaSH/Netlist/Util.hs +79/−32
- src/CLaSH/Normalize/Strategy.hs +1/−1
- src/CLaSH/Normalize/Transformations.hs +12/−12
- src/CLaSH/Rewrite/Combinators.hs +1/−1
- src/CLaSH/Rewrite/Types.hs +1/−1
- src/CLaSH/Rewrite/Util.hs +12/−2
CHANGELOG.md view
@@ -1,6 +1,11 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package -## 0.6.10+## 0.6.11 *March 11th 2016*+* New features:+ * Add support for HDL synthesis tool specific HDL generation+ * Preserve more Haskell names in generated HDL [#128](https://github.com/clash-lang/clash-compiler/issues/128)++## 0.6.10 *February 10th 2016* * New features: * hdl files can be written to a directory other than the current working directory [#125](https://github.com/clash-lang/clash-compiler/issues/125) * Fixes bugs:
clash-lib.cabal view
@@ -1,5 +1,5 @@ Name: clash-lib-Version: 0.6.10+Version: 0.6.11 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that
src/CLaSH/Backend.hs view
@@ -12,10 +12,13 @@ import Text.PrettyPrint.Leijen.Text.Monadic (Doc) import CLaSH.Netlist.Types+import CLaSH.Netlist.BlackBox.Types +type ModName = String+ class Backend state where -- | Initial state for state monad- initBackend :: Int -> state+ initBackend :: Int -> HdlSyn -> state -- | Location for the primitive definitions primDir :: state -> IO FilePath@@ -54,3 +57,9 @@ toBV :: HWType -> Text -> State state Doc -- | Convert from a bit-vector fromBV :: HWType -> Text -> State state Doc+ -- | Synthesis tool we're generating HDL for+ hdlSyn :: State state HdlSyn+ -- | mkBasicId+ mkBasicId :: State state (Identifier -> Identifier)+ -- | setModName+ setModName :: ModName -> state -> state
src/CLaSH/Driver.hs view
@@ -30,7 +30,7 @@ import Text.PrettyPrint.Leijen.Text (Doc, hPutDoc) import Unbound.Generics.LocallyNameless (name2String) -import CLaSH.Annotations.TopEntity (TopEntity)+import CLaSH.Annotations.TopEntity (TopEntity (..)) import CLaSH.Backend import CLaSH.Core.Term (Term, TmName) import CLaSH.Core.Type (Type)@@ -84,23 +84,31 @@ let prepNormDiff = Clock.diffUTCTime normTime prepTime putStrLn $ "Normalisation took " ++ show prepNormDiff - let modName = takeWhile (/= '.') (name2String topEntity)- iw = opt_intWidth opts- (netlist,dfiles,cmpCnt) <- genNetlist Nothing transformedBindings primMap' tcm- typeTrans Nothing modName [] iw topEntity+ let modName = takeWhile (/= '.') (name2String topEntity)+ iw = opt_intWidth opts+ hdlsyn = opt_hdlSyn opts+ hdlState' = setModName modName+ $ fromMaybe (initBackend iw hdlsyn :: backend) hdlState+ mkId = evalState mkBasicId hdlState'+ topNm = maybe (mkId (Text.pack $ modName ++ "_topEntity"))+ (Text.pack . t_name)+ annM + (netlist,dfiles,seen) <- genNetlist transformedBindings primMap' tcm+ typeTrans Nothing modName [] iw mkId [topNm] topEntity+ netlistTime <- netlist `deepseq` Clock.getCurrentTime let normNetDiff = Clock.diffUTCTime netlistTime normTime putStrLn $ "Netlist generation took " ++ show normNetDiff let topComponent = head $ filter (\(Component cName _ _ _ _) ->- Text.isSuffixOf (genComponentName modName topEntity 0)+ Text.isSuffixOf (genComponentName [topNm] mkId modName topEntity) cName) netlist (testBench,dfiles') <- genTestBench opts supplyTB primMap'- typeTrans tcm tupTcm eval cmpCnt bindingsMap+ typeTrans tcm tupTcm eval mkId seen bindingsMap testInpM expOutM modName@@ -112,8 +120,7 @@ let netTBDiff = Clock.diffUTCTime testBenchTime netlistTime putStrLn $ "Testbench generation took " ++ show netTBDiff - let hdlState' = fromMaybe (initBackend iw :: backend) hdlState- topWrapper = mkTopWrapper primMap' annM modName iw topComponent+ let topWrapper = mkTopWrapper primMap' mkId annM modName iw topComponent hdlDocs = createHDL hdlState' modName (topWrapper : netlist ++ testBench) dir = fromMaybe "." (opt_hdlDir opts) </> CLaSH.Backend.name hdlState' </>
src/CLaSH/Driver/TestbenchGen.hs view
@@ -21,7 +21,7 @@ import Data.IntMap.Strict (IntMap) import Data.List (find,nub) import Data.Maybe (catMaybes,mapMaybe)-import Data.Text.Lazy (append,pack,splitOn)+import Data.Text.Lazy (append,pack) import Unbound.Generics.LocallyNameless (name2String) import CLaSH.Core.Term@@ -50,7 +50,8 @@ -> HashMap TyConName TyCon -> IntMap TyConName -> (HashMap TyConName TyCon -> Bool -> Term -> Term)- -> Int+ -> (Identifier -> Identifier)+ -> [Identifier] -> HashMap TmName (Type,Term) -- ^ Global binders -> Maybe TmName -- ^ Stimuli -> Maybe TmName -- ^ Expected output@@ -58,18 +59,18 @@ -> [(String,FilePath)] -- ^ Set of collected data-files -> Component -- ^ Component to generate TB for -> IO ([Component],[(String,FilePath)])-genTestBench opts supply primMap typeTrans tcm tupTcm eval cmpCnt globals stimuliNmM expectedNmM modName dfiles+genTestBench opts supply primMap typeTrans tcm tupTcm eval mkId seen globals stimuliNmM expectedNmM modName dfiles (Component cName hidden [inp] [outp] _) = do let iw = opt_intWidth opts ioDecl = [ uncurry NetDecl inp , uncurry NetDecl outp ] inpExpr = Assignment (fst inp) (BlackBoxE "" [Err Nothing] (emptyBBContext {bbResult = (undefined,snd inp)}) False)- (inpInst,inpComps,cmpCnt',hidden',dfiles') <- maybe (return (inpExpr,[],cmpCnt,hidden,dfiles))- (genStimuli cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp modName dfiles iw)+ (inpInst,inpComps,seen',hidden',dfiles') <- maybe (return (inpExpr,[],seen,hidden,dfiles))+ (genStimuli seen primMap globals typeTrans mkId tcm normalizeSignal hidden inp modName dfiles iw) stimuliNmM - ((finDecl,finExpr),s) <- runNetlistMonad (Just cmpCnt') globals primMap tcm typeTrans modName dfiles' iw $ do+ ((finDecl,finExpr),s) <- runNetlistMonad globals primMap tcm typeTrans modName dfiles' iw mkId ("finished":"done":seen') $ do done <- genDone primMap let finDecl' = [ NetDecl "finished" Bool , done@@ -77,25 +78,26 @@ finExpr' <- genFinish primMap return (finDecl',finExpr') - (expInst,expComps,cmpCnt'',hidden'',dfiles'') <- maybe (return (finExpr,[],cmpCnt',hidden',dfiles'))- (genVerifier cmpCnt' primMap globals typeTrans tcm normalizeSignal hidden' outp modName dfiles' iw)+ (expInst,expComps,seen'',hidden'',dfiles'') <- maybe (return (finExpr,[],seen',hidden',dfiles'))+ (genVerifier seen' primMap globals typeTrans mkId tcm normalizeSignal hidden' outp modName dfiles' iw) 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+ let clkNms = mapMaybe (\hd -> case hd of (_,Clock _ _) -> Just hd; _ -> Nothing) hidden+ rstNms = mapMaybe (\hd -> case hd of (_,Reset _ _) -> Just hd; _ -> Nothing) hidden - ((clks,rsts),_) <- runNetlistMonad (Just cmpCnt'') globals primMap tcm typeTrans modName dfiles'' iw $ do+ ((clks,rsts),_) <- runNetlistMonad globals primMap tcm typeTrans modName dfiles'' iw mkId ("finished":"done":seen'') $ do varCount .= (_varCount s) clks' <- catMaybes <$> mapM (genClock primMap) hidden'' rsts' <- catMaybes <$> mapM (genReset primMap) hidden'' return (clks',rsts') let instDecl = InstDecl cName "totest"- (map (\i -> (i,Identifier i Nothing))- (concat [ clkNms, rstNms, [fst inp], [fst outp] ])- )+ (map (\(i,t) -> (i,In,t,Identifier i Nothing))+ (concat [ clkNms, rstNms, [inp] ])+ +++ [(\(i,t) -> (i,Out,t,Identifier i Nothing)) outp]) - tbComp = Component (pack modName `append` "_testbench") [] [] [("done",Bool)]+ tbComp = Component (mkId (pack modName `append` "_testbench")) [] [] [("done",Bool)] (concat [ finDecl , concat clks , concat rsts@@ -111,7 +113,7 @@ normalizeSignal glbls bndr = runNormalization opts supply glbls typeTrans tcm tupTcm eval primMap (normalize [bndr] >>= cleanupGraph bndr) -genTestBench opts _ _ _ _ _ _ _ _ _ _ _ dfiles c = traceIf (opt_dbgLevel opts > DebugNone) ("Can't make testbench for: " ++ show c) $ return ([],dfiles)+genTestBench opts _ _ _ _ _ _ _ _ _ _ _ _ dfiles c = traceIf (opt_dbgLevel opts > DebugNone) ("Can't make testbench for: " ++ show c) $ return ([],dfiles) genClock :: PrimMap BlackBoxTemplate -> (Identifier,HWType)@@ -183,10 +185,11 @@ return $ BlackBoxD "CLaSH.Driver.TestbenchGen.doneGen" templ' ctx pM -> error $ $(curLoc) ++ ("Can't make done declaration for: " ++ show pM) -genStimuli :: Int+genStimuli :: [Identifier] -> PrimMap BlackBoxTemplate -> HashMap TmName (Type,Term) -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))+ -> (Identifier -> Identifier) -> HashMap TyConName TyCon -> ( HashMap TmName (Type,Term) -> TmName@@ -197,12 +200,12 @@ -> [(String,FilePath)] -> Int -> TmName- -> IO (Declaration,[Component],Int,[(Identifier,HWType)],[(String,FilePath)])-genStimuli cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp modName dfiles iw signalNm = do+ -> IO (Declaration,[Component],[Identifier],[(Identifier,HWType)],[(String,FilePath)])+genStimuli seen primMap globals typeTrans mkId tcm normalizeSignal hidden inp modName dfiles iw signalNm = do let stimNormal = normalizeSignal globals signalNm- (comps,dfiles',cmpCnt') <- genNetlist (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing modName dfiles iw signalNm- let sigNm = pack (modName ++ "_") `append` last (splitOn (pack ".") (pack (name2String signalNm))) `append` pack "_" `append` (pack (show cmpCnt))- sigComp = case find ((== sigNm) . componentName) comps of+ (comps,dfiles',seen') <- genNetlist stimNormal primMap tcm typeTrans Nothing modName dfiles iw mkId seen signalNm+ let sigNm = genComponentName seen mkId modName signalNm+ sigComp = case find ((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) @@ -210,19 +213,20 @@ (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'+ clkNms = mapMaybe (\hd -> case hd of (_,Clock _ _) -> Just hd; _ -> Nothing) hidden'+ rstNms = mapMaybe (\hd -> case hd of (_,Reset _ _) -> Just hd; _ -> Nothing) hidden' decl = InstDecl cName "stimuli"- (map (\i -> (i,Identifier i Nothing))+ (map (\(i,t) -> (i,In,t,Identifier i Nothing)) (concat [ clkNms, rstNms ]) ++- [(outp,Identifier (fst inp) Nothing)]+ [(outp,Out,(snd inp),Identifier (fst inp) Nothing)] )- return (decl,comps,cmpCnt',hidden'',dfiles')+ return (decl,comps,seen',hidden'',dfiles') -genVerifier :: Int+genVerifier :: [Identifier] -> PrimMap BlackBoxTemplate -> HashMap TmName (Type,Term) -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))+ -> (Identifier -> Identifier) -> HashMap TyConName TyCon -> ( HashMap TmName (Type,Term) -> TmName@@ -233,23 +237,23 @@ -> [(String,FilePath)] -> Int -> TmName- -> IO (Declaration,[Component],Int,[(Identifier,HWType)],[(String,FilePath)])-genVerifier cmpCnt primMap globals typeTrans tcm normalizeSignal hidden outp modName dfiles iw signalNm = do+ -> IO (Declaration,[Component],[Identifier],[(Identifier,HWType)],[(String,FilePath)])+genVerifier seen primMap globals typeTrans mkId tcm normalizeSignal hidden outp modName dfiles iw signalNm = do let stimNormal = normalizeSignal globals signalNm- (comps,dfiles',cmpCnt') <- genNetlist (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing modName dfiles iw signalNm- let sigNm = pack (modName ++ "_") `append` last (splitOn (pack ".") (pack (name2String signalNm))) `append` "_" `append` (pack (show cmpCnt))- sigComp = case find ((== sigNm) . componentName) comps of+ (comps,dfiles',seen') <- genNetlist stimNormal primMap tcm typeTrans Nothing modName dfiles iw mkId seen signalNm+ let sigNm = genComponentName seen mkId modName signalNm+ sigComp = case find ((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'+ clkNms = mapMaybe (\hd -> case hd of (_,Clock _ _) -> Just hd; _ -> Nothing) hidden'+ rstNms = mapMaybe (\hd -> case hd of (_,Reset _ _) -> Just hd; _ -> Nothing) hidden' decl = InstDecl cName "verify"- (map (\i -> (i,Identifier i Nothing))+ (map (\(i,t) -> (i,In,t,Identifier i Nothing)) (concat [ clkNms, rstNms ]) ++- [(inp,Identifier (fst outp) Nothing),(fin,Identifier "finished" Nothing)]+ [(inp,In,snd outp,Identifier (fst outp) Nothing),(fin,Out,Bool,Identifier "finished" Nothing)] )- return (decl,comps,cmpCnt',hidden'',dfiles')+ return (decl,comps,seen',hidden'',dfiles')
src/CLaSH/Driver/TopWrapper.hs view
@@ -28,20 +28,21 @@ import CLaSH.Netlist.Types (BlackBoxContext (..), Component (..), Declaration (..), Expr (..), Identifier, HWType (..), Modifier (..), NetlistMonad,- emptyBBContext)+ PortDirection(..), emptyBBContext) import CLaSH.Primitives.Types (PrimMap, Primitive (..)) import CLaSH.Util -- | Create a wrapper around a component, potentially initiating clock sources mkTopWrapper :: PrimMap BlackBoxTemplate+ -> (Identifier -> Identifier) -> Maybe TopEntity -- ^ TopEntity specifications -> String -- ^ Name of the module containing the @topEntity@ -> Int -- ^ Int/Word/Integer bit-width -> Component -- ^ Entity to wrap -> Component-mkTopWrapper primMap teM modName iw topComponent+mkTopWrapper primMap mkId teM modName iw topComponent = Component- { componentName = maybe (pack modName `append` "_topEntity") (pack . t_name) teM+ { componentName = maybe (mkId (pack modName `append` "_topEntity")) (pack . t_name) teM , inputs = inputs'' ++ extraIn teM , outputs = outputs'' ++ extraOut teM , hiddenPorts = case maybe [] t_clocks teM of@@ -80,14 +81,14 @@ instDecl = InstDecl (componentName topComponent) (append (componentName topComponent) (pack "_inst"))- (zipWith (\(p,_) i -> (p,Identifier i Nothing))+ (zipWith (\(p,t) i -> (p,In,t,Identifier i Nothing)) (inputs topComponent) idsI ++- map (\(p,_) -> (p,Identifier p Nothing))+ map (\(p,t) -> (p,In,t,Identifier p Nothing)) (hiddenPorts topComponent) ++- zipWith (\(p,_) i -> (p,Identifier i Nothing))+ zipWith (\(p,t) i -> (p,Out,t,Identifier i Nothing)) (outputs topComponent) idsO) @@ -231,9 +232,9 @@ clkDecls = map mkClockDecl clks instDecl = InstDecl c_nameT (append c_nameT "_inst") $ concat [ ports- , maybe [] ((:[]) . (pack *** stringToVar))+ , maybe [] ((:[]) . (\(i,e) -> (pack i,In,Reset "" 0,stringToVar e))) c_reset- , [(pack c_lock,Identifier lockedName Nothing)]+ , [(pack c_lock,Out,Reset "" 0,Identifier lockedName Nothing)] ] mkClockDecl :: String -> Declaration@@ -244,10 +245,11 @@ -- | Create a single clock path clockPorts :: [(String,String)] -> [(String,String)]- -> ([(Identifier,Expr)],[String])-clockPorts inp outp = (ports,clks)+ -> ([(Identifier,PortDirection,HWType,Expr)],[String])+clockPorts inp outp = (inPorts ++ outPorts,clks) where- ports = map (pack *** stringToVar) (inp ++ outp)+ inPorts = map (\(i,e) -> (pack i,In,Clock "" 0,stringToVar e)) inp+ outPorts = map (\(i,e) -> (pack i,Out,Clock "" 0,stringToVar e)) inp clks = map snd outp -- | Generate resets@@ -300,5 +302,5 @@ unsafeRunNetlist iw = unsafePerformIO . fmap fst- . runNetlistMonad Nothing HashMap.empty HashMap.empty- HashMap.empty (\_ _ -> Nothing) "" [] iw+ . runNetlistMonad HashMap.empty HashMap.empty+ HashMap.empty (\_ _ -> Nothing) "" [] iw id []
src/CLaSH/Driver/Types.hs view
@@ -14,6 +14,7 @@ import CLaSH.Core.Type (Type) import CLaSH.Rewrite.Types (DebugLevel)+import CLaSH.Netlist.BlackBox.Types (HdlSyn) -- | Global function binders type BindingMap = HashMap TmName (Type,Term)@@ -25,4 +26,5 @@ , opt_cleanhdl :: Bool , opt_intWidth :: Int , opt_hdlDir :: Maybe String+ , opt_hdlSyn :: HdlSyn }
src/CLaSH/Netlist.hs view
@@ -11,7 +11,7 @@ module CLaSH.Netlist where -import Control.Lens ((.=), (<<%=))+import Control.Lens ((.=)) import qualified Control.Lens as Lens import Control.Monad.State.Strict (runStateT) import Control.Monad.Writer.Strict (listen, runWriterT, tell)@@ -48,9 +48,7 @@ -- | Generate a hierarchical netlist out of a set of global binders with -- @topEntity@ at the top.-genNetlist :: Maybe Int- -- ^ Starting number of the component counter- -> HashMap TmName (Type,Term)+genNetlist :: HashMap TmName (Type,Term) -- ^ Global binders -> PrimMap BlackBoxTemplate -- ^ Primitive definitions@@ -66,17 +64,19 @@ -- ^ Set of collected data-files -> Int -- ^ Int/Word/Integer bit-width+ -> (Identifier -> Identifier)+ -- ^ valid identifiers+ -> [Identifier]+ -- ^ Seen components -> TmName -- ^ Name of the @topEntity@- -> IO ([Component],[(String,FilePath)],Int)-genNetlist compCntM globals primMap tcm typeTrans mStart modName dfiles iw topEntity = do- (_,s) <- runNetlistMonad compCntM globals primMap tcm typeTrans modName dfiles iw $ genComponent topEntity mStart- return (HashMap.elems $ _components s, _dataFiles s, _cmpCount s)+ -> IO ([Component],[(String,FilePath)],[Identifier])+genNetlist globals primMap tcm typeTrans mStart modName dfiles iw mkId seen topEntity = do+ (_,s) <- runNetlistMonad globals primMap tcm typeTrans modName dfiles iw mkId seen $ genComponent topEntity mStart+ return (HashMap.elems $ _components s, _dataFiles s, _seenComps s) -- | Run a NetlistMonad action in a given environment-runNetlistMonad :: Maybe Int- -- ^ Starting number of the component counter- -> HashMap TmName (Type,Term)+runNetlistMonad :: HashMap TmName (Type,Term) -- ^ Global binders -> PrimMap BlackBoxTemplate -- ^ Primitive Definitions@@ -90,17 +90,36 @@ -- ^ Set of collected data-files -> Int -- ^ Int/Word/Integer bit-width+ -> (Identifier -> Identifier)+ -- ^ valid identifiers+ -> [Identifier]+ -- ^ Seen components -> NetlistMonad a -- ^ Action to run -> IO (a, NetlistState)-runNetlistMonad compCntM s p tcm typeTrans modName dfiles iw+runNetlistMonad s p tcm typeTrans modName dfiles iw mkId seen = 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 dfiles iw+ s' = NetlistState s HashMap.empty 0 HashMap.empty p typeTrans tcm Text.empty dfiles iw mkId [] seen' names+ (seen',names) = genNames mkId modName seen HashMap.empty (HashMap.keys s) +genNames :: (Identifier -> Identifier)+ -> String+ -> [Identifier]+ -> HashMap TmName Identifier+ -> [TmName]+ -> ([Identifier], HashMap TmName Identifier)+genNames mkId modName = go+ where+ go s m [] = (s,m)+ go s m (nm:nms) = let nm' = genComponentName s mkId modName nm+ s' = nm':s+ m' = HashMap.insert nm nm' m+ in go s' m' nms+ -- | Generate a component for a given function (caching) genComponent :: TmName -- ^ Name of the function -> Maybe Int -- ^ Starting value of the unique counter@@ -119,13 +138,11 @@ -> NetlistMonad Component genComponentT compName componentExpr mStart = do varCount .= fromMaybe 0 mStart- componentNumber <- cmpCount <<%= (+1)- modName <- Lens.use modNm-- let componentName' = genComponentName modName compName componentNumber+ componentName' <- (HashMap.! compName) <$> Lens.use componentNames curCompNm .= componentName' tcm <- Lens.use tcCache+ seenIds .= [] (arguments,binders,result) <- do { normalizedM <- splitNormalized tcm componentExpr ; case normalizedM of Right normalized -> mkUniqueNormalized normalized@@ -146,31 +163,37 @@ argTypes = map (\(Id _ (Embed t)) -> unsafeCoreTypeToHWType $(curLoc) typeTrans tcm t) arguments let netDecls = map (\(id_,_) ->- NetDecl (mkBasicId . Text.pack . name2String $ varName id_)+ NetDecl (Text.pack . name2String $ varName id_) (unsafeCoreTypeToHWType $(curLoc) typeTrans tcm . unembed $ varType id_) ) $ filter ((/= result) . varName . fst) binders (decls,clks) <- listen $ concat <$> mapM (uncurry mkDeclarations . second unembed) binders - let compInps = zip (map (mkBasicId . Text.pack . name2String . varName) arguments) argTypes- compOutp = (mkBasicId . Text.pack $ name2String result, resType)+ let compInps = zip (map (Text.pack . name2String . varName) arguments) argTypes+ compOutp = (Text.pack $ name2String result, resType) component = Component componentName' (toList clks) compInps [compOutp] (netDecls ++ decls) return component -genComponentName :: String -> TmName -> Int -> Identifier-genComponentName prefix nm i- = mkBasicId' True- . (Text.pack (prefix ++ "_") `Text.append`)- . (`Text.append` (Text.pack $ show i))- . ifThenElse Text.null- (`Text.append` Text.pack "Component_")- (`Text.append` Text.pack "_")- . mkBasicId' True- . stripDollarPrefixes- . last- . Text.splitOn (Text.pack ".")- . Text.pack- $ name2String nm +genComponentName :: [Identifier] -> (Identifier -> Identifier) -> String -> TmName -> Identifier+genComponentName seen mkId prefix nm =+ let i = mkId . stripDollarPrefixes . last+ . Text.splitOn (Text.pack ".") . Text.pack+ $ name2String nm+ i' = if Text.null i+ then Text.pack "Component"+ else i+ i'' = mkId (Text.pack (prefix ++ "_") `Text.append` i')+ in if i'' `elem` seen+ then go 0 i''+ else i''+ where+ go :: Integer -> Identifier -> Identifier+ go n i =+ let i' = mkId (i `Text.append` Text.pack ('_':show n))+ in if i' `elem` seen+ then go (n+1) i+ else i'+ -- | Generate a list of Declarations for a let-binder mkDeclarations :: Id -- ^ LHS of the let-binder -> Term -- ^ RHS of the let-binder@@ -191,17 +214,19 @@ let sHwTy = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm scrutTy vHwTy = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm varTy (selId,decls) <- case scrut of- (Var _ scrutNm) -> return (mkBasicId . Text.pack $ name2String scrutNm,[])- _ -> do- (newExpr, newDecls) <- mkExpr False scrutTy scrut- i <- varCount <<%= (+1)- let tmpNm = "tmp_" ++ show i- tmpNmT = Text.pack tmpNm- tmpDecl = NetDecl tmpNmT sHwTy- tmpAssn = Assignment tmpNmT newExpr- return (tmpNmT,newDecls ++ [tmpDecl,tmpAssn])- let dstId = mkBasicId . Text.pack . name2String $ varName bndr- altVarId = mkBasicId . Text.pack $ name2String varTm+ (Var _ scrutNm) -> return (Text.pack $ name2String scrutNm,[])+ _ -> do+ let scrutId = Text.pack . (++ "_case_scrut") . name2String $ varName bndr+ (newExpr, newDecls) <- mkExpr False (Left scrutId) scrutTy scrut+ case newExpr of+ (Identifier newId Nothing) -> return (newId,newDecls)+ _ -> do+ scrutId' <- mkUniqueIdentifier scrutId+ let scrutDecl = NetDecl scrutId' sHwTy+ scrutAssn = Assignment scrutId' newExpr+ return (scrutId',newDecls ++ [scrutDecl,scrutAssn])+ let dstId = Text.pack . name2String $ varName bndr+ altVarId = Text.pack $ name2String varTm modifier = case pat of DataPat (Embed dc) ids -> let (exts,tms) = unrebind ids tmsTys = map (unembed . varType) tms@@ -227,15 +252,17 @@ scrutTy <- termType tcm scrut scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy altHTy <- unsafeCoreTypeToHWTypeM $(curLoc) altTy- (scrutExpr,scrutDecls) <- first (mkScrutExpr scrutHTy (fst (head alts'))) <$> mkExpr True scrutTy scrut+ let scrutId = Text.pack . (++ "_case_scrut") . name2String $ varName bndr+ (scrutExpr,scrutDecls) <- first (mkScrutExpr scrutHTy (fst (head alts'))) <$> mkExpr True (Left scrutId) scrutTy scrut (exprs,altsDecls) <- (second concat . unzip) <$> mapM (mkCondExpr scrutHTy) alts' - let dstId = mkBasicId . Text.pack . name2String $ varName bndr+ let dstId = Text.pack . name2String $ varName bndr return $! scrutDecls ++ altsDecls ++ [CondAssignment dstId altHTy scrutExpr scrutHTy exprs] where mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe HW.Literal,Expr),[Declaration]) mkCondExpr scrutHTy (pat,alt) = do- (altExpr,altDecls) <- mkExpr False altTy alt+ let altId = Text.pack . (++ "_case_alt") . name2String $ varName bndr+ (altExpr,altDecls) <- mkExpr False (Left altId) altTy alt (,altDecls) <$> case pat of DefaultPat -> return (Nothing,altExpr) DataPat (Embed dc) _ -> return (Just (dcToLiteral scrutHTy (dcTag dc)),altExpr)@@ -268,9 +295,12 @@ | null tyArgs -> mkFunApp bndr f args | otherwise -> error $ $(curLoc) ++ "Not in normal form: Var-application with Type arguments" _ -> do- (exprApp,declsApp) <- mkExpr False (unembed $ varType bndr) app- let dstId = mkBasicId . Text.pack . name2String $ varName bndr- return (declsApp ++ [Assignment dstId exprApp])+ (exprApp,declsApp) <- mkExpr False (Right bndr) (unembed $ varType bndr) app+ let dstId = Text.pack . name2String $ varName bndr+ assn = case exprApp of+ Identifier _ Nothing -> []+ _ -> [Assignment dstId exprApp]+ return (declsApp ++ assn) -- | Generate a list of Declarations for a let-binder where the RHS is a function application mkFunApp :: Id -- ^ LHS of the let-binder@@ -285,12 +315,12 @@ if length args == length compInps then do tcm <- Lens.use tcCache argTys <- mapM (termType tcm) args- (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr False t e) (zip args argTys)- (argExprs',argDecls') <- (second concat . unzip) <$> mapM toSimpleVar (zip argExprs argTys)- let dstId = mkBasicId . Text.pack . name2String $ varName dst- hiddenAssigns = map (\(i,_) -> (i,Identifier i Nothing)) hidden- inpAssigns = zip (map fst compInps) argExprs'- outpAssign = (fst compOutp,Identifier dstId Nothing)+ let dstId = Text.pack . name2String $ varName dst+ (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr False (Left dstId) t e) (zip args argTys)+ (argExprs',argDecls') <- (second concat . unzip) <$> mapM (toSimpleVar dst) (zip argExprs argTys)+ let hiddenAssigns = map (\(i,t) -> (i,In,t,Identifier i Nothing)) hidden+ inpAssigns = zipWith (\(i,t) e -> (i,In,t,e)) compInps argExprs'+ outpAssign = (fst compOutp,Out,snd compOutp,Identifier dstId Nothing) instLabel = Text.concat [compName, Text.pack "_", dstId] instDecl = InstDecl compName instLabel (outpAssign:hiddenAssigns ++ inpAssigns) tell (fromList hidden)@@ -298,28 +328,29 @@ else error $ $(curLoc) ++ "under-applied normalized function" Nothing -> case args of [] -> do- let dstId = mkBasicId . Text.pack . name2String $ varName dst- return [Assignment dstId (Identifier (mkBasicId . Text.pack $ name2String fun) Nothing)]+ let dstId = Text.pack . name2String $ varName dst+ return [Assignment dstId (Identifier (Text.pack $ name2String fun) Nothing)] _ -> error $ $(curLoc) ++ "Unknown function: " ++ showDoc fun -toSimpleVar :: (Expr,Type)+toSimpleVar :: Id+ -> (Expr,Type) -> NetlistMonad (Expr,[Declaration])-toSimpleVar (e@(Identifier _ _),_) = return (e,[])-toSimpleVar (e,ty) = do- i <- varCount <<%= (+1)+toSimpleVar _ (e@(Identifier _ _),_) = return (e,[])+toSimpleVar dst (e,ty) = do+ let argNm = Text.pack . (++ "_app_arg") . name2String $ varName dst+ argNm' <- mkUniqueIdentifier argNm hTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty- let tmpNm = "tmp_" ++ show i- tmpNmT = Text.pack tmpNm- tmpDecl = NetDecl tmpNmT hTy- tmpAssn = Assignment tmpNmT e- return (Identifier tmpNmT Nothing,[tmpDecl,tmpAssn])+ let argDecl = NetDecl argNm' hTy+ argAssn = Assignment argNm' e+ return (Identifier argNm' Nothing,[argDecl,argAssn]) -- | Generate an expression for a term occurring on the RHS of a let-binder mkExpr :: Bool -- ^ Treat BlackBox expression as declaration+ -> (Either Identifier Id) -- ^ Id to assign the result to -> Type -- ^ Type of the LHS of the let-binder -> Term -- ^ Term to convert to an expression -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations-mkExpr _ _ (Core.Literal l) = do+mkExpr _ _ _ (Core.Literal l) = do iw <- Lens.use intWidth case l of IntegerLiteral i -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, [])@@ -330,35 +361,38 @@ CharLiteral c -> return (HW.Literal (Just (Unsigned 21,21)) . NumLit . toInteger $ ord c, []) _ -> error $ $(curLoc) ++ "not an integer or char literal" -mkExpr bbEasD ty app = do+mkExpr bbEasD bndr ty app = do let (appF,args) = collectArgs app tmArgs = lefts args hwTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty case appF of Data dc- | all (\e -> isConstant e || isVar e) tmArgs -> mkDcApplication hwTy dc tmArgs+ | all (\e -> isConstant e || isVar e) tmArgs -> mkDcApplication hwTy bndr dc tmArgs | otherwise -> error $ $(curLoc) ++ "Not in normal form: DataCon-application with non-Simple arguments: " ++ showDoc app- Prim nm _ -> mkPrimitive False bbEasD nm args ty+ Prim nm _ -> mkPrimitive False bbEasD bndr nm args ty Var _ f- | null tmArgs -> return (Identifier (mkBasicId . Text.pack $ name2String f) Nothing,[])+ | null tmArgs -> return (Identifier (Text.pack $ name2String f) Nothing,[]) | otherwise -> error $ $(curLoc) ++ "Not in normal form: top-level binder in argument position: " ++ showDoc app _ -> error $ $(curLoc) ++ "Not in normal form: application of a Let/Lam/Case: " ++ showDoc app -- | Generate an expression for a DataCon application occurring on the RHS of a let-binder mkDcApplication :: HWType -- ^ HWType of the LHS of the let-binder+ -> (Either Identifier Id) -- ^ Id to assign the result to -> DataCon -- ^ Applied DataCon -> [Term] -- ^ DataCon Arguments -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations-mkDcApplication dstHType dc args = do+mkDcApplication dstHType bndr dc args = do tcm <- Lens.use tcCache argTys <- mapM (termType tcm) args let isSP (SP _ _) = True isSP _ = False- (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr (isSP dstHType) t e) (zip args argTys)+ let argNm = either id (Text.pack . (++ "_app_arg") . name2String . varName) bndr+ (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr (isSP dstHType) (Left argNm) t e) (zip args argTys) argHWTys <- mapM coreTypeToHWTypeM argTys fmap (,argDecls) $! case (argHWTys,argExprs) of -- Is the DC just a newtype wrapper?- ([Just argHwTy],[argExpr]) | argHwTy == dstHType -> return argExpr+ ([Just argHwTy],[argExpr]) | argHwTy == dstHType ->+ return (HW.DataCon dstHType (DC (Void,-1)) [argExpr]) _ -> case dstHType of SP _ dcArgPairs -> do let dcI = dcTag dc - 1
src/CLaSH/Netlist.hs-boot view
@@ -9,7 +9,8 @@ import CLaSH.Core.DataCon (DataCon) import CLaSH.Core.Term (Term,TmName) import CLaSH.Core.Type (Type)-import CLaSH.Netlist.Types (Expr, HWType, NetlistMonad, Component,+import CLaSH.Core.Var (Id)+import CLaSH.Netlist.Types (Expr, HWType, Identifier, NetlistMonad, Component, Declaration) genComponent :: TmName@@ -17,11 +18,13 @@ -> NetlistMonad Component mkExpr :: Bool+ -> Either Identifier Id -> Type -> Term -> NetlistMonad (Expr,[Declaration]) mkDcApplication :: HWType+ -> Either Identifier Id -> DataCon -> [Term] -> NetlistMonad (Expr,[Declaration])
src/CLaSH/Netlist/BlackBox.hs view
@@ -19,7 +19,7 @@ import Data.Either (lefts) import qualified Data.HashMap.Lazy as HashMap import qualified Data.IntMap as IntMap-import Data.Text.Lazy (fromStrict, pack)+import Data.Text.Lazy (append,fromStrict, pack) import qualified Data.Text.Lazy as Text import Data.Text (unpack) import qualified Data.Text as TextS@@ -40,7 +40,6 @@ mkExpr) import CLaSH.Netlist.BlackBox.Types as B import CLaSH.Netlist.BlackBox.Util as B-import CLaSH.Netlist.Id as N import CLaSH.Netlist.Types as N import CLaSH.Netlist.Util as N import CLaSH.Normalize.Util (isConstant)@@ -54,13 +53,14 @@ mkBlackBoxContext resId args = do -- Make context inputs tcm <- Lens.use tcCache- (imps,impDecls) <- unzip <$> mapM mkArgument args+ let resNm = Text.pack . name2String $ varName resId+ (imps,impDecls) <- unzip <$> mapM (mkArgument resNm) args (funs,funDecls) <- mapAccumLM (addFunction tcm) IntMap.empty (zip args [0..]) -- Make context result- let res = case synchronizedClk tcm (unembed $ V.varType resId) of- Just clk -> Right . (,clk) . (`N.Identifier` Nothing) . mkBasicId . pack $ name2String (V.varName resId)- Nothing -> Left . (`N.Identifier` Nothing) . mkBasicId . pack $ name2String (V.varName resId)+ res <- case synchronizedClk tcm (unembed $ V.varType resId) of+ Just clk -> Right . (,clk) . (`N.Identifier` Nothing) <$> mkBasicId (pack $ name2String (V.varName resId))+ Nothing -> Left . (`N.Identifier` Nothing) <$> mkBasicId (pack $ name2String (V.varName resId)) resTy <- unsafeCoreTypeToHWTypeM $(curLoc) (unembed $ V.varType resId) return ( Context (res,resTy) imps funs@@ -81,19 +81,20 @@ -> NetlistMonad BlackBoxTemplate prepareBlackBox pNm templ bbCtx = if verifyBlackBoxContext bbCtx templ- then instantiateSym >=>+ then instantiateCompName >=>+ setSym >=> setClocks bbCtx >=>- collectFilePaths bbCtx >=>- instantiateCompName $ templ+ collectFilePaths bbCtx $ templ else error $ $(curLoc) ++ "\nCan't match template for " ++ show pNm ++ " :\n" ++ show templ ++ "\nwith context:\n" ++ show bbCtx -mkArgument :: Term+mkArgument :: Identifier -- ^ LHS of the original let-binder+ -> Term -> NetlistMonad ( (SyncExpr,HWType,Bool) , [Declaration] )-mkArgument e = do+mkArgument bndr e = do tcm <- Lens.use tcCache ty <- termType tcm e iw <- Lens.use intWidth@@ -101,8 +102,8 @@ ((e',t,l),d) <- case hwTyM of Nothing -> return ((Identifier "__VOID__" Nothing,Void,False),[]) Just hwTy -> case collectArgs e of- (Var _ v,[]) -> let vT = Identifier (mkBasicId . pack $ name2String v) Nothing- in return ((vT,hwTy,False),[])+ (Var _ v,[]) -> do vT <- (`Identifier` Nothing) <$> mkBasicId (pack $ name2String v)+ return ((vT,hwTy,False),[]) (C.Literal (IntegerLiteral i),[]) -> return ((N.Literal (Just (Signed iw,iw)) (N.NumLit i),hwTy,True),[]) (C.Literal (IntLiteral i), []) -> return ((N.Literal (Just (Signed iw,iw)) (N.NumLit i),hwTy,True),[]) (C.Literal (WordLiteral w), []) -> return ((N.Literal (Just (Unsigned iw,iw)) (N.NumLit w),hwTy,True),[])@@ -111,14 +112,14 @@ (C.Literal (Int64Literal i), []) -> return ((N.Literal (Just (Signed 64,64)) (N.NumLit i),hwTy,True),[]) (C.Literal (Word64Literal i), []) -> return ((N.Literal (Just (Unsigned 64,64)) (N.NumLit i),hwTy,True),[]) (Prim f _,args) -> do- (e',d) <- mkPrimitive True False f args ty+ (e',d) <- mkPrimitive True False (Left bndr) f args ty case e' of (Identifier _ _) -> return ((e',hwTy,False), d) _ -> return ((e',hwTy,isConstant e), d) (Data dc, args) -> do typeTrans <- Lens.use typeTranslator args' <- filterM (fmap (representableType typeTrans tcm) . termType tcm) (lefts args)- (exprN,dcDecls) <- mkDcApplication hwTy dc args'+ (exprN,dcDecls) <- mkDcApplication hwTy (Left bndr) dc args' return ((exprN,hwTy,isConstant e),dcDecls) _ -> return ((Identifier "__VOID__" Nothing,hwTy,False),[]) return ((addClock tcm ty e',t,l),d)@@ -129,34 +130,36 @@ mkPrimitive :: Bool -- ^ Put BlackBox expression in parenthesis -> Bool -- ^ Treat BlackBox expression as declaration+ -> (Either Identifier Id) -- ^ Id to assign the result to -> TextS.Text -> [Either Term Type] -> Type -> NetlistMonad (Expr,[Declaration])-mkPrimitive bbEParen bbEasD nm args ty = do+mkPrimitive bbEParen bbEasD dst nm args ty = do bbM <- HashMap.lookup nm <$> Lens.use primitives case bbM of Just p@(P.BlackBox {}) -> do- i <- varCount <<%= (+1)- let tmpNm = "tmp_" ++ show i- tmpNmT = pack tmpNm- tmpId = Id (string2Name tmpNm) (embed ty)- (bbCtx,ctxDcls) <- mkBlackBoxContext tmpId (lefts args)- let hwTy = snd $ bbResult bbCtx case template p of (Left tempD) -> do- let tmpDecl = NetDecl tmpNmT hwTy- pNm = name p+ let pNm = name p+ (dst',dstNm,dstDecl) <- resBndr True dst+ (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args) bbDecl <- N.BlackBoxD pNm <$> prepareBlackBox pNm tempD bbCtx <*> pure bbCtx- return (Identifier tmpNmT Nothing,ctxDcls ++ [tmpDecl,bbDecl])+ return (Identifier dstNm Nothing,dstDecl ++ ctxDcls ++ [bbDecl]) (Right tempE) -> do let pNm = name p- bbTempl <- prepareBlackBox pNm tempE bbCtx if bbEasD- then let tmpDecl = NetDecl tmpNmT hwTy- tmpAssgn = Assignment tmpNmT (BlackBoxE pNm bbTempl bbCtx bbEParen)- in return (Identifier tmpNmT Nothing, ctxDcls ++ [tmpDecl,tmpAssgn])- else return (BlackBoxE pNm bbTempl bbCtx bbEParen,ctxDcls)+ then do+ (dst',dstNm,dstDecl) <- resBndr True dst+ (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args)+ bbTempl <- prepareBlackBox pNm tempE bbCtx+ let tmpAssgn = Assignment dstNm (BlackBoxE pNm bbTempl bbCtx bbEParen)+ return (Identifier dstNm Nothing, dstDecl ++ ctxDcls ++ [tmpAssgn])+ else do+ (dst',_,_) <- resBndr False dst+ (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args)+ bbTempl <- prepareBlackBox pNm tempE bbCtx+ return (BlackBoxE pNm bbTempl bbCtx bbEParen,ctxDcls) Just (P.Primitive pNm _) | pNm == "GHC.Prim.tagToEnum#" -> do hwTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) ty@@ -165,44 +168,56 @@ tcm <- Lens.use tcCache let dcs = tyConDataCons (tcm HashMap.! tcN) dc = dcs !! fromInteger i- (exprN,dcDecls) <- mkDcApplication hwTy dc []+ (exprN,dcDecls) <- mkDcApplication hwTy dst dc [] return (exprN,dcDecls) [Right _, Left scrut] -> do- i <- varCount <<%= (+1) tcm <- Lens.use tcCache scrutTy <- termType tcm scrut- scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy- (scrutExpr,scrutDecls) <- mkExpr False scrutTy scrut- let tmpRhs = pack ("tmp_tte_rhs_" ++ show i)- tmpS = pack ("tmp_tte_" ++ show i)- netDeclRhs = NetDecl tmpRhs scrutHTy- netDeclS = NetDecl tmpS hwTy- netAssignRhs = Assignment tmpRhs scrutExpr- netAssignS = Assignment tmpS (DataTag hwTy (Left tmpRhs))- return (Identifier tmpS Nothing,[netDeclRhs,netDeclS,netAssignRhs,netAssignS] ++ scrutDecls)+ (scrutExpr,scrutDecls) <- mkExpr False (Left "tte_rhs") scrutTy scrut+ case scrutExpr of+ Identifier id_ Nothing -> return (DataTag hwTy (Left id_),scrutDecls)+ _ -> do+ scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy+ tmpRhs <- mkUniqueIdentifier (pack "tte_rhs")+ let netDeclRhs = NetDecl tmpRhs scrutHTy+ netAssignRhs = Assignment tmpRhs scrutExpr+ return (DataTag hwTy (Left tmpRhs),[netDeclRhs,netAssignRhs] ++ scrutDecls) _ -> error $ $(curLoc) ++ "tagToEnum: " ++ show (map (either showDoc showDoc) args) | pNm == "GHC.Prim.dataToTag#" -> case args of [Right _,Left (Data dc)] -> do iw <- Lens.use intWidth return (N.Literal (Just (Signed iw,iw)) (NumLit $ toInteger $ dcTag dc - 1),[]) [Right _,Left scrut] -> do- i <- varCount <<%= (+1)- j <- varCount <<%= (+1) tcm <- Lens.use tcCache scrutTy <- termType tcm scrut scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy- (scrutExpr,scrutDecls) <- mkExpr False scrutTy scrut- iw <- Lens.use intWidth- let tmpRhs = pack ("tmp_dtt_rhs_" ++ show i)- tmpS = pack ("tmp_dtt_" ++ show j)- netDeclRhs = NetDecl tmpRhs scrutHTy- netDeclS = NetDecl tmpS (Signed iw)- netAssignRhs = Assignment tmpRhs scrutExpr- netAssignS = Assignment tmpS (DataTag scrutHTy (Right tmpRhs))- return (Identifier tmpS Nothing,[netDeclRhs,netDeclS,netAssignRhs,netAssignS] ++ scrutDecls)+ (scrutExpr,scrutDecls) <- mkExpr False (Left "dtt_rhs") scrutTy scrut+ case scrutExpr of+ Identifier id_ Nothing -> return (DataTag scrutHTy (Right id_),scrutDecls)+ _ -> do+ tmpRhs <- mkUniqueIdentifier "dtt_rhs"+ let netDeclRhs = NetDecl tmpRhs scrutHTy+ netAssignRhs = Assignment tmpRhs scrutExpr+ return (DataTag scrutHTy (Right tmpRhs),[netDeclRhs,netAssignRhs] ++ scrutDecls) _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showDoc showDoc) args) | otherwise -> return (BlackBoxE "" [C $ mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]] emptyBBContext False,[]) _ -> error $ $(curLoc) ++ "No blackbox found for: " ++ unpack nm+ where+ resBndr :: Bool -> (Either Identifier Id) -> NetlistMonad (Id,Identifier,[Declaration])+ resBndr mkDec dst' = case dst' of+ Left dstL -> case mkDec of+ False -> do+ let nm' = Text.unpack dstL+ id_ = Id (string2Name nm') (embed ty)+ return (id_,dstL,[])+ True -> do+ let nm' = append dstL "_app_arg"+ nm'' <- mkUniqueIdentifier nm'+ hwTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) ty+ let id_ = Id (string2Name (Text.unpack nm'')) (embed ty)+ idDecl = NetDecl nm'' hwTy+ return (id_,nm'',[idDecl])+ Right dstR -> return (dstR,Text.pack . name2String . varName $ dstR,[]) -- | Create an template instantiation text and a partial blackbox content for an -- argument term, given that the term is a function. Errors if the term is not@@ -249,9 +264,9 @@ case HashMap.lookup fun normalized of Just _ -> do (Component compName hidden compInps [compOutp] _) <- preserveVarEnv $ genComponent fun Nothing- let hiddenAssigns = map (\(i,_) -> (i,Identifier i Nothing)) hidden- inpAssigns = zip (map fst compInps) [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..] ]- outpAssign = (fst compOutp,Identifier (pack "~RESULT") Nothing)+ let hiddenAssigns = map (\(i,t) -> (i,In,t,Identifier i Nothing)) hidden+ inpAssigns = zipWith (\(i,t) e' -> (i,In,t,e')) compInps [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..] ]+ outpAssign = (fst compOutp,Out,snd compOutp,Identifier (pack "~RESULT") Nothing) i <- varCount <<%= (+1) let instLabel = Text.concat [compName,pack ("_" ++ show i)] instDecl = InstDecl compName instLabel (outpAssign:hiddenAssigns ++ inpAssigns)@@ -260,9 +275,10 @@ _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e case templ of Left (_, Left templ') -> do- l' <- instantiateSym templ'+ l <- instantiateCompName templ'+ l' <- setSym l l'' <- setClocks bbCtx l'- l3 <- instantiateCompName l''+ l3 <- collectFilePaths bbCtx l'' return ((Left l3,bbCtx),dcls) Left (_, Right templ') -> do templ'' <- prettyBlackBox templ'@@ -272,13 +288,15 @@ return ((Right decl,bbCtx),dcls) -- | Instantiate symbols references with a new symbol and increment symbol counter-instantiateSym :: BlackBoxTemplate- -> NetlistMonad BlackBoxTemplate-instantiateSym l = do- i <- Lens.use varCount- let (l',i') = setSym i l- varCount .= i'- return l'+--instantiateSym :: BlackBoxTemplate+-- -> NetlistMonad BlackBoxTemplate+--instantiateSym l = do+-- i <- Lens.use varCount+-- ids <- Lens.use seenIds+-- let (l',(ids',i')) = setSym ids i l+-- varCount .= i'+-- seenIds .= ids'+-- return l' instantiateCompName :: BlackBoxTemplate -> NetlistMonad BlackBoxTemplate
src/CLaSH/Netlist/BlackBox/Parser.hs view
@@ -11,6 +11,7 @@ where import Data.Text.Lazy (Text, pack)+import qualified Data.Text.Lazy as Text import Text.ParserCombinators.UU import Text.ParserCombinators.UU.BasicInstances hiding (Parser) import qualified Text.ParserCombinators.UU.Core as PCC (parse)@@ -71,7 +72,7 @@ <|> Clk Nothing <$ pToken "~CLKO" <|> (Rst . Just) <$> (pToken "~RST" *> pBrackets pNatural) <|> Rst Nothing <$ pToken "~RSTO"- <|> Sym <$> (pToken "~SYM" *> pBrackets pNatural)+ <|> (Sym Text.empty) <$> (pToken "~SYM" *> pBrackets pNatural) <|> Typ Nothing <$ pToken "~TYPO" <|> (Typ . Just) <$> (pToken "~TYP" *> pBrackets pNatural) <|> TypM Nothing <$ pToken "~TYPMO"@@ -89,11 +90,17 @@ <|> SigD <$> (pToken "~SIGD" *> pBrackets pSigD) <*> (Just <$> (pBrackets pNatural)) <|> (`SigD` Nothing) <$> (pToken "~SIGDO" *> pBrackets pSigD) <|> IW64 <$ pToken "~IW64"- <|> (BV True) <$> (pToken "~TOBV" *> pBrackets pSigD) <*> (Just <$> pBrackets pNatural)- <|> (BV True) <$> (pToken "~TOBVO" *> pBrackets pSigD) <*> pure Nothing- <|> (BV False) <$> (pToken "~FROMBV" *> pBrackets pSigD) <*> (Just <$> pBrackets pNatural)- <|> (BV False) <$> (pToken "~FROMBVO" *> pBrackets pSigD) <*> pure Nothing+ <|> (HdlSyn Vivado) <$ pToken "~VIVADO"+ <|> (HdlSyn Other) <$ pToken "~OTHERSYN"+ <|> (BV True) <$> (pToken "~TOBV" *> pBrackets pSigD) <*> pBrackets pTagE+ <|> (BV False) <$> (pToken "~FROMBV" *> pBrackets pSigD) <*> pBrackets pTagE+ <|> IsLit <$> (pToken "~ISLIT" *> pBrackets pNatural)+ <|> IsVar <$> (pToken "~ISVAR" *> pBrackets pNatural)+ <|> GenSym <$> (pToken "~GENSYM" *> pBrackets pSigD) <*> pBrackets pNatural+ <|> And <$> (pToken "~AND" *> listParser pTagE)+ <|> Vars <$> (pToken "~VARS" *> pBrackets pNatural) + -- | Parse a bracketed text pBrackets :: Parser a -> Parser a pBrackets p = pSym '[' *> p <* pSym ']'@@ -113,10 +120,7 @@ -- | Parse SigD pSigD :: Parser [Element]-pSigD = pSome (pTagE <|> pLimitedText- <|> (C <$> (pack <$> pToken "[ "))- <|> (C <$> (pack <$> pToken " ]")))---- | Text excluding square brackets and tilde-pLimitedText :: Parser Element-pLimitedText = C <$> (pack <$> pList1 (pSatisfy (`notElem` "[]~") (Insertion (show "notElem \"[]~\"") '_' 5)))+pSigD = pSome (pTagE <|> (C (pack "[") <$ (pack <$> pToken "[\\"))+ <|> (C (pack "]") <$ (pack <$> pToken "\\]"))+ <|> (C <$> (pack <$> pList1 (pRange ('\000','\90'))))+ <|> (C <$> (pack <$> pList1 (pRange ('\94','\125')))))
src/CLaSH/Netlist/BlackBox/Types.hs view
@@ -19,7 +19,7 @@ | O -- ^ Output hole | I !Int -- ^ Input hole | L !Int -- ^ Literal hole- | Sym !Int -- ^ Symbol hole+ | Sym !Text !Int -- ^ Symbol hole | Clk !(Maybe Int) -- ^ Clock hole (Maybe clk corresponding to -- input, clk corresponding to output if Nothing) | Rst !(Maybe Int) -- ^ Reset hole@@ -37,9 +37,16 @@ | Gen !Bool -- ^ Hole marking beginning (True) or end (False) -- of a generative construct | IF !Element [Element] [Element]+ | And [Element] | IW64 -- ^ Hole indicating whether Int/Word/Integer -- are 64-Bit- | BV Bool [Element] (Maybe Int) -- ^ Convert to (True)/from(False) a bit-vector+ | HdlSyn HdlSyn -- ^ Hole indicating which synthesis tool we're+ -- generating HDL for+ | BV !Bool [Element] !Element -- ^ Convert to (True)/from(False) a bit-vector+ | IsLit !Int+ | IsVar !Int+ | Vars !Int+ | GenSym [Element] !Int | SigD [Element] !(Maybe Int) deriving Show @@ -52,3 +59,6 @@ -- is the type of the signal data Decl = Decl !Int [(BlackBoxTemplate,BlackBoxTemplate)] deriving Show++data HdlSyn = Vivado | Other+ deriving (Eq,Show,Read)
src/CLaSH/Netlist/BlackBox/Util.hs view
@@ -15,9 +15,10 @@ module CLaSH.Netlist.BlackBox.Util where -import Control.Lens (at, use, (%=), (+=), _1,- _2)-import Control.Monad.State (State, runState)+--import Control.Lens (at, use, (%=), (+=), _1,+-- _2)+import Control.Monad.State (State, StateT, evalStateT,+ lift, modify, get) import Control.Monad.Writer.Strict (MonadWriter, tell) import Data.Foldable (foldrM) import qualified Data.IntMap as IntMap@@ -40,8 +41,8 @@ import CLaSH.Netlist.Types (HWType (..), Identifier, BlackBoxContext (..), SyncExpr, Expr (..),- Literal (..))-import CLaSH.Netlist.Util (typeSize)+ Literal (..), NetlistMonad)+import CLaSH.Netlist.Util (mkUniqueIdentifier,typeSize) import CLaSH.Util -- | Determine if the number of normal/literal/function inputs of a blackbox@@ -75,32 +76,52 @@ -- | Update all the symbol references in a template, and increment the symbol -- counter for every newly encountered symbol.-setSym :: Int -> BlackBoxTemplate -> (BlackBoxTemplate,Int)-setSym i l- = second fst- $ runState (setSym' l) (i,IntMap.empty)+setSym :: BlackBoxTemplate+ -> NetlistMonad BlackBoxTemplate+--setSym l = second fst+-- $ runState (setSym' l) ((ids,i),IntMap.empty)+setSym l = evalStateT (mapM setSym' l) IntMap.empty where- setSym' :: BlackBoxTemplate -> State (Int,IntMap.IntMap Int) BlackBoxTemplate- setSym' = mapM (\e -> case e of- Sym i' -> do symM <- use (_2 . at i')- case symM of- Nothing -> do k <- use _1- _1 += 1- _2 %= IntMap.insert i' k- return (Sym k)- Just k -> return (Sym k)- D (Decl n l') -> D <$> (Decl n <$> mapM (combineM setSym' setSym') l')- IF c t f -> IF <$> pure c <*> setSym' t <*> setSym' f- SigD e' m -> SigD <$> (setSym' e') <*> pure m- BV t e' m -> BV <$> pure t <*> setSym' e' <*> pure m- _ -> pure e- )+ setSym' :: Element+ -> StateT (IntMap.IntMap Identifier)+ NetlistMonad+ Element+ setSym' e = case e of+ Sym _ i -> do+ symM <- IntMap.lookup i <$> get+ case symM of+ Nothing -> do+ t <- lift (mkUniqueIdentifier (Text.pack "n"))+ modify (IntMap.insert i t)+ return (Sym t i)+ Just t -> return (Sym t i)+ GenSym t i -> do+ symM <- IntMap.lookup i <$> get+ case symM of+ Nothing -> do+ t' <- lift (mkUniqueIdentifier (concatT t))+ modify (IntMap.insert i t')+ return (GenSym [C t'] i)+ Just _ -> error ("Symbol #" ++ show (t,i) ++ " is already defined")+ D (Decl n l') -> D <$> (Decl n <$> mapM (combineM (mapM setSym') (mapM setSym')) l')+ IF c t f -> IF <$> pure c <*> mapM setSym' t <*> mapM setSym' f+ SigD e' m -> SigD <$> (mapM setSym' e') <*> pure m+ BV t e' m -> BV <$> pure t <*> mapM setSym' e' <*> pure m+ _ -> pure e + concatT :: [Element] -> Text+ concatT = Text.concat+ . map (\case {C t -> t; _ -> error "unexpected element in GENSYM"})+ setCompName :: Identifier -> BlackBoxTemplate -> BlackBoxTemplate setCompName nm = map setCompName' where- setCompName' CompName = C nm- setCompName' e = e+ setCompName' CompName = C nm+ setCompName' (D (Decl n l)) = D (Decl n (map (setCompName nm *** setCompName nm) l))+ setCompName' (IF c t f) = IF c (setCompName nm t) (setCompName nm f)+ setCompName' (GenSym es i) = GenSym (setCompName nm es) i+ setCompName' (BV t e m) = BV t (setCompName nm e) (setCompName' m)+ setCompName' e = e setClocks :: ( MonadWriter (Set (Identifier,HWType)) m , Applicative m@@ -203,17 +224,36 @@ renderElem b (IF c t f) = do iw <- iwWidth- let c' = case c of- (Size e) -> typeSize (lineToType b [e])- (Length e) -> case lineToType b [e] of- (Vector n _) -> n- _ -> error $ $(curLoc) ++ "IF: veclen of a non-vector type"- (L n) -> case bbInputs b !! n of- (either id fst -> Literal _ (NumLit i),_,_) -> fromInteger i- _ -> error $ $(curLoc) ++ "IF: LIT must be a numeric lit"- IW64 -> if iw == 64 then 1 else 0- _ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGTH, IW64, or LIT"+ syn <- hdlSyn+ let c' = check iw syn c if c' > 0 then renderBlackBox t b else renderBlackBox f b+ where+ check iw syn c' = case c' of+ (Size e) -> typeSize (lineToType b [e])+ (Length e) -> case lineToType b [e] of+ (Vector n _) -> n+ _ -> error $ $(curLoc) ++ "IF: veclen of a non-vector type"+ (L n) -> case bbInputs b !! n of+ (either id fst -> Literal _ (NumLit i),_,_) -> fromInteger i+ _ -> error $ $(curLoc) ++ "IF: LIT must be a numeric lit"+ IW64 -> if iw == 64 then 1 else 0+ (HdlSyn s) -> if s == syn then 1 else 0+ (IsVar n) -> let (s,_,_) = bbInputs b !! n+ e = either id fst s+ in case e of+ Identifier _ Nothing -> 1+ _ -> 0+ (IsLit n) -> let (s,_,_) = bbInputs b !! n+ e = either id fst s+ in case e of+ DataCon {} -> 1+ Literal {} -> 1+ BlackBoxE {} -> 1+ _ -> 0+ (And es) -> if all (==1) (map (check iw syn) es)+ then 1+ else 0+ _ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGTH, IW64, LIT, ISLIT, or ISARG" renderElem b e = renderTag b e @@ -272,24 +312,16 @@ mkLit (Literal (Just (Signed _,_)) i) = Literal Nothing i mkLit i = i -renderTag _ (Sym n) = return $ Text.pack ("n_" ++ show n)+renderTag _ (Sym t _) = return t -renderTag b (BV True es (Just n)) = do- e' <- Text.concat <$> mapM (renderElem b) es- let (_,hty,_) = bbInputs b !! n- (displayT . renderOneLine) <$> toBV hty e'-renderTag b (BV True es Nothing) = do- e' <- Text.concat <$> mapM (renderElem b) es- let (_,hty) = bbResult b- (displayT . renderOneLine) <$> toBV hty e'-renderTag b (BV False es (Just n)) = do+renderTag b (BV True es e) = do e' <- Text.concat <$> mapM (renderElem b) es- let (_,hty,_) = bbInputs b !! n- (displayT . renderOneLine) <$> fromBV hty e'-renderTag b (BV False es Nothing) = do+ let ty = lineToType b [e]+ (displayT . renderOneLine) <$> toBV ty e'+renderTag b (BV False es e) = do e' <- Text.concat <$> mapM (renderElem b) es- let (_,hty) = bbResult b- (displayT . renderOneLine) <$> fromBV hty e'+ let ty = lineToType b [e]+ (displayT . renderOneLine) <$> fromBV ty e' renderTag b (Typ Nothing) = fmap (displayT . renderOneLine) . hdlType . snd $ bbResult b renderTag b (Typ (Just n)) = let (_,ty,_) = bbInputs b !! n@@ -308,6 +340,26 @@ renderTag b e@(TypElem _) = let ty = lineToType b [e] in (displayT . renderOneLine) <$> hdlType ty renderTag _ (Gen b) = displayT . renderOneLine <$> genStmt b+renderTag _ (GenSym [C t] _) = return t+renderTag b (Vars n) =+ let (s,_,_) = bbInputs b !! n+ e = either id fst s++ go (Identifier i _) = [i]+ go (DataCon _ _ es) = concatMap go es+ go (DataTag _ e') = [either id id e']+ go _ = []++ vars = go e+ in case vars of+ [] -> return Text.empty+ _ -> return (Text.concat $ map (Text.cons ',') vars)+renderTag b (IndexType (L n)) =+ case bbInputs b !! n of+ (Left (Literal _ (NumLit n')),_,_) ->+ let hty = Index (fromInteger n')+ in fmap (displayT . renderOneLine) (hdlType hty)+ x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x renderTag _ (IF _ _ _) = error $ $(curLoc) ++ "Unexpected IF" renderTag _ (D _) = error $ $(curLoc) ++ "Unexpected component declaration" renderTag _ (SigD _ _) = error $ $(curLoc) ++ "Unexpected signal declaration"@@ -317,6 +369,11 @@ renderTag _ (IndexType _) = error $ $(curLoc) ++ "Unexpected index type" renderTag _ (FilePath _) = error $ $(curLoc) ++ "Unexpected file name" renderTag _ IW64 = error $ $(curLoc) ++ "Unexpected IW64"+renderTag _ (HdlSyn s) = error $ $(curLoc) ++ "Unexpected ~" ++ show s+renderTag _ (IsLit _) = error $ $(curLoc) ++ "Unexpected ~ISLIT"+renderTag _ (IsVar _) = error $ $(curLoc) ++ "Unexpected ~ISVAR"+renderTag _ (GenSym _ _) = error $ $(curLoc) ++ "Unexpected ~GENSYM"+renderTag _ (And _) = error $ $(curLoc) ++ "Unexpected ~AND" prettyBlackBox :: Monad m => BlackBoxTemplate@@ -337,7 +394,7 @@ prettyElem O = return "~RESULT" prettyElem (I i) = (displayT . renderOneLine) <$> (text "~ARG" <> brackets (int i)) prettyElem (L i) = (displayT . renderOneLine) <$> (text "~LIT" <> brackets (int i))-prettyElem (Sym i) = (displayT . renderOneLine) <$> (text "~SYM" <> brackets (int i))+prettyElem (Sym _ i) = (displayT . renderOneLine) <$> (text "~SYM" <> brackets (int i)) prettyElem (Clk Nothing) = return "~CLKO" prettyElem (Clk (Just i)) = (displayT . renderOneLine) <$> (text "~CLK" <> brackets (int i)) prettyElem (Rst Nothing) = return "~RSTO"@@ -375,23 +432,32 @@ text "~ELSE" PP.<$> text esF' PP.<$> text "~FI")+prettyElem (And es) =+ (displayT . renderCompact) <$>+ (PP.brackets (PP.tupled $ mapM (text <=< prettyElem) es)) prettyElem IW64 = return "~IW64"-prettyElem (BV b es mI) = do+prettyElem (HdlSyn s) = case s of+ Vivado -> return "~VIVADO"+ _ -> return "~OTHERSYN"+prettyElem (BV b es e) = do es' <- prettyBlackBox es+ e' <- prettyBlackBox [e] (displayT . renderOneLine) <$> if b- then maybe (text "~TOBVO" <> brackets (text es'))- (((text "~TOBV" <> brackets (text es')) <>) . int)- mI- else maybe (text "~FROMBVO" <> brackets (text es'))- (((text "~FROMBV" <> brackets (text es')) <>) . int)- mI+ then text "~TOBV" <> brackets (text es') <> brackets (text e')+ else text "~FROMBV" <> brackets (text es') <> brackets (text e')+prettyElem (IsLit i) = (displayT . renderOneLine) <$> (text "~ISLIT" <> brackets (int i))+prettyElem (IsVar i) = (displayT . renderOneLine) <$> (text "~ISVAR" <> brackets (int i))+prettyElem (GenSym es i) = do+ es' <- prettyBlackBox es+ (displayT . renderOneLine) <$> (text "~GENSYM" <> brackets (text es') <> brackets (int i)) prettyElem (SigD es mI) = do es' <- prettyBlackBox es (displayT . renderOneLine) <$> (maybe (text "~SIGDO" <> brackets (text es')) (((text "~SIGD" <> brackets (text es')) <>) . int) mI)+prettyElem (Vars i) = (displayT . renderOneLine) <$> (text "~VARS" <> brackets (int i)) usedArguments :: BlackBoxTemplate -> [Int]
src/CLaSH/Netlist/Id.hs view
@@ -11,8 +11,7 @@ {-# LANGUAGE ViewPatterns #-} module CLaSH.Netlist.Id- ( mkBasicId- , mkBasicId'+ ( mkBasicId' , stripDollarPrefixes ) where@@ -21,15 +20,9 @@ #error MIN_VERSION_text undefined #endif -import Data.Char (isAsciiLower,isAsciiUpper,isDigit,ord)+import Data.Char (isAsciiLower,isAsciiUpper,isDigit) import Data.Text.Lazy as Text-import Numeric (showHex) --- | Transform/format a text so that it is acceptable as a HDL identifier-mkBasicId :: Text- -> Text-mkBasicId = mkBasicId' False- mkBasicId' :: Bool -> Text -> Text@@ -91,42 +84,12 @@ Nothing -> append (encodeCh c) (go' $ uncons cs') encodeDigitCh :: Char -> EncodedString-encodeDigitCh c | isDigit c = encodeAsUnicodeChar c+encodeDigitCh c | isDigit c = Text.empty -- encodeAsUnicodeChar c encodeDigitCh c = encodeCh c encodeCh :: Char -> EncodedString encodeCh c | unencodedChar c = singleton c -- Common case first---- Constructors-encodeCh '[' = "ZM"-encodeCh ']' = "ZN"-encodeCh ':' = "ZC"---- Variables-encodeCh '&' = "za"-encodeCh '|' = "zb"-encodeCh '^' = "zc"-encodeCh '$' = "zd"-encodeCh '=' = "ze"-encodeCh '>' = "zf"-encodeCh '#' = "zg"-encodeCh '.' = "zh"-encodeCh '<' = "zu"-encodeCh '-' = "zj"-encodeCh '!' = "zk"-encodeCh '+' = "zl"-encodeCh '\'' = "zm"-encodeCh '\\' = "zn"-encodeCh '/' = "zo"-encodeCh '*' = "zp"-encodeCh '%' = "zq"-encodeCh c = encodeAsUnicodeChar c--encodeAsUnicodeChar :: Char -> EncodedString-encodeAsUnicodeChar c = cons 'z' (if isDigit (Text.head hex_str)- then hex_str- else cons '0' hex_str)- where hex_str = pack $ showHex (ord c) "U"+ | otherwise = Text.empty unencodedChar :: Char -> Bool -- True for chars that don't need encoding unencodedChar c = or [ isAsciiLower c@@ -135,15 +98,15 @@ , c == '_'] maybeTuple :: UserString -> Maybe (EncodedString,UserString)-maybeTuple "(# #)" = Just ("Z1H",empty)-maybeTuple "()" = Just ("Z0T",empty)+maybeTuple "(# #)" = Just ("Unit",empty)+maybeTuple "()" = Just ("Unit",empty) maybeTuple (uncons -> Just ('(',uncons -> Just ('#',cs))) = case countCommas 0 cs of- (n,uncons -> Just ('#',uncons -> Just (')',cs'))) -> Just (pack ('Z':shows (n+1) "H"),cs')+ (n,uncons -> Just ('#',uncons -> Just (')',cs'))) -> Just (pack ("Tup" ++ show (n+1)),cs') _ -> Nothing maybeTuple (uncons -> Just ('(',cs)) = case countCommas 0 cs of- (n,uncons -> Just (')',cs')) -> Just (pack ('Z':shows (n+1) "T"),cs')+ (n,uncons -> Just (')',cs')) -> Just (pack ("Tup" ++ show (n+1)),cs') _ -> Nothing maybeTuple _ = Nothing
src/CLaSH/Netlist/Types.hs view
@@ -49,15 +49,17 @@ { _bindings :: HashMap TmName (Type,Term) -- ^ Global binders , _varEnv :: Gamma -- ^ Type environment/context , _varCount :: !Int -- ^ Number of signal declarations- , _cmpCount :: !Int -- ^ Number of create components , _components :: HashMap TmName Component -- ^ Cached components , _primitives :: PrimMap BlackBoxTemplate -- ^ Primitive Definitions , _typeTranslator :: HashMap TyConName TyCon -> Type -> Maybe (Either String HWType) -- ^ Hardcoded Type -> HWType translator , _tcCache :: HashMap TyConName TyCon -- ^ TyCon cache- , _modNm :: !String -- ^ Name of the module containing the @topEntity@ , _curCompNm :: !Identifier , _dataFiles :: [(String,FilePath)] , _intWidth :: Int+ , _mkBasicIdFn :: Identifier -> Identifier+ , _seenIds :: [Identifier]+ , _seenComps :: [Identifier]+ , _componentNames :: HashMap TmName Identifier } -- | Signal reference@@ -122,9 +124,12 @@ -- * Type of the scrutinee -- -- * List of: (Maybe expression scrutinized expression is compared with,RHS of alternative)- | InstDecl !Identifier !Identifier [(Identifier,Expr)] -- ^ Instantiation of another component+ | InstDecl !Identifier !Identifier [(Identifier,PortDirection,HWType,Expr)] -- ^ Instantiation of another component | BlackBoxD !S.Text !BlackBoxTemplate BlackBoxContext -- ^ Instantiation of blackbox declaration | NetDecl !Identifier !HWType -- ^ Signal declaration+ deriving Show++data PortDirection = In | Out deriving Show instance NFData Declaration where
src/CLaSH/Netlist/Util.hs view
@@ -12,14 +12,15 @@ module CLaSH.Netlist.Util where import Control.Error (hush)-import Control.Lens ((.=),(<<%=))+import Control.Lens ((.=),(%=)) import qualified Control.Lens as Lens import qualified Control.Monad as Monad import Data.Either (partitionEithers) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Maybe (catMaybes,fromMaybe)-import Data.Text.Lazy (pack)+import Data.Text.Lazy (append,pack,unpack)+import qualified Data.Text.Lazy as Text import Unbound.Generics.LocallyNameless (Embed, Fresh, bind, embed, makeName, name2Integer, name2String, unbind, unembed, unrec)@@ -34,10 +35,17 @@ splitTyConAppM, tyView) import CLaSH.Core.Util (collectBndrs, termType) import CLaSH.Core.Var (Id, Var (..), modifyVarName)-import CLaSH.Netlist.Id import CLaSH.Netlist.Types as HW import CLaSH.Util +mkBasicId :: Identifier -> NetlistMonad Identifier+mkBasicId n = do+ f <- Lens.use mkBasicIdFn+ let n' = f n+ if Text.null n'+ then return (pack "x")+ else return n'+ -- | Split a normalized term into: a list of arguments, a list of let-bindings, -- and a variable reference that is the body of the let-binding. Returns a -- String containing the error is the term was not in a normalized form.@@ -218,42 +226,39 @@ ty <- termType m e coreTypeToHWTypeM ty --- | Turns a Core variable reference to a Netlist expression. Errors if the term--- is not a variable.-varToExpr :: Term- -> Expr-varToExpr (Var _ var) = Identifier (mkBasicId . pack $ name2String var) Nothing-varToExpr _ = error $ $(curLoc) ++ "not a var"- -- | Uniquely rename all the variables and their references in a normalized -- term mkUniqueNormalized :: ([Id],[LetBinding],Id) -> NetlistMonad ([Id],[LetBinding],TmName) mkUniqueNormalized (args,binds,res) = do- let args' = zipWith (\n s -> modifyVarName (`appendToName` s) n)- args ["_i" ++ show i | i <- [(1::Integer)..]]- let res1 = appendToName (varName res) "_o"+ -- Make arguments unique+ (args',subst) <- mkUnique [] args+ -- Make result unique+ ([res1],subst') <- mkUnique subst [res] let bndrs = map fst binds- let exprs = map (unembed . snd) binds- let usesOutput = concatMap (filter (== varName res) . Lens.toListOf termFreeIds) exprs- let (res2,extraBndr) = case usesOutput of- [] -> (res1,[] :: [(Id, Embed Term)])- _ -> let res3 = appendToName (varName res) "_o_sig"- in (res3,[(Id res1 (varType res),embed $ Var (unembed $ varType res) res3)])- bndrs' <- mapM (mkUnique (varName res,res2)) bndrs- let repl = zip args args' ++ zip bndrs bndrs'- exprs' <- fmap (map embed) $ Monad.foldM subsBndrs exprs repl- return (args',zip bndrs' exprs' ++ extraBndr,res1)-+ exprs = map (unembed . snd) binds+ usesOutput = concatMap (filter (== varName res) . Lens.toListOf termFreeIds) exprs+ -- If the let-binder carrying the result is used in a feedback loop+ -- rename the let-binder to "<X>_rec", and assign the "<X>_rec" to+ -- "<X>". We do this because output ports in most HDLs cannot be read.+ (res2,subst'',extraBndr) <- case usesOutput of+ [] -> return (varName res1,(res,res1):subst',[] :: [(Id, Embed Term)])+ _ -> do+ ([res3],_) <- mkUnique [] [modifyVarName (`appendToName` "_rec") res1]+ return (varName res3,(res,res3):subst'+ ,[(res1,embed $ Var (unembed $ varType res) (varName res3))])+ -- Replace occurences of "<X>" by "<X>_rec"+ let resN = varName res+ bndrs' = map (\i -> if varName i == resN then modifyVarName (const res2) i else i) bndrs+ (bndrsL,r:bndrsR) = break ((== res2).varName) bndrs'+ -- Make let-binders unique+ (bndrsL',substL) <- mkUnique subst'' bndrsL+ (bndrsR',substR) <- mkUnique substL bndrsR+ -- Replace old IDs by update unique IDs in the RHSs of the let-binders+ exprs' <- fmap (map embed) $ Monad.foldM subsBndrs exprs substR+ -- Return the uniquely named arguments, let-binders, and result+ return (args',zip (bndrsL' ++ r:bndrsR') exprs' ++ extraBndr,varName res1) where- mkUnique :: (TmName,TmName) -> Id -> NetlistMonad Id- mkUnique (find,repl) v = if find == varName v- then return $ modifyVarName (const repl) v- else do- varCnt <- varCount <<%= (+1)- let v' = modifyVarName (`appendToName` ('_' : show varCnt)) v- return v'- subsBndrs :: [Term] -> (Id,Id) -> NetlistMonad [Term] subsBndrs es (f,r) = mapM (subsBndr f r) es @@ -271,6 +276,46 @@ ) alts _ -> return e +-- | Make a set of IDs unique; also returns a substitution from old ID to new+-- updated unique ID.+mkUnique :: [(Id,Id)] -- ^ Existing substitution+ -> [Id] -- ^ IDs to make unique+ -> NetlistMonad ([Id],[(Id,Id)])+ -- ^ (Unique IDs, update substitution)+mkUnique = go []+ where+ go :: [Id] -> [(Id,Id)] -> [Id] -> NetlistMonad ([Id],[(Id,Id)])+ go processed subst [] = return (reverse processed,subst)+ go processed subst (i:is) = do+ iN <- mkUniqueIdentifier . pack . name2String $ varName i+ let iN_unpacked = unpack iN+ i' = modifyVarName (repName iN_unpacked) i+ go (i':processed) ((i,i'):subst) is++ repName s n = makeName s (name2Integer n)++mkUniqueIdentifier :: Identifier+ -> NetlistMonad Identifier+mkUniqueIdentifier nm = do+ seen <- Lens.use seenIds+ seenC <- Lens.use seenComps+ i <- mkBasicId nm+ let s = seenC ++ seen+ if i `elem` s+ then go 0 s i+ else do+ seenIds %= (i:)+ return i+ where+ go :: Integer -> [Identifier] -> Identifier -> NetlistMonad Identifier+ go n s i = do+ i' <- mkBasicId (i `append` pack ('_':show n))+ if i' `elem` s+ then go (n+1) s i+ else do+ seenIds %= (i':)+ return i'+ -- | Append a string to a name appendToName :: TmName -> String@@ -285,12 +330,14 @@ vCnt <- Lens.use varCount vEnv <- Lens.use varEnv vComp <- Lens.use curCompNm+ vSeen <- Lens.use seenIds -- perform action val <- action -- restore state varCount .= vCnt varEnv .= vEnv curCompNm .= vComp+ seenIds .= vSeen return val dcToLiteral :: HWType -> Int -> Literal
src/CLaSH/Normalize/Strategy.hs view
@@ -16,7 +16,7 @@ -- | Normalisation transformation normalization :: NormRewrite-normalization = etaTL >-> constantPropgation >-> rmUnusedExpr >-!-> anf >-!-> rmDeadcode >->+normalization = constantPropgation >-> etaTL >-> rmUnusedExpr >-!-> anf >-!-> rmDeadcode >-> bindConst >-> letTL >-> evalConst >-!-> cse >-!-> recLetRec where etaTL = apply "etaTL" etaExpansionTL
src/CLaSH/Normalize/Transformations.hs view
@@ -313,7 +313,7 @@ if untranslatable then return e else do tcm <- Lens.view tcCache- (argId,argVar) <- mkTmBinderFor tcm "topLet" e+ (argId,argVar) <- mkTmBinderFor tcm "result" e changed . Letrec $ bind (rec [(argId,embed e)]) argVar topLet ctx e@(Letrec b)@@ -325,7 +325,7 @@ if localVar || untranslatable then return e else do tcm <- Lens.view tcCache- (argId,argVar) <- mkTmBinderFor tcm "topLet" body+ (argId,argVar) <- mkTmBinderFor tcm "result" body changed . Letrec $ bind (rec $ unrec binds ++ [(argId,embed body)]) argVar topLet _ e = return e@@ -498,7 +498,7 @@ (v,e) <- unbind b changed . Letrec $ bind v (App e arg) -appProp _ (App (Case scrut ty alts) arg) = do+appProp ctx (App (Case scrut ty alts) arg) = do tcm <- Lens.view tcCache argTy <- termType tcm arg let ty' = applyFunTy tcm ty argTy@@ -511,7 +511,7 @@ ) alts changed $ Case scrut ty' alts' else do- (boundArg,argVar) <- mkTmBinderFor tcm "caseApp" arg+ (boundArg,argVar) <- mkTmBinderFor tcm (mkDerivedName ctx "app_arg") arg alts' <- mapM ( return . uncurry bind . second (`App` argVar)@@ -663,7 +663,7 @@ _ -> changed . Letrec $ bind (rec bndrs) e' collectANF :: NormRewriteW-collectANF _ e@(App appf arg)+collectANF ctx e@(App appf arg) | (conVarPrim, _) <- collectArgs e , isCon conVarPrim || isPrim conVarPrim || isVar conVarPrim = do@@ -671,7 +671,7 @@ localVar <- lift (isLocalVar arg) case (untranslatable,localVar || isConstant arg,arg) of (False,False,_) -> do tcm <- Lens.view tcCache- (argId,argVar) <- lift (mkTmBinderFor tcm "repANF" arg)+ (argId,argVar) <- lift (mkTmBinderFor tcm (mkDerivedName ctx "app_arg") arg) tell [(argId,embed arg)] return (App appf argVar) (True,False,Letrec b) -> do (binds,body) <- unbind b@@ -689,7 +689,7 @@ then return body else do tcm <- Lens.view tcCache- (argId,argVar) <- lift (mkTmBinderFor tcm "bodyVar" body)+ (argId,argVar) <- lift (mkTmBinderFor tcm "result" body) tell [(argId,embed body)] return argVar @@ -712,12 +712,12 @@ collectANF _ e@(Case _ _ [unsafeUnbind -> (DataPat dc _,_)]) | name2String (dcName $ unembed dc) == "CLaSH.Signal.Internal.:-" = return e -collectANF _ (Case subj ty alts) = do+collectANF ctx (Case subj ty alts) = do localVar <- lift (isLocalVar subj) (bndr,subj') <- if localVar || isConstant subj then return ([],subj) else do tcm <- Lens.view tcCache- (argId,argVar) <- lift (mkTmBinderFor tcm "subjLet" subj)+ (argId,argVar) <- lift (mkTmBinderFor tcm (mkDerivedName ctx "case_scrut") subj) return ([(argId,embed subj)],argVar) (binds,alts') <- fmap (first concat . unzip) $ mapM (lift . doAlt subj') alts@@ -738,7 +738,7 @@ if (lv && not (usesXs altExpr)) || isConstant altExpr then return (patSels,alt) else do tcm <- Lens.view tcCache- (altId,altVar) <- mkTmBinderFor tcm "altLet" altExpr+ (altId,altVar) <- mkTmBinderFor tcm (mkDerivedName ctx "case_alt") altExpr return ((altId,embed altExpr):patSels,(DataPat dc pxs,altVar)) doAlt' _ alt@(DataPat _ _, _) = return ([],alt) doAlt' _ alt@(pat,altExpr) = do@@ -746,7 +746,7 @@ if lv || isConstant altExpr then return ([],alt) else do tcm <- Lens.view tcCache- (altId,altVar) <- mkTmBinderFor tcm "altLet" altExpr+ (altId,altVar) <- mkTmBinderFor tcm (mkDerivedName ctx "case_alt") altExpr return ([(altId,embed altExpr)],(pat,altVar)) doPatBndr :: Term -> DataCon -> Id -> Int -> RewriteMonad NormalizeState LetBinding@@ -776,7 +776,7 @@ . splitFunTy tcm <=< termType tcm ) e- (newIdB,newIdV) <- mkInternalVar "eta" argTy+ (newIdB,newIdV) <- mkInternalVar "arg" argTy e' <- etaExpansionTL (LamBody newIdB:ctx) (App e newIdV) changed . Lam $ bind newIdB e' else return e
src/CLaSH/Rewrite/Combinators.hs view
@@ -62,7 +62,7 @@ where rewriteBind :: [Id] -> (Id,Embed Term) -> m (Id,Embed Term) rewriteBind bndrs (b', e) = do- e' <- trans (LetBinding bndrs:c) (unembed e)+ e' <- trans (LetBinding b' bndrs:c) (unembed e) return (b',embed e') allR rf trans c (Case scrut ty alts) = do
src/CLaSH/Rewrite/Types.hs view
@@ -38,7 +38,7 @@ = AppFun -- ^ Function position of an application | AppArg -- ^ Argument position of an application | TyAppC -- ^ Function position of a type application- | LetBinding [Id] -- ^ RHS of a Let-binder with the sibling LHS'+ | LetBinding Id [Id] -- ^ RHS of a Let-binder with the sibling LHS' | LetBody [Id] -- ^ Body of a Let-binding with the bound LHS' | LamBody Id -- ^ Body of a lambda-term with the abstracted variable | TyLamBody TyVar -- ^ Body of a TyLambda-term with the abstracted
src/CLaSH/Rewrite/Util.hs view
@@ -144,7 +144,7 @@ contextEnv = go HML.empty HML.empty where go gamma delta [] = (gamma,delta)- go gamma delta (LetBinding ids:ctx) = go gamma' delta ctx+ go gamma delta (LetBinding _ ids:ctx) = go gamma' delta ctx where gamma' = foldl addToGamma gamma ids @@ -172,6 +172,16 @@ addToDelta delta (TyVar tvName ki) = HML.insert tvName (unembed ki) delta addToDelta _ _ = error $ $(curLoc) ++ "Adding Id to Delta" +closestLetBinder :: [CoreContext] -> Maybe Id+closestLetBinder [] = Nothing+closestLetBinder (LetBinding id_ _:_) = Just id_+closestLetBinder (_:ctx) = closestLetBinder ctx++mkDerivedName :: [CoreContext] -> String -> String+mkDerivedName ctx sf = case closestLetBinder ctx of+ Just id_ -> ((++ ('_':sf)) . name2String . varName) id_+ _ -> sf+ -- | Create a complete type and kind context out of the global binders and the -- transformation context mkEnv :: [CoreContext]@@ -329,7 +339,7 @@ case replace of [] -> return expr _ -> do- (gamma,delta) <- mkEnv (LetBinding (map fst $ unrec xes) : ctx)+ (gamma,delta) <- mkEnv (LetBinding undefined (map fst $ unrec xes) : ctx) replace' <- mapM (liftBinding gamma delta) replace let (others',res') = substituteBinders replace' others res newExpr = case others' of