If the case scrutinee can't allocate, we don't need to do a heap
check in the case alternatives. (A previous patch got that right.)
In that case, we had better not adjust the heap pointer to recover
unused stack space before evaluating the scrutinee -- because we
aren't going to reallocate for the case alternative.
; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
alt_regs = map idToReg ret_bndrs
simple_scrut = isSimpleScrut scrut alt_type
; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
alt_regs = map idToReg ret_bndrs
simple_scrut = isSimpleScrut scrut alt_type
- gc_plan | not simple_scrut = GcInAlts alt_regs srt
- | isSingleton alts = NoGcInAlts
- | up_hp_usg > 0 = NoGcInAlts
- | otherwise = GcInAlts alt_regs srt
+ gcInAlts | not simple_scrut = True
+ | isSingleton alts = False
+ | up_hp_usg > 0 = False
+ | otherwise = True
+ gc_plan = if gcInAlts then GcInAlts alt_regs srt else NoGcInAlts
; mb_cc <- maybeSaveCostCentre simple_scrut
; c_srt <- getSRTInfo srt
; mb_cc <- maybeSaveCostCentre simple_scrut
; c_srt <- getSRTInfo srt
- ; withSequel (AssignTo alt_regs c_srt)
- (cgExpr scrut)
+ ; withSequel (AssignTo alt_regs gcInAlts) (cgExpr scrut)
; restoreCurrentCostCentre mb_cc
; bindArgsToRegs ret_bndrs
; restoreCurrentCostCentre mb_cc
; bindArgsToRegs ret_bndrs
-- return (x,y)
-- If the sequel is AssignTo [p,q]
-- p=x; q=y;
-- return (x,y)
-- If the sequel is AssignTo [p,q]
-- p=x; q=y;
-emitReturn results
- = do { adjustHpBackwards
- ; sequel <- getSequel;
- ; updfr_off <- getUpdFrameOff
- ; case sequel of
- Return _ -> emit (mkReturnSimple results updfr_off)
- AssignTo regs _ -> emit (mkMultiAssign regs results)
- }
+emitReturn results
+ = do { sequel <- getSequel;
+ ; updfr_off <- getUpdFrameOff
+ ; emit $ mkComment $ mkFastString "emitReturn"
+ ; case sequel of
+ Return _ ->
+ do { adjustHpBackwards
+ ; emit (mkReturnSimple results updfr_off) }
+ AssignTo regs adjust ->
+ do { if adjust then adjustHpBackwards else return ()
+ ; emit (mkMultiAssign regs results) }
+ }
emitCall :: Convention -> CmmExpr -> [CmmExpr] -> FCode ()
-- (cgCall fun args) makes a call to the entry-code of 'fun',
emitCall :: Convention -> CmmExpr -> [CmmExpr] -> FCode ()
-- (cgCall fun args) makes a call to the entry-code of 'fun',
= do { adjustHpBackwards
; sequel <- getSequel
; updfr_off <- getUpdFrameOff
= do { adjustHpBackwards
; sequel <- getSequel
; updfr_off <- getUpdFrameOff
- ; emit $ mkComment $ mkFastString "emitcall"
+ ; emit $ mkComment $ mkFastString "emitCall"
- Return _ -> emit (mkForeignJump conv fun args updfr_off)
- AssignTo res_regs srt -> emit (mkCall fun conv res_regs args updfr_off)
+ Return _ -> emit (mkForeignJump conv fun args updfr_off)
+ AssignTo res_regs _ -> emit (mkCall fun conv res_regs args updfr_off)
}
adjustHpBackwards :: FCode ()
}
adjustHpBackwards :: FCode ()
; let srt = pprTrace "Urk! SRT for over-sat call"
(ppr lbl) NoC_SRT
-- XXX: what if rest_args contains static refs?
; let srt = pprTrace "Urk! SRT for over-sat call"
(ppr lbl) NoC_SRT
-- XXX: what if rest_args contains static refs?
- ; withSequel (AssignTo [pap_id] srt)
+ ; withSequel (AssignTo [pap_id] True)
(emitCall Native target fast_args)
; slow_call (CmmReg (CmmLocal pap_id))
rest_args rest_reps }
(emitCall Native target fast_args)
; slow_call (CmmReg (CmmLocal pap_id))
rest_args rest_reps }
| AssignTo
[LocalReg] -- Put result(s) in these regs and fall through
-- NB: no void arguments here
| AssignTo
[LocalReg] -- Put result(s) in these regs and fall through
-- NB: no void arguments here
- C_SRT -- Here are the statics live in the continuation
- -- E.g. case (case x# of 0# -> a; DEFAULT -> b) of {
- -- r -> <blah>
- -- When compiling the nested case, remember to put the
- -- result in r, and fall through
-
+ Bool -- Should we adjust the heap pointer back to recover
+ -- space that's unused on this path?
+ -- We need to do this only if the expression may
+ -- allocate (e.g. it's a foreign call or allocating primOp)
initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags mod
initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags mod