clash-lib 0.5.1 → 0.5.2

raw patch · 12 files changed

+444/−70 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• clash-lib.cabal +4/−2
• src/CLaSH/Driver.hs +7/−4
• src/CLaSH/Driver/TestbenchGen.hs +18/−18
• src/CLaSH/Driver/TopWrapper.hs +372/−0
• src/CLaSH/Netlist.hs +2/−2
• src/CLaSH/Netlist/BlackBox.hs +1/−1
• src/CLaSH/Netlist/BlackBox/Util.hs +9/−6
• src/CLaSH/Netlist/Types.hs +4/−18
• src/CLaSH/Netlist/Util.hs +4/−4
• src/CLaSH/Primitives/Util.hs +1/−15
• src/Data/Aeson/Extra.hs +18/−0

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

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

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

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

@@ -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 <christiaan.baaij@gmail.com>+-}+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)

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

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

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

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

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

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

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