Skip to content

GitLab

Commit 3a179c20 authored by Simon Marlow's avatar Simon Marlow
Browse files

Refactoring: reduce usage of mkConInfo, with a view to killing it

parent 4a86a0bf
Hide whitespace changes
Inline Side-by-side
compiler/cmm/CLabel.hs
View file @ 3a179c20
......@@ -104,8 +104,9 @@ module CLabel (
needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel,
isMathFun,
isCFunctionLabel, isGcPtrLabel, labelDynamic,
infoLblToEntryLbl, entryLblToInfoLbl,
pprCLabel
pprCLabel
) where
#include "HsVersions.h"
......@@ -285,11 +286,14 @@ type IsLocal = Bool
data IdLabelInfo
= Closure -- ^ Label for closure
| SRT -- ^ Static reference table
| InfoTable IsLocal -- ^ Info tables for closures; always read-only
| InfoTable -- ^ Info tables for closures; always read-only
| Entry -- ^ Entry point
| Slow -- ^ Slow entry point
| Slow -- ^ Slow entry point
| RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id
| LocalInfoTable -- ^ Like InfoTable but not externally visible
| LocalEntry -- ^ Like Entry but not externally visible
| RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id
| ConEntry -- ^ Constructor entry point
| ConInfoTable -- ^ Corresponding info table
......@@ -362,12 +366,12 @@ mkRednCountsLabel name c = IdLabel name c RednCounts
-- These have local & (possibly) external variants:
mkLocalClosureLabel name c = IdLabel name c Closure
mkLocalInfoTableLabel name c = IdLabel name c (InfoTable True)
mkLocalEntryLabel name c = IdLabel name c Entry
mkLocalInfoTableLabel name c = IdLabel name c LocalInfoTable
mkLocalEntryLabel name c = IdLabel name c LocalEntry
mkLocalClosureTableLabel name c = IdLabel name c ClosureTable
mkClosureLabel name c = IdLabel name c Closure
mkInfoTableLabel name c = IdLabel name c (InfoTable False)
mkInfoTableLabel name c = IdLabel name c InfoTable
mkEntryLabel name c = IdLabel name c Entry
mkClosureTableLabel name c = IdLabel name c ClosureTable
mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable
......@@ -504,14 +508,37 @@ mkPlainModuleInitLabel mod = PlainModuleInitLabel mod
-- -----------------------------------------------------------------------------
-- Brutal method of obtaining a closure label
cvtToClosureLbl (IdLabel n c (InfoTable _)) = IdLabel n c Closure
cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure
cvtToClosureLbl (IdLabel n c ConEntry) = IdLabel n c Closure
cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure
cvtToClosureLbl (IdLabel n c LocalInfoTable) = IdLabel n c Closure -- XXX?
cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure
cvtToClosureLbl (IdLabel n c LocalEntry) = IdLabel n c Closure -- XXX?
cvtToClosureLbl (IdLabel n c ConEntry) = IdLabel n c Closure
cvtToClosureLbl (IdLabel n c RednCounts) = IdLabel n c Closure
cvtToClosureLbl l@(IdLabel n c Closure) = l
cvtToClosureLbl l
= pprPanic "cvtToClosureLbl" (pprCLabel l)
infoLblToEntryLbl :: CLabel -> CLabel
infoLblToEntryLbl (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry
infoLblToEntryLbl (IdLabel n c InfoTable) = IdLabel n c Entry
infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry
infoLblToEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry
infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
infoLblToEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry
infoLblToEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet
infoLblToEntryLbl _
= panic "CLabel.infoLblToEntryLbl"
entryLblToInfoLbl :: CLabel -> CLabel
entryLblToInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable
entryLblToInfoLbl (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable
entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable
entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable
entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo
entryLblToInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo
entryLblToInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo
entryLblToInfoLbl l
= pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l)
-- -----------------------------------------------------------------------------
-- Does a CLabel refer to a CAF?
......@@ -678,7 +705,8 @@ externallyVisibleCLabel (LargeSRTLabel _) = False
externallyVisibleIdLabel :: IdLabelInfo -> Bool
externallyVisibleIdLabel SRT = False
externallyVisibleIdLabel (InfoTable lcl) = not lcl
externallyVisibleIdLabel LocalInfoTable = False
externallyVisibleIdLabel LocalEntry = False
externallyVisibleIdLabel _ = True
-- -----------------------------------------------------------------------------
......@@ -726,8 +754,9 @@ labelType _ = DataLabel
idInfoLabelType info =
case info of
InfoTable _ -> DataLabel
Closure -> GcPtrLabel
InfoTable -> DataLabel
LocalInfoTable -> DataLabel
Closure -> GcPtrLabel
ConInfoTable -> DataLabel
StaticInfoTable -> DataLabel
ClosureTable -> DataLabel
......@@ -991,9 +1020,11 @@ ppIdFlavor x = pp_cSEP <>
(case x of
Closure -> ptext (sLit "closure")
SRT -> ptext (sLit "srt")
InfoTable _ -> ptext (sLit "info")
Entry -> ptext (sLit "entry")
Slow -> ptext (sLit "slow")
InfoTable -> ptext (sLit "info")
LocalInfoTable -> ptext (sLit "info")
Entry -> ptext (sLit "entry")
LocalEntry -> ptext (sLit "entry")
Slow -> ptext (sLit "slow")
RednCounts -> ptext (sLit "ct")
ConEntry -> ptext (sLit "con_entry")
ConInfoTable -> ptext (sLit "con_info")
......
compiler/codeGen/StgCmm.hs
View file @ 3a179c20
......@@ -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 }
---------------------------------------------------------------
......
compiler/codeGen/StgCmmBind.hs
View file @ 3a179c20
......@@ -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
......
compiler/codeGen/StgCmmClosure.hs
View file @ 3a179c20
......@@ -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
compiler/codeGen/StgCmmLayout.hs
View file @ 3a179c20
......@@ -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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment