{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.StgToCmm.Heap (
getVirtHp, setVirtHp, setRealHp,
getHpRelOffset,
entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,
heapStackCheckGen,
entryHeapCheck',
mkStaticClosureFields, mkStaticClosure,
allocDynClosure, allocDynClosureCmm, allocHeapClosure,
emitSetDynHdr
) where
import GHC.Prelude hiding ((<*>))
import GHC.Stg.Syntax
import GHC.Cmm.CLabel
import GHC.StgToCmm.Layout
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Prof (profDynAlloc, dynProfHdr, staticProfHdr)
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Env
import GHC.Cmm.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Runtime.Heap.Layout
import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Types.CostCentre
import GHC.Types.Id.Info( CafInfo(..), mayHaveCafRefs )
import GHC.Types.Id ( Id )
import GHC.Unit
import GHC.Driver.Session
import GHC.Platform
import GHC.Platform.Profile
import GHC.Data.FastString( mkFastString, fsLit )
import GHC.Utils.Panic( sorry )
import Control.Monad (when)
import Data.Maybe (isJust)
allocDynClosure
:: Maybe Id
-> CmmInfoTable
-> LambdaFormInfo
-> CmmExpr
-> CmmExpr
-> [(NonVoid StgArg, VirtualHpOffset)]
-> FCode CmmExpr
allocDynClosureCmm
:: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
-> [(CmmExpr, ByteOff)]
-> FCode CmmExpr
allocDynClosure :: Maybe Id
-> CmmInfoTable
-> LambdaFormInfo
-> CmmExpr
-> CmmExpr
-> [(NonVoid StgArg, Int)]
-> FCode CmmExpr
allocDynClosure Maybe Id
mb_id CmmInfoTable
info_tbl LambdaFormInfo
lf_info CmmExpr
use_cc CmmExpr
_blame_cc [(NonVoid StgArg, Int)]
args_w_offsets = do
let ([NonVoid StgArg]
args, [Int]
offsets) = forall a b. [(a, b)] -> ([a], [b])
unzip [(NonVoid StgArg, Int)]
args_w_offsets
[CmmExpr]
cmm_args <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NonVoid StgArg -> FCode CmmExpr
getArgAmode [NonVoid StgArg]
args
Maybe Id
-> CmmInfoTable
-> LambdaFormInfo
-> CmmExpr
-> CmmExpr
-> [(CmmExpr, Int)]
-> FCode CmmExpr
allocDynClosureCmm Maybe Id
mb_id CmmInfoTable
info_tbl LambdaFormInfo
lf_info
CmmExpr
use_cc CmmExpr
_blame_cc (forall a b. [a] -> [b] -> [(a, b)]
zip [CmmExpr]
cmm_args [Int]
offsets)
allocDynClosureCmm :: Maybe Id
-> CmmInfoTable
-> LambdaFormInfo
-> CmmExpr
-> CmmExpr
-> [(CmmExpr, Int)]
-> FCode CmmExpr
allocDynClosureCmm Maybe Id
mb_id CmmInfoTable
info_tbl LambdaFormInfo
lf_info CmmExpr
use_cc CmmExpr
_blame_cc [(CmmExpr, Int)]
amodes_w_offsets = do
let rep :: SMRep
rep = CmmInfoTable -> SMRep
cit_rep CmmInfoTable
info_tbl
Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
tickyDynAlloc Maybe Id
mb_id SMRep
rep LambdaFormInfo
lf_info
let info_ptr :: CmmExpr
info_ptr = CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (CmmInfoTable -> CLabel
cit_lbl CmmInfoTable
info_tbl))
SMRep -> CmmExpr -> CmmExpr -> [(CmmExpr, Int)] -> FCode CmmExpr
allocHeapClosure SMRep
rep CmmExpr
info_ptr CmmExpr
use_cc [(CmmExpr, Int)]
amodes_w_offsets
allocHeapClosure
:: SMRep
-> CmmExpr
-> CmmExpr
-> [(CmmExpr,ByteOff)]
-> FCode CmmExpr
allocHeapClosure :: SMRep -> CmmExpr -> CmmExpr -> [(CmmExpr, Int)] -> FCode CmmExpr
allocHeapClosure SMRep
rep CmmExpr
info_ptr CmmExpr
use_cc [(CmmExpr, Int)]
payload = do
SMRep -> CmmExpr -> FCode ()
profDynAlloc SMRep
rep CmmExpr
use_cc
Int
virt_hp <- FCode Int
getVirtHp
let info_offset :: Int
info_offset = Int
virt_hp forall a. Num a => a -> a -> a
+ Int
1
CmmExpr
base <- Int -> FCode CmmExpr
getHpRelOffset Int
info_offset
FastString -> FCode ()
emitComment forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString String
"allocHeapClosure"
CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
emitSetDynHdr CmmExpr
base CmmExpr
info_ptr CmmExpr
use_cc
CmmExpr -> [(CmmExpr, Int)] -> FCode ()
hpStore CmmExpr
base [(CmmExpr, Int)]
payload
Profile
profile <- FCode Profile
getProfile
Int -> FCode ()
setVirtHp (Int
virt_hp forall a. Num a => a -> a -> a
+ Profile -> SMRep -> Int
heapClosureSizeW Profile
profile SMRep
rep)
forall (m :: * -> *) a. Monad m => a -> m a
return CmmExpr
base
emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
emitSetDynHdr CmmExpr
base CmmExpr
info_ptr CmmExpr
ccs
= do Profile
profile <- FCode Profile
getProfile
CmmExpr -> [(CmmExpr, Int)] -> FCode ()
hpStore CmmExpr
base (forall a b. [a] -> [b] -> [(a, b)]
zip (Profile -> [CmmExpr]
header Profile
profile) [Int
0, Profile -> Int
profileWordSizeInBytes Profile
profile ..])
where
header :: Profile -> [CmmExpr]
header :: Profile -> [CmmExpr]
header Profile
profile = [CmmExpr
info_ptr] forall a. [a] -> [a] -> [a]
++ Profile -> CmmExpr -> [CmmExpr]
dynProfHdr Profile
profile CmmExpr
ccs
hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode ()
hpStore :: CmmExpr -> [(CmmExpr, Int)] -> FCode ()
hpStore CmmExpr
base [(CmmExpr, Int)]
vals = do
Platform
platform <- FCode Platform
getPlatform
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$
[ CmmExpr -> CmmExpr -> FCode ()
emitStore (Platform -> CmmExpr -> Int -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
base Int
off) CmmExpr
val | (CmmExpr
val,Int
off) <- [(CmmExpr, Int)]
vals ]
mkStaticClosureFields
:: Profile
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
-> [CmmLit]
-> [CmmLit]
mkStaticClosureFields :: Profile
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
-> [CmmLit]
-> [CmmLit]
mkStaticClosureFields Profile
profile CmmInfoTable
info_tbl CostCentreStack
ccs CafInfo
caf_refs [CmmLit]
payload
= Profile
-> CLabel
-> CostCentreStack
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
mkStaticClosure Profile
profile CLabel
info_lbl CostCentreStack
ccs [CmmLit]
payload [CmmLit]
padding
[CmmLit]
static_link_field [CmmLit]
saved_info_field
where
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
info_lbl :: CLabel
info_lbl = CmmInfoTable -> CLabel
cit_lbl CmmInfoTable
info_tbl
is_caf :: Bool
is_caf = SMRep -> Bool
isThunkRep (CmmInfoTable -> SMRep
cit_rep CmmInfoTable
info_tbl)
padding :: [CmmLit]
padding
| Bool
is_caf Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CmmLit]
payload = [Platform -> Int -> CmmLit
mkIntCLit Platform
platform Int
0]
| Bool
otherwise = []
static_link_field :: [CmmLit]
static_link_field
| Bool
is_caf
= [Platform -> Int -> CmmLit
mkIntCLit Platform
platform Int
0]
| Bool -> CmmInfoTable -> Bool
staticClosureNeedsLink (CafInfo -> Bool
mayHaveCafRefs CafInfo
caf_refs) CmmInfoTable
info_tbl
= [CmmLit
static_link_value]
| Bool
otherwise
= []
saved_info_field :: [CmmLit]
saved_info_field
| Bool
is_caf = [Platform -> Int -> CmmLit
mkIntCLit Platform
platform Int
0]
| Bool
otherwise = []
static_link_value :: CmmLit
static_link_value
| CafInfo -> Bool
mayHaveCafRefs CafInfo
caf_refs = Platform -> Int -> CmmLit
mkIntCLit Platform
platform Int
0
| Bool
otherwise = Platform -> Int -> CmmLit
mkIntCLit Platform
platform Int
3
mkStaticClosure :: Profile -> CLabel -> CostCentreStack -> [CmmLit]
-> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
mkStaticClosure :: Profile
-> CLabel
-> CostCentreStack
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
mkStaticClosure Profile
profile CLabel
info_lbl CostCentreStack
ccs [CmmLit]
payload [CmmLit]
padding [CmmLit]
static_link_field [CmmLit]
saved_info_field
= [CLabel -> CmmLit
CmmLabel CLabel
info_lbl]
forall a. [a] -> [a] -> [a]
++ Profile -> CostCentreStack -> [CmmLit]
staticProfHdr Profile
profile CostCentreStack
ccs
forall a. [a] -> [a] -> [a]
++ [CmmLit]
payload
forall a. [a] -> [a] -> [a]
++ [CmmLit]
padding
forall a. [a] -> [a] -> [a]
++ [CmmLit]
static_link_field
forall a. [a] -> [a] -> [a]
++ [CmmLit]
saved_info_field
entryHeapCheck :: ClosureInfo
-> Maybe LocalReg
-> Int
-> [LocalReg]
-> FCode ()
-> FCode ()
entryHeapCheck :: ClosureInfo
-> Maybe LocalReg -> Int -> [LocalReg] -> FCode () -> FCode ()
entryHeapCheck ClosureInfo
cl_info Maybe LocalReg
nodeSet Int
arity [LocalReg]
args FCode ()
code = do
Platform
platform <- FCode Platform
getPlatform
let
node :: CmmExpr
node = case Maybe LocalReg
nodeSet of
Just LocalReg
r -> CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
r)
Maybe LocalReg
Nothing -> CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel forall a b. (a -> b) -> a -> b
$ Platform -> ClosureInfo -> CLabel
staticClosureLabel Platform
platform ClosureInfo
cl_info)
is_fastf :: Bool
is_fastf = case ClosureInfo -> Maybe (Int, ArgDescr)
closureFunInfo ClosureInfo
cl_info of
Just (Int
_, ArgGen Liveness
_) -> Bool
False
Maybe (Int, ArgDescr)
_otherwise -> Bool
True
Bool -> CmmExpr -> Int -> [LocalReg] -> FCode () -> FCode ()
entryHeapCheck' Bool
is_fastf CmmExpr
node Int
arity [LocalReg]
args FCode ()
code
entryHeapCheck' :: Bool
-> CmmExpr
-> Int
-> [LocalReg]
-> FCode ()
-> FCode ()
entryHeapCheck' :: Bool -> CmmExpr -> Int -> [LocalReg] -> FCode () -> FCode ()
entryHeapCheck' Bool
is_fastf CmmExpr
node Int
arity [LocalReg]
args FCode ()
code
= do Profile
profile <- FCode Profile
getProfile
let is_thunk :: Bool
is_thunk = Int
arity forall a. Eq a => a -> a -> Bool
== Int
0
args' :: [CmmExpr]
args' = forall a b. (a -> b) -> [a] -> [b]
map (CmmReg -> CmmExpr
CmmReg forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalReg -> CmmReg
CmmLocal) [LocalReg]
args
stg_gc_fun :: CmmExpr
stg_gc_fun = CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
GCFun)
stg_gc_enter1 :: CmmExpr
stg_gc_enter1 = CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
GCEnter1)
gc_call :: Int -> CmmAGraph
gc_call Int
upd
| Bool
is_thunk
= Profile -> Convention -> CmmExpr -> [CmmExpr] -> Int -> CmmAGraph
mkJump Profile
profile Convention
NativeNodeCall CmmExpr
stg_gc_enter1 [CmmExpr
node] Int
upd
| Bool
is_fastf
= Profile -> Convention -> CmmExpr -> [CmmExpr] -> Int -> CmmAGraph
mkJump Profile
profile Convention
NativeNodeCall CmmExpr
stg_gc_fun (CmmExpr
node forall a. a -> [a] -> [a]
: [CmmExpr]
args') Int
upd
| Bool
otherwise
= Profile -> Convention -> CmmExpr -> [CmmExpr] -> Int -> CmmAGraph
mkJump Profile
profile Convention
Slow CmmExpr
stg_gc_fun (CmmExpr
node forall a. a -> [a] -> [a]
: [CmmExpr]
args') Int
upd
Int
updfr_sz <- FCode Int
getUpdFrameOff
BlockId
loop_id <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
BlockId -> FCode ()
emitLabel BlockId
loop_id
forall a. Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
heapCheck Bool
True Bool
True (Int -> CmmAGraph
gc_call Int
updfr_sz CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmAGraph
mkBranch BlockId
loop_id) FCode ()
code
altHeapCheck :: [LocalReg] -> FCode a -> FCode a
altHeapCheck :: forall a. [LocalReg] -> FCode a -> FCode a
altHeapCheck [LocalReg]
regs FCode a
code = forall a. Bool -> [LocalReg] -> FCode a -> FCode a
altOrNoEscapeHeapCheck Bool
False [LocalReg]
regs FCode a
code
altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a
altOrNoEscapeHeapCheck :: forall a. Bool -> [LocalReg] -> FCode a -> FCode a
altOrNoEscapeHeapCheck Bool
checkYield [LocalReg]
regs FCode a
code = do
Profile
profile <- FCode Profile
getProfile
Platform
platform <- FCode Platform
getPlatform
case Platform -> [LocalReg] -> Maybe CmmExpr
cannedGCEntryPoint Platform
platform [LocalReg]
regs of
Maybe CmmExpr
Nothing -> forall a. Bool -> FCode a -> FCode a
genericGC Bool
checkYield FCode a
code
Just CmmExpr
gc -> do
BlockId
lret <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
let (Int
off, [GlobalReg]
_, CmmAGraph
copyin) = Profile
-> Convention
-> Area
-> [LocalReg]
-> [LocalReg]
-> (Int, [GlobalReg], CmmAGraph)
copyInOflow Profile
profile Convention
NativeReturn (BlockId -> Area
Young BlockId
lret) [LocalReg]
regs []
BlockId
lcont <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
CmmTickScope
tscope <- FCode CmmTickScope
getTickScope
BlockId -> CmmAGraphScoped -> FCode ()
emitOutOfLine BlockId
lret (CmmAGraph
copyin CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmAGraph
mkBranch BlockId
lcont, CmmTickScope
tscope)
BlockId -> FCode ()
emitLabel BlockId
lcont
forall a.
Bool
-> Bool
-> CmmExpr
-> [LocalReg]
-> BlockId
-> Int
-> FCode a
-> FCode a
cannedGCReturnsTo Bool
checkYield Bool
False CmmExpr
gc [LocalReg]
regs BlockId
lret Int
off FCode a
code
altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a
altHeapCheckReturnsTo :: forall a. [LocalReg] -> BlockId -> Int -> FCode a -> FCode a
altHeapCheckReturnsTo [LocalReg]
regs BlockId
lret Int
off FCode a
code
= do Platform
platform <- FCode Platform
getPlatform
case Platform -> [LocalReg] -> Maybe CmmExpr
cannedGCEntryPoint Platform
platform [LocalReg]
regs of
Maybe CmmExpr
Nothing -> forall a. Bool -> FCode a -> FCode a
genericGC Bool
False FCode a
code
Just CmmExpr
gc -> forall a.
Bool
-> Bool
-> CmmExpr
-> [LocalReg]
-> BlockId
-> Int
-> FCode a
-> FCode a
cannedGCReturnsTo Bool
False Bool
True CmmExpr
gc [LocalReg]
regs BlockId
lret Int
off FCode a
code
noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a
noEscapeHeapCheck :: forall a. [LocalReg] -> FCode a -> FCode a
noEscapeHeapCheck [LocalReg]
regs FCode a
code = forall a. Bool -> [LocalReg] -> FCode a -> FCode a
altOrNoEscapeHeapCheck Bool
True [LocalReg]
regs FCode a
code
cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff
-> FCode a
-> FCode a
cannedGCReturnsTo :: forall a.
Bool
-> Bool
-> CmmExpr
-> [LocalReg]
-> BlockId
-> Int
-> FCode a
-> FCode a
cannedGCReturnsTo Bool
checkYield Bool
cont_on_stack CmmExpr
gc [LocalReg]
regs BlockId
lret Int
off FCode a
code
= do Profile
profile <- FCode Profile
getProfile
Int
updfr_sz <- FCode Int
getUpdFrameOff
forall a. Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
heapCheck Bool
False Bool
checkYield (Profile -> CmmExpr -> Int -> CmmAGraph
gc_call Profile
profile CmmExpr
gc Int
updfr_sz) FCode a
code
where
reg_exprs :: [CmmExpr]
reg_exprs = forall a b. (a -> b) -> [a] -> [b]
map (CmmReg -> CmmExpr
CmmReg forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalReg -> CmmReg
CmmLocal) [LocalReg]
regs
gc_call :: Profile -> CmmExpr -> Int -> CmmAGraph
gc_call Profile
profile CmmExpr
label Int
sp
| Bool
cont_on_stack
= Profile
-> CmmExpr
-> Convention
-> [CmmExpr]
-> BlockId
-> Int
-> Int
-> CmmAGraph
mkJumpReturnsTo Profile
profile CmmExpr
label Convention
NativeReturn [CmmExpr]
reg_exprs BlockId
lret Int
off Int
sp
| Bool
otherwise
= Profile
-> CmmExpr
-> Convention
-> [CmmExpr]
-> BlockId
-> Int
-> Int
-> [CmmExpr]
-> CmmAGraph
mkCallReturnsTo Profile
profile CmmExpr
label Convention
NativeReturn [CmmExpr]
reg_exprs BlockId
lret Int
off Int
sp []
genericGC :: Bool -> FCode a -> FCode a
genericGC :: forall a. Bool -> FCode a -> FCode a
genericGC Bool
checkYield FCode a
code
= do Int
updfr_sz <- FCode Int
getUpdFrameOff
BlockId
lretry <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
BlockId -> FCode ()
emitLabel BlockId
lretry
CmmAGraph
call <- CmmExpr
-> (Convention, Convention)
-> [LocalReg]
-> [CmmExpr]
-> Int
-> [CmmExpr]
-> FCode CmmAGraph
mkCall CmmExpr
generic_gc (Convention
GC, Convention
GC) [] [] Int
updfr_sz []
forall a. Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
heapCheck Bool
False Bool
checkYield (CmmAGraph
call CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmAGraph
mkBranch BlockId
lretry) FCode a
code
cannedGCEntryPoint :: Platform -> [LocalReg] -> Maybe CmmExpr
cannedGCEntryPoint :: Platform -> [LocalReg] -> Maybe CmmExpr
cannedGCEntryPoint Platform
platform [LocalReg]
regs
= case forall a b. (a -> b) -> [a] -> [b]
map LocalReg -> CmmType
localRegType [LocalReg]
regs of
[] -> forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_noregs")
[CmmType
ty]
| CmmType -> Bool
isGcPtrType CmmType
ty -> forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_unpt_r1")
| CmmType -> Bool
isFloatType CmmType
ty -> case Width
width of
Width
W32 -> forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_f1")
Width
W64 -> forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_d1")
Width
_ -> forall a. Maybe a
Nothing
| Width
width forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform -> forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_unbx_r1")
| Width
width forall a. Eq a => a -> a -> Bool
== Width
W64 -> forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_l1")
| Bool
otherwise -> forall a. Maybe a
Nothing
where
width :: Width
width = CmmType -> Width
typeWidth CmmType
ty
[CmmType
ty1,CmmType
ty2]
| CmmType -> Bool
isGcPtrType CmmType
ty1
Bool -> Bool -> Bool
&& CmmType -> Bool
isGcPtrType CmmType
ty2 -> forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_pp")
[CmmType
ty1,CmmType
ty2,CmmType
ty3]
| CmmType -> Bool
isGcPtrType CmmType
ty1
Bool -> Bool -> Bool
&& CmmType -> Bool
isGcPtrType CmmType
ty2
Bool -> Bool -> Bool
&& CmmType -> Bool
isGcPtrType CmmType
ty3 -> forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_ppp")
[CmmType
ty1,CmmType
ty2,CmmType
ty3,CmmType
ty4]
| CmmType -> Bool
isGcPtrType CmmType
ty1
Bool -> Bool -> Bool
&& CmmType -> Bool
isGcPtrType CmmType
ty2
Bool -> Bool -> Bool
&& CmmType -> Bool
isGcPtrType CmmType
ty3
Bool -> Bool -> Bool
&& CmmType -> Bool
isGcPtrType CmmType
ty4 -> forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_pppp")
[CmmType]
_otherwise -> forall a. Maybe a
Nothing
generic_gc :: CmmExpr
generic_gc :: CmmExpr
generic_gc = String -> CmmExpr
mkGcLabel String
"stg_gc_noregs"
mkGcLabel :: String -> CmmExpr
mkGcLabel :: String -> CmmExpr
mkGcLabel String
s = CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
rtsUnitId (String -> FastString
fsLit String
s)))
heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
heapCheck :: forall a. Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
heapCheck Bool
checkStack Bool
checkYield CmmAGraph
do_gc FCode a
code
= forall a. (Int -> FCode a) -> FCode a
getHeapUsage forall a b. (a -> b) -> a -> b
$ \ Int
hpHw ->
do { Platform
platform <- FCode Platform
getPlatform
; let mb_alloc_bytes :: Maybe CmmExpr
mb_alloc_bytes
| Int
hpHw forall a. Ord a => a -> a -> Bool
> Int
mBLOCK_SIZE = forall a. String -> a
sorry forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[String
" Trying to allocate more than "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Int
mBLOCK_SIZEforall a. [a] -> [a] -> [a]
++String
" bytes.",
String
"",
String
"This is currently not possible due to a limitation of GHC's code generator.",
String
"See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.",
String
"Suggestion: read data from a file instead of having large static data",
String
"structures in code."]
| Int
hpHw forall a. Ord a => a -> a -> Bool
> Int
0 = forall a. a -> Maybe a
Just (Platform -> Int -> CmmExpr
mkIntExpr Platform
platform (Int
hpHw forall a. Num a => a -> a -> a
* (Platform -> Int
platformWordSizeInBytes Platform
platform)))
| Bool
otherwise = forall a. Maybe a
Nothing
where
constants :: PlatformConstants
constants = Platform -> PlatformConstants
platformConstants Platform
platform
bLOCK_SIZE_W :: Int
bLOCK_SIZE_W = PlatformConstants -> Int
pc_BLOCK_SIZE (Platform -> PlatformConstants
platformConstants Platform
platform) forall a. Integral a => a -> a -> a
`quot` Platform -> Int
platformWordSizeInBytes Platform
platform
mBLOCK_SIZE :: Int
mBLOCK_SIZE = PlatformConstants -> Int
pc_BLOCKS_PER_MBLOCK PlatformConstants
constants forall a. Num a => a -> a -> a
* Int
bLOCK_SIZE_W
stk_hwm :: Maybe CmmExpr
stk_hwm | Bool
checkStack = forall a. a -> Maybe a
Just (CmmLit -> CmmExpr
CmmLit CmmLit
CmmHighStackMark)
| Bool
otherwise = forall a. Maybe a
Nothing
; FCode () -> FCode ()
codeOnly forall a b. (a -> b) -> a -> b
$ Maybe CmmExpr -> Bool -> Maybe CmmExpr -> CmmAGraph -> FCode ()
do_checks Maybe CmmExpr
stk_hwm Bool
checkYield Maybe CmmExpr
mb_alloc_bytes CmmAGraph
do_gc
; Bool -> Int -> FCode ()
tickyAllocHeap Bool
True Int
hpHw
; Int -> FCode ()
setRealHp Int
hpHw
; FCode a
code }
heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()
heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()
heapStackCheckGen Maybe CmmExpr
stk_hwm Maybe CmmExpr
mb_bytes
= do Int
updfr_sz <- FCode Int
getUpdFrameOff
BlockId
lretry <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
BlockId -> FCode ()
emitLabel BlockId
lretry
CmmAGraph
call <- CmmExpr
-> (Convention, Convention)
-> [LocalReg]
-> [CmmExpr]
-> Int
-> [CmmExpr]
-> FCode CmmAGraph
mkCall CmmExpr
generic_gc (Convention
GC, Convention
GC) [] [] Int
updfr_sz []
Maybe CmmExpr -> Bool -> Maybe CmmExpr -> CmmAGraph -> FCode ()
do_checks Maybe CmmExpr
stk_hwm Bool
False Maybe CmmExpr
mb_bytes (CmmAGraph
call CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmAGraph
mkBranch BlockId
lretry)
do_checks :: Maybe CmmExpr
-> Bool
-> Maybe CmmExpr
-> CmmAGraph
-> FCode ()
do_checks :: Maybe CmmExpr -> Bool -> Maybe CmmExpr -> CmmAGraph -> FCode ()
do_checks Maybe CmmExpr
mb_stk_hwm Bool
checkYield Maybe CmmExpr
mb_alloc_lit CmmAGraph
do_gc = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Platform
platform <- FCode Platform
getPlatform
BlockId
gc_id <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
let
Just CmmExpr
alloc_lit = Maybe CmmExpr
mb_alloc_lit
bump_hp :: CmmExpr
bump_hp = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprB Platform
platform CmmExpr
hpExpr CmmExpr
alloc_lit
sp_oflo :: CmmExpr -> CmmExpr
sp_oflo CmmExpr
sp_hwm =
MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Platform -> MachOp
mo_wordULt Platform
platform)
[MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Sub (CmmType -> Width
typeWidth (Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
spReg)))
[Area -> Int -> CmmExpr
CmmStackSlot Area
Old Int
0, CmmExpr
sp_hwm],
CmmReg -> CmmExpr
CmmReg CmmReg
spLimReg]
hp_oflo :: CmmExpr
hp_oflo = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Platform -> MachOp
mo_wordUGt Platform
platform) [CmmExpr
hpExpr, CmmExpr
hpLimExpr]
alloc_n :: CmmAGraph
alloc_n = CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
hpAllocReg CmmExpr
alloc_lit
case Maybe CmmExpr
mb_stk_hwm of
Maybe CmmExpr
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just CmmExpr
stk_hwm -> FCode ()
tickyStackCheck
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (CmmAGraph -> FCode ()
emit forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph
mkCmmIfGoto' (CmmExpr -> CmmExpr
sp_oflo CmmExpr
stk_hwm) BlockId
gc_id (forall a. a -> Maybe a
Just Bool
False) )
Maybe SelfLoopInfo
self_loop_info <- FCode (Maybe SelfLoopInfo)
getSelfLoop
case Maybe SelfLoopInfo
self_loop_info of
Just (Id
_, BlockId
loop_header_id, [LocalReg]
_)
| Bool
checkYield Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe CmmExpr
mb_stk_hwm -> BlockId -> FCode ()
emitLabel BlockId
loop_header_id
Maybe SelfLoopInfo
_otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
if (forall a. Maybe a -> Bool
isJust Maybe CmmExpr
mb_alloc_lit)
then do
FCode ()
tickyHeapCheck
CmmReg -> CmmExpr -> FCode ()
emitAssign CmmReg
hpReg CmmExpr
bump_hp
CmmAGraph -> FCode ()
emit forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
mkCmmIfThen' CmmExpr
hp_oflo (CmmAGraph
alloc_n CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmAGraph
mkBranch BlockId
gc_id) (forall a. a -> Maybe a
Just Bool
False)
else
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
checkYield Bool -> Bool -> Bool
&& Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitYields DynFlags
dflags)) forall a b. (a -> b) -> a -> b
$ do
let yielding :: CmmExpr
yielding = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Platform -> MachOp
mo_wordEq Platform
platform)
[CmmReg -> CmmExpr
CmmReg CmmReg
hpLimReg,
CmmLit -> CmmExpr
CmmLit (Platform -> CmmLit
zeroCLit Platform
platform)]
CmmAGraph -> FCode ()
emit forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph
mkCmmIfGoto' CmmExpr
yielding BlockId
gc_id (forall a. a -> Maybe a
Just Bool
False)
CmmTickScope
tscope <- FCode CmmTickScope
getTickScope
BlockId -> CmmAGraphScoped -> FCode ()
emitOutOfLine BlockId
gc_id
(CmmAGraph
do_gc, CmmTickScope
tscope)