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.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.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) = [(NonVoid StgArg, Int)] -> ([NonVoid StgArg], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip [(NonVoid StgArg, Int)]
args_w_offsets
cmm_args <- (NonVoid StgArg -> FCode CmmExpr)
-> [NonVoid StgArg] -> FCode [CmmExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM NonVoid StgArg -> FCode CmmExpr
getArgAmode [NonVoid StgArg]
args
allocDynClosureCmm mb_id info_tbl lf_info
use_cc _blame_cc (zip cmm_args 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
virt_hp <- FCode Int
getVirtHp
let info_offset = Int
virt_hp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
base <- getHpRelOffset info_offset
emitComment $ mkFastString "allocHeapClosure"
emitSetDynHdr base info_ptr use_cc
hpStore base payload
profile <- getProfile
setVirtHp (virt_hp + heapClosureSizeW profile rep)
return base
emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
emitSetDynHdr CmmExpr
base CmmExpr
info_ptr CmmExpr
ccs
= do profile <- FCode Profile
getProfile
hpStore base (zip (header profile) [0, profileWordSizeInBytes profile ..])
where
header :: Profile -> [CmmExpr]
header :: Profile -> [CmmExpr]
header Profile
profile = [CmmExpr
info_ptr] [CmmExpr] -> [CmmExpr] -> [CmmExpr]
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 <- FCode Platform
getPlatform
sequence_ $
[ emitStore (cmmOffsetB platform base off) val | (val,off) <- vals ]
mkStaticClosureFields
:: Profile
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
mkStaticClosureFields :: Profile
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
mkStaticClosureFields Profile
profile CmmInfoTable
info_tbl CostCentreStack
ccs CafInfo
caf_refs [CmmLit]
payload [CmmLit]
extras
= Profile
-> CLabel
-> CostCentreStack
-> [CmmLit]
-> [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 [CmmLit]
extras
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
&& [CmmLit] -> Bool
forall a. [a] -> 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] -> [CmmLit]
mkStaticClosure :: Profile
-> CLabel
-> CostCentreStack
-> [CmmLit]
-> [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 [CmmLit]
extras
= [CLabel -> CmmLit
CmmLabel CLabel
info_lbl]
[CmmLit] -> [CmmLit] -> [CmmLit]
forall a. [a] -> [a] -> [a]
++ Profile -> CostCentreStack -> [CmmLit]
staticProfHdr Profile
profile CostCentreStack
ccs
[CmmLit] -> [CmmLit] -> [CmmLit]
forall a. [a] -> [a] -> [a]
++ [CmmLit]
payload
[CmmLit] -> [CmmLit] -> [CmmLit]
forall a. [a] -> [a] -> [a]
++ [CmmLit]
padding
[CmmLit] -> [CmmLit] -> [CmmLit]
forall a. [a] -> [a] -> [a]
++ [CmmLit]
static_link_field
[CmmLit] -> [CmmLit] -> [CmmLit]
forall a. [a] -> [a] -> [a]
++ [CmmLit]
saved_info_field
[CmmLit] -> [CmmLit] -> [CmmLit]
forall a. [a] -> [a] -> [a]
++ [CmmLit]
extras
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 <- FCode Platform
getPlatform
let
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 (CLabel -> CmmLit) -> CLabel -> CmmLit
forall a b. (a -> b) -> a -> b
$ Platform -> ClosureInfo -> CLabel
staticClosureLabel Platform
platform ClosureInfo
cl_info)
is_fastf = case ClosureInfo -> Maybe (Int, ArgDescr)
closureFunInfo ClosureInfo
cl_info of
Just (Int
_, ArgGen Liveness
_) -> Bool
False
Maybe (Int, ArgDescr)
_otherwise -> Bool
True
entryHeapCheck' is_fastf node arity args 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 <- FCode Profile
getProfile
let platform = Profile -> Platform
profilePlatform Profile
profile
is_thunk = Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
args' = (LocalReg -> CmmExpr) -> [LocalReg] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> (LocalReg -> CmmReg) -> LocalReg -> CmmExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalReg -> CmmReg
CmmLocal) [LocalReg]
args
stg_gc_fun = CmmReg -> CmmExpr
CmmReg (GlobalRegUse -> CmmReg
CmmGlobal (GlobalRegUse -> CmmReg) -> GlobalRegUse -> CmmReg
forall a b. (a -> b) -> a -> b
$ GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse GlobalReg
GCFun (CmmType -> GlobalRegUse) -> CmmType -> GlobalRegUse
forall a b. (a -> b) -> a -> b
$ Platform -> CmmType
bWord Platform
platform)
stg_gc_enter1 = CmmReg -> CmmExpr
CmmReg (GlobalRegUse -> CmmReg
CmmGlobal (GlobalRegUse -> CmmReg) -> GlobalRegUse -> CmmReg
forall a b. (a -> b) -> a -> b
$ GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse GlobalReg
GCEnter1 (CmmType -> GlobalRegUse) -> CmmType -> GlobalRegUse
forall a b. (a -> b) -> a -> b
$ Platform -> CmmType
bWord Platform
platform)
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 CmmExpr -> [CmmExpr] -> [CmmExpr]
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 CmmExpr -> [CmmExpr] -> [CmmExpr]
forall a. a -> [a] -> [a]
: [CmmExpr]
args') Int
upd
updfr_sz <- getUpdFrameOff
loop_id <- newBlockId
emitLabel loop_id
heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code
altHeapCheck :: [LocalReg] -> FCode a -> FCode a
altHeapCheck :: forall a. [LocalReg] -> FCode a -> FCode a
altHeapCheck [LocalReg]
regs FCode a
code = Bool -> [LocalReg] -> FCode a -> FCode a
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 <- FCode Profile
getProfile
platform <- getPlatform
case cannedGCEntryPoint platform regs of
Maybe CmmExpr
Nothing -> Bool -> FCode a -> FCode a
forall a. Bool -> FCode a -> FCode a
genericGC Bool
checkYield FCode a
code
Just CmmExpr
gc -> do
lret <- FCode BlockId
forall (m :: * -> *). MonadGetUnique m => m BlockId
newBlockId
let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) regs []
lcont <- newBlockId
tscope <- getTickScope
emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)
emitLabel lcont
cannedGCReturnsTo checkYield False gc regs lret off 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 <- FCode Platform
getPlatform
case cannedGCEntryPoint platform regs of
Maybe CmmExpr
Nothing -> Bool -> FCode a -> FCode a
forall a. Bool -> FCode a -> FCode a
genericGC Bool
False FCode a
code
Just CmmExpr
gc -> Bool
-> Bool
-> CmmExpr
-> [LocalReg]
-> BlockId
-> Int
-> FCode a
-> FCode a
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 = Bool -> [LocalReg] -> FCode a -> FCode a
forall a. Bool -> [LocalReg] -> FCode a -> FCode a
altOrNoEscapeHeapCheck Bool
True
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 <- FCode Profile
getProfile
updfr_sz <- getUpdFrameOff
heapCheck False checkYield (gc_call profile gc updfr_sz) code
where
reg_exprs :: [CmmExpr]
reg_exprs = (LocalReg -> CmmExpr) -> [LocalReg] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> (LocalReg -> CmmReg) -> LocalReg -> CmmExpr
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 updfr_sz <- FCode Int
getUpdFrameOff
lretry <- newBlockId
emitLabel lretry
call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
heapCheck False checkYield (call <*> mkBranch lretry) code
cannedGCEntryPoint :: Platform -> [LocalReg] -> Maybe CmmExpr
cannedGCEntryPoint :: Platform -> [LocalReg] -> Maybe CmmExpr
cannedGCEntryPoint Platform
platform [LocalReg]
regs
= case (LocalReg -> CmmType) -> [LocalReg] -> [CmmType]
forall a b. (a -> b) -> [a] -> [b]
map LocalReg -> CmmType
localRegType [LocalReg]
regs of
[] -> CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_noregs")
[CmmType
ty]
| CmmType -> Bool
isGcPtrType CmmType
ty -> CmmExpr -> Maybe CmmExpr
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 -> CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_f1")
Width
W64 -> CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_d1")
Width
_ -> Maybe CmmExpr
forall a. Maybe a
Nothing
| Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform -> CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_unbx_r1")
| Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 -> CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_l1")
| Bool
otherwise -> Maybe CmmExpr
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 -> CmmExpr -> Maybe CmmExpr
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 -> CmmExpr -> Maybe CmmExpr
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 -> CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just (String -> CmmExpr
mkGcLabel String
"stg_gc_pppp")
[CmmType]
_otherwise -> Maybe CmmExpr
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
= (Int -> FCode a) -> FCode a
forall a. (Int -> FCode a) -> FCode a
getHeapUsage ((Int -> FCode a) -> FCode a) -> (Int -> FCode a) -> FCode a
forall a b. (a -> b) -> a -> b
$ \ Int
hpHw ->
do { platform <- FCode Platform
getPlatform
; let mb_alloc_bytes
| Int
hpHw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
mBLOCK_SIZE = String -> Maybe CmmExpr
forall a. HasCallStack => String -> a
sorry (String -> Maybe CmmExpr) -> String -> Maybe CmmExpr
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[String
" Trying to allocate more than "String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
mBLOCK_SIZEString -> String -> String
forall 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just (Platform -> Int -> CmmExpr
mkIntExpr Platform
platform (Int
hpHw Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Platform -> Int
platformWordSizeInBytes Platform
platform)))
| Bool
otherwise = Maybe CmmExpr
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) Int -> Int -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bLOCK_SIZE_W
stk_hwm | Bool
checkStack = CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just (CmmLit -> CmmExpr
CmmLit CmmLit
CmmHighStackMark)
| Bool
otherwise = Maybe CmmExpr
forall a. Maybe a
Nothing
; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc
; tickyAllocHeap True hpHw
; setRealHp hpHw
; code }
heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()
heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()
heapStackCheckGen Maybe CmmExpr
stk_hwm Maybe CmmExpr
mb_bytes
= do updfr_sz <- FCode Int
getUpdFrameOff
lretry <- newBlockId
emitLabel lretry
call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
do_checks stk_hwm False mb_bytes (call <*> mkBranch 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
omit_yields <- StgToCmmConfig -> Bool
stgToCmmOmitYields (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig
platform <- getPlatform
gc_id <- newBlockId
let
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 (CmmReg -> CmmType
cmmRegType (CmmReg -> CmmType) -> CmmReg -> CmmType
forall a b. (a -> b) -> a -> b
$ Platform -> CmmReg
spReg Platform
platform)))
[Area -> Int -> CmmExpr
CmmStackSlot Area
Old Int
0, CmmExpr
sp_hwm],
CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> CmmReg -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Platform -> CmmReg
spLimReg Platform
platform]
hp_oflo = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Platform -> MachOp
mo_wordUGt Platform
platform) [Platform -> CmmExpr
hpExpr Platform
platform, Platform -> CmmExpr
hpLimExpr Platform
platform]
case mb_stk_hwm of
Maybe CmmExpr
Nothing -> () -> FCode ()
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just CmmExpr
stk_hwm -> FCode ()
tickyStackCheck
FCode () -> FCode () -> FCode ()
forall a b. FCode a -> FCode b -> FCode b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
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 (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) )
self_loop_info <- getSelfLoop
case self_loop_info of
Just MkSelfLoopInfo { sli_header_block :: SelfLoopInfo -> BlockId
sli_header_block = BlockId
loop_header_id }
| Bool
checkYield Bool -> Bool -> Bool
&& Maybe CmmExpr -> Bool
forall a. Maybe a -> Bool
isJust Maybe CmmExpr
mb_stk_hwm -> BlockId -> FCode ()
emitLabel BlockId
loop_header_id
Maybe SelfLoopInfo
_otherwise -> () -> FCode ()
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
case mb_alloc_lit of
Just CmmExpr
alloc_lit -> do
let bump_hp :: CmmExpr
bump_hp = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprB Platform
platform (Platform -> CmmExpr
hpExpr Platform
platform) CmmExpr
alloc_lit
alloc_n :: CmmAGraph
alloc_n = CmmReg -> CmmExpr -> CmmAGraph
mkAssign (Platform -> CmmReg
hpAllocReg Platform
platform) CmmExpr
alloc_lit
FCode ()
tickyHeapCheck
CmmReg -> CmmExpr -> FCode ()
emitAssign (Platform -> CmmReg
hpReg Platform
platform) CmmExpr
bump_hp
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
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) (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
Maybe CmmExpr
Nothing ->
Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
checkYield Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
omit_yields) (FCode () -> FCode ()) -> FCode () -> FCode ()
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 -> CmmExpr) -> CmmReg -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Platform -> CmmReg
hpLimReg Platform
platform,
CmmLit -> CmmExpr
CmmLit (Platform -> CmmLit
zeroCLit Platform
platform)]
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
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 (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
tscope <- getTickScope
emitOutOfLine gc_id
(do_gc, tscope)