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

module GHC.StgToJS.Utils
  ( assignCoerce1
  , assignToExprCtx
  , fixedLayout
  , assocIdExprs
  -- * Unboxable datacon
  , isUnboxableCon
  , isUnboxable
  , isBoolDataCon
  -- * JSRep
  , slotCount
  , varSize
  , typeSize
  , isVoid
  , isMultiVar
  , idJSRep
  , typeJSRep
  , unaryTypeJSRep
  , primRepToJSRep
  , primOrVoidRepToJSRep
  , stackSlotType
  , primRepSize
  , mkArityTag
  -- * References and Ids
  , exprRefs
  , hasExport
  , collectTopIds
  , collectIds
  -- * Live variables
  , LiveVars
  , liveStatic
  , liveVars
  , stgRhsLive
  , stgExprLive
  , isUpdatableRhs
  , stgLneLive'
  , stgLneLiveExpr
  , isInlineExpr
  )
where

import GHC.Prelude

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

import GHC.JS.JStg.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.Names
import GHC.Builtin.PrimOps (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.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] -> [JStgExpr] -> JStgStat
assignToTypedExprs :: [TypedExpr] -> [JStgExpr] -> JStgStat
assignToTypedExprs [TypedExpr]
tes [JStgExpr]
es =
  [JStgExpr] -> [JStgExpr] -> JStgStat
HasDebugCallStack => [JStgExpr] -> [JStgExpr] -> JStgStat
assignAllEqual ((TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr [TypedExpr]
tes) [JStgExpr]
es

assignTypedExprs :: [TypedExpr] -> [TypedExpr] -> JStgStat
assignTypedExprs :: [TypedExpr] -> [TypedExpr] -> JStgStat
assignTypedExprs [TypedExpr]
tes [TypedExpr]
es =
  let prim_tes :: [JStgExpr]
prim_tes = (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr [TypedExpr]
tes
      prim_es :: [JStgExpr]
prim_es  = (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr [TypedExpr]
es
        -- extract the JExprs, effectively unarising a RuntimeRep thing to
        -- multiple VarType-repped things (e.g., AddrRep takes two VarType-regs)
  in Bool -> SDoc -> JStgStat -> JStgStat
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([JStgExpr] -> [JStgExpr] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [JStgExpr]
prim_tes [JStgExpr]
prim_es)
               ([PrimRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((TypedExpr -> PrimRep) -> [TypedExpr] -> [PrimRep]
forall a b. (a -> b) -> [a] -> [b]
map TypedExpr -> PrimRep
typex_typ [TypedExpr]
tes) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [PrimRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((TypedExpr -> PrimRep) -> [TypedExpr] -> [PrimRep]
forall a b. (a -> b) -> [a] -> [b]
map TypedExpr -> PrimRep
typex_typ [TypedExpr]
es))
               ([JStgExpr] -> [JStgExpr] -> JStgStat
HasDebugCallStack => [JStgExpr] -> [JStgExpr] -> JStgStat
assignAllEqual [JStgExpr]
prim_tes [JStgExpr]
prim_es)

assignToExprCtx :: ExprCtx -> [JStgExpr] -> JStgStat
assignToExprCtx :: ExprCtx -> [JStgExpr] -> JStgStat
assignToExprCtx ExprCtx
ctx [JStgExpr]
es = [TypedExpr] -> [JStgExpr] -> JStgStat
assignToTypedExprs (ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) [JStgExpr]
es

-- | Assign first expr only (if it exists), performing coercions between some
-- PrimReps (e.g. StablePtr# and Addr#).
assignCoerce1 :: [TypedExpr] -> [TypedExpr] -> JStgStat
assignCoerce1 :: [TypedExpr] -> [TypedExpr] -> JStgStat
assignCoerce1 [TypedExpr
x] [TypedExpr
y] = TypedExpr -> TypedExpr -> JStgStat
assignCoerce TypedExpr
x TypedExpr
y
assignCoerce1 []  []  = JStgStat
forall a. Monoid a => a
mempty
-- We silently ignore the case of an empty list on the first argument. It denotes
-- "assign nothing to n empty slots on the right". Usually this case shouldn't come
-- up, but rare cases where the earlier code can't correctly guess the size of type
-- classes causes slots to be allocated when they aren't needed.
assignCoerce1 []  [TypedExpr]
_   = JStgStat
forall a. Monoid a => a
mempty
assignCoerce1 [TypedExpr]
x [TypedExpr]
y     = String -> SDoc -> JStgStat
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
                                , [TypedExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TypedExpr]
x
                                , [TypedExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TypedExpr]
y
                                ])

-- | Assign p2 to p1 with optional coercion
assignCoerce :: TypedExpr -> TypedExpr -> JStgStat
-- Coercion between StablePtr# and Addr#
assignCoerce :: TypedExpr -> TypedExpr -> JStgStat
assignCoerce (TypedExpr PrimRep
AddrRep [JStgExpr
a_val, JStgExpr
a_off]) (TypedExpr (BoxedRep (Just Levity
Unlifted)) [JStgExpr
sptr]) = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
    [ JStgExpr
a_val JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdStablePtrBuf
    , JStgExpr
a_off JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
sptr
    ]
assignCoerce (TypedExpr (BoxedRep (Just Levity
Unlifted)) [JStgExpr
sptr]) (TypedExpr PrimRep
AddrRep [JStgExpr
_a_val, JStgExpr
a_off]) =
  JStgExpr
sptr JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
a_off
assignCoerce TypedExpr
p1 TypedExpr
p2 = [TypedExpr] -> [TypedExpr] -> JStgStat
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
  , [JSRep
t1] <- HasDebugCallStack => Type -> [JSRep]
Type -> [JSRep]
typeJSRep (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
t)
  = JSRep -> Bool
isUnboxable JSRep
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 :: JSRep -> Bool
isUnboxable :: JSRep -> Bool
isUnboxable JSRep
DoubleV = Bool
True
isUnboxable JSRep
IntV    = Bool
True -- includes Char#
isUnboxable JSRep
_       = 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 JSRep
varSize :: JSRep -> Int
varSize :: JSRep -> Int
varSize = SlotCount -> Int
slotCount (SlotCount -> Int) -> (JSRep -> SlotCount) -> JSRep -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSRep -> SlotCount
jsRepSlots

jsRepSlots :: JSRep -> SlotCount
jsRepSlots :: JSRep -> SlotCount
jsRepSlots JSRep
VoidV = SlotCount
NoSlot
jsRepSlots JSRep
LongV = SlotCount
TwoSlots -- hi, low
jsRepSlots JSRep
AddrV = SlotCount
TwoSlots -- obj/array, offset
jsRepSlots JSRep
_     = 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
. (JSRep -> Int) -> [JSRep] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map JSRep -> Int
varSize ([JSRep] -> [Int]) -> (Type -> [JSRep]) -> Type -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> [JSRep]
Type -> [JSRep]
typeJSRep (Type -> Int) -> Type -> Int
forall a b. (a -> b) -> a -> b
$ Type
t

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

isMultiVar :: JSRep -> Bool
isMultiVar :: JSRep -> Bool
isMultiVar JSRep
v = case JSRep -> SlotCount
jsRepSlots JSRep
v of
  SlotCount
NoSlot   -> Bool
False
  SlotCount
OneSlot  -> Bool
False
  SlotCount
TwoSlots -> Bool
True

idJSRep :: HasDebugCallStack => Id -> [JSRep]
idJSRep :: HasDebugCallStack => Id -> [JSRep]
idJSRep = HasDebugCallStack => Type -> [JSRep]
Type -> [JSRep]
typeJSRep (Type -> [JSRep]) -> (Id -> Type) -> Id -> [JSRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType

typeJSRep :: HasDebugCallStack => Type -> [JSRep]
typeJSRep :: HasDebugCallStack => Type -> [JSRep]
typeJSRep Type
t = (PrimRep -> JSRep) -> [PrimRep] -> [JSRep]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => PrimRep -> JSRep
PrimRep -> JSRep
primRepToJSRep (HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
t)

-- only use if you know it's not an unboxed tuple
unaryTypeJSRep :: HasDebugCallStack => UnaryType -> JSRep
unaryTypeJSRep :: HasDebugCallStack => Type -> JSRep
unaryTypeJSRep Type
ut = HasDebugCallStack => PrimOrVoidRep -> JSRep
PrimOrVoidRep -> JSRep
primOrVoidRepToJSRep (HasDebugCallStack => Type -> PrimOrVoidRep
Type -> PrimOrVoidRep
typePrimRep1 Type
ut)

primRepToJSRep :: HasDebugCallStack => PrimRep -> JSRep
primRepToJSRep :: HasDebugCallStack => PrimRep -> JSRep
primRepToJSRep (BoxedRep Maybe Levity
_) = JSRep
PtrV
primRepToJSRep PrimRep
IntRep       = JSRep
IntV
primRepToJSRep PrimRep
Int8Rep      = JSRep
IntV
primRepToJSRep PrimRep
Int16Rep     = JSRep
IntV
primRepToJSRep PrimRep
Int32Rep     = JSRep
IntV
primRepToJSRep PrimRep
WordRep      = JSRep
IntV
primRepToJSRep PrimRep
Word8Rep     = JSRep
IntV
primRepToJSRep PrimRep
Word16Rep    = JSRep
IntV
primRepToJSRep PrimRep
Word32Rep    = JSRep
IntV
primRepToJSRep PrimRep
Int64Rep     = JSRep
LongV
primRepToJSRep PrimRep
Word64Rep    = JSRep
LongV
primRepToJSRep PrimRep
AddrRep      = JSRep
AddrV
primRepToJSRep PrimRep
FloatRep     = JSRep
DoubleV
primRepToJSRep PrimRep
DoubleRep    = JSRep
DoubleV
primRepToJSRep (VecRep{})   = String -> JSRep
forall a. HasCallStack => String -> a
error String
"primRepToJSRep: vector types are unsupported"

primOrVoidRepToJSRep :: HasDebugCallStack => PrimOrVoidRep -> JSRep
primOrVoidRepToJSRep :: HasDebugCallStack => PrimOrVoidRep -> JSRep
primOrVoidRepToJSRep PrimOrVoidRep
VoidRep = JSRep
VoidV
primOrVoidRepToJSRep (NVRep PrimRep
rep) = HasDebugCallStack => PrimRep -> JSRep
PrimRep -> JSRep
primRepToJSRep PrimRep
rep

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 :: [JSRep] -> CILayout
fixedLayout :: [JSRep] -> CILayout
fixedLayout [JSRep]
vts = Int -> [JSRep] -> CILayout
CILayoutFixed ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((JSRep -> Int) -> [JSRep] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map JSRep -> Int
varSize [JSRep]
vts)) [JSRep]
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 -> JSRep
stackSlotType :: Id -> JSRep
stackSlotType Id
i
  | SlotCount
OneSlot <- JSRep -> SlotCount
jsRepSlots JSRep
otype = JSRep
otype
  | Bool
otherwise                   = JSRep
DoubleV
  where otype :: JSRep
otype = HasDebugCallStack => Type -> JSRep
Type -> JSRep
unaryTypeJSRep (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 = JSRep -> SlotCount
jsRepSlots (HasDebugCallStack => PrimRep -> JSRep
PrimRep -> JSRep
primRepToJSRep PrimRep
p)

-- | Associate the given values to each RrimRep in the given order, taking into
-- account the number of slots per PrimRep
assocPrimReps :: [PrimRep] -> [JStgExpr] -> [(PrimRep, [JStgExpr])]
assocPrimReps :: [PrimRep] -> [JStgExpr] -> [(PrimRep, [JStgExpr])]
assocPrimReps []     [JStgExpr]
_  = []
assocPrimReps (PrimRep
r:[PrimRep]
rs) [JStgExpr]
vs = case (PrimRep -> SlotCount
primRepSize PrimRep
r,[JStgExpr]
vs) of
  (SlotCount
NoSlot,   [JStgExpr]
xs)     -> (PrimRep
r,[])    (PrimRep, [JStgExpr])
-> [(PrimRep, [JStgExpr])] -> [(PrimRep, [JStgExpr])]
forall a. a -> [a] -> [a]
: [PrimRep] -> [JStgExpr] -> [(PrimRep, [JStgExpr])]
assocPrimReps [PrimRep]
rs [JStgExpr]
xs
  (SlotCount
OneSlot,  JStgExpr
x:[JStgExpr]
xs)   -> (PrimRep
r,[JStgExpr
x])   (PrimRep, [JStgExpr])
-> [(PrimRep, [JStgExpr])] -> [(PrimRep, [JStgExpr])]
forall a. a -> [a] -> [a]
: [PrimRep] -> [JStgExpr] -> [(PrimRep, [JStgExpr])]
assocPrimReps [PrimRep]
rs [JStgExpr]
xs
  (SlotCount
TwoSlots, JStgExpr
x:JStgExpr
y:[JStgExpr]
xs) -> (PrimRep
r,[JStgExpr
x,JStgExpr
y]) (PrimRep, [JStgExpr])
-> [(PrimRep, [JStgExpr])] -> [(PrimRep, [JStgExpr])]
forall a. a -> [a] -> [a]
: [PrimRep] -> [JStgExpr] -> [(PrimRep, [JStgExpr])]
assocPrimReps [PrimRep]
rs [JStgExpr]
xs
  (SlotCount, [JStgExpr])
err                -> String -> SDoc -> [(PrimRep, [JStgExpr])]
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
$ (JStgExpr -> JExpr) -> [JStgExpr] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map JStgExpr -> JExpr
jStgExprToJS ([JStgExpr] -> [JExpr])
-> (SlotCount, [JStgExpr]) -> (SlotCount, [JExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SlotCount, [JStgExpr])
err)

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

--------------------------------------------------------------------------------
--                        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 [[PrimRep]]
_     -> (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] -> ZonkAny 0 -> ZonkAny 0
forall a b. [a] -> b -> b
seqList [Id]
xs (ZonkAny 0 -> ZonkAny 0) -> [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 {a}. NamedThing a => a -> 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] -> ZonkAny 1 -> ZonkAny 1
forall a b. [a] -> b -> b
seqList [Id]
xs (ZonkAny 1 -> ZonkAny 1) -> [Id] -> [Id]
forall a b. a -> b -> b
`seq` [Id]
xs
  where
    acceptId :: a -> Bool
acceptId a
i = ((a -> Bool) -> Bool) -> [a -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((a -> Bool) -> a -> Bool
forall a b. (a -> b) -> a -> b
$ a
i) [Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
forall {a}. NamedThing a => a -> Bool
isForbidden] -- fixme test this: [isExported[isGlobalId, not.isForbidden]
    isForbidden :: a -> Bool
isForbidden a
i
      -- the GHC.Prim module has no js source file
      | 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
True
      -- unboxed tuples have no definition
      | Name -> Bool
isUnboxedTupleDataConLikeName (a -> Name
forall a. NamedThing a => a -> Name
getName a
i)
      = Bool
True
      | Bool
otherwise
      = Bool
False

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

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 [[PrimRep]]
_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)

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 :: CgStgExpr -> Bool
isInlineExpr :: CgStgExpr -> Bool
isInlineExpr = \case
  StgApp Id
i [StgArg]
args
    -> Id -> [StgArg] -> Bool
isInlineApp Id
i [StgArg]
args
  StgLit{}
    -> Bool
True
  StgConApp{}
    -> Bool
True
  StgOpApp (StgFCallOp ForeignCall
f Type
_) [StgArg]
_ Type
_
    -> ForeignCall -> Bool
isInlineForeignCall ForeignCall
f
  StgOpApp (StgPrimOp PrimOp
op) [StgArg]
_ Type
_
    -> PrimOp -> Bool
primOpIsReallyInline PrimOp
op
  StgOpApp (StgPrimCallOp PrimCall
_c) [StgArg]
_ Type
_
    -> Bool
True
  StgCase CgStgExpr
e BinderP 'CodeGen
_ AltType
_ [GenStgAlt 'CodeGen]
alts
    ->let ie :: Bool
ie   = CgStgExpr -> Bool
isInlineExpr CgStgExpr
e
          ias :: [Bool]
ias  = (CgStgExpr -> Bool) -> [CgStgExpr] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map CgStgExpr -> Bool
isInlineExpr ((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)
      in Bool
ie Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
ias
  StgLet XLet 'CodeGen
_ CgStgBinding
_ CgStgExpr
e
    -> CgStgExpr -> Bool
isInlineExpr CgStgExpr
e
  StgLetNoEscape XLetNoEscape 'CodeGen
_ CgStgBinding
_ CgStgExpr
e
    -> CgStgExpr -> Bool
isInlineExpr CgStgExpr
e
  StgTick StgTickish
_ CgStgExpr
e
    -> CgStgExpr -> Bool
isInlineExpr CgStgExpr
e

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 :: Id -> [StgArg] -> Bool
isInlineApp :: Id -> [StgArg] -> Bool
isInlineApp 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 -> Bool
ctxIsEvaluated Id
i

  [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 -> Bool
ctxIsEvaluated Id
a Bool -> Bool -> Bool
|| Id -> Bool
isStrictId Id
a
    -> Bool
True
  [StgArg]
_ -> Bool
False