{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module Clash.GHC.NetlistTypes
(ghcTypeToHWType)
where
import Data.Coerce (coerce)
import Data.Functor.Identity (Identity (..))
import Data.HashMap.Strict (HashMap,(!))
import Data.Text.Lazy (pack)
import Control.Monad.Trans.Except
(ExceptT (..), mapExceptT, runExceptT, throwE)
import Clash.Core.DataCon (DataCon (..))
import Clash.Core.Name (Name (..), name2String)
import Clash.Core.Pretty (showDoc)
import Clash.Core.TyCon (TyCon (..), TyConOccName, tyConDataCons)
import Clash.Core.Type
(LitTy (..), Type (..), TypeView (..), coreView, tyView)
import Clash.Core.Util (tyNatSize)
import Clash.Netlist.Util (coreTypeToHWType)
import Clash.Netlist.Types (HWType(..))
import Clash.Signal.Internal (ClockKind (..), ResetKind (..))
import Clash.Util (curLoc)
ghcTypeToHWType
:: Int
-> Bool
-> HashMap TyConOccName TyCon
-> Bool
-> Type
-> Maybe (Either String HWType)
ghcTypeToHWType iw floatSupport = go
where
go m keepVoid ty@(tyView -> TyConApp tc args) = runExceptT $
case name2String tc of
"GHC.Int.Int8" -> return (Signed 8)
"GHC.Int.Int16" -> return (Signed 16)
"GHC.Int.Int32" -> return (Signed 32)
"GHC.Int.Int64" ->
if iw < 64
then case tyConDataCons (m ! nameOcc tc) of
[dc] -> case dcArgTys dc of
[tyView -> TyConApp nm _]
| name2String nm == "GHC.Prim.Int#" ->
throwE $ unlines ["Int64 not supported in forced 32-bit mode on a 64-bit machine."
,"Run Clash with `-fclash-intwidth=64`."
]
| name2String nm == "GHC.Prim.Int64#" ->
return (Signed 64)
_ -> throwE $ $(curLoc) ++ "Int64 DC has unexpected amount of arguments"
_ -> throwE $ $(curLoc) ++ "Int64 TC has unexpected amount of DCs"
else return (Signed 64)
"GHC.Word.Word8" -> return (Unsigned 8)
"GHC.Word.Word16" -> return (Unsigned 16)
"GHC.Word.Word32" -> return (Unsigned 32)
"GHC.Word.Word64" ->
if iw < 64
then case tyConDataCons (m ! nameOcc tc) of
[dc] -> case dcArgTys dc of
[tyView -> TyConApp nm _]
| name2String nm == "GHC.Prim.Word#" ->
throwE $ unlines ["Word64 not supported in forced 32-bit mode on a 64-bit machine."
,"Run Clash with `-fclash-intwidth=64`."
]
| name2String nm == "GHC.Prim.Word64#" ->
return (Unsigned 64)
_ -> throwE $ $(curLoc) ++ "Word64 DC has unexpected amount of arguments"
_ -> throwE $ $(curLoc) ++ "Word64 TC has unexpected amount of DCs"
else return (Unsigned 64)
"GHC.Integer.Type.Integer" -> return (Signed iw)
"GHC.Natural.Natural" -> return (Unsigned iw)
"GHC.Prim.Char#" -> return (Unsigned 21)
"GHC.Prim.Int#" -> return (Signed iw)
"GHC.Prim.Word#" -> return (Unsigned iw)
"GHC.Prim.Int64#" -> return (Signed 64)
"GHC.Prim.Word64#" -> return (Unsigned 64)
"GHC.Prim.Float#" | floatSupport -> return (BitVector 32)
"GHC.Prim.Double#" | floatSupport -> return (BitVector 64)
"GHC.Prim.ByteArray#" ->
throwE $ "Can't translate type: " ++ showDoc ty
"GHC.Types.Bool" -> return Bool
"GHC.Types.Float" | floatSupport-> return (BitVector 32)
"GHC.Types.Double" | floatSupport -> return (BitVector 64)
"GHC.Prim.~#" -> return (Void Nothing)
"GHC.Prim.Any" -> return (Void Nothing)
"Clash.Signal.Internal.Signal" ->
ExceptT $ return $ coreTypeToHWType go m keepVoid (args !! 1)
"Clash.Signal.Internal.Clock"
| [dom,clkKind] <- args
-> do (nm,rate) <- domain m dom
gated <- clockKind m clkKind
return (Clock (pack nm) rate gated)
"Clash.Signal.Internal.Reset"
| [dom,rstKind] <- args
-> do (nm,rate) <- domain m dom
synchronous <- resetKind m rstKind
return (Reset (pack nm) rate synchronous)
"Clash.Sized.Internal.BitVector.Bit" -> return Bit
"Clash.Sized.Internal.BitVector.BitVector" -> do
n <- mapExceptT (Just . coerce) (tyNatSize m (head args))
case n of
0 -> return (Void (Just (BitVector (fromInteger n))))
_ -> return (BitVector (fromInteger n))
"Clash.Sized.Internal.Index.Index" -> do
n <- mapExceptT (Just . coerce) (tyNatSize m (head args))
if n < 2
then return (Void (Just (Index (fromInteger n))))
else return (Index (fromInteger n))
"Clash.Sized.Internal.Signed.Signed" -> do
n <- mapExceptT (Just . coerce) (tyNatSize m (head args))
if n == 0
then return (Void (Just (Signed (fromInteger n))))
else return (Signed (fromInteger n))
"Clash.Sized.Internal.Unsigned.Unsigned" -> do
n <- mapExceptT (Just .coerce) (tyNatSize m (head args))
if n == 0
then return (Void (Just (Unsigned (fromInteger n))))
else return (Unsigned (fromInteger n))
"Clash.Sized.Vector.Vec" -> do
let [szTy,elTy] = args
sz <- mapExceptT (Just . coerce) (tyNatSize m szTy)
elHWTy <- ExceptT $ return $ coreTypeToHWType go m keepVoid elTy
case elHWTy of
Void {} -> return (Void (Just (Vector (fromInteger sz) elHWTy)))
_ | sz == 0 -> return (Void (Just (Vector (fromInteger sz) elHWTy)))
_ -> return $ Vector (fromInteger sz) elHWTy
"Clash.Sized.RTree.RTree" -> do
let [szTy,elTy] = args
sz <- mapExceptT (Just . coerce) (tyNatSize m szTy)
elHWTy <- ExceptT $ return $ coreTypeToHWType go m keepVoid elTy
case elHWTy of
Void {} -> return (Void (Just (RTree (fromInteger sz) elHWTy)))
_ -> return $ RTree (fromInteger sz) elHWTy
"String" -> return String
"GHC.Types.[]" -> case tyView (head args) of
(TyConApp (name2String -> "GHC.Types.Char") []) -> return String
_ -> throwE $ "Can't translate type: " ++ showDoc ty
_ -> ExceptT Nothing
go _ _ _ = Nothing
domain
:: HashMap TyConOccName TyCon
-> Type
-> ExceptT String Maybe (String,Integer)
domain m (coreView m -> Just ty') = domain m ty'
domain m (tyView -> TyConApp tcNm [LitTy (SymTy nm),rateTy])
| name2String tcNm == "Clash.Signal.Internal.Dom"
= do rate <- mapExceptT (Just . coerce) (tyNatSize m rateTy)
return (nm,rate)
domain _ ty = throwE $ "Can't translate domain: " ++ showDoc ty
clockKind
:: HashMap TyConOccName TyCon
-> Type
-> ExceptT String Maybe ClockKind
clockKind m (coreView m -> Just ty') = clockKind m ty'
clockKind _ (tyView -> TyConApp tcNm [])
| name2String tcNm == "Clash.Signal.Internal.Source"
= return Source
| name2String tcNm == "Clash.Signal.Internal.Gated"
= return Gated
clockKind _ ty = throwE $ "Can't translate ClockKind" ++ showDoc ty
resetKind
:: HashMap TyConOccName TyCon
-> Type
-> ExceptT String Maybe ResetKind
resetKind m (coreView m -> Just ty') = resetKind m ty'
resetKind _ (tyView -> TyConApp tcNm [])
| name2String tcNm == "Clash.Signal.Internal.Synchronous"
= return Synchronous
| name2String tcNm == "Clash.Signal.Internal.Asynchronous"
= return Asynchronous
resetKind _ ty = throwE $ "Can't translate ResetKind" ++ showDoc ty