module GHC.StgToCmm.Heap (
getVirtHp, setVirtHp, setRealHp,
getHpRelOffset,
entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,
heapStackCheckGen,
entryHeapCheck',
mkStaticClosureFields, mkStaticClosure,
allocDynClosure, allocDynClosureCmm, allocHeapClosure,
emitSetDynHdr
) where
import GhcPrelude hiding ((<*>))
import StgSyn
import 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 MkGraph
import Hoopl.Label
import SMRep
import BlockId
import Cmm
import CmmUtils
import CostCentre
import IdInfo( CafInfo(..), mayHaveCafRefs )
import Id ( Id )
import Module
import DynFlags
import FastString( mkFastString, fsLit )
import 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, VirtualHpOffset)]
-> FCode CmmExpr
allocDynClosure Maybe Id
mb_id CmmInfoTable
info_tbl LambdaFormInfo
lf_info CmmExpr
use_cc CmmExpr
_blame_cc [(NonVoid StgArg, VirtualHpOffset)]
args_w_offsets = do
let ([NonVoid StgArg]
args, [VirtualHpOffset]
offsets) = [(NonVoid StgArg, VirtualHpOffset)]
-> ([NonVoid StgArg], [VirtualHpOffset])
forall a b. [(a, b)] -> ([a], [b])
unzip [(NonVoid StgArg, VirtualHpOffset)]
args_w_offsets
[CmmExpr]
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)
mapM NonVoid StgArg -> FCode CmmExpr
getArgAmode [NonVoid StgArg]
args
Maybe Id
-> CmmInfoTable
-> LambdaFormInfo
-> CmmExpr
-> CmmExpr
-> [(CmmExpr, VirtualHpOffset)]
-> FCode CmmExpr
allocDynClosureCmm Maybe Id
mb_id CmmInfoTable
info_tbl LambdaFormInfo
lf_info
CmmExpr
use_cc CmmExpr
_blame_cc ([CmmExpr] -> [VirtualHpOffset] -> [(CmmExpr, VirtualHpOffset)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmExpr]
cmm_args [VirtualHpOffset]
offsets)
allocDynClosureCmm :: Maybe Id
-> CmmInfoTable
-> LambdaFormInfo
-> CmmExpr
-> CmmExpr
-> [(CmmExpr, VirtualHpOffset)]
-> FCode CmmExpr
allocDynClosureCmm Maybe Id
mb_id CmmInfoTable
info_tbl LambdaFormInfo
lf_info CmmExpr
use_cc CmmExpr
_blame_cc [(CmmExpr, VirtualHpOffset)]
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, VirtualHpOffset)]
-> FCode CmmExpr
allocHeapClosure SMRep
rep CmmExpr
info_ptr CmmExpr
use_cc [(CmmExpr, VirtualHpOffset)]
amodes_w_offsets
allocHeapClosure
:: SMRep
-> CmmExpr
-> CmmExpr
-> [(CmmExpr,ByteOff)]
-> FCode CmmExpr
allocHeapClosure :: SMRep
-> CmmExpr
-> CmmExpr
-> [(CmmExpr, VirtualHpOffset)]
-> FCode CmmExpr
allocHeapClosure SMRep
rep CmmExpr
info_ptr CmmExpr
use_cc [(CmmExpr, VirtualHpOffset)]
payload = do
SMRep -> CmmExpr -> FCode ()
profDynAlloc SMRep
rep CmmExpr
use_cc
VirtualHpOffset
virt_hp <- FCode VirtualHpOffset
getVirtHp
let info_offset :: VirtualHpOffset
info_offset = VirtualHpOffset
virt_hp VirtualHpOffset -> VirtualHpOffset -> VirtualHpOffset
forall a. Num a => a -> a -> a
+ VirtualHpOffset
1
CmmExpr
base <- VirtualHpOffset -> FCode CmmExpr
getHpRelOffset VirtualHpOffset
info_offset
FastString -> FCode ()
emitComment (FastString -> FCode ()) -> FastString -> FCode ()
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, VirtualHpOffset)] -> FCode ()
hpStore CmmExpr
base [(CmmExpr, VirtualHpOffset)]
payload
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
VirtualHpOffset -> FCode ()
setVirtHp (VirtualHpOffset
virt_hp VirtualHpOffset -> VirtualHpOffset -> VirtualHpOffset
forall a. Num a => a -> a -> a
+ DynFlags -> SMRep -> VirtualHpOffset
heapClosureSizeW DynFlags
dflags SMRep
rep)
CmmExpr -> FCode CmmExpr
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 DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> FCode ()
hpStore CmmExpr
base ([CmmExpr] -> [VirtualHpOffset] -> [(CmmExpr, VirtualHpOffset)]
forall a b. [a] -> [b] -> [(a, b)]
zip (DynFlags -> [CmmExpr]
header DynFlags
dflags) [VirtualHpOffset
0, DynFlags -> VirtualHpOffset
wORD_SIZE DynFlags
dflags ..])
where
header :: DynFlags -> [CmmExpr]
header :: DynFlags -> [CmmExpr]
header DynFlags
dflags = [CmmExpr
info_ptr] [CmmExpr] -> [CmmExpr] -> [CmmExpr]
forall a. [a] -> [a] -> [a]
++ DynFlags -> CmmExpr -> [CmmExpr]
dynProfHdr DynFlags
dflags CmmExpr
ccs
hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode ()
hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> FCode ()
hpStore CmmExpr
base [(CmmExpr, VirtualHpOffset)]
vals = do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
[FCode ()] -> FCode ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([FCode ()] -> FCode ()) -> [FCode ()] -> FCode ()
forall a b. (a -> b) -> a -> b
$
[ CmmExpr -> CmmExpr -> FCode ()
emitStore (DynFlags -> CmmExpr -> VirtualHpOffset -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
base VirtualHpOffset
off) CmmExpr
val | (CmmExpr
val,VirtualHpOffset
off) <- [(CmmExpr, VirtualHpOffset)]
vals ]
mkStaticClosureFields
:: DynFlags
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
-> [CmmLit]
-> [CmmLit]
mkStaticClosureFields :: DynFlags
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
-> [CmmLit]
-> [CmmLit]
mkStaticClosureFields DynFlags
dflags CmmInfoTable
info_tbl CostCentreStack
ccs CafInfo
caf_refs [CmmLit]
payload
= DynFlags
-> CLabel
-> CostCentreStack
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
mkStaticClosure DynFlags
dflags CLabel
info_lbl CostCentreStack
ccs [CmmLit]
payload [CmmLit]
padding
[CmmLit]
static_link_field [CmmLit]
saved_info_field
where
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 (t :: * -> *) a. Foldable t => t a -> Bool
null [CmmLit]
payload = [DynFlags -> VirtualHpOffset -> CmmLit
mkIntCLit DynFlags
dflags VirtualHpOffset
0]
| Bool
otherwise = []
static_link_field :: [CmmLit]
static_link_field
| Bool
is_caf Bool -> Bool -> Bool
|| 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 = [DynFlags -> VirtualHpOffset -> CmmLit
mkIntCLit DynFlags
dflags VirtualHpOffset
0]
| Bool
otherwise = []
static_link_value :: CmmLit
static_link_value
| CafInfo -> Bool
mayHaveCafRefs CafInfo
caf_refs = DynFlags -> VirtualHpOffset -> CmmLit
mkIntCLit DynFlags
dflags VirtualHpOffset
0
| Bool
otherwise = DynFlags -> VirtualHpOffset -> CmmLit
mkIntCLit DynFlags
dflags VirtualHpOffset
3
mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]
-> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
mkStaticClosure :: DynFlags
-> CLabel
-> CostCentreStack
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
mkStaticClosure DynFlags
dflags CLabel
info_lbl CostCentreStack
ccs [CmmLit]
payload [CmmLit]
padding [CmmLit]
static_link_field [CmmLit]
saved_info_field
= [CLabel -> CmmLit
CmmLabel CLabel
info_lbl]
[CmmLit] -> [CmmLit] -> [CmmLit]
forall a. [a] -> [a] -> [a]
++ DynFlags -> CostCentreStack -> [CmmLit]
staticProfHdr DynFlags
dflags 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
entryHeapCheck :: ClosureInfo
-> Maybe LocalReg
-> Int
-> [LocalReg]
-> FCode ()
-> FCode ()
entryHeapCheck :: ClosureInfo
-> Maybe LocalReg
-> VirtualHpOffset
-> [LocalReg]
-> FCode ()
-> FCode ()
entryHeapCheck ClosureInfo
cl_info Maybe LocalReg
nodeSet VirtualHpOffset
arity [LocalReg]
args FCode ()
code
= Bool
-> CmmExpr -> VirtualHpOffset -> [LocalReg] -> FCode () -> FCode ()
entryHeapCheck' Bool
is_fastf CmmExpr
node VirtualHpOffset
arity [LocalReg]
args FCode ()
code
where
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 (CLabel -> CmmLit) -> CLabel -> CmmLit
forall a b. (a -> b) -> a -> b
$ ClosureInfo -> CLabel
staticClosureLabel ClosureInfo
cl_info)
is_fastf :: Bool
is_fastf = case ClosureInfo -> Maybe (VirtualHpOffset, ArgDescr)
closureFunInfo ClosureInfo
cl_info of
Just (VirtualHpOffset
_, ArgGen Liveness
_) -> Bool
False
Maybe (VirtualHpOffset, ArgDescr)
_otherwise -> Bool
True
entryHeapCheck' :: Bool
-> CmmExpr
-> Int
-> [LocalReg]
-> FCode ()
-> FCode ()
entryHeapCheck' :: Bool
-> CmmExpr -> VirtualHpOffset -> [LocalReg] -> FCode () -> FCode ()
entryHeapCheck' Bool
is_fastf CmmExpr
node VirtualHpOffset
arity [LocalReg]
args FCode ()
code
= do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let is_thunk :: Bool
is_thunk = VirtualHpOffset
arity VirtualHpOffset -> VirtualHpOffset -> Bool
forall a. Eq a => a -> a -> Bool
== VirtualHpOffset
0
args' :: [CmmExpr]
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 :: 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 :: VirtualHpOffset -> CmmAGraph
gc_call VirtualHpOffset
upd
| Bool
is_thunk
= DynFlags
-> Convention
-> CmmExpr
-> [CmmExpr]
-> VirtualHpOffset
-> CmmAGraph
mkJump DynFlags
dflags Convention
NativeNodeCall CmmExpr
stg_gc_enter1 [CmmExpr
node] VirtualHpOffset
upd
| Bool
is_fastf
= DynFlags
-> Convention
-> CmmExpr
-> [CmmExpr]
-> VirtualHpOffset
-> CmmAGraph
mkJump DynFlags
dflags Convention
NativeNodeCall CmmExpr
stg_gc_fun (CmmExpr
node CmmExpr -> [CmmExpr] -> [CmmExpr]
forall a. a -> [a] -> [a]
: [CmmExpr]
args') VirtualHpOffset
upd
| Bool
otherwise
= DynFlags
-> Convention
-> CmmExpr
-> [CmmExpr]
-> VirtualHpOffset
-> CmmAGraph
mkJump DynFlags
dflags Convention
Slow CmmExpr
stg_gc_fun (CmmExpr
node CmmExpr -> [CmmExpr] -> [CmmExpr]
forall a. a -> [a] -> [a]
: [CmmExpr]
args') VirtualHpOffset
upd
VirtualHpOffset
updfr_sz <- FCode VirtualHpOffset
getUpdFrameOff
BlockId
loop_id <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
BlockId -> FCode ()
emitLabel BlockId
loop_id
Bool -> Bool -> CmmAGraph -> FCode () -> FCode ()
forall a. Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
heapCheck Bool
True Bool
True (VirtualHpOffset -> CmmAGraph
gc_call VirtualHpOffset
updfr_sz CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmAGraph
mkBranch BlockId
loop_id) FCode ()
code
altHeapCheck :: [LocalReg] -> FCode a -> FCode a
altHeapCheck :: [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 :: Bool -> [LocalReg] -> FCode a -> FCode a
altOrNoEscapeHeapCheck Bool
checkYield [LocalReg]
regs FCode a
code = do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
case DynFlags -> [LocalReg] -> Maybe CmmExpr
cannedGCEntryPoint DynFlags
dflags [LocalReg]
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
BlockId
lret <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
let (VirtualHpOffset
off, [GlobalReg]
_, CmmAGraph
copyin) = DynFlags
-> Convention
-> Area
-> [LocalReg]
-> [LocalReg]
-> (VirtualHpOffset, [GlobalReg], CmmAGraph)
copyInOflow DynFlags
dflags Convention
NativeReturn (BlockId -> Area
Young BlockId
lret) [LocalReg]
regs []
BlockId
lcont <- FCode BlockId
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
Bool
-> Bool
-> CmmExpr
-> [LocalReg]
-> BlockId
-> VirtualHpOffset
-> FCode a
-> FCode a
forall a.
Bool
-> Bool
-> CmmExpr
-> [LocalReg]
-> BlockId
-> VirtualHpOffset
-> FCode a
-> FCode a
cannedGCReturnsTo Bool
checkYield Bool
False CmmExpr
gc [LocalReg]
regs BlockId
lret VirtualHpOffset
off FCode a
code
altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a
altHeapCheckReturnsTo :: [LocalReg] -> BlockId -> VirtualHpOffset -> FCode a -> FCode a
altHeapCheckReturnsTo [LocalReg]
regs BlockId
lret VirtualHpOffset
off FCode a
code
= do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
case DynFlags -> [LocalReg] -> Maybe CmmExpr
cannedGCEntryPoint DynFlags
dflags [LocalReg]
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
-> VirtualHpOffset
-> FCode a
-> FCode a
forall a.
Bool
-> Bool
-> CmmExpr
-> [LocalReg]
-> BlockId
-> VirtualHpOffset
-> FCode a
-> FCode a
cannedGCReturnsTo Bool
False Bool
True CmmExpr
gc [LocalReg]
regs BlockId
lret VirtualHpOffset
off FCode a
code
noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a
noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a
noEscapeHeapCheck [LocalReg]
regs FCode a
code = Bool -> [LocalReg] -> FCode a -> FCode a
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 :: Bool
-> Bool
-> CmmExpr
-> [LocalReg]
-> BlockId
-> VirtualHpOffset
-> FCode a
-> FCode a
cannedGCReturnsTo Bool
checkYield Bool
cont_on_stack CmmExpr
gc [LocalReg]
regs BlockId
lret VirtualHpOffset
off FCode a
code
= do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
VirtualHpOffset
updfr_sz <- FCode VirtualHpOffset
getUpdFrameOff
Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
forall a. Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
heapCheck Bool
False Bool
checkYield (DynFlags -> CmmExpr -> VirtualHpOffset -> CmmAGraph
gc_call DynFlags
dflags CmmExpr
gc VirtualHpOffset
updfr_sz) FCode a
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 :: DynFlags -> CmmExpr -> VirtualHpOffset -> CmmAGraph
gc_call DynFlags
dflags CmmExpr
label VirtualHpOffset
sp
| Bool
cont_on_stack
= DynFlags
-> CmmExpr
-> Convention
-> [CmmExpr]
-> BlockId
-> VirtualHpOffset
-> VirtualHpOffset
-> CmmAGraph
mkJumpReturnsTo DynFlags
dflags CmmExpr
label Convention
NativeReturn [CmmExpr]
reg_exprs BlockId
lret VirtualHpOffset
off VirtualHpOffset
sp
| Bool
otherwise
= DynFlags
-> CmmExpr
-> Convention
-> [CmmExpr]
-> BlockId
-> VirtualHpOffset
-> VirtualHpOffset
-> [CmmExpr]
-> CmmAGraph
mkCallReturnsTo DynFlags
dflags CmmExpr
label Convention
NativeReturn [CmmExpr]
reg_exprs BlockId
lret VirtualHpOffset
off VirtualHpOffset
sp []
genericGC :: Bool -> FCode a -> FCode a
genericGC :: Bool -> FCode a -> FCode a
genericGC Bool
checkYield FCode a
code
= do VirtualHpOffset
updfr_sz <- FCode VirtualHpOffset
getUpdFrameOff
BlockId
lretry <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
BlockId -> FCode ()
emitLabel BlockId
lretry
CmmAGraph
call <- CmmExpr
-> (Convention, Convention)
-> [LocalReg]
-> [CmmExpr]
-> VirtualHpOffset
-> [CmmExpr]
-> FCode CmmAGraph
mkCall CmmExpr
generic_gc (Convention
GC, Convention
GC) [] [] VirtualHpOffset
updfr_sz []
Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
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 :: DynFlags -> [LocalReg] -> Maybe CmmExpr
cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr
cannedGCEntryPoint DynFlags
dflags [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
== DynFlags -> Width
wordWidth DynFlags
dflags -> 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 :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
heapCheck Bool
checkStack Bool
checkYield CmmAGraph
do_gc FCode a
code
= (VirtualHpOffset -> FCode a) -> FCode a
forall a. (VirtualHpOffset -> FCode a) -> FCode a
getHeapUsage ((VirtualHpOffset -> FCode a) -> FCode a)
-> (VirtualHpOffset -> FCode a) -> FCode a
forall a b. (a -> b) -> a -> b
$ \ VirtualHpOffset
hpHw ->
do { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let mb_alloc_bytes :: Maybe CmmExpr
mb_alloc_bytes
| VirtualHpOffset
hpHw VirtualHpOffset -> VirtualHpOffset -> Bool
forall a. Ord a => a -> a -> Bool
> VirtualHpOffset
mBLOCK_SIZE = String -> Maybe CmmExpr
forall a. 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]
++VirtualHpOffset -> String
forall a. Show a => a -> String
show VirtualHpOffset
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."]
| VirtualHpOffset
hpHw VirtualHpOffset -> VirtualHpOffset -> Bool
forall a. Ord a => a -> a -> Bool
> VirtualHpOffset
0 = CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just (DynFlags -> VirtualHpOffset -> CmmExpr
mkIntExpr DynFlags
dflags (VirtualHpOffset
hpHw VirtualHpOffset -> VirtualHpOffset -> VirtualHpOffset
forall a. Num a => a -> a -> a
* (DynFlags -> VirtualHpOffset
wORD_SIZE DynFlags
dflags)))
| Bool
otherwise = Maybe CmmExpr
forall a. Maybe a
Nothing
where mBLOCK_SIZE :: VirtualHpOffset
mBLOCK_SIZE = DynFlags -> VirtualHpOffset
bLOCKS_PER_MBLOCK DynFlags
dflags VirtualHpOffset -> VirtualHpOffset -> VirtualHpOffset
forall a. Num a => a -> a -> a
* DynFlags -> VirtualHpOffset
bLOCK_SIZE_W DynFlags
dflags
stk_hwm :: Maybe CmmExpr
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
; FCode () -> FCode ()
codeOnly (FCode () -> FCode ()) -> FCode () -> FCode ()
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 -> VirtualHpOffset -> FCode ()
tickyAllocHeap Bool
True VirtualHpOffset
hpHw
; VirtualHpOffset -> FCode ()
setRealHp VirtualHpOffset
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 VirtualHpOffset
updfr_sz <- FCode VirtualHpOffset
getUpdFrameOff
BlockId
lretry <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
BlockId -> FCode ()
emitLabel BlockId
lretry
CmmAGraph
call <- CmmExpr
-> (Convention, Convention)
-> [LocalReg]
-> [CmmExpr]
-> VirtualHpOffset
-> [CmmExpr]
-> FCode CmmAGraph
mkCall CmmExpr
generic_gc (Convention
GC, Convention
GC) [] [] VirtualHpOffset
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 <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
BlockId
gc_id <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
let
Just CmmExpr
alloc_lit = Maybe CmmExpr
mb_alloc_lit
bump_hp :: CmmExpr
bump_hp = DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprB DynFlags
dflags CmmExpr
hpExpr CmmExpr
alloc_lit
sp_oflo :: CmmExpr -> CmmExpr
sp_oflo CmmExpr
sp_hwm =
MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordULt DynFlags
dflags)
[MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Sub (CmmType -> Width
typeWidth (DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
spReg)))
[Area -> VirtualHpOffset -> CmmExpr
CmmStackSlot Area
Old VirtualHpOffset
0, CmmExpr
sp_hwm],
CmmReg -> CmmExpr
CmmReg CmmReg
spLimReg]
hp_oflo :: CmmExpr
hp_oflo = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordUGt DynFlags
dflags) [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 -> () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just CmmExpr
stk_hwm -> FCode ()
tickyStackCheck
FCode () -> FCode () -> FCode ()
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) )
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
&& 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 (m :: * -> *) a. Monad m => a -> m a
return ()
if (Maybe CmmExpr -> Bool
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 (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)
else do
Bool -> FCode () -> FCode ()
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)) (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
let yielding :: CmmExpr
yielding = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordEq DynFlags
dflags)
[CmmReg -> CmmExpr
CmmReg CmmReg
hpLimReg,
CmmLit -> CmmExpr
CmmLit (DynFlags -> CmmLit
zeroCLit DynFlags
dflags)]
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)
CmmTickScope
tscope <- FCode CmmTickScope
getTickScope
BlockId -> CmmAGraphScoped -> FCode ()
emitOutOfLine BlockId
gc_id
(CmmAGraph
do_gc, CmmTickScope
tscope)