diff options
Diffstat (limited to 'compiler/codeGen')
| -rw-r--r-- | compiler/codeGen/StgCmm.hs | 25 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 11 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmClosure.hs | 82 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmLayout.hs | 28 |
4 files changed, 87 insertions, 59 deletions
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index c4ba409734..f88541a023 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -245,21 +245,18 @@ cgDataCon :: DataCon -> FCode () -- the static closure, for a constructor. cgDataCon data_con = do { let - -- To allow the debuggers, interpreters, etc to cope with - -- static data structures (ie those built at compile - -- time), we take care that info-table contains the - -- information we need. - static_cl_info = mkConInfo True no_cafs data_con tot_wds ptr_wds - dyn_cl_info = mkConInfo False NoCafRefs data_con tot_wds ptr_wds - no_cafs = pprPanic "cgDataCon: CAF field should not be reqd" (ppr data_con) - - (tot_wds, -- #ptr_wds + #nonptr_wds + (tot_wds, -- #ptr_wds + #nonptr_wds ptr_wds, -- #ptr_wds arg_things) = mkVirtConstrOffsets arg_reps - emit_info cl_info ticky_code - = emitClosureAndInfoTable cl_info NativeDirectCall [] - $ mk_code ticky_code + nonptr_wds = tot_wds - ptr_wds + + sta_info_tbl = mkDataConInfoTable data_con True ptr_wds nonptr_wds + dyn_info_tbl = mkDataConInfoTable data_con False ptr_wds nonptr_wds + + emit_info info_tbl ticky_code + = emitClosureAndInfoTable info_tbl NativeDirectCall [] + $ mk_code ticky_code mk_code ticky_code = -- NB: We don't set CC when entering data (WDP 94/06) @@ -275,10 +272,10 @@ cgDataCon data_con -- Dynamic closure code for non-nullary constructors only ; whenC (not (isNullaryRepDataCon data_con)) - (emit_info dyn_cl_info tickyEnterDynCon) + (emit_info dyn_info_tbl tickyEnterDynCon) -- Dynamic-Closure first, to reduce forward references - ; emit_info static_cl_info tickyEnterStaticCon } + ; emit_info sta_info_tbl tickyEnterStaticCon } --------------------------------------------------------------- diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 3823fa15b0..281ad31fa2 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -379,8 +379,11 @@ closureCodeBody :: Bool -- whether this is a top-level binding closureCodeBody top_lvl bndr cl_info cc args arity body fv_details | length args == 0 -- No args i.e. thunk - = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $ + = emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ \(_, node, _) -> thunkCode cl_info fv_details cc node arity body + where + lf_info = closureLFInfo cl_info + info_tbl = mkCmmInfo cl_info closureCodeBody top_lvl bndr cl_info cc args arity body fv_details = ASSERT( length args > 0 ) @@ -392,8 +395,12 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details ; emitTickyCounter cl_info (map stripNV args) ; setTickyCtrLabel ticky_ctr_lbl $ do + ; let + lf_info = closureLFInfo cl_info + info_tbl = mkCmmInfo cl_info + -- Emit the main entry code - ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ + ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $ \(offset, node, arg_regs) -> do -- Emit slow-entry code (for entering a closure through a PAP) { mkSlowEntryCode cl_info arg_regs diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 498aea8c55..bbf884bfc4 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -33,6 +33,7 @@ module StgCmmClosure ( ----------------------------------- ClosureInfo, mkClosureInfo, mkConInfo, + mkCmmInfo, closureSize, closureName, infoTableLabelFromCI, entryLabelFromCI, @@ -43,7 +44,7 @@ module StgCmmClosure ( closureFunInfo, isStandardFormThunk, isKnownFun, funTag, tagForArity, - enterIdLabel, enterLocalIdLabel, + enterIdLabel, enterLocalIdLabel, nodeMustPointToIt, CallMethod(..), getCallMethod, @@ -55,6 +56,8 @@ module StgCmmClosure ( cafBlackHoleClosureInfo, staticClosureNeedsLink, clHasCafRefs, clProfInfo, + + mkDataConInfoTable, ) where #include "../includes/MachDeps.h" @@ -360,8 +363,8 @@ isLFReEntrant _ = False lfClosureType :: LambdaFormInfo -> ClosureTypeInfo lfClosureType (LFReEntrant _ arity _ argd) = Fun (fromIntegral arity) argd -lfClosureType (LFCon con) = Constr (fromIntegral (dataConTagZ con)) - (dataConIdentity con) +lfClosureType (LFCon con) = Constr (fromIntegral (dataConTagZ con)) + (dataConIdentity con) lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel lfClosureType _ = panic "lfClosureType" @@ -743,6 +746,15 @@ cafBlackHoleClosureInfo cl_info@(ClosureInfo {}) , closureInfLcl = False } cafBlackHoleClosureInfo (ConInfo {}) = panic "cafBlackHoleClosureInfo" +-- Convert from 'ClosureInfo' to 'CmmInfoTable'. +-- Not used for return points. +mkCmmInfo :: ClosureInfo -> CmmInfoTable +mkCmmInfo cl_info + = CmmInfoTable { cit_lbl = infoTableLabelFromCI cl_info, + cit_rep = closureSMRep cl_info, + cit_prof = clProfInfo cl_info, + cit_srt = closureSRT cl_info } + -------------------------------------- -- Functions about closure *sizes* @@ -856,45 +868,39 @@ isToplevClosure _ = False -- Label generation -------------------------------------- -infoTableLabelFromCI :: ClosureInfo -> CLabel -infoTableLabelFromCI = fst . labelsFromCI - entryLabelFromCI :: ClosureInfo -> CLabel -entryLabelFromCI = snd . labelsFromCI +entryLabelFromCI = infoLblToEntryLbl . infoTableLabelFromCI -labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry) -labelsFromCI (ClosureInfo { closureName = name, +infoTableLabelFromCI :: ClosureInfo -> CLabel +infoTableLabelFromCI (ClosureInfo { closureName = name, closureLFInfo = lf_info, closureCafs = cafs, closureInfLcl = is_lcl }) = case lf_info of - LFBlackHole -> (mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel) + LFBlackHole -> mkCAFBlackHoleInfoTableLabel LFThunk _ _ upd_flag (SelectorThunk offset) _ - -> bothL (mkSelectorInfoLabel, mkSelectorEntryLabel) upd_flag offset + -> mkSelectorInfoLabel upd_flag offset LFThunk _ _ upd_flag (ApThunk arity) _ - -> bothL (mkApInfoTableLabel, mkApEntryLabel) upd_flag arity + -> mkApInfoTableLabel upd_flag arity - LFThunk{} -> bothL std_mk_lbls name cafs - LFReEntrant{} -> bothL std_mk_lbls name cafs + LFThunk{} -> std_mk_lbl name cafs + LFReEntrant{} -> std_mk_lbl name cafs _other -> panic "labelsFromCI" where - std_mk_lbls | is_lcl = (mkLocalInfoTableLabel, mkLocalEntryLabel) - | otherwise = (mkInfoTableLabel, mkEntryLabel) - -labelsFromCI (ConInfo { closureCon = con, closureSMRep = rep, closureCafs = cafs }) - | isStaticRep rep - = bothL (mkStaticInfoTableLabel, mkStaticConEntryLabel) name cafs - | otherwise - = bothL (mkConInfoTableLabel, mkConEntryLabel) name cafs + std_mk_lbl | is_lcl = mkLocalInfoTableLabel + | otherwise = mkInfoTableLabel + +infoTableLabelFromCI (ConInfo { closureCon = con, + closureSMRep = rep, + closureCafs = cafs }) + | isStaticRep rep = mkStaticInfoTableLabel name cafs + | otherwise = mkConInfoTableLabel name cafs where name = dataConName con -bothL :: (a -> b -> c, a -> b -> c) -> a -> b -> (c, c) -bothL (f, g) x y = (f x y, g x y) - -- ClosureInfo for a closure (as opposed to a constructor) is always local closureLabelFromCI :: ClosureInfo -> CLabel closureLabelFromCI cl@(ClosureInfo { closureName = nm }) = @@ -973,3 +979,29 @@ getPredTyDescription (ClassP cl _) = getOccString cl getPredTyDescription (IParam ip _) = getOccString (ipNameName ip) getPredTyDescription (EqPred {}) = "Type equality" +-------------------------------------- +-- Misc things +-------------------------------------- + +mkDataConInfoTable :: DataCon -> Bool -> Int -> Int -> CmmInfoTable +mkDataConInfoTable data_con is_static ptr_wds nonptr_wds + = CmmInfoTable { cit_lbl = info_lbl + , cit_rep = sm_rep + , cit_prof = prof + , cit_srt = NoC_SRT } + where + name = dataConName data_con + + info_lbl | is_static = mkStaticInfoTableLabel name NoCafRefs + | otherwise = mkConInfoTableLabel name NoCafRefs + + sm_rep = mkHeapRep is_static ptr_wds nonptr_wds cl_type + + cl_type = Constr (fromIntegral (dataConTagZ data_con)) + (dataConIdentity data_con) + + prof | not opt_SccProfilingOn = NoProfilingInfo + | otherwise = ProfilingInfo ty_descr val_descr + + ty_descr = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con + val_descr = stringToWord8s $ occNameString $ getOccName data_con diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 953aa1cdd2..8b94abf828 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -369,12 +369,13 @@ stdPattern reps emitClosureProcAndInfoTable :: Bool -- top-level? -> Id -- name of the closure - -> ClosureInfo -- lots of info abt the closure + -> LambdaFormInfo + -> CmmInfoTable -> [NonVoid Id] -- incoming arguments -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body -> FCode () -emitClosureProcAndInfoTable top_lvl bndr cl_info args body - = do { let lf_info = closureLFInfo cl_info +emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body + = do { -- Bind the binder itself, but only if it's not a top-level -- binding. We need non-top let-bindings to refer to the -- top-level binding, which this binding would incorrectly shadow. @@ -386,28 +387,19 @@ emitClosureProcAndInfoTable top_lvl bndr cl_info args body conv = if nodeMustPointToIt lf_info then NativeNodeCall else NativeDirectCall (offset, _) = mkCallEntry conv args' - ; emitClosureAndInfoTable cl_info conv args' $ body (offset, node, arg_regs) + ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs) } -- Data constructors need closures, but not with all the argument handling -- needed for functions. The shared part goes here. emitClosureAndInfoTable :: - ClosureInfo -> Convention -> [LocalReg] -> FCode () -> FCode () -emitClosureAndInfoTable cl_info conv args body - = do { let info = mkCmmInfo cl_info - ; blks <- getCode body - ; emitProcWithConvention conv info (entryLabelFromCI cl_info) args blks + CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode () +emitClosureAndInfoTable info_tbl conv args body + = do { blks <- getCode body + ; let entry_lbl = infoLblToEntryLbl (cit_lbl info_tbl) + ; emitProcWithConvention conv info_tbl entry_lbl args blks } --- Convert from 'ClosureInfo' to 'CmmInfoTable'. --- Not used for return points. -mkCmmInfo :: ClosureInfo -> CmmInfoTable -mkCmmInfo cl_info - = CmmInfoTable { cit_lbl = infoTableLabelFromCI cl_info, - cit_rep = closureSMRep cl_info, - cit_prof = clProfInfo cl_info, - cit_srt = closureSRT cl_info } - ----------------------------------------------------------------------------- -- -- Info table offsets |