Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
jberryman
GHC
Commits
4efb0abc
Commit
4efb0abc
authored
Aug 23, 2011
by
Simon Peyton Jones
Committed by
Simon Marlow
Aug 25, 2011
Browse files
Renaming only
CmmTop -> CmmDecl CmmPgm -> CmmGroup
parent
190d8e13
Changes
45
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/Cmm.hs
View file @
4efb0abc
...
...
@@ -10,8 +10,8 @@
module
Cmm
(
-- * Cmm top-level datatypes
CmmP
gm
,
GenCmm
Pgm
,
Cmm
Top
,
GenCmm
Top
(
..
),
CmmP
rogram
,
CmmGroup
,
GenCmm
Group
,
Cmm
Decl
,
GenCmm
Decl
(
..
),
CmmGraph
,
GenCmmGraph
(
..
),
CmmBlock
,
Section
(
..
),
CmmStatics
(
..
),
CmmStatic
(
..
),
...
...
@@ -46,10 +46,22 @@ import Data.Word ( Word8 )
-- Cmm, GenCmm
-----------------------------------------------------------------------------
-- A
file
is a list of
top-level chunks. These may be arbitrarily
--
re-orderd during code gene
ration
.
-- A
CmmProgram
is a list of
CmmGroups
--
A CmmGroup is a list of top-level decla
ration
s
-- GenCmm is abstracted over
-- When object-splitting is on,each group is compiled into a separate
-- .o file. So typically we put closely related stuff in a CmmGroup.
type
CmmProgram
=
[
CmmGroup
]
type
GenCmmGroup
d
h
g
=
[
GenCmmDecl
d
h
g
]
type
CmmGroup
=
GenCmmGroup
CmmStatics
CmmTopInfo
CmmGraph
-----------------------------------------------------------------------------
-- CmmDecl, GenCmmDecl
-----------------------------------------------------------------------------
-- GenCmmDecl is abstracted over
-- d, the type of static data elements in CmmData
-- h, the static info preceding the code of a CmmProc
-- g, the control-flow graph of a CmmProc
...
...
@@ -60,18 +72,10 @@ import Data.Word ( Word8 )
-- (b) Native code, populated with data/instructions
--
-- A second family of instances based on Hoopl is in Cmm.hs.
--
type
GenCmmPgm
d
h
g
=
[
GenCmmTop
d
h
g
]
type
CmmPgm
=
GenCmmPgm
CmmStatics
CmmTopInfo
CmmGraph
-----------------------------------------------------------------------------
-- CmmTop, GenCmmTop
-----------------------------------------------------------------------------
-- | A top-level chunk, abstracted over the type of the contents of
-- the basic blocks (Cmm or instructions are the likely instantiations).
data
GenCmm
Top
d
h
g
data
GenCmm
Decl
d
h
g
=
CmmProc
-- A procedure
h
-- Extra header such as the info table
CLabel
-- Entry label
...
...
@@ -81,7 +85,7 @@ data GenCmmTop d h g
Section
d
type
Cmm
Top
=
GenCmm
Top
CmmStatics
CmmTopInfo
CmmGraph
type
Cmm
Decl
=
GenCmm
Decl
CmmStatics
CmmTopInfo
CmmGraph
-----------------------------------------------------------------------------
-- Graphs
...
...
compiler/cmm/CmmBuildInfoTables.hs
View file @
4efb0abc
...
...
@@ -160,7 +160,7 @@ live_ptrs oldByte slotEnv areaMap bid =
-- Construct the stack maps for a procedure _if_ it needs an infotable.
-- When wouldn't a procedure need an infotable? If it is a procpoint that
-- is not the successor of a call.
setInfoTableStackMap
::
SlotEnv
->
AreaMap
->
Cmm
Top
->
Cmm
Top
setInfoTableStackMap
::
SlotEnv
->
AreaMap
->
Cmm
Decl
->
Cmm
Decl
setInfoTableStackMap
slotEnv
areaMap
t
@
(
CmmProc
(
TopInfo
{
stack_info
=
StackInfo
{
updfr_space
=
Just
updfr_off
}})
_
(
CmmGraph
{
g_entry
=
eid
}))
...
...
@@ -240,7 +240,7 @@ addCAF caf srt =
,
elt_map
=
Map
.
insert
caf
last
(
elt_map
srt
)
}
where
last
=
next_elt
srt
srtToData
::
TopSRT
->
Cmm
Pgm
srtToData
::
TopSRT
->
Cmm
Group
srtToData
srt
=
[
CmmData
RelocatableReadOnlyData
(
Statics
(
lbl
srt
)
tbl
)]
where
tbl
=
map
(
CmmStaticLit
.
CmmLabel
)
(
reverse
(
rev_elts
srt
))
...
...
@@ -253,7 +253,7 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
-- we make sure they're all close enough to the bottom of the table that the
-- bitmap will be able to cover all of them.
buildSRTs
::
TopSRT
->
Map
CLabel
CAFSet
->
CAFSet
->
FuelUniqSM
(
TopSRT
,
Maybe
Cmm
Top
,
C_SRT
)
FuelUniqSM
(
TopSRT
,
Maybe
Cmm
Decl
,
C_SRT
)
buildSRTs
topSRT
topCAFMap
cafs
=
do
let
liftCAF
lbl
()
z
=
-- get CAFs for functions without static closures
case
Map
.
lookup
lbl
topCAFMap
of
Just
cafs
->
z
`
Map
.
union
`
cafs
...
...
@@ -296,7 +296,7 @@ buildSRTs topSRT topCAFMap cafs =
-- Construct an SRT bitmap.
-- Adapted from simpleStg/SRT.lhs, which expects Id's.
procpointSRT
::
CLabel
->
Map
CLabel
Int
->
[
CLabel
]
->
FuelUniqSM
(
Maybe
Cmm
Top
,
C_SRT
)
FuelUniqSM
(
Maybe
Cmm
Decl
,
C_SRT
)
procpointSRT
_
_
[]
=
return
(
Nothing
,
NoC_SRT
)
procpointSRT
top_srt
top_table
entries
=
...
...
@@ -314,7 +314,7 @@ maxBmpSize :: Int
maxBmpSize
=
widthInBits
wordWidth
`
div
`
2
-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
to_SRT
::
CLabel
->
Int
->
Int
->
Bitmap
->
FuelUniqSM
(
Maybe
Cmm
Top
,
C_SRT
)
to_SRT
::
CLabel
->
Int
->
Int
->
Bitmap
->
FuelUniqSM
(
Maybe
Cmm
Decl
,
C_SRT
)
to_SRT
top_srt
off
len
bmp
|
len
>
maxBmpSize
||
bmp
==
[
fromIntegral
srt_escape
]
=
do
id
<-
getUniqueM
...
...
@@ -335,7 +335,7 @@ to_SRT top_srt off len bmp
-- keep its CAFs live.)
-- Any procedure referring to a non-static CAF c must keep live
-- any CAF that is reachable from c.
localCAFInfo
::
CAFEnv
->
Cmm
Top
->
Maybe
(
CLabel
,
CAFSet
)
localCAFInfo
::
CAFEnv
->
Cmm
Decl
->
Maybe
(
CLabel
,
CAFSet
)
localCAFInfo
_
(
CmmData
_
_
)
=
Nothing
localCAFInfo
cafEnv
(
CmmProc
top_info
top_l
(
CmmGraph
{
g_entry
=
entry
}))
=
case
info_tbl
top_info
of
...
...
@@ -373,19 +373,19 @@ mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
(
map
(
\
n
@
(
l
,
cafs
)
->
(
n
,
l
,
Map
.
keys
cafs
))
localCAFs
)
-- Bundle the CAFs used at a procpoint.
bundleCAFs
::
CAFEnv
->
Cmm
Top
->
(
CAFSet
,
Cmm
Top
)
bundleCAFs
::
CAFEnv
->
Cmm
Decl
->
(
CAFSet
,
Cmm
Decl
)
bundleCAFs
cafEnv
t
@
(
CmmProc
_
_
(
CmmGraph
{
g_entry
=
entry
}))
=
(
expectJust
"bundleCAFs"
(
mapLookup
entry
cafEnv
),
t
)
bundleCAFs
_
t
=
(
Map
.
empty
,
t
)
-- Construct the SRTs for the given procedure.
setInfoTableSRT
::
Map
CLabel
CAFSet
->
TopSRT
->
(
CAFSet
,
Cmm
Top
)
->
FuelUniqSM
(
TopSRT
,
[
Cmm
Top
])
setInfoTableSRT
::
Map
CLabel
CAFSet
->
TopSRT
->
(
CAFSet
,
Cmm
Decl
)
->
FuelUniqSM
(
TopSRT
,
[
Cmm
Decl
])
setInfoTableSRT
topCAFMap
topSRT
(
cafs
,
t
)
=
setSRT
cafs
topCAFMap
topSRT
t
setSRT
::
CAFSet
->
Map
CLabel
CAFSet
->
TopSRT
->
Cmm
Top
->
FuelUniqSM
(
TopSRT
,
[
Cmm
Top
])
Cmm
Decl
->
FuelUniqSM
(
TopSRT
,
[
Cmm
Decl
])
setSRT
cafs
topCAFMap
topSRT
t
=
do
(
topSRT
,
cafTable
,
srt
)
<-
buildSRTs
topSRT
topCAFMap
cafs
let
t'
=
updInfo
id
(
const
srt
)
t
...
...
@@ -395,7 +395,7 @@ setSRT cafs topCAFMap topSRT t =
type
StackLayout
=
Liveness
updInfo
::
(
StackLayout
->
StackLayout
)
->
(
C_SRT
->
C_SRT
)
->
Cmm
Top
->
Cmm
Top
updInfo
::
(
StackLayout
->
StackLayout
)
->
(
C_SRT
->
C_SRT
)
->
Cmm
Decl
->
Cmm
Decl
updInfo
toVars
toSrt
(
CmmProc
top_info
top_l
g
)
=
CmmProc
(
top_info
{
info_tbl
=
updInfoTbl
toVars
toSrt
(
info_tbl
top_info
)})
top_l
g
updInfo
_
_
t
=
t
...
...
@@ -426,7 +426,7 @@ updInfoTbl _ _ t@CmmNonInfoTable = t
-- needed to generate the infotables along with the Cmm data and procedures.
-- JD: Why not do this while splitting procedures?
lowerSafeForeignCalls
::
AreaMap
->
Cmm
Top
->
FuelUniqSM
Cmm
Top
lowerSafeForeignCalls
::
AreaMap
->
Cmm
Decl
->
FuelUniqSM
Cmm
Decl
lowerSafeForeignCalls
_
t
@
(
CmmData
_
_
)
=
return
t
lowerSafeForeignCalls
areaMap
(
CmmProc
info
l
g
@
(
CmmGraph
{
g_entry
=
entry
}))
=
do
let
block
b
mblocks
=
mblocks
>>=
lowerSafeCallBlock
entry
areaMap
b
...
...
compiler/cmm/CmmContFlowOpt.hs
View file @
4efb0abc
...
...
@@ -21,7 +21,7 @@ import Prelude hiding (succ, unzip, zip)
import
Util
------------------------------------
runCmmContFlowOpts
::
Cmm
Pgm
->
Cmm
Pgm
runCmmContFlowOpts
::
Cmm
Group
->
Cmm
Group
runCmmContFlowOpts
prog
=
runCmmOpts
cmmCfgOpts
prog
oldCmmCfgOpts
::
Old
.
ListGraph
Old
.
CmmStmt
->
Old
.
ListGraph
Old
.
CmmStmt
...
...
@@ -33,11 +33,11 @@ cmmCfgOpts =
-- Here branchChainElim can ultimately be replaced
-- with a more exciting combination of optimisations
runCmmOpts
::
(
g
->
g
)
->
GenCmm
Pgm
d
h
g
->
GenCmm
Pgm
d
h
g
runCmmOpts
::
(
g
->
g
)
->
GenCmm
Group
d
h
g
->
GenCmm
Group
d
h
g
-- Lifts a transformer on a single graph to one on the whole program
runCmmOpts
opt
=
map
(
optProc
opt
)
optProc
::
(
g
->
g
)
->
GenCmm
Top
d
h
g
->
GenCmm
Top
d
h
g
optProc
::
(
g
->
g
)
->
GenCmm
Decl
d
h
g
->
GenCmm
Decl
d
h
g
optProc
_
top
@
(
CmmData
{})
=
top
optProc
opt
(
CmmProc
info
lbl
g
)
=
CmmProc
info
lbl
(
opt
g
)
...
...
compiler/cmm/CmmCvt.hs
View file @
4efb0abc
...
...
@@ -17,7 +17,7 @@ import Data.Maybe
import
Maybes
import
Outputable
cmmOfZgraph
::
Cmm
Pgm
->
Old
.
Cmm
Pgm
cmmOfZgraph
::
Cmm
Group
->
Old
.
Cmm
Group
cmmOfZgraph
tops
=
map
mapTop
tops
where
mapTop
(
CmmProc
h
l
g
)
=
CmmProc
(
Old
.
CmmInfo
Nothing
Nothing
(
info_tbl
h
))
l
(
ofZgraph
g
)
mapTop
(
CmmData
s
ds
)
=
CmmData
s
ds
...
...
compiler/cmm/CmmInfo.hs
View file @
4efb0abc
...
...
@@ -30,7 +30,7 @@ mkEmptyContInfoTable info_lbl
,
cit_prof
=
NoProfilingInfo
,
cit_srt
=
NoC_SRT
}
cmmToRawCmm
::
[
Old
.
Cmm
Pgm
]
->
IO
[
Old
.
RawCmm
Pgm
]
cmmToRawCmm
::
[
Old
.
Cmm
Group
]
->
IO
[
Old
.
RawCmm
Group
]
cmmToRawCmm
cmms
=
do
{
uniqs
<-
mkSplitUniqSupply
'i'
;
return
(
initUs_
uniqs
(
mapM
(
concatMapM
mkInfoTable
)
cmms
))
}
...
...
@@ -68,7 +68,7 @@ cmmToRawCmm cmms
--
-- * The SRT slot is only there if there is SRT info to record
mkInfoTable
::
Cmm
Top
->
UniqSM
[
RawCmm
Top
]
mkInfoTable
::
Cmm
Decl
->
UniqSM
[
RawCmm
Decl
]
mkInfoTable
(
CmmData
sec
dat
)
=
return
[
CmmData
sec
dat
]
...
...
@@ -89,17 +89,21 @@ type InfoTableContents = ( [CmmLit] -- The standard part
-- These Lits have *not* had mkRelativeTo applied to them
mkInfoTableContents
::
CmmInfoTable
->
Maybe
StgHalfWord
--
o
verride default RTS type tag?
->
UniqSM
([
RawCmm
Top
],
-- Auxiliary top decls
->
Maybe
StgHalfWord
--
O
verride default RTS type tag?
->
UniqSM
([
RawCmm
Decl
],
-- Auxiliary top decls
InfoTableContents
)
-- Info tbl + extra bits
mkInfoTableContents
info
@
(
CmmInfoTable
{
cit_rep
=
RTSRep
ty
rep
})
_
=
mkInfoTableContents
info
{
cit_rep
=
rep
}
(
Just
ty
)
mkInfoTableContents
info
@
(
CmmInfoTable
{
cit_lbl
=
info_lbl
,
cit_rep
=
smrep
,
cit_prof
=
prof
,
cit_srt
=
srt
})
mb_rts_tag
|
RTSRep
rts_tag
rep
<-
smrep
=
mkInfoTableContents
info
{
cit_rep
=
rep
}
(
Just
rts_tag
)
-- Completely override the rts_tag that mkInfoTableContents would
-- otherwise compute, with the rts_tag stored in the RTSRep
-- (which in turn came from a handwritten .cmm file)
mkInfoTableContents
(
CmmInfoTable
{
cit_lbl
=
info_lbl
,
cit_rep
=
smrep
,
cit_prof
=
prof
,
cit_srt
=
srt
})
mb_rts_tag
|
StackRep
frame
<-
smrep
=
do
{
(
prof_lits
,
prof_data
)
<-
mkProfLits
prof
;
let
(
srt_label
,
srt_bitmap
)
=
mkSRTLit
srt
...
...
@@ -128,7 +132,7 @@ mkInfoTableContents (CmmInfoTable { cit_lbl = info_lbl
->
UniqSM
(
Maybe
StgHalfWord
-- Override the SRT field with this
,
Maybe
CmmLit
-- Override the layout field with this
,
[
CmmLit
]
-- "Extra bits" for info table
,
[
RawCmm
Top
])
-- Auxiliary data decls
,
[
RawCmm
Decl
])
-- Auxiliary data decls
mk_pieces
(
Constr
con_tag
con_descr
)
_no_srt
-- A data constructor
=
do
{
(
descr_lit
,
decl
)
<-
newStringLit
con_descr
;
return
(
Just
con_tag
,
Nothing
,
[
descr_lit
],
[
decl
])
}
...
...
@@ -180,7 +184,7 @@ mkSRTLit (C_SRT lbl off bitmap) = ([cmmLabelOffW lbl off], bitmap)
-- * the "extra bits" (StgFunInfoExtraRev etc.)
-- * the entry label
-- * the code
-- and lays them out in memory, producing a list of RawCmmDecl
-- The value of tablesNextToCode determines the relative positioning
-- of the extra bits and the standard info table, and whether the
...
...
@@ -192,7 +196,7 @@ mkInfoTableAndCode :: CLabel -- Info table label
->
InfoTableContents
->
CLabel
-- Entry label
->
ListGraph
CmmStmt
-- Entry code
->
[
RawCmm
Top
]
->
[
RawCmm
Decl
]
mkInfoTableAndCode
info_lbl
(
std_info
,
extra_bits
)
entry_lbl
blocks
|
tablesNextToCode
-- Reverse the extra_bits; and emit the top-level proc
=
[
CmmProc
(
Just
$
Statics
info_lbl
$
map
CmmStaticLit
$
...
...
@@ -256,7 +260,7 @@ makeRelativeRefTo _ lit = lit
-- The head of the stack layout is the top of the stack and
-- the least-significant bit.
mkLivenessBits
::
Liveness
->
UniqSM
(
CmmLit
,
[
RawCmm
Top
])
mkLivenessBits
::
Liveness
->
UniqSM
(
CmmLit
,
[
RawCmm
Decl
])
-- ^ Returns:
-- 1. The bitmap (literal value or label)
-- 2. Large bitmap CmmData if needed
...
...
@@ -327,14 +331,14 @@ mkStdInfoTable (type_descr, closure_descr) cl_type srt_len layout_lit
--
-------------------------------------------------------------------------
mkProfLits
::
ProfilingInfo
->
UniqSM
((
CmmLit
,
CmmLit
),
[
RawCmm
Top
])
mkProfLits
::
ProfilingInfo
->
UniqSM
((
CmmLit
,
CmmLit
),
[
RawCmm
Decl
])
mkProfLits
NoProfilingInfo
=
return
((
zeroCLit
,
zeroCLit
),
[]
)
mkProfLits
(
ProfilingInfo
td
cd
)
=
do
{
(
td_lit
,
td_decl
)
<-
newStringLit
td
;
(
cd_lit
,
cd_decl
)
<-
newStringLit
cd
;
return
((
td_lit
,
cd_lit
),
[
td_decl
,
cd_decl
])
}
newStringLit
::
[
Word8
]
->
UniqSM
(
CmmLit
,
GenCmm
Top
CmmStatics
info
stmt
)
newStringLit
::
[
Word8
]
->
UniqSM
(
CmmLit
,
GenCmm
Decl
CmmStatics
info
stmt
)
newStringLit
bytes
=
do
{
uniq
<-
getUniqueUs
;
return
(
mkByteStringCLit
uniq
bytes
)
}
...
...
compiler/cmm/CmmLint.hs
View file @
4efb0abc
...
...
@@ -31,12 +31,12 @@ import Data.Maybe
-- Exported entry points:
cmmLint
::
(
Outputable
d
,
Outputable
h
)
=>
Platform
->
GenCmm
Pgm
d
h
(
ListGraph
CmmStmt
)
->
Maybe
SDoc
cmmLint
platform
tops
=
runCmmLint
platform
(
mapM_
lintCmm
Top
)
tops
=>
Platform
->
GenCmm
Group
d
h
(
ListGraph
CmmStmt
)
->
Maybe
SDoc
cmmLint
platform
tops
=
runCmmLint
platform
(
mapM_
lintCmm
Decl
)
tops
cmmLintTop
::
(
Outputable
d
,
Outputable
h
)
=>
Platform
->
GenCmm
Top
d
h
(
ListGraph
CmmStmt
)
->
Maybe
SDoc
cmmLintTop
platform
top
=
runCmmLint
platform
lintCmm
Top
top
=>
Platform
->
GenCmm
Decl
d
h
(
ListGraph
CmmStmt
)
->
Maybe
SDoc
cmmLintTop
platform
top
=
runCmmLint
platform
lintCmm
Decl
top
runCmmLint
::
PlatformOutputable
a
=>
Platform
->
(
a
->
CmmLint
b
)
->
a
->
Maybe
SDoc
...
...
@@ -48,13 +48,13 @@ runCmmLint platform l p =
nest
2
(
pprPlatform
platform
p
)])
Right
_
->
Nothing
lintCmm
Top
::
(
GenCmm
Top
h
i
(
ListGraph
CmmStmt
))
->
CmmLint
()
lintCmm
Top
(
CmmProc
_
lbl
(
ListGraph
blocks
))
lintCmm
Decl
::
(
GenCmm
Decl
h
i
(
ListGraph
CmmStmt
))
->
CmmLint
()
lintCmm
Decl
(
CmmProc
_
lbl
(
ListGraph
blocks
))
=
addLintInfo
(
text
"in proc "
<>
pprCLabel
lbl
)
$
let
labels
=
foldl
(
\
s
b
->
setInsert
(
blockId
b
)
s
)
setEmpty
blocks
in
mapM_
(
lintCmmBlock
labels
)
blocks
lintCmm
Top
(
CmmData
{})
lintCmm
Decl
(
CmmData
{})
=
return
()
lintCmmBlock
::
BlockSet
->
GenBasicBlock
CmmStmt
->
CmmLint
()
...
...
compiler/cmm/CmmOpt.hs
View file @
4efb0abc
...
...
@@ -672,7 +672,7 @@ exactLog2 x_
except factorial, but what the hell.
-}
cmmLoopifyForC
::
RawCmm
Top
->
RawCmm
Top
cmmLoopifyForC
::
RawCmm
Decl
->
RawCmm
Decl
cmmLoopifyForC
p
@
(
CmmProc
Nothing
_
_
)
=
p
-- only if there's an info table, ignore case alts
cmmLoopifyForC
p
@
(
CmmProc
(
Just
info
@
(
Statics
info_lbl
_
))
entry_lbl
(
ListGraph
blocks
@
(
BasicBlock
top_id
_
:
_
)))
=
...
...
compiler/cmm/CmmParse.y
View file @
4efb0abc
...
...
@@ -1061,7 +1061,7 @@ initEnv = listToUFM [
VarN (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordWidth) ))
]
parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe Cmm
Pgm
)
parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe Cmm
Group
)
parseCmmFile dflags filename = do
showPass dflags "ParseCmm"
buf <- hGetStringBuffer filename
...
...
compiler/cmm/CmmPipeline.hs
View file @
4efb0abc
...
...
@@ -53,9 +53,9 @@ import StaticFlags
-- we actually need to do the initial pass.
cmmPipeline
::
HscEnv
-- Compilation env including
-- dynamic flags: -dcmm-lint -ddump-cps-cmm
->
(
TopSRT
,
[
Cmm
Pgm
])
-- SRT table and accumulating list of compiled procs
->
Cmm
Pgm
-- Input C-- with Procedures
->
IO
(
TopSRT
,
[
Cmm
Pgm
])
-- Output CPS transformed C--
->
(
TopSRT
,
[
Cmm
Group
])
-- SRT table and accumulating list of compiled procs
->
Cmm
Group
-- Input C-- with Procedures
->
IO
(
TopSRT
,
[
Cmm
Group
])
-- Output CPS transformed C--
cmmPipeline
hsc_env
(
topSRT
,
rst
)
prog
=
do
let
dflags
=
hsc_dflags
hsc_env
--
...
...
@@ -63,7 +63,7 @@ cmmPipeline hsc_env (topSRT, rst) prog =
let
tops
=
runCmmContFlowOpts
prog
(
cafEnvs
,
tops
)
<-
liftM
unzip
$
mapM
(
cpsTop
hsc_env
)
tops
-- tops :: [[(Cmm
Top
,CAFSet]] (one list per group)
-- tops :: [[(Cmm
Decl
,CAFSet]] (one list per group)
let
topCAFEnv
=
mkTopCAFInfo
(
concat
cafEnvs
)
...
...
@@ -90,7 +90,7 @@ global to one compiler session.
-- input for any given phase, besides just turning it all on with
-- -ddump-cmmz
cpsTop
::
HscEnv
->
Cmm
Top
->
IO
([(
CLabel
,
CAFSet
)],
[(
CAFSet
,
Cmm
Top
)])
cpsTop
::
HscEnv
->
Cmm
Decl
->
IO
([(
CLabel
,
CAFSet
)],
[(
CAFSet
,
Cmm
Decl
)])
cpsTop
_
p
@
(
CmmData
{})
=
return
(
[]
,
[(
Map
.
empty
,
p
)])
cpsTop
hsc_env
(
CmmProc
h
@
(
TopInfo
{
stack_info
=
StackInfo
{
arg_space
=
entry_off
}})
l
g
)
=
do
...
...
@@ -162,7 +162,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
mapM_
(
dumpPlatform
platform
Opt_D_dump_cmmz_cafs
"after bundleCAFs"
)
gs
return
(
localCAFs
,
gs
)
-- gs :: [ (CAFSet, Cmm
Top
) ]
-- gs :: [ (CAFSet, Cmm
Decl
) ]
-- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)
where
dflags
=
hsc_dflags
hsc_env
...
...
@@ -186,8 +186,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
-- This probably belongs in CmmBuildInfoTables?
-- We're just finishing the job here: once we know what CAFs are defined
-- in non-static closures, we can build the SRTs.
toTops
::
HscEnv
->
Map
CLabel
CAFSet
->
(
TopSRT
,
[[
Cmm
Top
]])
->
[(
CAFSet
,
Cmm
Top
)]
->
IO
(
TopSRT
,
[[
Cmm
Top
]])
toTops
::
HscEnv
->
Map
CLabel
CAFSet
->
(
TopSRT
,
[[
Cmm
Decl
]])
->
[(
CAFSet
,
Cmm
Decl
)]
->
IO
(
TopSRT
,
[[
Cmm
Decl
]])
toTops
hsc_env
topCAFEnv
(
topSRT
,
tops
)
gs
=
do
let
setSRT
(
topSRT
,
rst
)
g
=
do
(
topSRT
,
gs
)
<-
setInfoTableSRT
topCAFEnv
topSRT
g
...
...
compiler/cmm/CmmProcPoint.hs
View file @
4efb0abc
...
...
@@ -381,7 +381,7 @@ add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty)
-- ToDo: use the _ret naming convention that the old code generator
-- used. -- EZY
splitAtProcPoints
::
CLabel
->
ProcPointSet
->
ProcPointSet
->
BlockEnv
Status
->
Cmm
Top
->
FuelUniqSM
[
Cmm
Top
]
Cmm
Decl
->
FuelUniqSM
[
Cmm
Decl
]
splitAtProcPoints
entry_label
callPPs
procPoints
procMap
(
CmmProc
(
TopInfo
{
info_tbl
=
info_tbl
,
stack_info
=
stack_info
})
...
...
compiler/cmm/CmmUtils.hs
View file @
4efb0abc
...
...
@@ -124,19 +124,19 @@ mkIntCLit i = CmmInt (toInteger i) wordWidth
zeroCLit
::
CmmLit
zeroCLit
=
CmmInt
0
wordWidth
mkByteStringCLit
::
Unique
->
[
Word8
]
->
(
CmmLit
,
GenCmm
Top
CmmStatics
info
stmt
)
mkByteStringCLit
::
Unique
->
[
Word8
]
->
(
CmmLit
,
GenCmm
Decl
CmmStatics
info
stmt
)
-- We have to make a top-level decl for the string,
-- and return a literal pointing to it
mkByteStringCLit
uniq
bytes
=
(
CmmLabel
lbl
,
CmmData
ReadOnlyData
$
Statics
lbl
[
CmmString
bytes
])
where
lbl
=
mkStringLitLabel
uniq
mkDataLits
::
Section
->
CLabel
->
[
CmmLit
]
->
GenCmm
Top
CmmStatics
info
stmt
mkDataLits
::
Section
->
CLabel
->
[
CmmLit
]
->
GenCmm
Decl
CmmStatics
info
stmt
-- Build a data-segment data block
mkDataLits
section
lbl
lits
=
CmmData
section
(
Statics
lbl
$
map
CmmStaticLit
lits
)
mkRODataLits
::
CLabel
->
[
CmmLit
]
->
GenCmm
Top
CmmStatics
info
stmt
mkRODataLits
::
CLabel
->
[
CmmLit
]
->
GenCmm
Decl
CmmStatics
info
stmt
-- Build a read-only data block
mkRODataLits
lbl
lits
=
mkDataLits
section
lbl
lits
...
...
compiler/cmm/OldCmm.hs
View file @
4efb0abc
...
...
@@ -7,7 +7,7 @@
-----------------------------------------------------------------------------
module
OldCmm
(
Cmm
Pgm
,
GenCmm
Pgm
,
RawCmm
Pgm
,
Cmm
Top
,
RawCmm
Top
,
Cmm
Group
,
GenCmm
Group
,
RawCmm
Group
,
Cmm
Decl
,
RawCmm
Decl
,
ListGraph
(
..
),
CmmInfo
(
..
),
UpdateFrame
(
..
),
CmmInfoTable
(
..
),
ClosureTypeInfo
(
..
),
CmmStatic
(
..
),
CmmStatics
(
..
),
CmmFormal
,
CmmActual
,
...
...
@@ -17,7 +17,7 @@ module OldCmm (
CmmStmt
(
..
),
CmmReturnInfo
(
..
),
CmmHinted
(
..
),
HintedCmmFormal
,
HintedCmmActual
,
CmmSafety
(
..
),
CmmCallTarget
(
..
),
New
.
GenCmm
Top
(
..
),
New
.
GenCmm
Decl
(
..
),
New
.
ForeignHint
(
..
),
module
CmmExpr
,
Section
(
..
),
...
...
@@ -27,7 +27,7 @@ module OldCmm (
#
include
"HsVersions.h"
import
qualified
Cmm
as
New
import
Cmm
(
CmmInfoTable
(
..
),
GenCmm
Pgm
,
CmmStatics
(
..
),
GenCmm
Top
(
..
),
import
Cmm
(
CmmInfoTable
(
..
),
GenCmm
Group
,
CmmStatics
(
..
),
GenCmm
Decl
(
..
),
CmmFormal
,
CmmActual
,
Section
(
..
),
CmmStatic
(
..
),
ProfilingInfo
(
..
),
ClosureTypeInfo
(
..
)
)
...
...
@@ -63,7 +63,7 @@ data UpdateFrame =
[
CmmExpr
]
-- Frame remainder. Behaves like the arguments of a 'jump'.
-----------------------------------------------------------------------------
-- Cmm, Cmm
Top
, CmmBasicBlock
-- Cmm, Cmm
Decl
, CmmBasicBlock
-----------------------------------------------------------------------------
-- A file is a list of top-level chunks. These may be arbitrarily
...
...
@@ -80,15 +80,15 @@ newtype ListGraph i = ListGraph [GenBasicBlock i]
-- across a whole compilation unit.
-- | Cmm with the info table as a data type
type
Cmm
Pgm
=
GenCmm
Pgm
CmmStatics
CmmInfo
(
ListGraph
CmmStmt
)
type
Cmm
Top
=
GenCmm
Top
CmmStatics
CmmInfo
(
ListGraph
CmmStmt
)
type
Cmm
Group
=
GenCmm
Group
CmmStatics
CmmInfo
(
ListGraph
CmmStmt
)
type
Cmm
Decl
=
GenCmm
Decl
CmmStatics
CmmInfo
(
ListGraph
CmmStmt
)
-- | Cmm with the info tables converted to a list of 'CmmStatic' along with the info
-- table label. If we are building without tables-next-to-code there will be no statics
--
-- INVARIANT: if there is an info table, it has at least one CmmStatic
type
RawCmm
Pgm
=
GenCmm
Pgm
CmmStatics
(
Maybe
CmmStatics
)
(
ListGraph
CmmStmt
)
type
RawCmm
Top
=
GenCmm
Top
CmmStatics
(
Maybe
CmmStatics
)
(
ListGraph
CmmStmt
)
type
RawCmm
Group
=
GenCmm
Group
CmmStatics
(
Maybe
CmmStatics
)
(
ListGraph
CmmStmt
)
type
RawCmm
Decl
=
GenCmm
Decl
CmmStatics
(
Maybe
CmmStatics
)
(
ListGraph
CmmStmt
)
-- A basic block containing a single label, at the beginning.
...
...
@@ -118,11 +118,11 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
-- graph maps
----------------------------------------------------------------
cmmMapGraph
::
(
g
->
g'
)
->
GenCmm
Pgm
d
h
g
->
GenCmm
Pgm
d
h
g'
cmmTopMapGraph
::
(
g
->
g'
)
->
GenCmm
Top
d
h
g
->
GenCmm
Top
d
h
g'
cmmMapGraph
::
(
g
->
g'
)
->
GenCmm
Group
d
h
g
->
GenCmm
Group
d
h
g'
cmmTopMapGraph
::
(
g
->
g'
)
->
GenCmm
Decl
d
h
g
->
GenCmm
Decl
d
h
g'
cmmMapGraphM
::
Monad
m
=>
(
String
->
g
->
m
g'
)
->
GenCmm
Pgm
d
h
g
->
m
(
GenCmm
Pgm
d
h
g'
)
cmmTopMapGraphM
::
Monad
m
=>
(
String
->
g
->
m
g'
)
->
GenCmm
Top
d
h
g
->
m
(
GenCmm
Top
d
h
g'
)
cmmMapGraphM
::
Monad
m
=>
(
String
->
g
->
m
g'
)
->
GenCmm
Group
d
h
g
->
m
(
GenCmm
Group
d
h
g'
)
cmmTopMapGraphM
::
Monad
m
=>
(
String
->
g
->
m
g'
)
->
GenCmm
Decl
d
h
g
->
m
(
GenCmm
Decl
d
h
g'
)
cmmMapGraph
f
tops
=
map
(
cmmTopMapGraph
f
)
tops
cmmTopMapGraph
f
(
CmmProc
h
l
g
)
=
CmmProc
h
l
(
f
g
)
...
...
compiler/cmm/PprC.hs
View file @
4efb0abc
...
...
@@ -65,7 +65,7 @@ import Control.Monad.ST
-- --------------------------------------------------------------------------
-- Top level
pprCs
::
DynFlags
->
[
RawCmm
Pgm
]
->
SDoc
pprCs
::
DynFlags
->
[
RawCmm
Group
]
->
SDoc
pprCs
dflags
cmms
=
pprCode
CStyle
(
vcat
$
map
(
\
c
->
split_marker
$$
pprC
c
)
cmms
)
where
...
...
@@ -73,7 +73,7 @@ pprCs dflags cmms
|
dopt
Opt_SplitObjs
dflags
=
ptext
(
sLit
"__STG_SPLIT_MARKER"
)
|
otherwise
=
empty
writeCs
::
DynFlags
->
Handle
->
[
RawCmm
Pgm
]
->
IO
()
writeCs
::
DynFlags
->
Handle
->
[
RawCmm
Group
]
->
IO
()
writeCs
dflags
handle
cmms
=
printForC
handle
(
pprCs
dflags
cmms
)
...
...
@@ -83,13 +83,13 @@ writeCs dflags handle cmms
-- for fun, we could call cmmToCmm over the tops...
--
pprC
::
RawCmm
Pgm
->
SDoc
pprC
::
RawCmm
Group
->
SDoc
pprC
tops
=
vcat
$
intersperse
blankLine
$
map
pprTop
tops
--
-- top level procs
--
pprTop
::
RawCmm
Top
->
SDoc
pprTop
::
RawCmm
Decl
->
SDoc
pprTop
(
CmmProc
mb_info
clbl
(
ListGraph
blocks
))
=
(
case
mb_info
of
Nothing
->
empty
...
...
compiler/cmm/PprCmmDecl.hs
View file @
4efb0abc
...
...
@@ -33,7 +33,7 @@
--
module
PprCmmDecl
(
writeCmms
,
pprCmms
,
pprCmm
Pgm
,
pprSection
,
pprStatic
(
writeCmms
,
pprCmms
,
pprCmm
Group
,
pprSection
,
pprStatic
)
where
...
...
@@ -54,19 +54,19 @@ import SMRep
pprCmms
::
(
Outputable
info
,
PlatformOutputable
g
)
=>
Platform
->
[
GenCmm
Pgm
CmmStatics
info
g
]
->
SDoc
=>
Platform
->
[
GenCmm
Group
CmmStatics
info
g
]
->
SDoc
pprCmms
platform
cmms
=
pprCode
CStyle
(
vcat
(
intersperse
separator
$
map
(
pprPlatform
platform
)
cmms
))
where
separator
=
space
$$
ptext
(
sLit
"-------------------"
)
$$
space
writeCmms
::
(
Outputable
info
,
PlatformOutputable
g
)
=>
Platform
->
Handle
->
[
GenCmm
Pgm
CmmStatics
info
g
]
->
IO
()
=>
Platform
->
Handle
->
[
GenCmm
Group
CmmStatics
info
g
]
->
IO
()
writeCmms
platform
handle
cmms
=
printForC
handle
(
pprCmms
platform
cmms
)
-----------------------------------------------------------------------------
instance
(
Outputable
d
,
Outputable
info
,
PlatformOutputable
i
)
=>
PlatformOutputable
(
GenCmm
Top
d
info
i
)
where
=>
PlatformOutputable
(
GenCmm
Decl
d
info
i
)
where
pprPlatform
platform
t
=
pprTop
platform
t
instance
Outputable
CmmStatics
where
...
...
@@ -81,16 +81,16 @@ instance Outputable CmmInfoTable where
-----------------------------------------------------------------------------
pprCmm
Pgm
::
(
Outputable
d
,
Outputable
info
,
PlatformOutputable
g
)
=>
Platform
->
GenCmm
Pgm
d
info
g
->
SDoc
pprCmm
Pgm
platform
tops
pprCmm
Group
::
(
Outputable
d
,
Outputable
info
,
PlatformOutputable
g
)
=>
Platform
->
GenCmm
Group
d
info
g
->
SDoc
pprCmm
Group
platform
tops
=
vcat
$
intersperse
blankLine
$
map
(
pprTop
platform
)
tops
-- --------------------------------------------------------------------------
-- Top level `procedure' blocks.
--
pprTop
::
(
Outputable
d
,
Outputable
info
,
PlatformOutputable
i
)
=>
Platform
->
GenCmm
Top
d
info
i
->
SDoc
=>
Platform
->
GenCmm
Decl
d
info
i
->
SDoc
pprTop
platform
(
CmmProc
info
lbl
graph
)
...
...
compiler/codeGen/CgCon.lhs
View file @
4efb0abc
...
...
@@ -402,7 +402,7 @@ For charlike and intlike closures there is a fixed array of static
closures predeclared.
\begin{code}
cgTyCon :: TyCon -> FCode Cmm
Pgm
-- each constructor gets a separate Cmm
Pgm
cgTyCon :: TyCon -> FCode Cmm
Group
-- each constructor gets a separate Cmm
Group
cgTyCon tycon
= do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
...
...
compiler/codeGen/CgMonad.lhs
View file @
4efb0abc
...
...
@@ -120,7 +120,7 @@ initCgInfoDown dflags mod
data CgState
= MkCgState {
cgs_stmts :: OrdList CgStmt, -- Current proc
cgs_tops :: OrdList Cmm
Top
,
cgs_tops :: OrdList Cmm
Decl
,
-- Other procedures and data blocks in this compilation unit
-- Both the latter two are ordered only so that we can