module CLaSH.Driver.TopWrapper where
import qualified Data.HashMap.Lazy as HashMap
import Data.List (mapAccumL)
import Data.Text.Lazy (Text, append, pack, unpack)
import System.IO.Unsafe (unsafePerformIO)
import CLaSH.Annotations.TopEntity (TopEntity (..), ClockSource (..))
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
mkTopWrapper :: PrimMap
-> Maybe TopEntity
-> Component
-> Component
mkTopWrapper primMap teM topComponent
= Component
{ componentName = maybe "topEntity" (pack . 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 [] (map pack . 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 [] (map pack . 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 (pack *** BitVector)) . t_extraIn)
extraOut :: Maybe TopEntity -> [(Identifier,HWType)]
extraOut = maybe [] ((map (pack *** 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 = maybe [] (const (map (uncurry NetDecl) hidden)) teM
(clockGens,clkLocks) = maybe ([],[])
(first concat . unzip . map mkClock . t_clocks)
teM
resets = mkResets primMap hidden clkLocks
stringToVar :: String -> Expr
stringToVar = (`Identifier` Nothing) . pack
mkClock :: ClockSource -> ([Declaration],(Identifier,[String],Bool))
mkClock (ClockSource {..}) = ([lockedDecl,instDecl],(lockedName,clks,c_sync))
where
c_nameT = pack c_name
lockedName = append c_nameT "_locked"
lockedDecl = NetDecl lockedName (Reset lockedName 0)
(ports,clks) = clockPorts c_inp c_outp
instDecl = InstDecl c_nameT (append c_nameT "_inst")
$ concat [ ports
, maybe [] ((:[]) . (pack *** stringToVar))
c_reset
, [(pack c_lock,Identifier lockedName Nothing)]
]
clockPorts :: Maybe (String,String) -> [(String,String)]
-> ([(Identifier,Expr)],[String])
clockPorts inp outp = (inp' ++ outp',clks)
where
inp' = maybe [] ((:[]) . (pack *** stringToVar)) inp
outp' = map (pack *** stringToVar) outp
clks = map snd outp
mkResets :: PrimMap
-> [(Identifier,HWType)]
-> [(Identifier,[String],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 (unpack nm ++ show r) clks
match _ = False
connectReset (rst,(Reset nm r)) = if doSync
then return [Assignment rst (Identifier lock Nothing)]
else genSyncReset primMap lock rst nm r
connectReset _ = return []
genSyncReset :: PrimMap
-> Identifier
-> Identifier
-> Text
-> Int
-> NetlistMonad [Declaration]
genSyncReset primMap lock rst 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)