Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
3a179c20
Commit
3a179c20
authored
Aug 24, 2011
by
Simon Marlow
Browse files
Refactoring: reduce usage of mkConInfo, with a view to killing it
parent
4a86a0bf
Changes
5
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
Local
InfoTable
mkLocalEntryLabel
name
c
=
IdLabel
name
c
Local
Entry
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
sta
tic_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
c
l_info
[]
$
=
emitClosureProcAndInfoTable
top_lvl
bndr
l
f
_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
c
l_info
args
$
;
emitClosureProcAndInfoTable
top_lvl
bndr
l
f
_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
.
l
abel
s
FromCI
entryLabelFromCI
=
infoLblToEntryLbl
.
infoTableL
abelFromCI
l
abel
s
FromCI
::
ClosureInfo
->
(
CLabel
,
CLabel
)
-- (Info, Entry)
l
abel
s
FromCI
(
ClosureInfo
{
closureName
=
name
,
infoTableL
abelFromCI
::
ClosureInfo
->
CLabel
infoTableL
abelFromCI
(
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_lbl
s
name
cafs
LFReEntrant
{}
->
bothL
std_mk_lbl
s
name
cafs
LFThunk
{}
->
std_mk_lbl
name
cafs
LFReEntrant
{}
->
std_mk_lbl
name
cafs
_other
->
panic
"labelsFromCI"
where
std_mk_lbl
s
|
is_lcl
=
(
mkLocalInfoTableLabel
,
mkLocalEntryLabel
)
|
otherwise
=
(
mkInfoTableLabel
,
mkEntryLabel
)
l
abel
s
FromCI
(
ConInfo
{
closureCon
=
con
,
closureSMRep
=
rep
,
closureCafs
=
cafs
})
|
isStatic
Rep
rep
=
bothL
(
mkStaticInfoTableLabel
,
mkStaticConEntryLabel
)
name
cafs
|
otherwise
=
bothL
(
mkConInfoTableLabel
,
mkConEntryLabel
)
name
cafs
std_mk_lbl
|
is_lcl
=
mkLocalInfoTableLabel
|
otherwise
=
mkInfoTableLabel
infoTableL
abelFromCI
(
ConInfo
{
closureCon
=
con
,
closureSM
Rep
=
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
c
l_info
args
body
=
do
{
let
lf_info
=
closureLFInfo
cl_info
emitClosureProcAndInfoTable
top_lvl
bndr
l
f
_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
::
C
losureInfo
->
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
C
mmInfoTable
->
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
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment