{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Clash.Netlist where
import Control.Exception (throw)
import Control.Lens ((.=),(^.),_2)
import qualified Control.Lens as Lens
import Control.Monad (join)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (runReaderT)
import Control.Monad.State.Strict (State, runStateT)
import Data.Binary.IEEE754 (floatToWord, doubleToWord)
import Data.Char (ord)
import Data.Either (partitionEithers)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMapS
import qualified Data.HashMap.Lazy as HashMap
import Data.List (elemIndex, sortOn)
import Data.Maybe (catMaybes, listToMaybe, fromMaybe)
import qualified Data.Set as Set
import Data.Primitive.ByteArray (ByteArray (..))
import qualified Data.Text as StrictText
import qualified Data.Vector.Primitive as PV
import GHC.Integer.GMP.Internals (Integer (..), BigNat (..))
import System.FilePath ((</>), (<.>))
import Text.Read (readMaybe)
import Outputable (ppr, showSDocUnsafe)
import SrcLoc (isGoodSrcSpan)
import Clash.Annotations.Primitive (extractPrim)
import Clash.Annotations.BitRepresentation.ClashLib
(coreToType')
import Clash.Annotations.BitRepresentation.Internal
(CustomReprs, DataRepr'(..), ConstrRepr'(..), getDataRepr, getConstrRepr)
import Clash.Annotations.TopEntity (TopEntity (..))
import Clash.Core.DataCon (DataCon (..))
import Clash.Core.Literal (Literal (..))
import Clash.Core.Name (Name(..))
import Clash.Core.Pretty (showPpr)
import Clash.Core.Term
(Alt, Pat (..), Term (..), TickInfo (..), collectArgs, collectArgsTicks, collectTicks)
import qualified Clash.Core.Term as Core
import Clash.Core.Type
(Type (..), coreView1, splitFunTys, splitCoreFunForallTy)
import Clash.Core.TyCon (TyConMap)
import Clash.Core.Util
(mkApps, mkTicks, stripTicks, termType)
import Clash.Core.Var (Id, Var (..))
import Clash.Core.VarEnv
(VarEnv, eltsVarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, lookupVarEnv,
lookupVarEnv', mkVarEnv)
import Clash.Driver.Types (BindingMap, ClashOpts (..))
import Clash.Netlist.BlackBox
import Clash.Netlist.Id
import Clash.Netlist.Types as HW
import Clash.Netlist.Util
import Clash.Primitives.Types as P
import Clash.Util
genNetlist
:: Bool
-> ClashOpts
-> CustomReprs
-> BindingMap
-> [(Id,Maybe TopEntity,Maybe Id)]
-> CompiledPrimMap
-> TyConMap
-> (CustomReprs -> TyConMap -> Type ->
State HWMap (Maybe (Either String FilteredHWType)))
-> Int
-> (IdType -> Identifier -> Identifier)
-> (IdType -> Identifier -> Identifier -> Identifier)
-> Bool
-> HashMap Identifier Word
-> FilePath
-> (Maybe Identifier,Maybe Identifier)
-> Id
-> IO ([([Bool],SrcSpan,HashMap Identifier Word,Component)],HashMap Identifier Word)
genNetlist isTb opts reprs globals tops primMap tcm typeTrans iw mkId extId ite seen env prefixM topEntity = do
(_,s) <- runNetlistMonad isTb opts reprs globals (mkTopEntityMap tops)
primMap tcm typeTrans iw mkId extId ite seen env prefixM $
genComponent topEntity
return ( eltsVarEnv $ _components s
, _seenComps s
)
where
mkTopEntityMap
:: [(Id,Maybe TopEntity,Maybe Id)]
-> VarEnv (Type,Maybe TopEntity)
mkTopEntityMap = mkVarEnv . map (\(a,b,_) -> (a,(varType a,b)))
runNetlistMonad
:: Bool
-> ClashOpts
-> CustomReprs
-> BindingMap
-> VarEnv (Type, Maybe TopEntity)
-> CompiledPrimMap
-> TyConMap
-> (CustomReprs -> TyConMap -> Type ->
State HWMap (Maybe (Either String FilteredHWType)))
-> Int
-> (IdType -> Identifier -> Identifier)
-> (IdType -> Identifier -> Identifier -> Identifier)
-> Bool
-> HashMap Identifier Word
-> FilePath
-> (Maybe Identifier,Maybe Identifier)
-> NetlistMonad a
-> IO (a, NetlistState)
runNetlistMonad isTb opts reprs s tops p tcm typeTrans iw mkId extId ite seenIds_ env prefixM
= flip runReaderT (NetlistEnv "" "" Nothing)
. flip runStateT s'
. runNetlist
where
s' =
NetlistState
s 0 emptyVarEnv p typeTrans tcm (StrictText.empty,noSrcSpan) iw mkId
extId HashMapS.empty seenIds' Set.empty names tops env 0 prefixM reprs opts isTb ite
HashMapS.empty
(seenIds',names) = genNames (opt_newInlineStrat opts) mkId prefixM seenIds_
emptyVarEnv s
genNames :: Bool
-> (IdType -> Identifier -> Identifier)
-> (Maybe Identifier,Maybe Identifier)
-> HashMap Identifier Word
-> VarEnv Identifier
-> BindingMap
-> (HashMap Identifier Word, VarEnv Identifier)
genNames newInlineStrat mkId prefixM s0 m0 = foldr go (s0,m0)
where
go (v,_,_,_) (s,m) =
let nm' = genComponentName newInlineStrat s mkId prefixM v
s' = HashMapS.insert nm' 0 s
m' = extendVarEnv v nm' m
in (s', m')
genComponent
:: HasCallStack
=> Id
-> NetlistMonad ([Bool],SrcSpan,HashMap Identifier Word,Component)
genComponent compName = do
compExprM <- lookupVarEnv 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_) -> do
makeCachedU compName components $ genComponentT compName expr_
genComponentT
:: HasCallStack
=> Id
-> Term
-> NetlistMonad ([Bool],SrcSpan,HashMap Identifier Word,Component)
genComponentT compName componentExpr = do
varCount .= 0
componentName1 <- (`lookupVarEnv'` compName) <$> Lens.use componentNames
topEntMM <- fmap snd . lookupVarEnv compName <$> Lens.use topEntityAnns
prefixM <- Lens.use componentPrefix
let componentName2 = case (prefixM,join topEntMM) of
((Just p,_),Just ann) -> p `StrictText.append` StrictText.pack ('_':t_name ann)
(_,Just ann) -> StrictText.pack (t_name ann)
_ -> componentName1
sp <- ((^. _2) . (`lookupVarEnv'` compName)) <$> Lens.use bindings
curCompNm .= (componentName2,sp)
tcm <- Lens.use tcCache
topEntityTypeM <- lookupVarEnv compName <$> Lens.use topEntityAnns
let topEntityTypeM' = snd . splitCoreFunForallTy tcm . fst <$> topEntityTypeM
seenIds .= HashMapS.empty
(wereVoids,compInps,argWrappers,compOutps,resUnwrappers,binders,resultM) <-
case splitNormalized tcm componentExpr of
Right (args, binds, res) -> do
let varType' = fromMaybe (varType res) topEntityTypeM'
mkUniqueNormalized emptyInScopeSet topEntMM ((args, binds, res{varType=varType'}))
Left err ->
throw (ClashException sp err Nothing)
netDecls <- fmap catMaybes . mapM mkNetDecl $ filter (maybe (const True) (/=) resultM . fst) binders
decls <- concat <$> mapM (uncurry mkDeclarations) binders
case resultM of
Just result -> do
Just (NetDecl' _ rw _ _) <- mkNetDecl . head $ filter ((==result) . fst) binders
let (compOutps',resUnwrappers') = case compOutps of
[oport] -> ([(rw,oport)],resUnwrappers)
_ -> let NetDecl n res resTy = head resUnwrappers
in (map (Wire,) compOutps
,NetDecl' n rw res (Right resTy):tail resUnwrappers
)
component = Component componentName2 compInps compOutps'
(netDecls ++ argWrappers ++ decls ++ resUnwrappers')
ids <- Lens.use seenIds
return (wereVoids, sp, ids, component)
Nothing -> do
let component = Component componentName2 compInps [] (netDecls ++ argWrappers ++ decls)
ids <- Lens.use seenIds
return (wereVoids, sp, ids, component)
mkNetDecl :: (Id, Term) -> NetlistMonad (Maybe Declaration)
mkNetDecl (id_,tm) = do
let typ = varType id_
hwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) typ
wr <- termToWireOrReg tm
if isVoid hwTy
then return Nothing
else return . Just $ NetDecl' (addSrcNote sp)
wr
(id2identifier id_)
(Right hwTy)
where
nm = varName id_
sp = case tm of {Tick (SrcSpan s) _ -> s; _ -> nameLoc nm}
termToWireOrReg :: Term -> NetlistMonad WireOrReg
termToWireOrReg (stripTicks -> Case scrut _ alts0@(_:_:_)) = do
tcm <- Lens.use tcCache
let scrutTy = termType tcm scrut
scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy
ite <- Lens.use backEndITE
case iteAlts scrutHTy alts0 of
Just _ | ite -> return Wire
_ -> return Reg
termToWireOrReg (collectArgs -> (Prim nm' _,_)) = do
bbM <- HashMap.lookup nm' <$> Lens.use primitives
case bbM of
Just (extractPrim -> Just BlackBox {..}) | outputReg -> return Reg
_ -> return Wire
termToWireOrReg _ = return Wire
addSrcNote loc = if isGoodSrcSpan loc
then Just (StrictText.pack (showSDocUnsafe (ppr loc)))
else Nothing
isWriteToBiSignalPrimitive :: Term -> Bool
isWriteToBiSignalPrimitive e = case collectArgs e of
(Prim nm _,_) -> nm == StrictText.pack "Clash.Signal.BiSignal.writeToBiSignal#"
_ -> False
mkDeclarations
:: HasCallStack
=> Id
-> Term
-> NetlistMonad [Declaration]
mkDeclarations bndr e = do
hty <- unsafeCoreTypeToHWTypeM' $(curLoc) (varType bndr)
if isVoid hty && not (isBiSignalOut hty)
then return []
else mkDeclarations' bndr e
mkDeclarations'
:: HasCallStack
=> Id
-> Term
-> NetlistMonad [Declaration]
mkDeclarations' bndr (collectTicks -> (Var v,ticks)) =
withTicks ticks $ \tickDecls -> do
mkFunApp (id2identifier bndr) v [] tickDecls
mkDeclarations' _ e@(collectTicks -> (Case _ _ [],_)) = do
(_,sp) <- Lens.use curCompNm
throw $ ClashException
sp
( unwords [ $(curLoc)
, "Not in normal form: Case-decompositions with an"
, "empty list of alternatives not supported:\n\n"
, showPpr e
])
Nothing
mkDeclarations' bndr (collectTicks -> (Case scrut altTy alts@(_:_:_),ticks)) =
withTicks ticks $ \tickDecls -> do
mkSelection (Right bndr) scrut altTy alts tickDecls
mkDeclarations' bndr app =
let (appF,args0,ticks) = collectArgsTicks app
(args,tyArgs) = partitionEithers args0
in withTicks ticks $ \tickDecls -> do
case appF of
Var f
| null tyArgs -> mkFunApp (id2identifier bndr) f args tickDecls
| otherwise -> do
(_,sp) <- Lens.use curCompNm
throw (ClashException sp ($(curLoc) ++ "Not in normal form: Var-application with Type arguments:\n\n" ++ showPpr app) Nothing)
_ -> do
hwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) (id2type bndr)
if isBiSignalOut hwTy && not (isWriteToBiSignalPrimitive app)
then return []
else do
(exprApp,declsApp0) <- mkExpr False (Right bndr) (varType bndr) app
let dstId = id2identifier bndr
assn = case exprApp of
Identifier _ Nothing -> []
_ -> [Assignment dstId exprApp]
declsApp1 = if null declsApp0 then tickDecls else declsApp0
return (declsApp1 ++ assn)
mkSelection
:: (Either Identifier Id)
-> Term
-> Type
-> [Alt]
-> [Declaration]
-> NetlistMonad [Declaration]
mkSelection bndr scrut altTy alts0 tickDecls = do
let dstId = either id id2identifier bndr
tcm <- Lens.use tcCache
let scrutTy = termType tcm scrut
scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy
scrutId <- extendIdentifier Extended dstId "_selection"
(_,sp) <- Lens.use curCompNm
ite <- Lens.use backEndITE
case iteAlts scrutHTy alts0 of
Just (altT,altF)
| ite
-> do
(scrutExpr,scrutDecls) <- case scrutHTy of
SP {} -> first (mkScrutExpr sp scrutHTy (fst (last alts0))) <$>
mkExpr True (Left scrutId) scrutTy scrut
_ -> mkExpr False (Left scrutId) scrutTy scrut
altTId <- extendIdentifier Extended dstId "_sel_alt_t"
altFId <- extendIdentifier Extended dstId "_sel_alt_f"
(altTExpr,altTDecls) <- mkExpr False (Left altTId) altTy altT
(altFExpr,altFDecls) <- mkExpr False (Left altFId) altTy altF
return $! scrutDecls ++ altTDecls ++ altFDecls ++ tickDecls ++
[Assignment dstId (IfThenElse scrutExpr altTExpr altFExpr)]
_ -> do
reprs <- Lens.use customReprs
let alts1 = (reorderDefault . reorderCustom tcm reprs scrutTy) alts0
altHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) altTy
(scrutExpr,scrutDecls) <- first (mkScrutExpr sp scrutHTy (fst (head alts1))) <$>
mkExpr True (Left scrutId) scrutTy scrut
(exprs,altsDecls) <- (second concat . unzip) <$> mapM (mkCondExpr scrutHTy) alts1
return $! scrutDecls ++ altsDecls ++ tickDecls ++ [CondAssignment dstId altHTy scrutExpr scrutHTy exprs]
where
mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe HW.Literal,Expr),[Declaration])
mkCondExpr scrutHTy (pat,alt) = do
altId <- extendIdentifier Extended
(either id id2identifier bndr)
"_sel_alt"
(altExpr,altDecls) <- mkExpr False (Left altId) altTy alt
(,altDecls) <$> case pat of
DefaultPat -> return (Nothing,altExpr)
DataPat dc _ _ -> return (Just (dcToLiteral scrutHTy (dcTag dc)),altExpr)
LitPat (IntegerLiteral i) -> return (Just (NumLit i),altExpr)
LitPat (IntLiteral i) -> return (Just (NumLit i), altExpr)
LitPat (WordLiteral w) -> return (Just (NumLit w), altExpr)
LitPat (CharLiteral c) -> return (Just (NumLit . toInteger $ ord c), altExpr)
LitPat (Int64Literal i) -> return (Just (NumLit i), altExpr)
LitPat (Word64Literal w) -> return (Just (NumLit w), altExpr)
LitPat (NaturalLiteral n) -> return (Just (NumLit n), altExpr)
_ -> do
(_,sp) <- Lens.use curCompNm
throw (ClashException sp ($(curLoc) ++ "Not an integer literal in LitPat:\n\n" ++ showPpr pat) Nothing)
mkScrutExpr :: SrcSpan -> HWType -> Pat -> Expr -> Expr
mkScrutExpr sp scrutHTy pat scrutE = case pat of
DataPat dc _ _ -> let modifier = Just (DC (scrutHTy,dcTag dc - 1))
in case scrutE of
Identifier scrutId Nothing -> 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
reorderDefault
:: [(Pat, Term)]
-> [(Pat, Term)]
reorderDefault ((DefaultPat,e):alts') = alts' ++ [(DefaultPat,e)]
reorderDefault alts' = alts'
reorderCustom
:: TyConMap
-> CustomReprs
-> Type
-> [(Pat, Term)]
-> [(Pat, Term)]
reorderCustom tcm reprs (coreView1 tcm -> Just ty) alts =
reorderCustom tcm reprs ty alts
reorderCustom _tcm reprs (coreToType' -> Right typeName) alts =
case getDataRepr typeName reprs of
Just (DataRepr' _name _size _constrReprs) ->
sortOn (patPos reprs . fst) alts
Nothing ->
alts
reorderCustom _tcm _reprs _type alts =
alts
patPos
:: CustomReprs
-> Pat
-> Int
patPos _reprs DefaultPat = -1
patPos _reprs (LitPat _) = 0
patPos reprs pat@(DataPat dataCon _ _) =
let name = nameOcc $ dcName dataCon in
case getConstrRepr name reprs of
Nothing ->
error $ $(curLoc) ++ (show pat)
Just (ConstrRepr' _name n _mask _value _anns) ->
n
mkFunApp
:: HasCallStack
=> Identifier
-> Id
-> [Term]
-> [Declaration]
-> NetlistMonad [Declaration]
mkFunApp dstId fun args tickDecls = do
topAnns <- Lens.use topEntityAnns
tcm <- Lens.use tcCache
case lookupVarEnv fun topAnns of
Just (ty,annM)
| let (fArgTys,fResTy) = splitFunTys tcm ty
, length fArgTys == length args
-> do
argHWTys <- mapM (unsafeCoreTypeToHWTypeM' $(curLoc)) fArgTys
let argsBundled = zip argHWTys (zip args fArgTys)
argsFiltered = filter (not . isVoid . fst) argsBundled
argsFiltered' = map snd argsFiltered
hWTysFiltered = filter (not . isVoid) argHWTys
(argExprs,argDecls) <- second concat . unzip <$>
mapM (\(e,t) -> mkExpr False (Left dstId) t e)
argsFiltered'
dstHWty <- unsafeCoreTypeToHWTypeM' $(curLoc) fResTy
env <- Lens.use hdlDir
mkId <- Lens.use mkIdentifierFn
prefixM <- Lens.use componentPrefix
newInlineStrat <- opt_newInlineStrat <$> Lens.use clashOpts
let topName = StrictText.unpack
(genTopComponentName newInlineStrat mkId prefixM annM fun)
modName = takeWhile (/= '.')
(StrictText.unpack (nameOcc (varName fun)))
manFile <- case annM of
Just _ -> return (env </> ".." </> modName </> topName </> topName <.> "manifest")
Nothing -> return (env </> topName <.> "manifest")
Just man <- readMaybe <$> liftIO (readFile manFile)
instDecls <- mkTopUnWrapper fun annM man (dstId,dstHWty)
(zip argExprs hWTysFiltered)
tickDecls
return (argDecls ++ instDecls)
| otherwise -> error $ $(curLoc) ++ "under-applied TopEntity"
_ -> do
normalized <- Lens.use bindings
case lookupVarEnv fun normalized of
Just _ -> do
(_,_,_,Component compName compInps co _) <- preserveVarEnv $ genComponent fun
let argTys = map (termType tcm) args
argHWTys <- mapM coreTypeToHWTypeM' argTys
let argsBundled = zip argHWTys (zip args argTys)
argsFiltered = filter (maybe True (not . isVoid) . fst) argsBundled
argsFiltered' = map snd argsFiltered
tysFiltered = map snd argsFiltered'
compOutp = snd <$> listToMaybe co
if length tysFiltered == length compInps
then do
(argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr False (Left dstId) t e) argsFiltered'
(argExprs',argDecls') <- (second concat . unzip) <$> mapM (toSimpleVar dstId) (zip argExprs tysFiltered)
let inpAssigns = zipWith (\(i,t) e -> (Identifier i Nothing,In,t,e)) compInps argExprs'
outpAssign = case compOutp of
Nothing -> []
Just (id_,hwtype) -> [(Identifier id_ Nothing,Out,hwtype,Identifier dstId Nothing)]
instLabel0 <- extendIdentifier Basic compName (StrictText.pack "_" `StrictText.append` dstId)
instLabel1 <- fromMaybe instLabel0 <$> Lens.view setName
instLabel2 <- affixName instLabel1
instLabel3 <- mkUniqueIdentifier Basic instLabel2
let instDecl = InstDecl Entity Nothing compName instLabel3 [] (outpAssign ++ inpAssigns)
return (argDecls ++ argDecls' ++ tickDecls ++ [instDecl])
else error $ $(curLoc) ++ "under-applied normalized function"
Nothing -> case args of
[] -> return [Assignment dstId (Identifier (nameOcc $ varName fun) Nothing)]
_ -> error $ $(curLoc) ++ "Unknown function: " ++ showPpr fun
toSimpleVar :: Identifier
-> (Expr,Type)
-> NetlistMonad (Expr,[Declaration])
toSimpleVar _ (e@(Identifier _ _),_) = return (e,[])
toSimpleVar dstId (e,ty) = do
argNm <- extendIdentifier Extended
dstId
"_fun_arg"
argNm' <- mkUniqueIdentifier Extended argNm
hTy <- unsafeCoreTypeToHWTypeM' $(curLoc) ty
let argDecl = NetDecl Nothing argNm' hTy
argAssn = Assignment argNm' e
return (Identifier argNm' Nothing,[argDecl,argAssn])
mkExpr :: HasCallStack
=> Bool
-> (Either Identifier Id)
-> Type
-> Term
-> NetlistMonad (Expr,[Declaration])
mkExpr _ _ _ (stripTicks -> 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, [])
FloatLiteral r -> let f = fromRational r :: Float
i = toInteger (floatToWord f)
in return (HW.Literal (Just (BitVector 32,32)) (NumLit i), [])
DoubleLiteral r -> let d = fromRational r :: Double
i = toInteger (doubleToWord d)
in return (HW.Literal (Just (BitVector 64,64)) (NumLit i), [])
NaturalLiteral n -> return (HW.Literal (Just (Unsigned iw,iw)) $ NumLit n, [])
ByteArrayLiteral (PV.Vector _ _ (ByteArray ba)) -> return (HW.Literal Nothing (NumLit (Jp# (BN# ba))),[])
_ -> error $ $(curLoc) ++ "not an integer or char literal"
mkExpr bbEasD bndr ty app =
let (appF,args,ticks) = collectArgsTicks app
(tmArgs,tyArgs) = partitionEithers args
in withTicks ticks $ \tickDecls -> do
hwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) ty
(_,sp) <- Lens.use curCompNm
case appF of
Data dc -> mkDcApplication hwTy bndr dc tmArgs
Prim nm _ -> mkPrimitive False bbEasD bndr nm args ty tickDecls
Var f
| null tmArgs -> return (Identifier (nameOcc $ varName f) Nothing,[])
| not (null tyArgs) ->
throw (ClashException sp ($(curLoc) ++ "Not in normal form: Var-application with Type arguments:\n\n" ++ showPpr app) Nothing)
| otherwise -> do
argNm0 <- extendIdentifier Extended (either id id2identifier bndr) "_fun_arg"
argNm1 <- mkUniqueIdentifier Extended argNm0
hwTyA <- unsafeCoreTypeToHWTypeM' $(curLoc) ty
decls <- mkFunApp argNm1 f tmArgs tickDecls
return (Identifier argNm1 Nothing, NetDecl' Nothing Wire argNm1 (Right hwTyA):decls)
Case scrut ty' [alt] -> mkProjection bbEasD bndr scrut ty' alt
Case scrut tyA alts -> do
tcm <- Lens.use tcCache
let scrutTy = termType tcm scrut
scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy
ite <- Lens.use backEndITE
let wr = case iteAlts scrutHTy alts of
Just _ | ite -> Wire
_ -> Reg
argNm0 <- extendIdentifier Extended (either id id2identifier bndr) "_sel_arg"
argNm1 <- mkUniqueIdentifier Extended argNm0
hwTyA <- unsafeCoreTypeToHWTypeM' $(curLoc) tyA
decls <- mkSelection (Left argNm1) scrut tyA alts tickDecls
return (Identifier argNm1 Nothing, NetDecl' Nothing wr argNm1 (Right hwTyA):decls)
Letrec binders body -> do
netDecls <- fmap catMaybes $ mapM mkNetDecl binders
decls <- concat <$> mapM (uncurry mkDeclarations) binders
(bodyE,bodyDecls) <- mkExpr bbEasD bndr ty (mkApps (mkTicks body ticks) args)
return (bodyE,netDecls ++ decls ++ bodyDecls)
_ -> throw (ClashException sp ($(curLoc) ++ "Not in normal form: application of a Lambda-expression\n\n" ++ showPpr app) Nothing)
mkProjection
:: Bool
-> Either Identifier Id
-> Term
-> Type
-> Alt
-> NetlistMonad (Expr, [Declaration])
mkProjection mkDec bndr scrut altTy alt@(pat,v) = do
tcm <- Lens.use tcCache
let scrutTy = termType tcm scrut
e = Case scrut scrutTy [alt]
(_,sp) <- Lens.use curCompNm
varTm <- case v of
(Var n) -> return n
_ -> throw (ClashException sp ($(curLoc) ++
"Not in normal form: RHS of case-projection is not a variable:\n\n"
++ showPpr e) Nothing)
sHwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy
vHwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) altTy
(selId,modM,decls) <- do
scrutNm <- either return
(\b -> extendIdentifier Extended
(id2identifier b)
"_projection")
bndr
(scrutExpr,newDecls) <- mkExpr False (Left scrutNm) scrutTy scrut
case scrutExpr of
Identifier newId modM -> return (newId,modM,newDecls)
_ -> do
scrutNm' <- mkUniqueIdentifier Extended scrutNm
let scrutDecl = NetDecl Nothing scrutNm' sHwTy
scrutAssn = Assignment scrutNm' scrutExpr
return (scrutNm',Nothing,newDecls ++ [scrutDecl,scrutAssn])
let altVarId = nameOcc (varName varTm)
modifier <- case pat of
DataPat dc exts tms -> do
let tms' = if bindsExistentials exts tms
then throw (ClashException sp ($(curLoc) ++ "Not in normal form: Pattern binds existential variables:\n\n" ++ showPpr e) Nothing)
else tms
argHWTys <- mapM coreTypeToHWTypeM' (map varType tms)
let tmsBundled = zip argHWTys tms'
tmsFiltered = filter (maybe False (not . isVoid) . fst) tmsBundled
tmsFiltered' = map snd tmsFiltered
case elemIndex varTm {varType = altTy} tmsFiltered' of
Nothing -> pure Nothing
Just fI
| sHwTy /= vHwTy -> pure $ nestModifier modM (Just (Indexed (sHwTy,dcTag dc - 1,fI)))
| otherwise -> pure $ nestModifier modM (Just (DC (Void Nothing,0)))
_ -> throw (ClashException sp ($(curLoc) ++ "Not in normal form: Unexpected pattern in case-projection:\n\n" ++ showPpr e) Nothing)
let extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier
case bndr of
Left scrutNm | mkDec -> do
scrutNm' <- mkUniqueIdentifier Extended scrutNm
let scrutDecl = NetDecl Nothing scrutNm' vHwTy
scrutAssn = Assignment scrutNm' extractExpr
return (Identifier scrutNm' Nothing,scrutDecl:scrutAssn:decls)
_ -> return (extractExpr,decls)
where
nestModifier Nothing m = m
nestModifier m Nothing = m
nestModifier (Just m1) (Just m2) = Just (Nested m1 m2)
mkDcApplication
:: HasCallStack
=> HWType
-> (Either Identifier Id)
-> DataCon
-> [Term]
-> NetlistMonad (Expr,[Declaration])
mkDcApplication dstHType bndr dc args = do
let dcNm = nameOcc (dcName dc)
tcm <- Lens.use tcCache
let argTys = map (termType tcm) args
argNm <- either return (\b -> extendIdentifier Extended (nameOcc (varName b)) "_dc_arg") bndr
argHWTys <- mapM coreTypeToHWTypeM' argTys
let argsBundled = zip argHWTys (zip args argTys)
(hWTysFiltered,argsFiltered) = unzip
(filter (maybe True (not . isVoid) . fst) argsBundled)
(argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr False (Left argNm) t e) argsFiltered
fmap (,argDecls) $! case (hWTysFiltered,argExprs) of
([Just argHwTy],[argExpr]) | argHwTy == dstHType ->
return (HW.DataCon dstHType (DC (Void Nothing,-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)) [])
CustomSP _ _ _ dcArgsTups -> do
let dcI = dcTag dc - 1
let note = $(curLoc) ++ "No DC with tag: " ++ show dcI
let argTup = indexNote note dcArgsTups dcI
let (_, _, dcArgs) = argTup
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"
CustomSum _ _ _ _ ->
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: " ++ showPpr 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])
_ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showPpr args
Vector _ _ -> case argExprs of
[e1,e2] -> return (HW.DataCon dstHType VecAppend [e1,e2])
_ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showPpr args
RTree 0 _ -> case argExprs of
[e] -> return (HW.DataCon dstHType RTreeAppend [e])
_ -> error $ $(curLoc) ++ "Unexpected number of arguments for `LR`: " ++ showPpr args
RTree _ _ -> case argExprs of
[e1,e2] -> return (HW.DataCon dstHType RTreeAppend [e1,e2])
_ -> error $ $(curLoc) ++ "Unexpected number of arguments for `BR`: " ++ showPpr args
String ->
let dc' = case dcTag dc of
1 -> HW.Literal Nothing (StringLit "")
_ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,dcTag dc,args,argHWTys)
in return dc'
Void {} -> return (Identifier "__VOID__" Nothing)
Signed _
| dcNm == "GHC.Integer.Type.S#"
-> pure (head argExprs)
| dcNm == "GHC.Integer.Type.Jp#"
-> pure (head argExprs)
| dcNm == "GHC.Integer.Type.Jn#"
, HW.Literal Nothing (NumLit i) <- head argExprs
-> pure (HW.Literal Nothing (NumLit (negate i)))
Unsigned _
| dcNm == "GHC.Natural.NatS#"
-> pure (head argExprs)
| dcNm == "GHC.Natural.NatJ#"
-> pure (head argExprs)
_ ->
error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys)