module CLaSH.Netlist where
import Control.Exception (throw)
import Control.Lens ((.=),(^.),_1,_2)
import qualified Control.Lens as Lens
import Control.Monad.State.Strict (runStateT)
import Control.Monad.Writer.Strict (listen, runWriterT, tell)
import Data.Char (ord)
import Data.Either (lefts,partitionEithers)
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap
import Data.List (elemIndex)
import Data.Maybe (fromMaybe)
import Data.Set (toList,fromList)
import qualified Data.Text.Lazy as Text
import Unbound.Generics.LocallyNameless (Embed (..), name2String,
runFreshMT, unbind, unembed,
unrebind)
import SrcLoc (SrcSpan,noSrcSpan)
import CLaSH.Core.DataCon (DataCon (..))
import CLaSH.Core.FreeVars (typeFreeVars)
import CLaSH.Core.Literal (Literal (..))
import CLaSH.Core.Pretty (showDoc)
import CLaSH.Core.Term (Pat (..), Term (..), TmName)
import qualified CLaSH.Core.Term as Core
import CLaSH.Core.Type (Type (..))
import CLaSH.Core.TyCon (TyConName, TyCon)
import CLaSH.Core.Util (collectArgs, isVar, termType)
import CLaSH.Core.Var (Id, Var (..))
import CLaSH.Driver.Types (CLaSHException (..))
import CLaSH.Netlist.BlackBox
import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate)
import CLaSH.Netlist.Id
import CLaSH.Netlist.Types as HW
import CLaSH.Netlist.Util
import CLaSH.Normalize.Util
import CLaSH.Primitives.Types as P
import CLaSH.Util
genNetlist :: HashMap TmName (Type,SrcSpan,Term)
-> PrimMap BlackBoxTemplate
-> HashMap TyConName TyCon
-> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))
-> Maybe Int
-> String
-> [(String,FilePath)]
-> Int
-> (Identifier -> Identifier)
-> [Identifier]
-> TmName
-> IO ([(SrcSpan,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)
runNetlistMonad :: HashMap TmName (Type,SrcSpan,Term)
-> PrimMap BlackBoxTemplate
-> HashMap TyConName TyCon
-> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))
-> String
-> [(String,FilePath)]
-> Int
-> (Identifier -> Identifier)
-> [Identifier]
-> NetlistMonad a
-> IO (a, NetlistState)
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 HashMap.empty p typeTrans tcm (Text.empty,noSrcSpan) 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
genComponent :: TmName
-> Maybe Int
-> NetlistMonad (SrcSpan,Component)
genComponent compName mStart = do
compExprM <- fmap (HashMap.lookup compName) $ Lens.use bindings
case compExprM of
Nothing -> do
(_,sp) <- Lens.use curCompNm
throw (CLaSHException sp ($(curLoc) ++ "No normalized expression found for: " ++ show compName) Nothing)
Just (_,_,expr_) -> makeCached compName components $
genComponentT compName expr_ mStart
genComponentT :: TmName
-> Term
-> Maybe Int
-> NetlistMonad (SrcSpan,Component)
genComponentT compName componentExpr mStart = do
varCount .= fromMaybe 0 mStart
componentName' <- (HashMap.! compName) <$> Lens.use componentNames
sp <- ((^. _2) . (HashMap.! compName)) <$> Lens.use bindings
curCompNm .= (componentName',sp)
tcm <- Lens.use tcCache
seenIds .= []
(arguments,binders,result) <- do { normalizedM <- splitNormalized tcm componentExpr
; case normalizedM of
Right normalized -> mkUniqueNormalized normalized
Left err -> throw (CLaSHException sp err Nothing)
}
let ids = HashMap.fromList
$ map (\(Id v (Embed t)) -> (v,t))
$ arguments ++ map fst binders
gamma <- (ids `HashMap.union`) . HashMap.map (^. _1)
<$> Lens.use bindings
varEnv .= gamma
typeTrans <- Lens.use typeTranslator
let resType = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm $ HashMap.lookupDefault (error $ $(curLoc) ++ "resType" ++ show (result,HashMap.keys ids)) result ids
argTypes = map (\(Id _ (Embed t)) -> unsafeCoreTypeToHWType $(curLoc) typeTrans tcm t) arguments
let netDecls = map (\(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 (Text.pack . name2String . varName) arguments) argTypes
compOutp = (Text.pack $ name2String result, resType)
component = Component componentName' (toList clks) compInps [compOutp] (netDecls ++ decls)
return (sp,component)
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'
mkDeclarations :: Id
-> Term
-> NetlistMonad [Declaration]
mkDeclarations bndr (Var _ v) = mkFunApp bndr v []
mkDeclarations _ e@(Case _ _ []) = do
(_,sp) <- Lens.use curCompNm
throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Case-decompositions with an empty list of alternatives not supported:\n\n" ++ showDoc e) Nothing)
mkDeclarations bndr e@(Case scrut _ [alt]) = do
(pat,v) <- unbind alt
(_,sp) <- Lens.use curCompNm
(varTy,varTm) <- case v of
(Var t n) -> return (t,n)
_ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: RHS of case-projection is not a variable:\n\n" ++ showDoc e) Nothing)
typeTrans <- Lens.use typeTranslator
tcm <- Lens.use tcCache
scrutTy <- termType tcm scrut
let sHwTy = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm scrutTy
vHwTy = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm varTy
(selId,decls) <- case scrut of
(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
tmsFVs = concatMap (Lens.toListOf typeFreeVars) tmsTys
extNms = map varName exts
tms' = if any (`elem` tmsFVs) extNms
then throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Pattern binds existential variables:\n\n" ++ showDoc e) Nothing)
else tms
in case elemIndex (Id varTm (Embed varTy)) tms' of
Nothing -> Nothing
Just fI
| sHwTy /= vHwTy -> Just (Indexed (sHwTy,dcTag dc 1,fI))
| otherwise -> Just (DC (Void,0))
_ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Unexpected pattern in case-projection:\n\n" ++ showDoc e) Nothing)
extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier
return (decls ++ [Assignment dstId extractExpr])
mkDeclarations bndr (Case scrut altTy alts) = do
alts' <- reorderPats <$> mapM unbind alts
tcm <- Lens.use tcCache
scrutTy <- termType tcm scrut
scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy
altHTy <- unsafeCoreTypeToHWTypeM $(curLoc) altTy
let scrutId = Text.pack . (++ "_case_scrut") . name2String $ varName bndr
(_,sp) <- Lens.use curCompNm
(scrutExpr,scrutDecls) <- first (mkScrutExpr sp scrutHTy (fst (head alts'))) <$> mkExpr True (Left scrutId) scrutTy scrut
(exprs,altsDecls) <- (second concat . unzip) <$> mapM (mkCondExpr scrutHTy) alts'
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
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)
LitPat (Embed (IntegerLiteral i)) -> return (Just (NumLit i),altExpr)
LitPat (Embed (IntLiteral i)) -> return (Just (NumLit i), altExpr)
LitPat (Embed (WordLiteral w)) -> return (Just (NumLit w), altExpr)
LitPat (Embed (CharLiteral c)) -> return (Just (NumLit . toInteger $ ord c), altExpr)
LitPat (Embed (Int64Literal i)) -> return (Just (NumLit i), altExpr)
LitPat (Embed (Word64Literal w)) -> return (Just (NumLit w), altExpr)
_ -> do
(_,sp) <- Lens.use curCompNm
throw (CLaSHException sp ($(curLoc) ++ "Not an integer literal in LitPat:\n\n" ++ showDoc pat) Nothing)
mkScrutExpr :: SrcSpan -> HWType -> Pat -> Expr -> Expr
mkScrutExpr sp scrutHTy pat scrutE = case pat of
DataPat (Embed dc) _ -> let modifier = Just (DC (scrutHTy,dcTag dc 1))
in case scrutE of
Identifier scrutId _ -> Identifier scrutId modifier
_ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Not a variable reference or primitive as subject of a case-statement:\n\n" ++ show scrutE) Nothing)
_ -> scrutE
reorderPats :: [(Pat,Term)] -> [(Pat,Term)]
reorderPats ((DefaultPat,e):alts') = alts' ++ [(DefaultPat,e)]
reorderPats alts' = alts'
mkDeclarations bndr app =
let (appF,(args,tyArgs)) = second partitionEithers $ collectArgs app
in case appF of
Var _ f
| null tyArgs -> mkFunApp bndr f args
| otherwise -> do
(_,sp) <- Lens.use curCompNm
throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Var-application with Type arguments:\n\n" ++ showDoc app) Nothing)
_ -> do
(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)
mkFunApp :: Id
-> TmName
-> [Term]
-> NetlistMonad [Declaration]
mkFunApp dst fun args = do
normalized <- Lens.use bindings
case HashMap.lookup fun normalized of
Just _ -> do
(_,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
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)
return (argDecls ++ argDecls' ++ [instDecl])
else error $ $(curLoc) ++ "under-applied normalized function"
Nothing -> case args of
[] -> do
let dstId = Text.pack . name2String $ varName dst
return [Assignment dstId (Identifier (Text.pack $ name2String fun) Nothing)]
_ -> error $ $(curLoc) ++ "Unknown function: " ++ showDoc fun
toSimpleVar :: Id
-> (Expr,Type)
-> NetlistMonad (Expr,[Declaration])
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 argDecl = NetDecl argNm' hTy
argAssn = Assignment argNm' e
return (Identifier argNm' Nothing,[argDecl,argAssn])
mkExpr :: Bool
-> (Either Identifier Id)
-> Type
-> Term
-> NetlistMonad (Expr,[Declaration])
mkExpr _ _ _ (Core.Literal l) = do
iw <- Lens.use intWidth
case l of
IntegerLiteral i -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, [])
IntLiteral i -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, [])
WordLiteral w -> return (HW.Literal (Just (Unsigned iw,iw)) $ NumLit w, [])
Int64Literal i -> return (HW.Literal (Just (Signed 64,64)) $ NumLit i, [])
Word64Literal w -> return (HW.Literal (Just (Unsigned 64,64)) $ NumLit w, [])
CharLiteral c -> return (HW.Literal (Just (Unsigned 21,21)) . NumLit . toInteger $ ord c, [])
_ -> error $ $(curLoc) ++ "not an integer or char literal"
mkExpr bbEasD bndr ty app = do
let (appF,args) = collectArgs app
tmArgs = lefts args
hwTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty
(_,sp) <- Lens.use curCompNm
case appF of
Data dc
| all (\e -> isConstant e || isVar e) tmArgs -> mkDcApplication hwTy bndr dc tmArgs
| otherwise ->
throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: DataCon-application with non-Simple arguments:\n\n" ++ showDoc app) Nothing)
Prim nm _ -> mkPrimitive False bbEasD bndr nm args ty
Var _ f
| null tmArgs -> return (Identifier (Text.pack $ name2String f) Nothing,[])
| otherwise ->
throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: top-level binder in argument position:\n\n" ++ showDoc app) Nothing)
_ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: application of a Let/Lam/Case:\n\n" ++ showDoc app) Nothing)
mkDcApplication :: HWType
-> (Either Identifier Id)
-> DataCon
-> [Term]
-> NetlistMonad (Expr,[Declaration])
mkDcApplication dstHType bndr dc args = do
tcm <- Lens.use tcCache
argTys <- mapM (termType tcm) args
let isSP (SP _ _) = True
isSP _ = False
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
([Just argHwTy],[argExpr]) | argHwTy == dstHType ->
return (HW.DataCon dstHType (DC (Void,1)) [argExpr])
_ -> case dstHType of
SP _ dcArgPairs -> do
let dcI = dcTag dc 1
dcArgs = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI
case compare (length dcArgs) (length argExprs) of
EQ -> return (HW.DataCon dstHType (DC (dstHType,dcI)) argExprs)
LT -> error $ $(curLoc) ++ "Over-applied constructor"
GT -> error $ $(curLoc) ++ "Under-applied constructor"
Product _ dcArgs ->
case compare (length dcArgs) (length argExprs) of
EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprs)
LT -> error $ $(curLoc) ++ "Over-applied constructor"
GT -> error $ $(curLoc) ++ "Under-applied constructor"
Sum _ _ ->
return (HW.DataCon dstHType (DC (dstHType,dcTag dc 1)) [])
Bool ->
let dc' = case dcTag dc of
1 -> HW.Literal Nothing (BoolLit False)
2 -> HW.Literal Nothing (BoolLit True)
tg -> error $ $(curLoc) ++ "unknown bool literal: " ++ showDoc dc ++ "(tag: " ++ show tg ++ ")"
in return dc'
Vector 0 _ -> return (HW.DataCon dstHType VecAppend [])
Vector 1 _ -> case argExprs of
[_,e,_] -> return (HW.DataCon dstHType VecAppend [e])
_ -> return (HW.DataCon dstHType VecAppend [head argExprs])
Vector _ _ -> case argExprs of
[_,e1,e2] -> return (HW.DataCon dstHType VecAppend [e1,e2])
_ -> return (HW.DataCon dstHType VecAppend argExprs)
_ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys)