diff options
Diffstat (limited to 'compiler/codeGen/StgCmmBind.hs')
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 55 |
1 files changed, 25 insertions, 30 deletions
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 31775d6624..aa2b954a95 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: bindings @@ -15,14 +13,14 @@ module StgCmmBind ( pushUpdateFrame, emitUpdateFrame ) where -#include "HsVersions.h" +import GhcPrelude hiding ((<*>)) import StgCmmExpr import StgCmmMonad import StgCmmEnv import StgCmmCon import StgCmmHeap -import StgCmmProf (curCCS, ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk, +import StgCmmProf (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk, initUpdFrameProf) import StgCmmTicky import StgCmmLayout @@ -53,8 +51,6 @@ import DynFlags import Control.Monad -import Prelude hiding ((<*>)) - ------------------------------------------------------------------------ -- Top-level bindings ------------------------------------------------------------------------ @@ -99,21 +95,20 @@ cgTopRhsClosure dflags rec id ccs _ upd_flag args body = emitDataLits closure_label closure_rep return () - gen_code dflags lf_info closure_label - = do { -- LAY OUT THE OBJECT - let name = idName id + gen_code dflags lf_info _closure_label + = do { let name = idName id ; mod_name <- getModuleName ; let descr = closureDescription dflags mod_name name closure_info = mkClosureInfo dflags True id lf_info 0 0 descr - caffy = idCafInfo id - info_tbl = mkCmmInfo closure_info -- XXX short-cut - closure_rep = mkStaticClosureFields dflags info_tbl ccs caffy [] + -- We don't generate the static closure here, because we might + -- want to add references to static closures to it later. The + -- static closure is generated by CmmBuildInfoTables.updInfoSRTs, + -- See Note [SRTs], specifically the [FUN] optimisation. - -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) - ; emitDataLits closure_label closure_rep - ; let fv_details :: [(NonVoid Id, VirtualHpOffset)] - (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info) [] + ; let fv_details :: [(NonVoid Id, ByteOff)] + header = if isLFThunk lf_info then ThunkHeader else StdHeader + (_, _, fv_details) = mkVirtHeapOffsets dflags header [] -- Don't drop the non-void args until the closure info has been made ; forkClosureBody (closureCodeBody True id closure_info ccs (nonVoidIds args) (length args) body fv_details) @@ -350,9 +345,9 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body ; let name = idName bndr descr = closureDescription dflags mod_name name fv_details :: [(NonVoid Id, ByteOff)] + header = if isLFThunk lf_info then ThunkHeader else StdHeader (tot_wds, ptr_wds, fv_details) - = mkVirtHeapOffsets dflags (isLFThunk lf_info) - (addIdReps reduced_fvs) + = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs) closure_info = mkClosureInfo dflags False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -367,10 +362,10 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body -- BUILD THE OBJECT -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body - ; let use_cc = curCCS; blame_cc = curCCS + ; let use_cc = cccsExpr; blame_cc = cccsExpr ; emit (mkComment $ mkFastString "calling allocDynClosure") ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off) - ; let info_tbl = mkCmmInfo closure_info + ; let info_tbl = mkCmmInfo closure_info bndr currentCCS ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc (map toVarArg fv_details) @@ -395,9 +390,10 @@ cgRhsStdThunk bndr lf_info payload { -- LAY OUT THE OBJECT mod_name <- getModuleName ; dflags <- getDynFlags - ; let (tot_wds, ptr_wds, payload_w_offsets) - = mkVirtHeapOffsets dflags (isLFThunk lf_info) - (addArgReps (nonVoidStgArgs payload)) + ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader + (tot_wds, ptr_wds, payload_w_offsets) + = mkVirtHeapOffsets dflags header + (addArgReps (nonVoidStgArgs payload)) descr = closureDescription dflags mod_name (idName bndr) closure_info = mkClosureInfo dflags False -- Not static @@ -405,11 +401,11 @@ cgRhsStdThunk bndr lf_info payload descr -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body - ; let use_cc = curCCS; blame_cc = curCCS + ; let use_cc = cccsExpr; blame_cc = cccsExpr -- BUILD THE OBJECT - ; let info_tbl = mkCmmInfo closure_info + ; let info_tbl = mkCmmInfo closure_info bndr currentCCS ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc payload_w_offsets @@ -465,7 +461,7 @@ closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details \(_, node, _) -> thunkCode cl_info fv_details cc node arity body where lf_info = closureLFInfo cl_info - info_tbl = mkCmmInfo cl_info + info_tbl = mkCmmInfo cl_info bndr cc closureCodeBody top_lvl bndr cl_info cc args arity body fv_details = -- Note: args may be [], if all args are Void @@ -476,7 +472,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details ; let lf_info = closureLFInfo cl_info - info_tbl = mkCmmInfo cl_info + info_tbl = mkCmmInfo cl_info bndr cc -- Emit the main entry code ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $ @@ -632,8 +628,7 @@ emitBlackHoleCode node = do -- work with profiling. when eager_blackholing $ do - emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) - (CmmReg (CmmGlobal CurrentTSO)) + emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr emitPrimCall [] MO_WriteBarrier [] emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo)) @@ -718,7 +713,7 @@ link_caf node _is_upd = do ForeignLabelInExternalPackage IsFunction ; bh <- newTemp (bWord dflags) ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl - [ (CmmReg (CmmGlobal BaseReg), AddrHint), + [ (baseExpr, AddrHint), (CmmReg (CmmLocal node), AddrHint) ] False |