diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.5.2 *May 1st 2015* +* New features: + * Generate wrappers around `topEntity` that have constant names and types + ## 0.5.1 *April 20th 2015* * GHC 7.10 support diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -1,5 +1,5 @@ Name: clash-lib -Version: 0.5.1 +Version: 0.5.2 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -94,6 +94,7 @@ CLaSH.Driver CLaSH.Driver.TestbenchGen + CLaSH.Driver.TopWrapper CLaSH.Driver.Types CLaSH.Netlist @@ -120,5 +121,6 @@ CLaSH.Util - Other-Modules: Paths_clash_lib + Other-Modules: Data.Aeson.Extra + Paths_clash_lib Unbound.Generics.LocallyNameless.Extra diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -25,6 +25,7 @@ import CLaSH.Core.Type (Type) import CLaSH.Core.TyCon (TyCon, TyConName) import CLaSH.Driver.TestbenchGen +import CLaSH.Driver.TopWrapper import CLaSH.Driver.Types import CLaSH.Netlist (genNetlist) import CLaSH.Netlist.Types (Component (..), HWType) @@ -42,9 +43,10 @@ -> HashMap TyConName TyCon -- ^ TyCon cache -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator -> (HashMap TyConName TyCon -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction) + -> Maybe TopEntity -> DebugLevel -- ^ Debug information level for the normalization process -> IO () -generateHDL bindingsMap hdlState primMap tcm typeTrans eval dbgLevel = do +generateHDL bindingsMap hdlState primMap tcm typeTrans eval teM dbgLevel = do start <- Clock.getCurrentTime prepTime <- start `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime let prepStartDiff = Clock.diffUTCTime prepTime start @@ -105,7 +107,8 @@ putStrLn $ "Testbench generation took " ++ show netTBDiff let hdlState' = fromMaybe (initBackend :: backend) hdlState - hdlDocs = createHDL hdlState' (netlist ++ testBench) + topWrapper = mkTopWrapper primMap teM topComponent + hdlDocs = createHDL hdlState' (topWrapper : netlist ++ testBench) dir = concat [ "./" ++ CLaSH.Backend.name hdlState' ++ "/" , takeWhile (/= '.') (name2String $ fst topEntity) , "/" @@ -122,8 +125,8 @@ -- | Pretty print Components to HDL Documents createHDL :: Backend backend - => backend - -> [Component] + => backend -- ^ Backend + -> [Component] -- ^ List of components -> [(String,Doc)] createHDL backend components = flip evalState backend $ do (hdlNms,hdlDocs) <- unzip <$> mapM genHDL components diff --git a/src/CLaSH/Driver/TestbenchGen.hs b/src/CLaSH/Driver/TestbenchGen.hs --- a/src/CLaSH/Driver/TestbenchGen.hs +++ b/src/CLaSH/Driver/TestbenchGen.hs @@ -45,7 +45,7 @@ -> Component -- ^ Component to generate TB for -> IO ([Component]) genTestBench dbgLvl supply primMap typeTrans tcm eval cmpCnt globals stimuliNmM expectedNmM - (Component cName hidden [inp] outp _) = do + (Component cName hidden [inp] [outp] _) = do let ioDecl = [ uncurry NetDecl inp , uncurry NetDecl outp ] @@ -61,8 +61,8 @@ (expInst,expComps,hidden'') <- maybe (return (finExpr,[],hidden')) (genVerifier cmpCnt' primMap globals typeTrans tcm normalizeSignal hidden' outp) expectedNmM - let clkNms = mapMaybe (\hd -> case hd of (clkNm,Clock _) -> Just clkNm ; _ -> Nothing) hidden - rstNms = mapMaybe (\hd -> case hd of (clkNm,Reset _) -> Just clkNm ; _ -> Nothing) hidden + let clkNms = mapMaybe (\hd -> case hd of (clkNm,Clock _ _) -> Just clkNm ; _ -> Nothing) hidden + rstNms = mapMaybe (\hd -> case hd of (clkNm,Reset _ _) -> Just clkNm ; _ -> Nothing) hidden clks = mapMaybe (genClock primMap) hidden'' rsts = mapMaybe (genReset primMap) hidden'' @@ -71,7 +71,7 @@ (concat [ clkNms, rstNms, [fst inp], [fst outp] ]) ) - tbComp = Component "testbench" [] [] ("done",Bool) + tbComp = Component "testbench" [] [] [("done",Bool)] (concat [ finDecl , concat clks , concat rsts @@ -92,13 +92,13 @@ genClock :: PrimMap -> (Identifier,HWType) -> Maybe [Declaration] -genClock primMap (clkName,Clock rate) = Just clkDecls +genClock primMap (clkName,Clock clkSym rate) = Just clkDecls where clkGenDecl = case HashMap.lookup "CLaSH.Driver.TestbenchGen.clockGen" primMap of Just (BlackBox _ (Left templ)) -> let (rising,rest) = divMod (toInteger rate) 2 falling = rising + rest ctx = emptyBBContext - { bbResult = (Left (Identifier clkName Nothing), Clock rate) + { bbResult = (Left (Identifier clkName Nothing), Clock clkSym rate) , bbInputs = [ (Left (N.Literal Nothing (NumLit 2)),Integer,True) , (Left (N.Literal Nothing (NumLit rising)),Integer,True) , (Left (N.Literal Nothing (NumLit falling)),Integer,True) @@ -107,7 +107,7 @@ in BlackBoxD "CLaSH.Driver.TestbenchGen.clockGen" (parseFail templ) ctx pM -> error $ $(curLoc) ++ ("Can't make clock declaration for: " ++ show pM) - clkDecls = [ NetDecl clkName (Clock rate) + clkDecls = [ NetDecl clkName (Clock clkSym rate) , clkGenDecl ] @@ -116,17 +116,17 @@ genReset :: PrimMap -> (Identifier,HWType) -> Maybe [Declaration] -genReset primMap (rstName,Reset clk) = Just rstDecls +genReset primMap (rstName,Reset clkSym rate) = Just rstDecls where resetGenDecl = case HashMap.lookup "CLaSH.Driver.TestbenchGen.resetGen" primMap of Just (BlackBox _ (Left templ)) -> let ctx = emptyBBContext - { bbResult = (Left (Identifier rstName Nothing), Reset clk) + { bbResult = (Left (Identifier rstName Nothing), Reset clkSym rate) , bbInputs = [(Left (N.Literal Nothing (NumLit 1)),Integer,True)] } in BlackBoxD "CLaSH.Driver.TestbenchGen.resetGen" (parseFail templ) ctx pM -> error $ $(curLoc) ++ ("Can't make reset declaration for: " ++ show pM) - rstDecls = [ NetDecl rstName (Reset clk) + rstDecls = [ NetDecl rstName (Reset clkSym rate) , resetGenDecl ] @@ -173,11 +173,11 @@ Nothing -> error $ $(curLoc) ++ "Can't locate component for stimuli gen: " ++ (show $ pack $ name2String signalNm) ++ show (map (componentName) comps) (cName,hidden',outp) = case sigComp of - (Component a b [] (c,_) _) -> (a,b,c) - (Component a _ is _ _) -> error $ $(curLoc) ++ "Stimuli gen " ++ show a ++ " has unexpected inputs: " ++ show is + (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 (clkNm,Clock _ _) -> Just clkNm ; _ -> Nothing) hidden' + rstNms = mapMaybe (\hd -> case hd of (clkNm,Reset _ _) -> Just clkNm ; _ -> Nothing) hidden' decl = InstDecl cName "stimuli" (map (\i -> (i,Identifier i Nothing)) (concat [ clkNms, rstNms ]) ++ @@ -205,11 +205,11 @@ 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 + (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 (clkNm,Clock _ _) -> Just clkNm ; _ -> Nothing) hidden' + rstNms = mapMaybe (\hd -> case hd of (clkNm,Reset _ _) -> Just clkNm ; _ -> Nothing) hidden' decl = InstDecl cName "verify" (map (\i -> (i,Identifier i Nothing)) (concat [ clkNms, rstNms ]) ++ diff --git a/src/CLaSH/Driver/TopWrapper.hs b/src/CLaSH/Driver/TopWrapper.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Driver/TopWrapper.hs @@ -0,0 +1,372 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +{-| +Copyright : (C) 2015, University of Twente +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} +module CLaSH.Driver.TopWrapper where + +import Data.Aeson (FromJSON (..), Value (..), (.:), (.:?), + (.!=)) +import Data.Aeson.Extra (decodeAndReport) +import qualified Data.ByteString.Lazy as B +import qualified Data.HashMap.Strict as H +import qualified Data.HashMap.Lazy as HashMap +import Data.List (mapAccumL) +import Data.Text.Lazy (Text, append, pack) +import System.Directory (doesFileExist) +import System.IO.Unsafe (unsafePerformIO) + +import CLaSH.Netlist (runNetlistMonad) +import CLaSH.Netlist.BlackBox (prepareBlackBox) +import CLaSH.Netlist.Types (BlackBoxContext (..), Component (..), + Declaration (..), Expr (..), Identifier, + HWType (..), Modifier (..), NetlistMonad, + emptyBBContext) +import CLaSH.Primitives.Types (PrimMap, Primitive (..)) +import CLaSH.Util + +-- | TopEntity specifications, fields are self-explanatory +data TopEntity + = TopEntity + { t_name :: Text + , t_inputs :: [Text] -- optional + , t_outputs :: [Text] -- optional + , t_extraIn :: [(Text,Int)] -- optional + , t_extraOut :: [(Text,Int)] -- optional + , t_clocks :: [ClockSource] -- optional + } + deriving Show + +-- | A clock source +data ClockSource + = ClockSource + { c_name :: Text -- ^ Component name + , c_paths :: [ClockPath] -- ^ Number of clock paths + , c_reset :: Maybe (Text,Text) -- ^ optional: Asynchronous reset input + , c_lock :: Text -- ^ Port name that indicates clock is stable + , c_sync :: Bool -- ^ optional: devices connected this clock + -- source should be pulled out of reset in-sync + } + deriving Show + +-- | A clock path +data ClockPath + = ClockPath + { cp_inp :: Maybe (Text,Text) -- optional: (Input port, clock pin) + , cp_outp :: [(Text,Clock)] -- [(output port,clock signal)] + } + deriving Show + +-- | A clock +data Clock + = Clk { clk_name :: Text, clk_rate :: Int } + deriving (Eq,Show) + +instance FromJSON TopEntity where + parseJSON (Object v) = case H.toList v of + [(conKey,Object conVal)] -> case conKey of + "TopEntity" -> TopEntity <$> conVal .: "name" + <*> (conVal .:? "inputs" .!= []) + <*> (conVal .:? "outputs" .!= []) + <*> (conVal .:? "extra_in" .!= []) + <*> (conVal .:? "extra_out" .!= []) + <*> (conVal .:? "clocks" .!= []) + _ -> error "Expected: TopEntity" + _ -> error "Expected: TopEntity object" + parseJSON _ = error "Expected: TopEntity object" + +instance FromJSON ClockSource where + parseJSON (Object v) = case H.toList v of + [(conKey,Object conVal)] -> case conKey of + "Source" -> ClockSource <$> conVal .: "name" <*> conVal .: "paths" + <*> conVal .:? "reset" <*> conVal .: "lock" + <*> (conVal .:? "sync" .!= False) + _ -> error "Expected: Source" + _ -> error "Expected: Source object" + parseJSON _ = error "Expected: Source object" + +instance FromJSON ClockPath where + parseJSON (Object v) = case H.toList v of + [(conKey,Object conVal)] -> case conKey of + "Path" -> ClockPath <$> conVal .:? "inp" <*> conVal .: "outp" + _ -> error "Expected: Path" + _ -> error "Expected: Path object" + parseJSON _ = error "Expected: Path object" + +instance FromJSON Clock where + parseJSON (Object v) = case H.toList v of + [(conKey,Object conVal)] -> case conKey of + "Clk" -> Clk <$> conVal .: "name" <*> conVal .: "rate" + _ -> error "Expected: Clk" + _ -> error "Expected: Clk object" + parseJSON (String "System") = pure (Clk "system" 1000) + parseJSON _ = error "Expected: System, or, Clk object" + +-- | Create a 'TopEntity' data type from the JSON encoded @.topentity@ file. +generateTopEnt :: String + -> IO (Maybe TopEntity) +generateTopEnt modName = do + let topEntityFile = modName ++ ".topentity" + exists <- doesFileExist topEntityFile + if exists + then return . decodeAndReport <=< B.readFile $ topEntityFile + else return Nothing + +-- | Create a wrapper around a component, potentially initiating clock sources +mkTopWrapper :: PrimMap + -> Maybe TopEntity -- ^ TopEntity specifications + -> Component -- ^ Entity to wrap + -> Component +mkTopWrapper primMap teM topComponent + = Component + { componentName = maybe "topEntity" t_name teM + , inputs = inputs'' ++ extraIn teM + , outputs = outputs'' ++ extraOut teM + , hiddenPorts = case maybe [] t_clocks teM of + [] -> originalHidden + _ -> [] + , declarations = concat [ mkClocks primMap originalHidden teM + , wrappers + , instDecl:unwrappers + ] + } + where + iNameSupply = maybe [] t_inputs teM + originalHidden = hiddenPorts topComponent + + inputs' = map (first (const "input")) + (inputs topComponent) + (inputs'',(wrappers,idsI)) = (concat *** (first concat . unzip)) + . unzip + . snd + $ mapAccumL (\nm (i,c) -> mkInput nm i c) + iNameSupply + (zip inputs' [0..]) + + oNameSupply = maybe [] t_outputs teM + outputs' = map (first (const "output")) + (outputs topComponent) + (outputs'',(unwrappers,idsO)) = (concat *** (first concat . unzip)) + . unzip + . snd + $ mapAccumL (\nm (o,c) -> mkOutput nm o c) + oNameSupply + (zip outputs' [0..]) + + instDecl = InstDecl (componentName topComponent) + (append (componentName topComponent) (pack "_inst")) + (zipWith (\(p,_) i -> (p,Identifier i Nothing)) + (inputs topComponent) + idsI + ++ + map (\(p,_) -> (p,Identifier p Nothing)) + (hiddenPorts topComponent) + ++ + zipWith (\(p,_) i -> (p,Identifier i Nothing)) + (outputs topComponent) + idsO) + +-- | Create extra input ports for the wrapper +extraIn :: Maybe TopEntity -> [(Identifier,HWType)] +extraIn = maybe [] ((map (second BitVector)) . t_extraIn) + +-- | Create extra output ports for the wrapper +extraOut :: Maybe TopEntity -> [(Identifier,HWType)] +extraOut = maybe [] ((map (second BitVector)) . t_extraOut) + +-- | Generate input port mappings +mkInput :: [Identifier] + -> (Identifier,HWType) + -> Int + -> ( [Identifier] + , ( [(Identifier,HWType)] + , ( [Declaration] + , Identifier + ) + ) + ) +mkInput nms (i,hwty) cnt = case hwty of + Vector sz hwty' -> + let (nms',(ports',(decls',ids))) + = second ( (concat *** (first concat . unzip)) + . unzip + ) + $ mapAccumL + (\nm c -> mkInput nm (iName,hwty') c) + nms [0..(sz-1)] + netdecl = NetDecl iName hwty + netassgn = Assignment iName (mkVectorChain sz hwty' ids) + in (nms',(ports',(netdecl:decls' ++ [netassgn],iName))) + Product _ hwtys -> + let (nms',(ports',(decls',ids))) + = second ( (concat *** (first concat . unzip)) + . unzip + ) + $ mapAccumL + (\nm (inp,c) -> mkInput nm inp c) + nms (zip (map (iName,) hwtys) [0..]) + netdecl = NetDecl iName hwty + ids' = map (`Identifier` Nothing) ids + netassgn = Assignment iName (DataCon hwty (DC (hwty,0)) ids') + in (nms',(ports',(netdecl:decls' ++ [netassgn],iName))) + _ -> case nms of + [] -> (nms,([(iName,hwty)],([],iName))) + (n:nms') -> (nms',([(n,hwty)],([],n))) + where + + iName = append i (pack ("_" ++ show cnt)) + +-- | Create a Vector chain for a list of 'Identifier's +mkVectorChain :: Int + -> HWType + -> [Identifier] + -> Expr +mkVectorChain _ elTy [] = DataCon (Vector 0 elTy) VecAppend [] +mkVectorChain _ elTy [i] = DataCon (Vector 1 elTy) VecAppend + [Identifier i Nothing] +mkVectorChain sz elTy (i:is) = DataCon (Vector sz elTy) VecAppend + [ Identifier i Nothing + , mkVectorChain (sz-1) elTy is + ] + +-- | Generate output port mappings +mkOutput :: [Identifier] + -> (Identifier,HWType) + -> Int + -> ( [Identifier] + , ( [(Identifier,HWType)] + , ( [Declaration] + , Identifier + ) + ) + ) +mkOutput nms (i,hwty) cnt = case hwty of + Vector sz hwty' -> + let (nms',(ports',(decls',ids))) + = second ( (concat *** (first concat . unzip)) + . unzip + ) + $ mapAccumL + (\nm c -> mkOutput nm (iName,hwty') c) + nms [0..(sz-1)] + netdecl = NetDecl iName hwty + assigns = zipWith + (\id_ n -> Assignment id_ + (Identifier iName (Just (Indexed (hwty,1,n))))) + ids + [0..] + in (nms',(ports',(netdecl:assigns ++ decls',iName))) + Product _ hwtys -> + let (nms',(ports',(decls',ids))) + = second ( (concat *** (first concat . unzip)) + . unzip + ) + $ mapAccumL + (\nm (inp,c) -> mkOutput nm inp c) + nms (zip (map (iName,) hwtys) [0..]) + netdecl = NetDecl iName hwty + assigns = zipWith + (\id_ n -> Assignment id_ + (Identifier iName (Just (Indexed (hwty,0,n))))) + ids + [0..] + in (nms',(ports',(netdecl:assigns ++ decls',iName))) + _ -> case nms of + [] -> (nms,([(iName,hwty)],([],iName))) + (n:nms') -> (nms',([(n,hwty)],([],n))) + where + iName = append i (pack ("_" ++ show cnt)) + +-- | Create clock generators +mkClocks :: PrimMap -> [(Identifier,HWType)] -> Maybe TopEntity -> [Declaration] +mkClocks primMap hidden teM = concat + [ hiddenSigDecs + , clockGens + , resets + ] + where + hiddenSigDecs = map (uncurry NetDecl) hidden + (clockGens,clkLocks) = maybe ([],[]) + (first concat . unzip . map mkClock . t_clocks) + teM + resets = mkResets primMap hidden clkLocks + +-- | Create a single clock generator +mkClock :: ClockSource -> ([Declaration],(Identifier,[Clock],Bool)) +mkClock (ClockSource {..}) = ([lockedDecl,instDecl],(lockedName,clks,c_sync)) + where + lockedName = append c_name "_locked" + lockedDecl = NetDecl lockedName (Reset lockedName 0) + (ports,clks) = (concat *** concat) . unzip $ map clockPorts c_paths + instDecl = InstDecl c_name (append c_name "_inst") + $ concat [ ports + , maybe [] ((:[]) . second (`Identifier` Nothing)) + c_reset + , [(c_lock,Identifier lockedName Nothing)] + ] + +-- | Create a single clock path +clockPorts :: ClockPath -> ([(Identifier,Expr)],[Clock]) +clockPorts (ClockPath {..}) = (inp ++ outp,clks) + where + inp = maybe [] ((:[]) . second (`Identifier` Nothing)) cp_inp + outp = map (second ((`Identifier` Nothing) . clkToId)) cp_outp + clks = map snd cp_outp + + clkToId (Clk nm r) = append nm (pack (show r)) + +-- | Generate resets +mkResets :: PrimMap + -> [(Identifier,HWType)] + -> [(Identifier,[Clock],Bool)] + -> [Declaration] +mkResets primMap hidden = unsafeRunNetlist . fmap concat . mapM assingReset + where + assingReset (lock,clks,doSync) = concat <$> mapM connectReset matched + where + matched = filter match hidden + match (_,(Reset nm r)) = elem (Clk nm r) clks + match _ = False + + connectReset (rst,(Reset nm r)) = if doSync + then return [Assignment rst (Identifier lock Nothing)] + else genSyncReset primMap lock rst (Clk nm r) + connectReset _ = return [] + +-- | Generate a reset synchroniser that synchronously de-asserts an +-- asynchronous reset signal +genSyncReset :: PrimMap + -> Identifier + -> Identifier + -> Clock + -> NetlistMonad [Declaration] +genSyncReset primMap lock rst (Clk nm r) = do + let resetType = Reset rst 0 + ctx = emptyBBContext + { bbResult = (Right ((Identifier rst Nothing),(nm,r)), resetType) + , bbInputs = [(Left (Identifier lock Nothing),resetType,False)] + } + bbName = "CLaSH.TopWrapper.syncReset" + resetGenDecl <- case HashMap.lookup bbName primMap of + Just (BlackBox _ (Left templ)) -> do + templ' <- prepareBlackBox bbName templ ctx + return (BlackBoxD bbName templ' ctx) + pM -> error $ $(curLoc) ++ ("Can't make reset sync for: " ++ show pM) + + return [resetGenDecl] + +-- | The 'NetListMonad' is an transformer stack with 'IO' at the bottom. +-- So we must use 'unsafePerformIO'. +unsafeRunNetlist :: NetlistMonad a + -> a +unsafeRunNetlist = unsafePerformIO + . fmap fst + . runNetlistMonad Nothing HashMap.empty HashMap.empty + HashMap.empty (\_ _ -> Nothing) diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -137,7 +137,7 @@ let compInps = zip (map (mkBasicId . Text.pack . name2String . varName) arguments) argTypes compOutp = (mkBasicId . Text.pack $ name2String result, resType) - component = Component componentName' (nub clks) compInps compOutp (netDecls ++ decls) + component = Component componentName' (nub clks) compInps [compOutp] (netDecls ++ decls) return component -- | Generate a list of Declarations for a let-binder @@ -234,7 +234,7 @@ normalized <- Lens.use bindings case HashMap.lookup fun normalized of Just _ -> do - (Component compName hidden compInps compOutp _) <- preserveVarEnv $ genComponent fun Nothing + (Component compName hidden compInps [compOutp] _) <- preserveVarEnv $ genComponent fun Nothing if length args == length compInps then do tcm <- Lens.use tcCache argTys <- mapM (termType tcm) args diff --git a/src/CLaSH/Netlist/BlackBox.hs b/src/CLaSH/Netlist/BlackBox.hs --- a/src/CLaSH/Netlist/BlackBox.hs +++ b/src/CLaSH/Netlist/BlackBox.hs @@ -228,7 +228,7 @@ normalized <- Lens.use bindings case HashMap.lookup fun normalized of Just _ -> do - (Component compName hidden compInps compOutp _) <- preserveVarEnv $ genComponent fun Nothing + (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) diff --git a/src/CLaSH/Netlist/BlackBox/Util.hs b/src/CLaSH/Netlist/BlackBox/Util.hs --- a/src/CLaSH/Netlist/BlackBox/Util.hs +++ b/src/CLaSH/Netlist/BlackBox/Util.hs @@ -88,17 +88,20 @@ setClocks' (SigD e m) = SigD <$> (head <$> setClocks bc [e]) <*> pure m setClocks' (Clk Nothing) = let (clk,rate) = clkSyncId $ fst $ bbResult bc - in tell [(clk,Clock rate)] >> return (C clk) + clkName = Text.append clk (Text.pack (show rate)) + in tell [(clkName,Clock clk rate)] >> return (C clkName) setClocks' (Clk (Just n)) = let (e,_,_) = bbInputs bc !! n (clk,rate) = clkSyncId e - in tell [(clk,Clock rate)] >> return (C clk) + clkName = Text.append clk (Text.pack (show rate)) + in tell [(clkName,Clock clk rate)] >> return (C clkName) - setClocks' (Rst Nothing) = let (rst,rate) = (first (`Text.append` "_rst")) . clkSyncId $ fst $ bbResult bc - in tell [(rst,Reset rate)] >> return (C rst) + setClocks' (Rst Nothing) = let (rst,rate) = clkSyncId $ fst $ bbResult bc + rstName = Text.concat [rst,Text.pack (show rate),"_rstn"] + in tell [(rstName,Reset rst rate)] >> return (C rstName) setClocks' (Rst (Just n)) = let (e,_,_) = bbInputs bc !! n (rst,rate) = clkSyncId e - rst' = Text.append rst "_rst" - in tell [(rst',Reset rate)] >> return (C rst') + rstName = Text.concat [rst,Text.pack (show rate),"_rstn"] + in tell [(rstName,Reset rst rate)] >> return (C rstName) setClocks' e = return e diff --git a/src/CLaSH/Netlist/Types.hs b/src/CLaSH/Netlist/Types.hs --- a/src/CLaSH/Netlist/Types.hs +++ b/src/CLaSH/Netlist/Types.hs @@ -57,7 +57,7 @@ { componentName :: Identifier -- ^ Name of the component , hiddenPorts :: [(Identifier,HWType)] -- ^ Ports that have no correspondence the original function definition , inputs :: [(Identifier,HWType)] -- ^ Input ports - , output :: (Identifier,HWType) -- ^ Output port + , outputs :: [(Identifier,HWType)] -- ^ Output ports , declarations :: [Declaration] -- ^ Internal declarations } deriving Show @@ -83,26 +83,12 @@ | Sum Identifier [Identifier] -- ^ Sum type: Name and Constructor names | Product Identifier [HWType] -- ^ Product type: Name and field types | SP Identifier [(Identifier,[HWType])] -- ^ Sum-of-Product type: Name and Constructor names + field types - | Clock Int -- ^ Clock type with specified period - | Reset Int -- ^ Reset type corresponding to clock with a specified period + | Clock Identifier Int -- ^ Clock type with specified name and period + | Reset Identifier Int -- ^ Reset type corresponding to clock with a specified name and period deriving (Eq,Show,Generic) instance Hashable HWType -instance NFData HWType where - rnf hwty = case hwty of - Void -> () - Bool -> () - Integer -> () - BitVector s -> rnf s - Index u -> rnf u - Signed s -> rnf s - Unsigned s -> rnf s - Vector s el -> rnf s `seq` rnf el - Sum i ids -> rnf i `seq` rnf ids - Product i ids -> rnf i `seq` rnf ids - SP i ids -> rnf i `seq` rnf ids - Clock i -> rnf i - Reset i -> rnf i +instance NFData HWType -- | Internals of a Component data Declaration diff --git a/src/CLaSH/Netlist/Util.hs b/src/CLaSH/Netlist/Util.hs --- a/src/CLaSH/Netlist/Util.hs +++ b/src/CLaSH/Netlist/Util.hs @@ -82,10 +82,10 @@ = case name2String tyCon of "CLaSH.Sized.Vector.Vec" -> synchronizedClk tcm (args!!1) "CLaSH.Signal.Internal.SClock" -> case splitTyConAppM (head args) of - Just (_,[LitTy (SymTy s),LitTy (NumTy i)]) -> Just (pack (s ++ show i),i) + Just (_,[LitTy (SymTy s),LitTy (NumTy i)]) -> Just (pack s,i) _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty "CLaSH.Signal.Internal.Signal'" -> case splitTyConAppM (head args) of - Just (_,[LitTy (SymTy s),LitTy (NumTy i)]) -> Just (pack (s ++ show i),i) + Just (_,[LitTy (SymTy s),LitTy (NumTy i)]) -> Just (pack s,i) _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty _ -> case tyConDataCons (tcm HashMap.! tyCon) of [dc] -> let argTys = dcArgTys dc @@ -165,8 +165,8 @@ -> Int typeSize Void = 1 typeSize Bool = 1 -typeSize (Clock _) = 1 -typeSize (Reset _) = 1 +typeSize (Clock _ _) = 1 +typeSize (Reset _ _) = 1 typeSize Integer = 32 typeSize (BitVector i) = i typeSize (Index u) = clog2 (max 2 u) diff --git a/src/CLaSH/Primitives/Util.hs b/src/CLaSH/Primitives/Util.hs --- a/src/CLaSH/Primitives/Util.hs +++ b/src/CLaSH/Primitives/Util.hs @@ -1,9 +1,7 @@ -- | Utility functions to generate Primitives module CLaSH.Primitives.Util where -import Data.Aeson (FromJSON, Result (..), fromJSON, json) -import qualified Data.Attoparsec.Lazy as L -import Data.ByteString.Lazy (ByteString) +import Data.Aeson.Extra (decodeAndReport) import qualified Data.ByteString.Lazy as LZ import qualified Data.HashMap.Lazy as HashMap import Data.List (isSuffixOf) @@ -36,15 +34,3 @@ let primMap = HashMap.fromList $ zip (map name primitives) primitives return primMap - --- | Parse a ByteString according to the given JSON template. Prints failures --- on @stdout@, and returns 'Nothing' if parsing fails. -decodeAndReport :: (FromJSON a) - => ByteString -- ^ Bytestring to parse - -> Maybe a -decodeAndReport s = - case L.parse json s of - L.Done _ v -> case fromJSON v of - Success a -> Just a - Error msg -> traceIf True msg Nothing - L.Fail _ _ msg -> traceIf True msg Nothing diff --git a/src/Data/Aeson/Extra.hs b/src/Data/Aeson/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extra.hs @@ -0,0 +1,18 @@ +module Data.Aeson.Extra where + +import Data.Aeson (FromJSON, Result (..), fromJSON, json) +import Data.Attoparsec.Lazy (Result (..), parse) +import Data.ByteString.Lazy (ByteString) +import CLaSH.Util (traceIf) + +-- | Parse a ByteString according to the given JSON template. Prints failures +-- on @stdout@, and returns 'Nothing' if parsing fails. +decodeAndReport :: (FromJSON a) + => ByteString -- ^ Bytestring to parse + -> Maybe a +decodeAndReport s = + case parse json s of + Done _ v -> case fromJSON v of + Success a -> Just a + Error msg -> traceIf True msg Nothing + Fail _ _ msg -> traceIf True msg Nothing