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
data TopEntity
= TopEntity
{ t_name :: Text
, t_inputs :: [Text]
, t_outputs :: [Text]
, t_extraIn :: [(Text,Int)]
, t_extraOut :: [(Text,Int)]
, t_clocks :: [ClockSource]
}
deriving Show
data ClockSource
= ClockSource
{ c_name :: Text
, c_paths :: [ClockPath]
, c_reset :: Maybe (Text,Text)
, c_lock :: Text
, c_sync :: Bool
}
deriving Show
data ClockPath
= ClockPath
{ cp_inp :: Maybe (Text,Text)
, cp_outp :: [(Text,Clock)]
}
deriving Show
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"
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
mkTopWrapper :: PrimMap
-> Maybe TopEntity
-> Component
-> 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)
extraIn :: Maybe TopEntity -> [(Identifier,HWType)]
extraIn = maybe [] ((map (second BitVector)) . t_extraIn)
extraOut :: Maybe TopEntity -> [(Identifier,HWType)]
extraOut = maybe [] ((map (second BitVector)) . t_extraOut)
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..(sz1)]
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))
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 (sz1) elTy is
]
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..(sz1)]
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))
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
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)]
]
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))
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 []
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]
unsafeRunNetlist :: NetlistMonad a
-> a
unsafeRunNetlist = unsafePerformIO
. fmap fst
. runNetlistMonad Nothing HashMap.empty HashMap.empty
HashMap.empty (\_ _ -> Nothing)