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

module GHC.StgToJS.Utils
  ( assignToTypedExprs
  , assignCoerce1
  , assignToExprCtx
  -- * Core Utils
  , isUnboxableCon
  , isUnboxable
  , SlotCount(..)
  , slotCount
  , varSize
  , varSlotCount
  , typeSize
  , isVoid
  , isPtr
  , isSingleVar
  , isMultiVar
  , isMatchable
  , tyConVt
  , idVt
  , typeVt
  , uTypeVt
  , primRepVt
  , typePrimRep'
  , tyConPrimRep'
  , kindPrimRep'
  , primTypeVt
  , argVt
  , dataConType
  , isBoolDataCon
  , fixedLayout
  , stackSlotType
  , idPrimReps
  , typePrimReps
  , primRepSize
  , assocPrimReps
  , assocIdPrimReps
  , assocIdExprs
  , mkArityTag
  , toTypeList
  -- * Stg Utils
  , bindingRefs
  , rhsRefs
  , exprRefs
  , altRefs
  , argRefs
  , hasExport
  , collectTopIds
  , collectIds
  , removeTick
  , LiveVars
  , liveStatic
  , liveVars
  , stgTopBindLive
  , stgBindLive
  , stgBindRhsLive
  , stgRhsLive
  , stgArgLive
  , stgExprLive
  , stgAltLive
  , stgLetNoEscapeLive
  , bindees
  , isUpdatableRhs
  , stgLneLive
  , stgLneLive'
  , stgLneLiveExpr
  , isInlineExpr
  , inspectInlineBinding
  , inspectInlineRhs
  , isInlineForeignCall
  , isInlineApp
  ) where

import GHC.Prelude

import GHC.StgToJS.Types
import GHC.StgToJS.ExprCtx

import GHC.JS.Unsat.Syntax
import GHC.JS.Make
import GHC.JS.Transform

import GHC.Core.DataCon
import GHC.Core.TyCo.Rep hiding (typeSize)
import GHC.Core.TyCon
import GHC.Core.Type hiding (typeSize)

import GHC.Stg.Syntax

import GHC.Tc.Utils.TcType

import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Builtin.Names
import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline)

import GHC.Types.RepType
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Types.ForeignCall
import GHC.Types.TyThing
import GHC.Types.Name

import GHC.Utils.Misc
import GHC.Utils.Outputable hiding ((<>))
import GHC.Utils.Panic

import qualified Data.Bits as Bits
import qualified Data.Foldable as F
import qualified Data.Set      as S
import qualified Data.List     as L
import Data.Set (Set)
import Data.Monoid


assignToTypedExprs :: [TypedExpr] -> [JExpr] -> JStat
assignToTypedExprs :: [TypedExpr] -> [JExpr] -> JStat
assignToTypedExprs [TypedExpr]
tes [JExpr]
es =
  [JExpr] -> [JExpr] -> JStat
HasDebugCallStack => [JExpr] -> [JExpr] -> JStat
assignAllEqual ((TypedExpr -> [JExpr]) -> [TypedExpr] -> [JExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr [TypedExpr]
tes) [JExpr]
es

assignTypedExprs :: [TypedExpr] -> [TypedExpr] -> JStat
assignTypedExprs :: [TypedExpr] -> [TypedExpr] -> JStat
assignTypedExprs [TypedExpr]
tes [TypedExpr]
es =
  -- TODO: check primRep (typex_typ) here?
  [TypedExpr] -> [JExpr] -> JStat
assignToTypedExprs [TypedExpr]
tes ((TypedExpr -> [JExpr]) -> [TypedExpr] -> [JExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr [TypedExpr]
es)

assignToExprCtx :: ExprCtx -> [JExpr] -> JStat
assignToExprCtx :: ExprCtx -> [JExpr] -> JStat
assignToExprCtx ExprCtx
ctx [JExpr]
es = [TypedExpr] -> [JExpr] -> JStat
assignToTypedExprs (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) [JExpr]
es

-- | Assign first expr only (if it exists), performing coercions between some
-- PrimReps (e.g. StablePtr# and Addr#).
assignCoerce1 :: [TypedExpr] -> [TypedExpr] -> JStat
assignCoerce1 :: [TypedExpr] -> [TypedExpr] -> JStat
assignCoerce1 [TypedExpr
x] [TypedExpr
y] = TypedExpr -> TypedExpr -> JStat
assignCoerce TypedExpr
x TypedExpr
y
assignCoerce1 []  []  = JStat
forall a. Monoid a => a
mempty
assignCoerce1 [TypedExpr]
_x [TypedExpr]
_y   = String -> SDoc -> JStat
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"assignCoerce1"
                          ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"lengths do not match"
                                -- FIXME: Outputable instance removed until JStg replaces JStat
                                -- , ppr x
                                -- , ppr y
                                ])

-- | Assign p2 to p1 with optional coercion
assignCoerce :: TypedExpr -> TypedExpr -> JStat
-- Coercion between StablePtr# and Addr#
assignCoerce :: TypedExpr -> TypedExpr -> JStat
assignCoerce (TypedExpr PrimRep
AddrRep [JExpr
a_val, JExpr
a_off]) (TypedExpr (BoxedRep (Just Levity
Unlifted)) [JExpr
sptr]) = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
    [ JExpr
a_val JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$stablePtrBuf"
    , JExpr
a_off JExpr -> JExpr -> JStat
|= JExpr
sptr
    ]
assignCoerce (TypedExpr (BoxedRep (Just Levity
Unlifted)) [JExpr
sptr]) (TypedExpr PrimRep
AddrRep [JExpr
_a_val, JExpr
a_off]) =
  JExpr
sptr JExpr -> JExpr -> JStat
|= JExpr
a_off
assignCoerce TypedExpr
p1 TypedExpr
p2 = [TypedExpr] -> [TypedExpr] -> JStat
assignTypedExprs [TypedExpr
p1] [TypedExpr
p2]


--------------------------------------------------------------------------------
--                        Core Utils
--------------------------------------------------------------------------------

-- | 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] <- HasDebugCallStack => 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
. HasDebugCallStack => 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 :: HasDebugCallStack => TyCon -> [VarType]
tyConVt = HasDebugCallStack => 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 :: HasDebugCallStack => Id -> [VarType]
idVt = HasDebugCallStack => 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 :: HasDebugCallStack => 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 HasDebugCallStack => PrimRep -> VarType
PrimRep -> VarType
primRepVt (HasDebugCallStack => 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 :: HasDebugCallStack => 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) <- HasDebugCallStack => 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 = (HasDebugCallStack => Type -> VarType
Type -> VarType
primTypeVt Type
ut)
  | Bool
otherwise          =
    case HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep' Type
ut of
      []   -> VarType
VoidV
      [PrimRep
pt] -> HasDebugCallStack => 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 :: HasDebugCallStack => PrimRep -> VarType
primRepVt PrimRep
VoidRep     = VarType
VoidV
primRepVt (BoxedRep Maybe Levity
_) = VarType
PtrV -- fixme does ByteArray# ever map to this?
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' :: HasDebugCallStack => Type -> [PrimRep]
typePrimRep' Type
ty = HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
kindPrimRep' SDoc
forall doc. IsOutput doc => doc
empty (HasDebugCallStack => 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' :: HasDebugCallStack => TyCon -> [PrimRep]
tyConPrimRep' TyCon
tc = HasDebugCallStack => 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' :: HasDebugCallStack => SDoc -> Type -> [PrimRep]
kindPrimRep' SDoc
doc Type
ki
  | Just Type
ki' <- Type -> Maybe Type
coreView Type
ki
  = HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
kindPrimRep' SDoc
doc Type
ki'
kindPrimRep' SDoc
doc (TyConApp TyCon
_typ [Type
runtime_rep])
  = -- ASSERT( typ `hasKey` tYPETyConKey )
    HasDebugCallStack => 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 :: HasDebugCallStack => 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
PtrV
    | 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
PtrV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
weakPrimTyCon              -> VarType
PtrV
    | 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
PtrV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mVarPrimTyCon              -> VarType
PtrV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tVarPrimTyCon              -> VarType
PtrV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
bcoPrimTyCon               -> VarType
PtrV -- unsupported?
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
stackSnapshotPrimTyCon     -> VarType
PtrV
    | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
ioPortPrimTyCon            -> VarType
PtrV -- 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
PtrV -- 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 = HasDebugCallStack => 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 = HasDebugCallStack => 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 = HasDebugCallStack => 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 (HasDebugCallStack => 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 :: [PrimRep] -> [JExpr] -> [(PrimRep, [JExpr])]
assocPrimReps :: [PrimRep] -> [JExpr] -> [(PrimRep, [JExpr])]
assocPrimReps []     [JExpr]
_  = []
assocPrimReps (PrimRep
r:[PrimRep]
rs) [JExpr]
vs = case (PrimRep -> SlotCount
primRepSize PrimRep
r,[JExpr]
vs) of
  (SlotCount
NoSlot,   [JExpr]
xs)     -> (PrimRep
r,[])    (PrimRep, [JExpr]) -> [(PrimRep, [JExpr])] -> [(PrimRep, [JExpr])]
forall a. a -> [a] -> [a]
: [PrimRep] -> [JExpr] -> [(PrimRep, [JExpr])]
assocPrimReps [PrimRep]
rs [JExpr]
xs
  (SlotCount
OneSlot,  JExpr
x:[JExpr]
xs)   -> (PrimRep
r,[JExpr
x])   (PrimRep, [JExpr]) -> [(PrimRep, [JExpr])] -> [(PrimRep, [JExpr])]
forall a. a -> [a] -> [a]
: [PrimRep] -> [JExpr] -> [(PrimRep, [JExpr])]
assocPrimReps [PrimRep]
rs [JExpr]
xs
  (SlotCount
TwoSlots, JExpr
x:JExpr
y:[JExpr]
xs) -> (PrimRep
r,[JExpr
x,JExpr
y]) (PrimRep, [JExpr]) -> [(PrimRep, [JExpr])] -> [(PrimRep, [JExpr])]
forall a. a -> [a] -> [a]
: [PrimRep] -> [JExpr] -> [(PrimRep, [JExpr])]
assocPrimReps [PrimRep]
rs [JExpr]
xs
  (SlotCount, [JExpr])
err                -> String -> SDoc -> [(PrimRep, [JExpr])]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"assocPrimReps" ((SlotCount, [JExpr]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((SlotCount, [JExpr]) -> SDoc) -> (SlotCount, [JExpr]) -> SDoc
forall a b. (a -> b) -> a -> b
$ (JExpr -> JExpr) -> [JExpr] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe FastString -> JExpr -> JExpr
satJExpr Maybe FastString
forall a. Maybe a
Nothing) ([JExpr] -> [JExpr])
-> (SlotCount, [JExpr]) -> (SlotCount, [JExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SlotCount, [JExpr])
err)

-- | Associate the given values to the Id's PrimReps, taking into account the
-- number of slots per PrimRep
assocIdPrimReps :: Id -> [JExpr] -> [(PrimRep, [JExpr])]
assocIdPrimReps :: Id -> [JExpr] -> [(PrimRep, [JExpr])]
assocIdPrimReps Id
i = [PrimRep] -> [JExpr] -> [(PrimRep, [JExpr])]
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])]
assocIdPrimReps Id
i [JExpr]
es)

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))

--------------------------------------------------------------------------------
--                        Stg Utils
--------------------------------------------------------------------------------

s :: a -> Set a
s :: forall a. a -> Set a
s = a -> Set a
forall a. a -> Set a
S.singleton

l :: (a -> Set Id) -> [a] -> Set Id
l :: forall a. (a -> Set Id) -> [a] -> Set Id
l = (a -> Set Id) -> [a] -> Set Id
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap

-- | collect Ids that this binding refers to
--   (does not include the bindees themselves)
-- first argument is Id -> StgExpr map for unfloated arguments
bindingRefs :: UniqFM Id CgStgExpr -> CgStgBinding -> Set Id
bindingRefs :: UniqFM Id CgStgExpr -> CgStgBinding -> Set Id
bindingRefs UniqFM Id CgStgExpr
u = \case
  StgNonRec BinderP 'CodeGen
_ GenStgRhs 'CodeGen
rhs -> UniqFM Id CgStgExpr -> GenStgRhs 'CodeGen -> Set Id
rhsRefs UniqFM Id CgStgExpr
u GenStgRhs 'CodeGen
rhs
  StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs       -> ((Id, GenStgRhs 'CodeGen) -> Set Id)
-> [(Id, GenStgRhs 'CodeGen)] -> Set Id
forall a. (a -> Set Id) -> [a] -> Set Id
l (UniqFM Id CgStgExpr -> GenStgRhs 'CodeGen -> Set Id
rhsRefs UniqFM Id CgStgExpr
u (GenStgRhs 'CodeGen -> Set Id)
-> ((Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen)
-> (Id, GenStgRhs 'CodeGen)
-> Set Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen
forall a b. (a, b) -> b
snd) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs

rhsRefs :: UniqFM Id CgStgExpr -> CgStgRhs -> Set Id
rhsRefs :: UniqFM Id CgStgExpr -> GenStgRhs 'CodeGen -> Set Id
rhsRefs UniqFM Id CgStgExpr
u = \case
  StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ UpdateFlag
_ [BinderP 'CodeGen]
_ CgStgExpr
body Type
_       -> UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u CgStgExpr
body
  StgRhsCon CostCentreStack
_ccs DataCon
d ConstructorNumber
_mu [StgTickish]
_ticks [StgArg]
args Type
_ -> (Id -> Set Id) -> [Id] -> Set Id
forall a. (a -> Set Id) -> [a] -> Set Id
l Id -> Set Id
forall a. a -> Set a
s [ Id
i | AnId Id
i <- DataCon -> [TyThing]
dataConImplicitTyThings DataCon
d] Set Id -> Set Id -> Set Id
forall a. Semigroup a => a -> a -> a
<> (StgArg -> Set Id) -> [StgArg] -> Set Id
forall a. (a -> Set Id) -> [a] -> Set Id
l (UniqFM Id CgStgExpr -> StgArg -> Set Id
argRefs UniqFM Id CgStgExpr
u) [StgArg]
args

exprRefs :: UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs :: UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u = \case
  StgApp Id
f [StgArg]
args             -> Id -> Set Id
forall a. a -> Set a
s Id
f Set Id -> Set Id -> Set Id
forall a. Semigroup a => a -> a -> a
<> (StgArg -> Set Id) -> [StgArg] -> Set Id
forall a. (a -> Set Id) -> [a] -> Set Id
l (UniqFM Id CgStgExpr -> StgArg -> Set Id
argRefs UniqFM Id CgStgExpr
u) [StgArg]
args
  StgConApp DataCon
d ConstructorNumber
_n [StgArg]
args [Type]
_     -> (Id -> Set Id) -> [Id] -> Set Id
forall a. (a -> Set Id) -> [a] -> Set Id
l Id -> Set Id
forall a. a -> Set a
s [ Id
i | AnId Id
i <- DataCon -> [TyThing]
dataConImplicitTyThings DataCon
d] Set Id -> Set Id -> Set Id
forall a. Semigroup a => a -> a -> a
<> (StgArg -> Set Id) -> [StgArg] -> Set Id
forall a. (a -> Set Id) -> [a] -> Set Id
l (UniqFM Id CgStgExpr -> StgArg -> Set Id
argRefs UniqFM Id CgStgExpr
u) [StgArg]
args
  StgOpApp StgOp
_ [StgArg]
args Type
_         -> (StgArg -> Set Id) -> [StgArg] -> Set Id
forall a. (a -> Set Id) -> [a] -> Set Id
l (UniqFM Id CgStgExpr -> StgArg -> Set Id
argRefs UniqFM Id CgStgExpr
u) [StgArg]
args
  StgLit {}                 -> Set Id
forall a. Monoid a => a
mempty
  StgCase CgStgExpr
expr BinderP 'CodeGen
_ AltType
_ [GenStgAlt 'CodeGen]
alts     -> UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u CgStgExpr
expr Set Id -> Set Id -> Set Id
forall a. Semigroup a => a -> a -> a
<> [Set Id] -> Set Id
forall a. Monoid a => [a] -> a
mconcat ((GenStgAlt 'CodeGen -> Set Id) -> [GenStgAlt 'CodeGen] -> [Set Id]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UniqFM Id CgStgExpr -> GenStgAlt 'CodeGen -> Set Id
altRefs UniqFM Id CgStgExpr
u) [GenStgAlt 'CodeGen]
alts)
  StgLet XLet 'CodeGen
_ CgStgBinding
bnd CgStgExpr
expr         -> UniqFM Id CgStgExpr -> CgStgBinding -> Set Id
bindingRefs UniqFM Id CgStgExpr
u CgStgBinding
bnd Set Id -> Set Id -> Set Id
forall a. Semigroup a => a -> a -> a
<> UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u CgStgExpr
expr
  StgLetNoEscape XLetNoEscape 'CodeGen
_ CgStgBinding
bnd CgStgExpr
expr -> UniqFM Id CgStgExpr -> CgStgBinding -> Set Id
bindingRefs UniqFM Id CgStgExpr
u CgStgBinding
bnd Set Id -> Set Id -> Set Id
forall a. Semigroup a => a -> a -> a
<> UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u CgStgExpr
expr
  StgTick StgTickish
_ CgStgExpr
expr            -> UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u CgStgExpr
expr

altRefs :: UniqFM Id CgStgExpr -> CgStgAlt -> Set Id
altRefs :: UniqFM Id CgStgExpr -> GenStgAlt 'CodeGen -> Set Id
altRefs UniqFM Id CgStgExpr
u GenStgAlt 'CodeGen
alt = UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u (GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)

argRefs :: UniqFM Id CgStgExpr -> StgArg -> Set Id
argRefs :: UniqFM Id CgStgExpr -> StgArg -> Set Id
argRefs UniqFM Id CgStgExpr
u = \case
  StgVarArg Id
id
    | Just CgStgExpr
e <- UniqFM Id CgStgExpr -> Id -> Maybe CgStgExpr
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Id CgStgExpr
u Id
id -> UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs UniqFM Id CgStgExpr
u CgStgExpr
e
    | Bool
otherwise                -> Id -> Set Id
forall a. a -> Set a
s Id
id
  StgArg
_ -> Set Id
forall a. Monoid a => a
mempty

hasExport :: CgStgBinding -> Bool
hasExport :: CgStgBinding -> Bool
hasExport CgStgBinding
bnd =
  case CgStgBinding
bnd of
    StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
e -> Id -> GenStgRhs 'CodeGen -> Bool
forall {p} {pass :: StgPass}. p -> GenStgRhs pass -> Bool
isExportedBind Id
BinderP 'CodeGen
b GenStgRhs 'CodeGen
e
    StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs     -> ((Id, GenStgRhs 'CodeGen) -> Bool)
-> [(Id, GenStgRhs 'CodeGen)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Id -> GenStgRhs 'CodeGen -> Bool)
-> (Id, GenStgRhs 'CodeGen) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Id -> GenStgRhs 'CodeGen -> Bool
forall {p} {pass :: StgPass}. p -> GenStgRhs pass -> Bool
isExportedBind) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
  where
    isExportedBind :: p -> GenStgRhs pass -> Bool
isExportedBind p
_i (StgRhsCon CostCentreStack
_cc DataCon
con ConstructorNumber
_ [StgTickish]
_ [StgArg]
_ Type
_) =
      DataCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique DataCon
con Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
staticPtrDataConKey
    isExportedBind p
_ GenStgRhs pass
_ = Bool
False

collectTopIds :: CgStgBinding -> [Id]
collectTopIds :: CgStgBinding -> [Id]
collectTopIds (StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
_) = [Id
BinderP 'CodeGen
b]
collectTopIds (StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs) = let xs :: [Id]
xs = ((Id, GenStgRhs 'CodeGen) -> Id)
-> [(Id, GenStgRhs 'CodeGen)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> Id
zapFragileIdInfo (Id -> Id)
-> ((Id, GenStgRhs 'CodeGen) -> Id)
-> (Id, GenStgRhs 'CodeGen)
-> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, GenStgRhs 'CodeGen) -> Id
forall a b. (a, b) -> a
fst) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs
                            in  [Id] -> Any -> Any
forall a b. [a] -> b -> b
seqList [Id]
xs (Any -> Any) -> [Id] -> [Id]
forall a b. a -> b -> b
`seq` [Id]
xs

collectIds :: UniqFM Id CgStgExpr -> CgStgBinding -> [Id]
collectIds :: UniqFM Id CgStgExpr -> CgStgBinding -> [Id]
collectIds UniqFM Id CgStgExpr
unfloated CgStgBinding
b =
  let xs :: [Id]
xs = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
zapFragileIdInfo ([Id] -> [Id]) -> ([Id] -> [Id]) -> [Id] -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
forall {p}. NamedThing p => p -> Bool
acceptId ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ Set Id -> [Id]
forall a. Set a -> [a]
S.toList (UniqFM Id CgStgExpr -> CgStgBinding -> Set Id
bindingRefs UniqFM Id CgStgExpr
unfloated CgStgBinding
b)
  in  [Id] -> Any -> Any
forall a b. [a] -> b -> b
seqList [Id]
xs (Any -> Any) -> [Id] -> [Id]
forall a b. a -> b -> b
`seq` [Id]
xs
  where
    acceptId :: p -> Bool
acceptId p
i = ((p -> Bool) -> Bool) -> [p -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((p -> Bool) -> p -> Bool
forall a b. (a -> b) -> a -> b
$ p
i) [Bool -> Bool
not (Bool -> Bool) -> (p -> Bool) -> p -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> Bool
forall {p}. NamedThing p => p -> Bool
isForbidden] -- fixme test this: [isExported[isGlobalId, not.isForbidden]
    -- the GHC.Prim module has no js source file
    isForbidden :: a -> Bool
isForbidden a
i
      | Just Module
m <- Name -> Maybe Module
nameModule_maybe (a -> Name
forall a. NamedThing a => a -> Name
getName a
i) = Module
m Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
gHC_PRIM
      | Bool
otherwise = Bool
False

removeTick :: CgStgExpr -> CgStgExpr
removeTick :: CgStgExpr -> CgStgExpr
removeTick (StgTick StgTickish
_ CgStgExpr
e) = CgStgExpr
e
removeTick CgStgExpr
e             = CgStgExpr
e

-----------------------------------------------------
-- Live vars
--
-- TODO: should probably be moved into GHC.Stg.LiveVars

type LiveVars = DVarSet

liveStatic :: LiveVars -> LiveVars
liveStatic :: LiveVars -> LiveVars
liveStatic = (Id -> Bool) -> LiveVars -> LiveVars
filterDVarSet Id -> Bool
isGlobalId

liveVars :: LiveVars -> LiveVars
liveVars :: LiveVars -> LiveVars
liveVars = (Id -> Bool) -> LiveVars -> LiveVars
filterDVarSet (Bool -> Bool
not (Bool -> Bool) -> (Id -> Bool) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Bool
isGlobalId)

stgTopBindLive :: CgStgTopBinding -> [(Id, LiveVars)]
stgTopBindLive :: CgStgTopBinding -> [(Id, LiveVars)]
stgTopBindLive = \case
  StgTopLifted CgStgBinding
b     -> CgStgBinding -> [(Id, LiveVars)]
stgBindLive CgStgBinding
b
  StgTopStringLit {} -> []

stgBindLive :: CgStgBinding -> [(Id, LiveVars)]
stgBindLive :: CgStgBinding -> [(Id, LiveVars)]
stgBindLive = \case
  StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
rhs -> [(Id
BinderP 'CodeGen
b, GenStgRhs 'CodeGen -> LiveVars
stgRhsLive GenStgRhs 'CodeGen
rhs)]
  StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs       -> ((Id, GenStgRhs 'CodeGen) -> (Id, LiveVars))
-> [(Id, GenStgRhs 'CodeGen)] -> [(Id, LiveVars)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
b,GenStgRhs 'CodeGen
rhs) -> (Id
b, GenStgRhs 'CodeGen -> LiveVars
stgRhsLive GenStgRhs 'CodeGen
rhs)) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs

stgBindRhsLive :: CgStgBinding -> LiveVars
stgBindRhsLive :: CgStgBinding -> LiveVars
stgBindRhsLive CgStgBinding
b =
  let ([Id]
bs, [LiveVars]
ls) = [(Id, LiveVars)] -> ([Id], [LiveVars])
forall a b. [(a, b)] -> ([a], [b])
unzip (CgStgBinding -> [(Id, LiveVars)]
stgBindLive CgStgBinding
b)
  in  LiveVars -> [Id] -> LiveVars
delDVarSetList ([LiveVars] -> LiveVars
unionDVarSets [LiveVars]
ls) [Id]
bs

stgRhsLive :: CgStgRhs -> LiveVars
stgRhsLive :: GenStgRhs 'CodeGen -> LiveVars
stgRhsLive = \case
  StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ UpdateFlag
_ [BinderP 'CodeGen]
args CgStgExpr
e Type
_ -> LiveVars -> [Id] -> LiveVars
delDVarSetList (Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
True CgStgExpr
e) [Id]
[BinderP 'CodeGen]
args
  StgRhsCon CostCentreStack
_ DataCon
_ ConstructorNumber
_ [StgTickish]
_ [StgArg]
args Type
_     -> [LiveVars] -> LiveVars
unionDVarSets ((StgArg -> LiveVars) -> [StgArg] -> [LiveVars]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> LiveVars
stgArgLive [StgArg]
args)

stgArgLive :: StgArg -> LiveVars
stgArgLive :: StgArg -> LiveVars
stgArgLive = \case
  StgVarArg Id
occ -> Id -> LiveVars
unitDVarSet Id
occ
  StgLitArg {}  -> LiveVars
emptyDVarSet

stgExprLive :: Bool -> CgStgExpr -> LiveVars
stgExprLive :: Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
includeLHS = \case
  StgApp Id
occ [StgArg]
args -> [LiveVars] -> LiveVars
unionDVarSets (Id -> LiveVars
unitDVarSet Id
occ LiveVars -> [LiveVars] -> [LiveVars]
forall a. a -> [a] -> [a]
: (StgArg -> LiveVars) -> [StgArg] -> [LiveVars]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> LiveVars
stgArgLive [StgArg]
args)
  StgLit {}       -> LiveVars
emptyDVarSet
  StgConApp DataCon
_dc ConstructorNumber
_n [StgArg]
args [Type]
_tys -> [LiveVars] -> LiveVars
unionDVarSets ((StgArg -> LiveVars) -> [StgArg] -> [LiveVars]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> LiveVars
stgArgLive [StgArg]
args)
  StgOpApp StgOp
_op [StgArg]
args Type
_ty      -> [LiveVars] -> LiveVars
unionDVarSets ((StgArg -> LiveVars) -> [StgArg] -> [LiveVars]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> LiveVars
stgArgLive [StgArg]
args)
  StgCase CgStgExpr
e BinderP 'CodeGen
b AltType
_at [GenStgAlt 'CodeGen]
alts
    | Bool
includeLHS -> LiveVars
el LiveVars -> LiveVars -> LiveVars
`unionDVarSet` LiveVars -> Id -> LiveVars
delDVarSet LiveVars
al Id
BinderP 'CodeGen
b
    | Bool
otherwise  -> LiveVars -> Id -> LiveVars
delDVarSet LiveVars
al Id
BinderP 'CodeGen
b
    where
      al :: LiveVars
al = [LiveVars] -> LiveVars
unionDVarSets ((GenStgAlt 'CodeGen -> LiveVars)
-> [GenStgAlt 'CodeGen] -> [LiveVars]
forall a b. (a -> b) -> [a] -> [b]
map GenStgAlt 'CodeGen -> LiveVars
stgAltLive [GenStgAlt 'CodeGen]
alts)
      el :: LiveVars
el = Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
True CgStgExpr
e
  StgLet XLet 'CodeGen
_ CgStgBinding
b CgStgExpr
e         -> LiveVars -> [Id] -> LiveVars
delDVarSetList (CgStgBinding -> LiveVars
stgBindRhsLive CgStgBinding
b LiveVars -> LiveVars -> LiveVars
`unionDVarSet` Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
True CgStgExpr
e) (CgStgBinding -> [Id]
bindees CgStgBinding
b)
  StgLetNoEscape XLetNoEscape 'CodeGen
_ CgStgBinding
b CgStgExpr
e -> LiveVars -> [Id] -> LiveVars
delDVarSetList (CgStgBinding -> LiveVars
stgBindRhsLive CgStgBinding
b LiveVars -> LiveVars -> LiveVars
`unionDVarSet` Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
True CgStgExpr
e) (CgStgBinding -> [Id]
bindees CgStgBinding
b)
  StgTick StgTickish
_ti CgStgExpr
e        -> Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
True CgStgExpr
e

stgAltLive :: CgStgAlt -> LiveVars
stgAltLive :: GenStgAlt 'CodeGen -> LiveVars
stgAltLive GenStgAlt 'CodeGen
alt =
  LiveVars -> [Id] -> LiveVars
delDVarSetList (Bool -> CgStgExpr -> LiveVars
stgExprLive Bool
True (GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)) (GenStgAlt 'CodeGen -> [BinderP 'CodeGen]
forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs GenStgAlt 'CodeGen
alt)

stgLetNoEscapeLive :: Bool -> StgBinding -> StgExpr -> LiveVars
stgLetNoEscapeLive :: Bool -> StgBinding -> StgExpr -> LiveVars
stgLetNoEscapeLive Bool
_someBool StgBinding
_b StgExpr
_e = String -> LiveVars
forall a. HasCallStack => String -> a
panic String
"stgLetNoEscapeLive"

bindees :: CgStgBinding -> [Id]
bindees :: CgStgBinding -> [Id]
bindees = \case
  StgNonRec BinderP 'CodeGen
b GenStgRhs 'CodeGen
_e -> [Id
BinderP 'CodeGen
b]
  StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs      -> ((Id, GenStgRhs 'CodeGen) -> Id)
-> [(Id, GenStgRhs 'CodeGen)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, GenStgRhs 'CodeGen) -> Id
forall a b. (a, b) -> a
fst [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs

isUpdatableRhs :: CgStgRhs -> Bool
isUpdatableRhs :: GenStgRhs 'CodeGen -> Bool
isUpdatableRhs (StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ UpdateFlag
u [BinderP 'CodeGen]
_ CgStgExpr
_ Type
_) = UpdateFlag -> Bool
isUpdatable UpdateFlag
u
isUpdatableRhs GenStgRhs 'CodeGen
_                           = Bool
False

stgLneLive' :: CgStgBinding -> [Id]
stgLneLive' :: CgStgBinding -> [Id]
stgLneLive' CgStgBinding
b = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` CgStgBinding -> [Id]
bindees CgStgBinding
b) (CgStgBinding -> [Id]
stgLneLive CgStgBinding
b)

stgLneLive :: CgStgBinding -> [Id]
stgLneLive :: CgStgBinding -> [Id]
stgLneLive (StgNonRec BinderP 'CodeGen
_b GenStgRhs 'CodeGen
e) = GenStgRhs 'CodeGen -> [Id]
stgLneLiveExpr GenStgRhs 'CodeGen
e
stgLneLive (StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs)      = [Id] -> [Id]
forall a. Eq a => [a] -> [a]
L.nub ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ ((Id, GenStgRhs 'CodeGen) -> [Id])
-> [(Id, GenStgRhs 'CodeGen)] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GenStgRhs 'CodeGen -> [Id]
stgLneLiveExpr (GenStgRhs 'CodeGen -> [Id])
-> ((Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen)
-> (Id, GenStgRhs 'CodeGen)
-> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, GenStgRhs 'CodeGen) -> GenStgRhs 'CodeGen
forall a b. (a, b) -> b
snd) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs

stgLneLiveExpr :: CgStgRhs -> [Id]
stgLneLiveExpr :: GenStgRhs 'CodeGen -> [Id]
stgLneLiveExpr GenStgRhs 'CodeGen
rhs = LiveVars -> [Id]
dVarSetElems (LiveVars -> LiveVars
liveVars (LiveVars -> LiveVars) -> LiveVars -> LiveVars
forall a b. (a -> b) -> a -> b
$ GenStgRhs 'CodeGen -> LiveVars
stgRhsLive GenStgRhs 'CodeGen
rhs)
-- stgLneLiveExpr (StgRhsClosure _ _ _ _ e) = dVarSetElems (liveVars (stgExprLive e))
-- stgLneLiveExpr StgRhsCon {}              = []

-- | returns True if the expression is definitely inline
isInlineExpr :: UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr :: UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr UniqSet Id
v = \case
  StgApp Id
i [StgArg]
args
    -> (UniqSet Id
forall a. UniqSet a
emptyUniqSet, UniqSet Id -> Id -> [StgArg] -> Bool
isInlineApp UniqSet Id
v Id
i [StgArg]
args)
  StgLit{}
    -> (UniqSet Id
forall a. UniqSet a
emptyUniqSet, Bool
True)
  StgConApp{}
    -> (UniqSet Id
forall a. UniqSet a
emptyUniqSet, Bool
True)
  StgOpApp (StgFCallOp ForeignCall
f Type
_) [StgArg]
_ Type
_
    -> (UniqSet Id
forall a. UniqSet a
emptyUniqSet, ForeignCall -> Bool
isInlineForeignCall ForeignCall
f)
  StgOpApp (StgPrimOp PrimOp
SeqOp) [StgVarArg Id
e] Type
t
    -> (UniqSet Id
forall a. UniqSet a
emptyUniqSet, Id
e Id -> UniqSet Id -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet Id
v Bool -> Bool -> Bool
|| HasDebugCallStack => Type -> Bool
Type -> Bool
isStrictType Type
t)
  StgOpApp (StgPrimOp PrimOp
op) [StgArg]
_ Type
_
    -> (UniqSet Id
forall a. UniqSet a
emptyUniqSet, PrimOp -> Bool
primOpIsReallyInline PrimOp
op)
  StgOpApp (StgPrimCallOp PrimCall
_c) [StgArg]
_ Type
_
    -> (UniqSet Id
forall a. UniqSet a
emptyUniqSet, Bool
True)
  StgCase CgStgExpr
e BinderP 'CodeGen
b AltType
_ [GenStgAlt 'CodeGen]
alts
    ->let (UniqSet Id
_ve, Bool
ie)   = UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr UniqSet Id
v CgStgExpr
e
          v' :: UniqSet Id
v'          = UniqSet Id -> Id -> UniqSet Id
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet Id
v Id
BinderP 'CodeGen
b
          ([UniqSet Id]
vas, [Bool]
ias)  = [(UniqSet Id, Bool)] -> ([UniqSet Id], [Bool])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(UniqSet Id, Bool)] -> ([UniqSet Id], [Bool]))
-> [(UniqSet Id, Bool)] -> ([UniqSet Id], [Bool])
forall a b. (a -> b) -> a -> b
$ (CgStgExpr -> (UniqSet Id, Bool))
-> [CgStgExpr] -> [(UniqSet Id, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr UniqSet Id
v') ((GenStgAlt 'CodeGen -> CgStgExpr)
-> [GenStgAlt 'CodeGen] -> [CgStgExpr]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs [GenStgAlt 'CodeGen]
alts)
          vr :: UniqSet Id
vr          = (UniqSet Id -> UniqSet Id -> UniqSet Id)
-> [UniqSet Id] -> UniqSet Id
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
L.foldl1' UniqSet Id -> UniqSet Id -> UniqSet Id
forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets [UniqSet Id]
vas
      in (UniqSet Id
vr, (Bool
ie Bool -> Bool -> Bool
|| Id
BinderP 'CodeGen
b Id -> UniqSet Id -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet Id
v) Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
ias)
  StgLet XLet 'CodeGen
_ CgStgBinding
b CgStgExpr
e
    -> UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr (UniqSet Id -> CgStgBinding -> UniqSet Id
inspectInlineBinding UniqSet Id
v CgStgBinding
b) CgStgExpr
e
  StgLetNoEscape XLetNoEscape 'CodeGen
_ CgStgBinding
_b CgStgExpr
e
    -> UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr UniqSet Id
v CgStgExpr
e
  StgTick  StgTickish
_ CgStgExpr
e
    -> UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
isInlineExpr UniqSet Id
v CgStgExpr
e

inspectInlineBinding :: UniqSet Id -> CgStgBinding -> UniqSet Id
inspectInlineBinding :: UniqSet Id -> CgStgBinding -> UniqSet Id
inspectInlineBinding UniqSet Id
v = \case
  StgNonRec BinderP 'CodeGen
i GenStgRhs 'CodeGen
r -> UniqSet Id -> Id -> GenStgRhs 'CodeGen -> UniqSet Id
inspectInlineRhs UniqSet Id
v Id
BinderP 'CodeGen
i GenStgRhs 'CodeGen
r
  StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs     -> (UniqSet Id -> (Id, GenStgRhs 'CodeGen) -> UniqSet Id)
-> UniqSet Id -> [(Id, GenStgRhs 'CodeGen)] -> UniqSet Id
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\UniqSet Id
v' (Id
i,GenStgRhs 'CodeGen
r) -> UniqSet Id -> Id -> GenStgRhs 'CodeGen -> UniqSet Id
inspectInlineRhs UniqSet Id
v' Id
i GenStgRhs 'CodeGen
r) UniqSet Id
v [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
bs

inspectInlineRhs :: UniqSet Id -> Id -> CgStgRhs -> UniqSet Id
inspectInlineRhs :: UniqSet Id -> Id -> GenStgRhs 'CodeGen -> UniqSet Id
inspectInlineRhs UniqSet Id
v Id
i = \case
  StgRhsCon{}                       -> UniqSet Id -> Id -> UniqSet Id
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet Id
v Id
i
  StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ UpdateFlag
ReEntrant [BinderP 'CodeGen]
_ CgStgExpr
_ Type
_ -> UniqSet Id -> Id -> UniqSet Id
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet Id
v Id
i
  GenStgRhs 'CodeGen
_                                 -> UniqSet Id
v

isInlineForeignCall :: ForeignCall -> Bool
isInlineForeignCall :: ForeignCall -> Bool
isInlineForeignCall (CCall (CCallSpec CCallTarget
_ CCallConv
cconv Safety
safety)) =
  Bool -> Bool
not (Safety -> Bool
playInterruptible Safety
safety) Bool -> Bool -> Bool
&&
  Bool -> Bool
not (CCallConv
cconv CCallConv -> CCallConv -> Bool
forall a. Eq a => a -> a -> Bool
/= CCallConv
JavaScriptCallConv Bool -> Bool -> Bool
&& Safety -> Bool
playSafe Safety
safety)

isInlineApp :: UniqSet Id -> Id -> [StgArg] -> Bool
isInlineApp :: UniqSet Id -> Id -> [StgArg] -> Bool
isInlineApp UniqSet Id
v Id
i = \case
  [StgArg]
_ | Id -> Bool
isJoinId Id
i -> Bool
False
  [] -> Type -> Bool
isUnboxedTupleType (Id -> Type
idType Id
i) Bool -> Bool -> Bool
||
                     HasDebugCallStack => Type -> Bool
Type -> Bool
isStrictType (Id -> Type
idType Id
i) Bool -> Bool -> Bool
||
                     Id
i Id -> UniqSet Id -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet Id
v

  [StgVarArg Id
a]
    | DataConWrapId DataCon
dc <- Id -> IdDetails
idDetails Id
i
    , TyCon -> Bool
isNewTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc)
    , HasDebugCallStack => Type -> Bool
Type -> Bool
isStrictType (Id -> Type
idType Id
a) Bool -> Bool -> Bool
|| Id
a Id -> UniqSet Id -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet Id
v Bool -> Bool -> Bool
|| Id -> Bool
isStrictId Id
a
    -> Bool
True
  [StgArg]
_ -> Bool
False