clash-lib-1.10.0: src/Clash/Core/TysPrim.hs
{-|
Copyright : (C) 2012-2016, University of Twente,
2016 , Myrtle Software Ltd,
2021-2026, QBayLogic B.V.
License : BSD2 (see the file LICENSE)
Maintainer : QBayLogic B.V. <devops@qbaylogic.com>
Builtin Type and Kind definitions
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module Clash.Core.TysPrim
( liftedTypeKind
, typeNatKind
, typeSymbolKind
, intPrimTy
, integerPrimTy
, charPrimTy
, stringPrimTy
, wordPrimTy
, int64PrimTy
, word64PrimTy
, int8PrimTy
, int16PrimTy
, int32PrimTy
, word8PrimTy
, word16PrimTy
, word32PrimTy
, floatPrimTy
, doublePrimTy
, naturalPrimTy
, byteArrayPrimTy
, eqPrimTy
, tysPrimMap
, integerIsDc
, naturalNsDc
)
where
import GHC.Builtin.Names
import GHC.Base hiding (Type, TyCon)
import Data.Text.Extra (showt)
import Clash.Core.DataCon (DataCon(..), DcStrictness(..))
import GHC.Num.Integer (Integer(..))
import GHC.Num.Natural (Natural(..))
import Clash.Core.Name
import Clash.Core.TyCon
import Clash.Core.Type
import Clash.Core.Var (mkTyVar)
import Clash.Unique (fromGhcUnique)
import qualified Clash.Data.UniqMap as UniqMap
-- | Builtin Name
liftedTypeKindTyConName, typeNatKindTyConName, typeSymbolKindTyConName :: TyConName
liftedTypeKindTyConName = mkUnsafeSystemName "Type"
(fromGhcUnique liftedTypeKindTyConKey)
typeNatKindTyConName = naturalPrimTyConName
typeSymbolKindTyConName = mkUnsafeSystemName "Symbol"
(fromGhcUnique typeSymbolKindConNameKey)
-- | Builtin Kind
liftedTypeKindTc, typeNatKindTc, typeSymbolKindTc :: TyCon
liftedTypeKindTc = mkKindTyCon liftedTypeKindTyConName liftedTypeKind
typeNatKindTc = mkKindTyCon typeNatKindTyConName liftedTypeKind
typeSymbolKindTc = mkKindTyCon typeSymbolKindTyConName liftedTypeKind
liftedTypeKind, typeNatKind, typeSymbolKind :: Type
liftedTypeKind = mkTyConTy liftedTypeKindTyConName
typeNatKind = mkTyConTy typeNatKindTyConName
typeSymbolKind = mkTyConTy typeSymbolKindTyConName
intPrimTyConName, integerPrimTyConName, charPrimTyConName, stringPrimTyConName,
wordPrimTyConName, int64PrimTyConName, word64PrimTyConName,
floatPrimTyConName, doublePrimTyConName,
naturalPrimTyConName, byteArrayPrimTyConName, eqPrimTyConName :: TyConName
intPrimTyConName = mkUnsafeSystemName (showt ''Int#)
(fromGhcUnique intPrimTyConKey)
integerPrimTyConName = mkUnsafeSystemName (showt ''Integer)
(fromGhcUnique integerTyConKey)
stringPrimTyConName = mkUnsafeSystemName (showt ''Addr#)
(fromGhcUnique addrPrimTyConKey)
charPrimTyConName = mkUnsafeSystemName (showt ''Char#)
(fromGhcUnique charPrimTyConKey)
wordPrimTyConName = mkUnsafeSystemName (showt ''Word#)
(fromGhcUnique wordPrimTyConKey)
int64PrimTyConName = mkUnsafeSystemName (showt ''Int64#)
(fromGhcUnique int64PrimTyConKey)
word64PrimTyConName = mkUnsafeSystemName (showt ''Word64#)
(fromGhcUnique word64PrimTyConKey)
floatPrimTyConName = mkUnsafeSystemName (showt ''Float#)
(fromGhcUnique floatPrimTyConKey)
doublePrimTyConName = mkUnsafeSystemName (showt ''Double#)
(fromGhcUnique doublePrimTyConKey)
naturalPrimTyConName = mkUnsafeSystemName (showt ''Natural)
(fromGhcUnique naturalTyConKey)
byteArrayPrimTyConName = mkUnsafeSystemName (showt ''ByteArray#)
(fromGhcUnique byteArrayPrimTyConKey)
eqPrimTyConName = mkUnsafeSystemName "GHC.Prim.~#" (fromGhcUnique eqPrimTyConKey)
int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, word8PrimTyConName,
word16PrimTyConName, word32PrimTyConName :: TyConName
int8PrimTyConName = mkUnsafeSystemName (showt ''Int8#)
(fromGhcUnique int8PrimTyConKey)
int16PrimTyConName = mkUnsafeSystemName (showt ''Int16#)
(fromGhcUnique int16PrimTyConKey)
int32PrimTyConName = mkUnsafeSystemName (showt ''Int32#)
(fromGhcUnique int32PrimTyConKey)
word8PrimTyConName = mkUnsafeSystemName (showt ''Word8#)
(fromGhcUnique word8PrimTyConKey)
word16PrimTyConName = mkUnsafeSystemName (showt ''Word16#)
(fromGhcUnique word16PrimTyConKey)
word32PrimTyConName = mkUnsafeSystemName (showt ''Word32#)
(fromGhcUnique word32PrimTyConKey)
liftedPrimTC :: TyConName
-> TyCon
liftedPrimTC name = PrimTyCon (nameUniq name) name liftedTypeKind 0
-- | Builtin Type
intPrimTc, integerPrimTc, charPrimTc, stringPrimTc, wordPrimTc,
int64PrimTc, word64PrimTc, floatPrimTc, doublePrimTc, naturalPrimTc,
byteArrayPrimTc :: TyCon
intPrimTc = liftedPrimTC intPrimTyConName
-- While GHC might have dropped Integer and Natural literals, in Clash it is
-- still nice to have them around. However, Integer and Natural are also no
-- longer primitive types in GHC, but we still want to give the Integer and
-- Natural type to our Integer and Natural literals.
--
-- So instead of recording the primitive types, we record the algebraic types,
-- i.e. the complete data type for Integer and Natural, data constructors and all.
integerIsDc, naturalNsDc :: DataCon
integerIsDc = isDc
where
isDcNm = mkUnsafeSystemName (showt 'IS) (fromGhcUnique integerISDataConKey)
isDc = MkData
{ dcName = isDcNm
, dcUniq = nameUniq isDcNm
, dcTag = 1
, dcType = mkPolyFunTy integerPrimTy [Right intPrimTy]
, dcUnivTyVars = []
, dcExtTyVars = []
, dcArgTys = [intPrimTy]
, dcArgStrict = [Strict]
, dcFieldLabels = []
}
integerPrimTc =
let
name = integerPrimTyConName
uniq = nameUniq name
isDc = integerIsDc
ipDcNm = mkUnsafeSystemName (showt 'IP) (fromGhcUnique integerIPDataConKey)
ipDc = MkData
{ dcName = ipDcNm
, dcUniq = nameUniq ipDcNm
, dcTag = 2
, dcType = mkPolyFunTy integerPrimTy [Right byteArrayPrimTy]
, dcUnivTyVars = []
, dcExtTyVars = []
, dcArgTys = [byteArrayPrimTy]
, dcArgStrict = [Strict]
, dcFieldLabels = []
}
inDcNm = mkUnsafeSystemName (showt 'IN) (fromGhcUnique integerINDataConKey)
inDc = MkData
{ dcName = inDcNm
, dcUniq = nameUniq inDcNm
, dcTag = 3
, dcType = mkPolyFunTy integerPrimTy [Right byteArrayPrimTy]
, dcUnivTyVars = []
, dcExtTyVars = []
, dcArgTys = [byteArrayPrimTy]
, dcArgStrict = [Strict]
, dcFieldLabels = []
}
rhs = DataTyCon [isDc,ipDc,inDc]
in
AlgTyCon uniq name liftedTypeKind 0 rhs False
naturalNsDc = nsDc
where
nsDcNm = mkUnsafeSystemName (showt 'NS) (fromGhcUnique naturalNSDataConKey)
nsDc = MkData
{ dcName = nsDcNm
, dcUniq = nameUniq nsDcNm
, dcTag = 1
, dcType = mkPolyFunTy naturalPrimTy [Right wordPrimTy]
, dcUnivTyVars = []
, dcExtTyVars = []
, dcArgTys = [wordPrimTy]
, dcArgStrict = [Strict]
, dcFieldLabels = []
}
naturalPrimTc =
let
name = naturalPrimTyConName
uniq = nameUniq name
nsDc = naturalNsDc
nbDcNm = mkUnsafeSystemName (showt 'NB) (fromGhcUnique naturalNBDataConKey)
nbDc = MkData
{ dcName = nbDcNm
, dcUniq = nameUniq nbDcNm
, dcTag = 2
, dcType = mkPolyFunTy naturalPrimTy [Right byteArrayPrimTy]
, dcUnivTyVars = []
, dcExtTyVars = []
, dcArgTys = [byteArrayPrimTy]
, dcArgStrict = [Strict]
, dcFieldLabels = []
}
rhs = DataTyCon [nsDc,nbDc]
in
AlgTyCon uniq name liftedTypeKind 0 rhs False
charPrimTc = liftedPrimTC charPrimTyConName
stringPrimTc = liftedPrimTC stringPrimTyConName
wordPrimTc = liftedPrimTC wordPrimTyConName
int64PrimTc = liftedPrimTC int64PrimTyConName
word64PrimTc = liftedPrimTC word64PrimTyConName
floatPrimTc = liftedPrimTC floatPrimTyConName
doublePrimTc = liftedPrimTC doublePrimTyConName
byteArrayPrimTc = liftedPrimTC byteArrayPrimTyConName
int8PrimTc, int16PrimTc, int32PrimTc, word8PrimTc, word16PrimTc,
word32PrimTc :: TyCon
int8PrimTc = liftedPrimTC int8PrimTyConName
int16PrimTc = liftedPrimTC int16PrimTyConName
int32PrimTc = liftedPrimTC int32PrimTyConName
word8PrimTc = liftedPrimTC word8PrimTyConName
word16PrimTc = liftedPrimTC word16PrimTyConName
word32PrimTc = liftedPrimTC word32PrimTyConName
eqPrimTc :: TyCon
eqPrimTc = PrimTyCon (nameUniq eqPrimTyConName) eqPrimTyConName ty 4
where
-- forall (a :: Type). forall (b :: Type). a -> b -> Type
--
-- The "real" type for this in GHC has a codomain of `TYPE ('TupleRep '[])`
-- instead of the `TYPE 'LiftedRep` used here.
ty = mkPolyFunTy liftedTypeKind
[Left aTv, Left bTv, Right (VarTy aTv), Right (VarTy bTv)]
aTv = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0)
bTv = mkTyVar liftedTypeKind (mkUnsafeSystemName "b" 1)
intPrimTy, integerPrimTy, charPrimTy, stringPrimTy, wordPrimTy,
int64PrimTy, word64PrimTy, floatPrimTy, doublePrimTy, naturalPrimTy,
byteArrayPrimTy, eqPrimTy :: Type
intPrimTy = mkTyConTy intPrimTyConName
integerPrimTy = mkTyConTy integerPrimTyConName
charPrimTy = mkTyConTy charPrimTyConName
stringPrimTy = mkTyConTy stringPrimTyConName
wordPrimTy = mkTyConTy wordPrimTyConName
int64PrimTy = mkTyConTy int64PrimTyConName
word64PrimTy = mkTyConTy word64PrimTyConName
floatPrimTy = mkTyConTy floatPrimTyConName
doublePrimTy = mkTyConTy doublePrimTyConName
naturalPrimTy = mkTyConTy naturalPrimTyConName
byteArrayPrimTy = mkTyConTy byteArrayPrimTyConName
eqPrimTy = mkTyConTy eqPrimTyConName
int8PrimTy, int16PrimTy, int32PrimTy, word8PrimTy, word16PrimTy,
word32PrimTy :: Type
int8PrimTy = mkTyConTy int8PrimTyConName
int16PrimTy = mkTyConTy int16PrimTyConName
int32PrimTy = mkTyConTy int32PrimTyConName
word8PrimTy = mkTyConTy word8PrimTyConName
word16PrimTy = mkTyConTy word16PrimTyConName
word32PrimTy = mkTyConTy word32PrimTyConName
tysPrimMap :: TyConMap
tysPrimMap = UniqMap.fromList
[ (liftedTypeKindTyConName , liftedTypeKindTc)
, (typeNatKindTyConName , typeNatKindTc)
, (typeSymbolKindTyConName , typeSymbolKindTc)
, (intPrimTyConName , intPrimTc)
, (integerPrimTyConName , integerPrimTc)
, (charPrimTyConName , charPrimTc)
, (stringPrimTyConName , stringPrimTc)
, (wordPrimTyConName , wordPrimTc)
, (int64PrimTyConName , int64PrimTc)
, (word64PrimTyConName , word64PrimTc)
, (int8PrimTyConName , int8PrimTc)
, (int16PrimTyConName , int16PrimTc)
, (int32PrimTyConName , int32PrimTc)
, (word8PrimTyConName , word8PrimTc)
, (word16PrimTyConName , word16PrimTc)
, (word32PrimTyConName , word32PrimTc)
, (floatPrimTyConName , floatPrimTc)
, (doublePrimTyConName , doublePrimTc)
, (naturalPrimTyConName , naturalPrimTc)
, (byteArrayPrimTyConName , byteArrayPrimTc)
, (eqPrimTyConName , eqPrimTc)
]