diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/Cmm/CLabel.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Settings.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Prim.hs | 23 |
3 files changed, 20 insertions, 7 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index c6969be7ca..4f28818291 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -43,6 +43,7 @@ module GHC.Cmm.CLabel ( mkDirty_MUT_VAR_Label, mkNonmovingWriteBarrierEnabledLabel, + mkKeepAliveInfoLabel, mkUpdInfoLabel, mkBHUpdInfoLabel, mkIndStaticInfoLabel, @@ -500,6 +501,7 @@ mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable -- Constructing Cmm Labels mkDirty_MUT_VAR_Label, mkNonmovingWriteBarrierEnabledLabel, + mkKeepAliveInfoLabel, mkUpdInfoLabel, mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel, @@ -512,6 +514,7 @@ mkDirty_MUT_VAR_Label, mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel = CmmLabel rtsUnitId (fsLit "nonmoving_write_barrier_enabled") CmmData +mkKeepAliveInfoLabel = CmmLabel rtsUnitId (fsLit "stg_keepAlive_frame") CmmInfo mkUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_upd_frame") CmmInfo mkBHUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" ) CmmInfo mkIndStaticInfoLabel = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC") CmmInfo diff --git a/compiler/GHC/Settings.hs b/compiler/GHC/Settings.hs index e0466a1cf2..b5699a7149 100644 --- a/compiler/GHC/Settings.hs +++ b/compiler/GHC/Settings.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} + -- | Run-time settings module GHC.Settings ( Settings (..) diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index 680645d8d6..338c401d0f 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -39,7 +39,6 @@ import GHC.StgToCmm.Prof ( costCentreFrom ) import GHC.Driver.Session import GHC.Platform import GHC.Types.Basic -import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Cmm.BlockId import GHC.Cmm.Graph import GHC.Stg.Syntax @@ -86,12 +85,8 @@ cgOpApp (StgFCallOp fcall ty) stg_args res_ty cgOpApp (StgPrimOp KeepAliveOp) args _res_ty | [x, s, StgVarArg k] <- args = do - { emitComment $ fsLit "keepAlive#" - ; r <- cgExpr (StgApp k [s]) - ; cmm_args <- getNonVoidArgAmodes [x, StgVarArg realWorldPrimId] - ; emitPrimCall [] MO_Touch cmm_args - ; return r - } + x' <- getNonVoidArgAmodes [x] + emitKeepAliveFrame (case x' of [y] -> y) $ cgExpr (StgApp k [s]) | otherwise = pprPanic "ill-formed keepAlive#" (ppr args) cgOpApp (StgPrimOp primop) args res_ty = do @@ -131,6 +126,20 @@ cgOpApp (StgPrimCallOp primcall) args _res_ty ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } +emitKeepAliveFrame :: CmmExpr -> FCode a -> FCode a +emitKeepAliveFrame x body + = do + updfr <- getUpdFrameOff + dflags <- getDynFlags + let hdr = fixedHdrSize dflags + off_frame = updfr + hdr + sIZEOF_StgKeepAliveFrame_NoHdr dflags + frame = CmmStackSlot Old off_frame + off_closure = hdr + oFFSET_StgKeepAliveFrame_closure dflags + + emitStore frame (mkLblExpr mkKeepAliveInfoLabel) + emitStore (cmmOffset (targetPlatform dflags) frame off_closure) x + withUpdFrameOff off_frame body + -- | Interpret the argument as an unsigned value, assuming the value -- is given in two-complement form in the given width. -- |