{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings    #-}

-- | Core utils
module GHC.StgToJS.CoreUtils where

import GHC.Prelude

import GHC.JS.Syntax

import GHC.StgToJS.Types

import GHC.Stg.Syntax

import GHC.Tc.Utils.TcType

import GHC.Builtin.Types
import GHC.Builtin.Types.Prim

import GHC.Core.DataCon
import GHC.Core.TyCo.Rep
import GHC.Core.TyCon
import GHC.Core.Type

import GHC.Types.RepType
import GHC.Types.Var
import GHC.Types.Id

import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic

import qualified Data.Bits as Bits

-- | can we unbox C x to x, only if x is represented as a Number
isUnboxableCon :: DataCon -> Bool
isUnboxableCon :: DataCon -> Bool
isUnboxableCon DataCon
dc
  | [Scaled Type
t] <- DataCon -> [Scaled Type]
dataConRepArgTys DataCon
dc
  , [VarType
t1] <- (() :: Constraint) => Type -> [VarType]
Type -> [VarType]
typeVt (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
t)
  = VarType -> Bool
isUnboxable VarType
t1 Bool -> Bool -> Bool
&&
    DataCon -> Int
dataConTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&&
    [DataCon] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TyCon -> [DataCon]
tyConDataCons (TyCon -> [DataCon]) -> TyCon -> [DataCon]
forall a b. (a -> b) -> a -> b
$ DataCon -> TyCon
dataConTyCon DataCon
dc) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
  | Bool
otherwise = Bool
False

-- | one-constructor types with one primitive field represented as a JS Number
-- can be unboxed
isUnboxable :: VarType -> Bool
isUnboxable :: VarType -> Bool
isUnboxable VarType
DoubleV = Bool
True
isUnboxable VarType
IntV    = Bool
True -- includes Char#
isUnboxable VarType
_       = Bool
False

-- | Number of slots occupied by a PrimRep
data SlotCount
  = NoSlot
  | OneSlot
  | TwoSlots
  deriving (Int -> SlotCount -> ShowS
[SlotCount] -> ShowS
SlotCount -> String
(Int -> SlotCount -> ShowS)
-> (SlotCount -> String)
-> ([SlotCount] -> ShowS)
-> Show SlotCount
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SlotCount -> ShowS
showsPrec :: Int -> SlotCount -> ShowS
$cshow :: SlotCount -> String
show :: SlotCount -> String
$cshowList :: [SlotCount] -> ShowS
showList :: [SlotCount] -> ShowS
Show,SlotCount -> SlotCount -> Bool
(SlotCount -> SlotCount -> Bool)
-> (SlotCount -> SlotCount -> Bool) -> Eq SlotCount
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SlotCount -> SlotCount -> Bool
== :: SlotCount -> SlotCount -> Bool
$c/= :: SlotCount -> SlotCount -> Bool
/= :: SlotCount -> SlotCount -> Bool
Eq,Eq SlotCount
Eq SlotCount =>
(SlotCount -> SlotCount -> Ordering)
-> (SlotCount -> SlotCount -> Bool)
-> (SlotCount -> SlotCount -> Bool)
-> (SlotCount -> SlotCount -> Bool)
-> (SlotCount -> SlotCount -> Bool)
-> (SlotCount -> SlotCount -> SlotCount)
-> (SlotCount -> SlotCount -> SlotCount)
-> Ord SlotCount
SlotCount -> SlotCount -> Bool
SlotCount -> SlotCount -> Ordering
SlotCount -> SlotCount -> SlotCount
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SlotCount -> SlotCount -> Ordering
compare :: SlotCount -> SlotCount -> Ordering
$c< :: SlotCount -> SlotCount -> Bool
< :: SlotCount -> SlotCount -> Bool
$c<= :: SlotCount -> SlotCount -> Bool
<= :: SlotCount -> SlotCount -> Bool
$c> :: SlotCount -> SlotCount -> Bool
> :: SlotCount -> SlotCount -> Bool
$c>= :: SlotCount -> SlotCount -> Bool
>= :: SlotCount -> SlotCount -> Bool
$cmax :: SlotCount -> SlotCount -> SlotCount
max :: SlotCount -> SlotCount -> SlotCount
$cmin :: SlotCount -> SlotCount -> SlotCount
min :: SlotCount -> SlotCount -> SlotCount
Ord)

instance Outputable SlotCount where
  ppr :: SlotCount -> SDoc
ppr = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> (SlotCount -> String) -> SlotCount -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotCount -> String
forall a. Show a => a -> String
show

-- | Return SlotCount as an Int
slotCount :: SlotCount -> Int
slotCount :: SlotCount -> Int
slotCount = \case
  SlotCount
NoSlot   -> Int
0
  SlotCount
OneSlot  -> Int
1
  SlotCount
TwoSlots -> Int
2


-- | Number of slots occupied by a value with the given VarType
varSize :: VarType -> Int
varSize :: VarType -> Int
varSize = SlotCount -> Int
slotCount (SlotCount -> Int) -> (VarType -> SlotCount) -> VarType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarType -> SlotCount
varSlotCount

varSlotCount :: VarType -> SlotCount
varSlotCount :: VarType -> SlotCount
varSlotCount VarType
VoidV = SlotCount
NoSlot
varSlotCount VarType
LongV = SlotCount
TwoSlots -- hi, low
varSlotCount VarType
AddrV = SlotCount
TwoSlots -- obj/array, offset
varSlotCount VarType
_     = SlotCount
OneSlot

typeSize :: Type -> Int
typeSize :: Type -> Int
typeSize Type
t = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> (Type -> [Int]) -> Type -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VarType -> Int) -> [VarType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map VarType -> Int
varSize ([VarType] -> [Int]) -> (Type -> [VarType]) -> Type -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => Type -> [VarType]
Type -> [VarType]
typeVt (Type -> Int) -> Type -> Int
forall a b. (a -> b) -> a -> b
$ Type
t

isVoid :: VarType -> Bool
isVoid :: VarType -> Bool
isVoid VarType
VoidV = Bool
True
isVoid VarType
_     = Bool
False

isPtr :: VarType -> Bool
isPtr :: VarType -> Bool
isPtr VarType
PtrV = Bool
True
isPtr VarType
_    = Bool
False

isSingleVar :: VarType -> Bool
isSingleVar :: VarType -> Bool
isSingleVar VarType
v = VarType -> SlotCount
varSlotCount VarType
v SlotCount -> SlotCount -> Bool
forall a. Eq a => a -> a -> Bool
== SlotCount
OneSlot

isMultiVar :: VarType -> Bool
isMultiVar :: VarType -> Bool
isMultiVar VarType
v = case VarType -> SlotCount
varSlotCount VarType
v of
  SlotCount
NoSlot   -> Bool
False
  SlotCount
OneSlot  -> Bool
False
  SlotCount
TwoSlots -> Bool
True

-- | can we pattern match on these values in a case?
isMatchable :: [VarType] -> Bool
isMatchable :: [VarType] -> Bool
isMatchable [VarType
DoubleV] = Bool
True
isMatchable [VarType
IntV]    = Bool
True
isMatchable [VarType]
_         = Bool
False

tyConVt :: HasDebugCallStack => TyCon -> [VarType]
tyConVt :: (() :: Constraint) => TyCon -> [VarType]
tyConVt = (() :: Constraint) => Type -> [VarType]
Type -> [VarType]
typeVt (Type -> [VarType]) -> (TyCon -> Type) -> TyCon -> [VarType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Type
mkTyConTy

idVt :: HasDebugCallStack => Id -> [VarType]
idVt :: (() :: Constraint) => Id -> [VarType]
idVt = (() :: Constraint) => Type -> [VarType]
Type -> [VarType]
typeVt (Type -> [VarType]) -> (Id -> Type) -> Id -> [VarType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType

typeVt :: HasDebugCallStack => Type -> [VarType]
typeVt :: (() :: Constraint) => Type -> [VarType]
typeVt Type
t | Type -> Bool
isRuntimeRepKindedTy Type
t = []
typeVt Type
t = (PrimRep -> VarType) -> [PrimRep] -> [VarType]
forall a b. (a -> b) -> [a] -> [b]
map (() :: Constraint) => PrimRep -> VarType
PrimRep -> VarType
primRepVt ((() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
t)-- map uTypeVt (repTypeArgs t)

-- only use if you know it's not an unboxed tuple
uTypeVt :: HasDebugCallStack => UnaryType -> VarType
uTypeVt :: (() :: Constraint) => Type -> VarType
uTypeVt Type
ut
  | Type -> Bool
isRuntimeRepKindedTy Type
ut = VarType
VoidV
--  | isRuntimeRepTy ut = VoidV
  -- GHC panics on this otherwise
  | Just (TyCon
tc, [Type]
ty_args) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ut
  , [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ty_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= TyCon -> Int
tyConArity TyCon
tc = VarType
PtrV
  | Type -> Bool
isPrimitiveType Type
ut = ((() :: Constraint) => Type -> VarType
Type -> VarType
primTypeVt Type
ut)
  | Bool
otherwise          =
    case (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep' Type
ut of
      []   -> VarType
VoidV
      [PrimRep
pt] -> (() :: Constraint) => PrimRep -> VarType
PrimRep -> VarType
primRepVt PrimRep
pt
      [PrimRep]
_    -> String -> SDoc -> VarType
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"uTypeVt: not unary" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ut)

primRepVt :: HasDebugCallStack => PrimRep -> VarType
primRepVt :: (() :: Constraint) => PrimRep -> VarType
primRepVt PrimRep
VoidRep     = VarType
VoidV
primRepVt PrimRep
LiftedRep   = VarType
PtrV -- fixme does ByteArray# ever map to this?
primRepVt PrimRep
UnliftedRep = VarType
RtsObjV
primRepVt PrimRep
IntRep      = VarType
IntV
primRepVt PrimRep
Int8Rep     = VarType
IntV
primRepVt PrimRep
Int16Rep    = VarType
IntV
primRepVt PrimRep
Int32Rep    = VarType
IntV
primRepVt PrimRep
WordRep     = VarType
IntV
primRepVt PrimRep
Word8Rep    = VarType
IntV
primRepVt PrimRep
Word16Rep   = VarType
IntV
primRepVt PrimRep
Word32Rep   = VarType
IntV
primRepVt PrimRep
Int64Rep    = VarType
LongV
primRepVt PrimRep
Word64Rep   = VarType
LongV
primRepVt PrimRep
AddrRep     = VarType
AddrV
primRepVt PrimRep
FloatRep    = VarType
DoubleV
primRepVt PrimRep
DoubleRep   = VarType
DoubleV
primRepVt (VecRep{})  = String -> VarType
forall a. HasCallStack => String -> a
error String
"uTypeVt: vector types are unsupported"

typePrimRep' :: HasDebugCallStack => UnaryType -> [PrimRep]
typePrimRep' :: (() :: Constraint) => Type -> [PrimRep]
typePrimRep' Type
ty = (() :: Constraint) => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
kindPrimRep' SDoc
forall doc. IsOutput doc => doc
empty ((() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty)

-- | Find the primitive representation of a 'TyCon'. Defined here to
-- avoid module loops. Call this only on unlifted tycons.
tyConPrimRep' :: HasDebugCallStack => TyCon -> [PrimRep]
tyConPrimRep' :: (() :: Constraint) => TyCon -> [PrimRep]
tyConPrimRep' TyCon
tc = (() :: Constraint) => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
kindPrimRep' SDoc
forall doc. IsOutput doc => doc
empty Type
res_kind
  where
    res_kind :: Type
res_kind = TyCon -> Type
tyConResKind TyCon
tc

-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's
-- of values of types of this kind.
kindPrimRep' :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]
kindPrimRep' :: (() :: Constraint) => SDoc -> Type -> [PrimRep]
kindPrimRep' SDoc
doc Type
ki
  | Just Type
ki' <- Type -> Maybe Type
coreView Type
ki
  = (() :: Constraint) => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
kindPrimRep' SDoc
doc Type
ki'
kindPrimRep' SDoc
doc (TyConApp TyCon
_typ [Type
runtime_rep])
  = -- ASSERT( typ `hasKey` tYPETyConKey )
    (() :: Constraint) => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
runtimeRepPrimRep SDoc
doc Type
runtime_rep
kindPrimRep' SDoc
doc Type
ki
  = String -> SDoc -> [PrimRep]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"kindPrimRep'" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ki SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
doc)

primTypeVt :: HasDebugCallStack => Type -> VarType
primTypeVt :: (() :: Constraint) => Type -> VarType
primTypeVt Type
t = case Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Type
unwrapType Type
t) of
  Maybe TyCon
Nothing -> String -> VarType
forall a. HasCallStack => String -> a
error String
"primTypeVt: not a TyCon"
  Just TyCon
tc
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
charPrimTyCon              -> VarType
IntV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
intPrimTyCon               -> VarType
IntV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
wordPrimTyCon              -> VarType
IntV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
floatPrimTyCon             -> VarType
DoubleV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
doublePrimTyCon            -> VarType
DoubleV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int8PrimTyCon              -> VarType
IntV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word8PrimTyCon             -> VarType
IntV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int16PrimTyCon             -> VarType
IntV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word16PrimTyCon            -> VarType
IntV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int32PrimTyCon             -> VarType
IntV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word32PrimTyCon            -> VarType
IntV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
int64PrimTyCon             -> VarType
LongV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
word64PrimTyCon            -> VarType
LongV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
addrPrimTyCon              -> VarType
AddrV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
stablePtrPrimTyCon         -> VarType
AddrV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
stableNamePrimTyCon        -> VarType
RtsObjV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
statePrimTyCon             -> VarType
VoidV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
proxyPrimTyCon             -> VarType
VoidV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
realWorldTyCon             -> VarType
VoidV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
threadIdPrimTyCon          -> VarType
RtsObjV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
weakPrimTyCon              -> VarType
RtsObjV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
arrayPrimTyCon             -> VarType
ArrV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallArrayPrimTyCon        -> VarType
ArrV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon         -> VarType
ObjV -- can contain any JS reference, used for JSVal
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableArrayPrimTyCon      -> VarType
ArrV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallMutableArrayPrimTyCon -> VarType
ArrV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon  -> VarType
ObjV -- can contain any JS reference, used for JSVal
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutVarPrimTyCon            -> VarType
RtsObjV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mVarPrimTyCon              -> VarType
RtsObjV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tVarPrimTyCon              -> VarType
RtsObjV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
bcoPrimTyCon               -> VarType
RtsObjV -- unsupported?
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
stackSnapshotPrimTyCon     -> VarType
RtsObjV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
ioPortPrimTyCon            -> VarType
RtsObjV -- unsupported?
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
anyTyCon                   -> VarType
PtrV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
compactPrimTyCon           -> VarType
ObjV -- unsupported?
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
eqPrimTyCon                -> VarType
VoidV -- coercion token?
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
eqReprPrimTyCon            -> VarType
VoidV -- role
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unboxedUnitTyCon           -> VarType
VoidV -- Void#
    | Bool
otherwise                        -> VarType
PtrV  -- anything else must be some boxed thing

argVt :: StgArg -> VarType
argVt :: StgArg -> VarType
argVt StgArg
a = (() :: Constraint) => Type -> VarType
Type -> VarType
uTypeVt (Type -> VarType) -> (StgArg -> Type) -> StgArg -> VarType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> Type
stgArgType (StgArg -> VarType) -> StgArg -> VarType
forall a b. (a -> b) -> a -> b
$ StgArg
a

dataConType :: DataCon -> Type
dataConType :: DataCon -> Type
dataConType DataCon
dc = Id -> Type
idType (DataCon -> Id
dataConWrapId DataCon
dc)

isBoolDataCon :: DataCon -> Bool
isBoolDataCon :: DataCon -> Bool
isBoolDataCon DataCon
dc = Type -> Bool
isBoolTy (DataCon -> Type
dataConType DataCon
dc)

-- standard fixed layout: payload types
-- payload starts at .d1 for heap objects, entry closest to Sp for stack frames
fixedLayout :: [VarType] -> CILayout
fixedLayout :: [VarType] -> CILayout
fixedLayout [VarType]
vts = Int -> [VarType] -> CILayout
CILayoutFixed ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((VarType -> Int) -> [VarType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map VarType -> Int
varSize [VarType]
vts)) [VarType]
vts

-- 2-var values might have been moved around separately, use DoubleV as substitute
-- ObjV is 1 var, so this is no problem for implicit metadata
stackSlotType :: Id -> VarType
stackSlotType :: Id -> VarType
stackSlotType Id
i
  | SlotCount
OneSlot <- VarType -> SlotCount
varSlotCount VarType
otype = VarType
otype
  | Bool
otherwise                     = VarType
DoubleV
  where otype :: VarType
otype = (() :: Constraint) => Type -> VarType
Type -> VarType
uTypeVt (Id -> Type
idType Id
i)

idPrimReps :: Id -> [PrimRep]
idPrimReps :: Id -> [PrimRep]
idPrimReps = Type -> [PrimRep]
typePrimReps (Type -> [PrimRep]) -> (Id -> Type) -> Id -> [PrimRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType

typePrimReps :: Type -> [PrimRep]
typePrimReps :: Type -> [PrimRep]
typePrimReps = (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Type -> [PrimRep]) -> (Type -> Type) -> Type -> [PrimRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
unwrapType

primRepSize :: PrimRep -> SlotCount
primRepSize :: PrimRep -> SlotCount
primRepSize PrimRep
p = VarType -> SlotCount
varSlotCount ((() :: Constraint) => PrimRep -> VarType
PrimRep -> VarType
primRepVt PrimRep
p)

-- | Associate the given values to each RrimRep in the given order, taking into
-- account the number of slots per PrimRep
assocPrimReps :: Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])]
assocPrimReps :: forall a. Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])]
assocPrimReps []     [a]
_  = []
assocPrimReps (PrimRep
r:[PrimRep]
rs) [a]
vs = case (PrimRep -> SlotCount
primRepSize PrimRep
r,[a]
vs) of
  (SlotCount
NoSlot,   [a]
xs)     -> (PrimRep
r,[])    (PrimRep, [a]) -> [(PrimRep, [a])] -> [(PrimRep, [a])]
forall a. a -> [a] -> [a]
: [PrimRep] -> [a] -> [(PrimRep, [a])]
forall a. Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])]
assocPrimReps [PrimRep]
rs [a]
xs
  (SlotCount
OneSlot,  a
x:[a]
xs)   -> (PrimRep
r,[a
x])   (PrimRep, [a]) -> [(PrimRep, [a])] -> [(PrimRep, [a])]
forall a. a -> [a] -> [a]
: [PrimRep] -> [a] -> [(PrimRep, [a])]
forall a. Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])]
assocPrimReps [PrimRep]
rs [a]
xs
  (SlotCount
TwoSlots, a
x:a
y:[a]
xs) -> (PrimRep
r,[a
x,a
y]) (PrimRep, [a]) -> [(PrimRep, [a])] -> [(PrimRep, [a])]
forall a. a -> [a] -> [a]
: [PrimRep] -> [a] -> [(PrimRep, [a])]
forall a. Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])]
assocPrimReps [PrimRep]
rs [a]
xs
  (SlotCount, [a])
err                -> String -> SDoc -> [(PrimRep, [a])]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"assocPrimReps" ((SlotCount, [a]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SlotCount, [a])
err)

-- | Associate the given values to the Id's PrimReps, taking into account the
-- number of slots per PrimRep
assocIdPrimReps :: Outputable a => Id -> [a] -> [(PrimRep, [a])]
assocIdPrimReps :: forall a. Outputable a => Id -> [a] -> [(PrimRep, [a])]
assocIdPrimReps Id
i = [PrimRep] -> [a] -> [(PrimRep, [a])]
forall a. Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])]
assocPrimReps (Id -> [PrimRep]
idPrimReps Id
i)

-- | Associate the given JExpr to the Id's PrimReps, taking into account the
-- number of slots per PrimRep
assocIdExprs :: Id -> [JExpr] -> [TypedExpr]
assocIdExprs :: Id -> [JExpr] -> [TypedExpr]
assocIdExprs Id
i [JExpr]
es = ((PrimRep, [JExpr]) -> TypedExpr)
-> [(PrimRep, [JExpr])] -> [TypedExpr]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PrimRep -> [JExpr] -> TypedExpr)
-> (PrimRep, [JExpr]) -> TypedExpr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PrimRep -> [JExpr] -> TypedExpr
TypedExpr) (Id -> [JExpr] -> [(PrimRep, [JExpr])]
forall a. Outputable a => Id -> [a] -> [(PrimRep, [a])]
assocIdPrimReps Id
i [JExpr]
es)

-- | Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as possible
might_be_a_function :: HasDebugCallStack => Type -> Bool
might_be_a_function :: (() :: Constraint) => Type -> Bool
might_be_a_function Type
ty
  | [PrimRep
LiftedRep] <- (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty
  , Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Type
unwrapType Type
ty)
  , TyCon -> Bool
isDataTyCon TyCon
tc
  = Bool
False
  | Bool
otherwise
  = Bool
True

mkArityTag :: Int -> Int -> Int
mkArityTag :: Int -> Int -> Int
mkArityTag Int
arity Int
registers = Int
arity Int -> Int -> Int
forall a. Bits a => a -> a -> a
Bits..|. (Int
registers Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`Bits.shiftL` Int
8)

toTypeList :: [VarType] -> [Int]
toTypeList :: [VarType] -> [Int]
toTypeList = (VarType -> [Int]) -> [VarType] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\VarType
x -> Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate (VarType -> Int
varSize VarType
x) (VarType -> Int
forall a. Enum a => a -> Int
fromEnum VarType
x))