Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
GHC
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
4,323
Issues
4,323
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
363
Merge Requests
363
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
3a179c20
Commit
3a179c20
authored
Aug 24, 2011
by
Simon Marlow
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Refactoring: reduce usage of mkConInfo, with a view to killing it
parent
4a86a0bf
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
134 additions
and
75 deletions
+134
-75
compiler/cmm/CLabel.hs
compiler/cmm/CLabel.hs
+47
-16
compiler/codeGen/StgCmm.hs
compiler/codeGen/StgCmm.hs
+11
-14
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmBind.hs
+9
-2
compiler/codeGen/StgCmmClosure.hs
compiler/codeGen/StgCmmClosure.hs
+57
-25
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmLayout.hs
+10
-18
No files found.
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
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
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
.
labels
FromCI
entryLabelFromCI
=
infoLblToEntryLbl
.
infoTableLabel
FromCI
labelsFromCI
::
ClosureInfo
->
(
CLabel
,
CLabel
)
-- (Info, Entry)
labels
FromCI
(
ClosureInfo
{
closureName
=
name
,
infoTableLabelFromCI
::
ClosureInfo
->
CLabel
infoTableLabel
FromCI
(
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_lbl
s
|
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
::
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
Markdown
is supported
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