Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
d31dfb32
Commit
d31dfb32
authored
Jun 27, 2007
by
Michael D. Adams
Browse files
Implemented and fixed bugs in CmmInfo handling
parent
c9c4951c
Changes
27
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CLabel.hs
View file @
d31dfb32
...
...
@@ -521,6 +521,8 @@ externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel
(
DynamicLinkerLabel
_
_
)
=
False
externallyVisibleCLabel
(
HpcTicksLabel
_
)
=
True
externallyVisibleCLabel
HpcModuleNameLabel
=
False
externallyVisibleCLabel
(
LargeBitmapLabel
_
)
=
False
externallyVisibleCLabel
(
LargeSRTLabel
_
)
=
False
-- -----------------------------------------------------------------------------
-- Finding the "type" of a CLabel
...
...
@@ -702,7 +704,11 @@ pprCLbl (CaseLabel u CaseDefault)
=
hcat
[
pprUnique
u
,
ptext
SLIT
(
"_dflt"
)]
pprCLbl
(
LargeSRTLabel
u
)
=
pprUnique
u
<>
pp_cSEP
<>
ptext
SLIT
(
"srtd"
)
pprCLbl
(
LargeBitmapLabel
u
)
=
pprUnique
u
<>
pp_cSEP
<>
ptext
SLIT
(
"btm"
)
pprCLbl
(
LargeBitmapLabel
u
)
=
text
"b"
<>
pprUnique
u
<>
pp_cSEP
<>
ptext
SLIT
(
"btm"
)
-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
-- until that gets resolved we'll just force them to start
-- with a letter so the label will be legal assmbly code.
pprCLbl
(
RtsLabel
(
RtsCode
str
))
=
ptext
str
pprCLbl
(
RtsLabel
(
RtsData
str
))
=
ptext
str
...
...
compiler/cmm/Cmm.hs
View file @
d31dfb32
...
...
@@ -9,9 +9,10 @@
module
Cmm
(
GenCmm
(
..
),
Cmm
,
RawCmm
,
GenCmmTop
(
..
),
CmmTop
,
RawCmmTop
,
CmmInfo
(
..
),
ClosureTypeInfo
(
..
),
ProfilingInfo
(
..
),
CmmInfo
(
..
),
ClosureTypeInfo
(
..
),
ProfilingInfo
(
..
),
ClosureTypeTag
,
GenBasicBlock
(
..
),
CmmBasicBlock
,
blockId
,
blockStmts
,
CmmStmt
(
..
),
CmmActuals
,
CmmFormal
,
CmmFormals
,
CmmHintFormals
,
CmmSafety
(
..
),
CmmCallTarget
(
..
),
CmmStatic
(
..
),
Section
(
..
),
CmmExpr
(
..
),
cmmExprRep
,
...
...
@@ -133,12 +134,14 @@ data ClosureTypeInfo
-- TODO: These types may need refinement
data
ProfilingInfo
=
ProfilingInfo
CmmLit
CmmLit
-- closure_type, closure_desc
type
ClosureTypeTag
=
StgHalfWord
type
ClosureLayout
=
(
StgHalfWord
,
StgHalfWord
)
-- pts, nptrs
type
ClosureLayout
=
(
StgHalfWord
,
StgHalfWord
)
-- pt
r
s, nptrs
type
ConstrTag
=
StgHalfWord
type
ConstrDescription
=
CmmLit
type
FunType
=
StgHalfWord
type
FunArity
=
StgHalfWord
type
SlowEntry
=
CLabel
type
SlowEntry
=
CmmLit
-- ^We would like this to be a CLabel but
-- for now the parser sets this to zero on an INFO_TABLE_FUN.
type
SelectorOffset
=
StgWord
-----------------------------------------------------------------------------
...
...
@@ -161,7 +164,7 @@ data CmmStmt
CmmCallTarget
CmmHintFormals
-- zero or more results
CmmActuals
-- zero or more arguments
C
_SRT
-- SRT for the
continuation
of the call
C
mmSafety
-- whether to build a
continuation
|
CmmBranch
BlockId
-- branch to another BB in this fn
...
...
@@ -184,6 +187,7 @@ type CmmActuals = [(CmmActual,MachHint)]
type
CmmFormal
=
LocalReg
type
CmmHintFormals
=
[(
CmmFormal
,
MachHint
)]
type
CmmFormals
=
[
CmmFormal
]
data
CmmSafety
=
CmmUnsafe
|
CmmSafe
C_SRT
{-
Discussion
...
...
compiler/cmm/CmmCPS.hs
View file @
d31dfb32
...
...
@@ -70,9 +70,9 @@ cmmCPS dflags abstractC = do
return
continuationC
stg_gc_gen
=
mkRtsApFastLabel
SLIT
(
"gen_cg_TODO"
)
--panic "Need the label for gc"
make_gc_block
block_id
fun_label
formals
s
rt
=
BasicBlock
block_id
stmts
make_gc_block
block_id
fun_label
formals
s
afety
=
BasicBlock
block_id
stmts
where
stmts
=
[
CmmCall
stg_gc_gen_target
[]
[]
s
rt
,
stmts
=
[
CmmCall
stg_gc_gen_target
[]
[]
s
afety
,
CmmJump
fun_expr
actuals
]
stg_gc_gen_target
=
CmmForeignCall
(
CmmLit
(
CmmLabel
stg_gc_gen
))
CmmCallConv
...
...
@@ -85,10 +85,10 @@ force_gc_block old_info block_id fun_label formals blocks =
CmmInfo
_
(
Just
_
)
_
_
->
(
old_info
,
[]
)
CmmNonInfo
Nothing
->
(
CmmNonInfo
(
Just
block_id
),
[
make_gc_block
block_id
fun_label
formals
NoC_SRT
])
[
make_gc_block
block_id
fun_label
formals
(
CmmSafe
NoC_SRT
)
])
CmmInfo
prof
Nothing
type_tag
type_info
->
(
CmmInfo
prof
(
Just
block_id
)
type_tag
type_info
,
[
make_gc_block
block_id
fun_label
formals
srt
])
[
make_gc_block
block_id
fun_label
formals
(
CmmSafe
srt
)
])
where
srt
=
case
type_info
of
ConstrInfo
_
_
_
->
NoC_SRT
...
...
@@ -361,9 +361,7 @@ applyStackFormat formats (Continuation (Left srt) label formals blocks) =
-- TODO prof: this is the same as the current implementation
-- but I think it could be improved
prof
=
ProfilingInfo
zeroCLit
zeroCLit
tag
=
if
stack_frame_size
format
>
mAX_SMALL_BITMAP_SIZE
then
rET_BIG
else
rET_SMALL
tag
=
rET_SMALL
-- cmmToRawCmm will convert this to rET_BIG if needed
format
=
maybe
unknown_block
id
$
lookup
label
formats
unknown_block
=
panic
"unknown BlockId in applyStackFormat"
...
...
compiler/cmm/CmmInfo.hs
View file @
d31dfb32
module
CmmInfo
(
cmmToRawCmm
,
mkInfoTable
)
where
...
...
@@ -6,30 +7,81 @@ module CmmInfo (
import
Cmm
import
CmmUtils
import
PprCmm
import
CLabel
import
MachOp
import
Bitmap
import
ClosureInfo
import
CgInfoTbls
import
CgCallConv
import
CgUtils
import
SMRep
import
Constants
import
StaticFlags
import
DynFlags
import
Unique
import
UniqSupply
import
Panic
import
Data.Bits
cmmToRawCmm
::
[
Cmm
]
->
IO
[
RawCmm
]
cmmToRawCmm
cmm
=
do
info_tbl_uniques
<-
mkSplitUniqSupply
'i'
return
$
zipWith
raw_cmm
(
listSplitUniqSupply
info_tbl_uniques
)
cmm
where
raw_cmm
uniq_supply
(
Cmm
procs
)
=
Cmm
$
concat
$
zipWith
mkInfoTable
(
uniqsFromSupply
uniq_supply
)
procs
-- Make a concrete info table, represented as a list of CmmStatic
-- (it can't be simply a list of Word, because the SRT field is
-- represented by a label+offset expression).
--
-- With tablesNextToCode, the layout is
-- <reversed variable part>
-- <normal forward StgInfoTable, but without
-- an entry point at the front>
-- <code>
--
-- Without tablesNextToCode, the layout of an info table is
-- <entry label>
-- <normal forward rest of StgInfoTable>
-- <forward variable part>
--
-- See includes/InfoTables.h
--
-- For return-points these are as follows
--
-- Tables next to code:
--
-- <srt slot>
-- <standard info table>
-- ret-addr --> <entry code (if any)>
--
-- Not tables-next-to-code:
--
-- ret-addr --> <ptr to entry code>
-- <standard info table>
-- <srt slot>
--
-- * The SRT slot is only there if there is SRT info to record
mkInfoTable
::
Unique
->
CmmTop
->
[
RawCmmTop
]
mkInfoTable
uniq
(
CmmData
sec
dat
)
=
[
CmmData
sec
dat
]
mkInfoTable
uniq
(
CmmProc
info
entry_label
arguments
blocks
)
=
case
info
of
-- | Code without an info table. Easy.
CmmNonInfo
_
->
[
CmmProc
[]
entry_label
arguments
blocks
]
-- | A function entry point.
CmmInfo
(
ProfilingInfo
ty_prof
cl_prof
)
_
type_tag
(
FunInfo
(
ptrs
,
nptrs
)
srt
fun_type
fun_arity
pap_bitmap
slow_entry
)
->
mkInfoTableAndCode
info_label
std_info
fun_extra_bits
entry_label
arguments
blocks
(
FunInfo
(
ptrs
,
nptrs
)
srt
fun_type
fun_arity
pap_bitmap
slow_entry
)
->
mkInfoTableAndCode
info_label
std_info
fun_extra_bits
entry_label
arguments
blocks
where
fun_extra_bits
=
[
packHalfWordsCLit
fun_type
fun_arity
]
++
...
...
@@ -37,71 +89,74 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
case
pap_bitmap
of
ArgGen
liveness
->
[
makeRelativeRefTo
info_label
$
mkLivenessCLit
liveness
,
makeRelativeRefTo
info_label
(
CmmLabel
slow_entry
)
]
makeRelativeRefTo
info_label
slow_entry
]
_
->
[]
std_info
=
mkStdInfoTable
ty_prof
cl_prof
type_tag
srt_bitmap
layout
info_label
=
entryLblToInfoLbl
entry_label
(
srt_label
,
srt_bitmap
)
=
case
srt
of
NoC_SRT
->
(
[]
,
0
)
(
C_SRT
lbl
off
bitmap
)
->
([
makeRelativeRefTo
info_label
(
cmmLabelOffW
lbl
off
)],
bitmap
)
(
srt_label
,
srt_bitmap
)
=
mkSRTLit
info_label
srt
layout
=
packHalfWordsCLit
ptrs
nptrs
-- | A constructor.
CmmInfo
(
ProfilingInfo
ty_prof
cl_prof
)
_
type_tag
(
ConstrInfo
(
ptrs
,
nptrs
)
con_tag
descr
)
->
mkInfoTableAndCode
info_label
std_info
[
con_name
]
entry_label
arguments
blocks
mkInfoTableAndCode
info_label
std_info
[
con_name
]
entry_label
arguments
blocks
where
std_info
=
mkStdInfoTable
ty_prof
cl_prof
type_tag
con_tag
layout
info_label
=
entryLblToInfoLbl
entry_label
con_name
=
makeRelativeRefTo
info_label
descr
layout
=
packHalfWordsCLit
ptrs
nptrs
-- | A thunk.
CmmInfo
(
ProfilingInfo
ty_prof
cl_prof
)
_
type_tag
(
ThunkInfo
(
ptrs
,
nptrs
)
srt
)
->
mkInfoTableAndCode
info_label
std_info
srt_label
entry_label
arguments
blocks
mkInfoTableAndCode
info_label
std_info
srt_label
entry_label
arguments
blocks
where
std_info
=
mkStdInfoTable
ty_prof
cl_prof
type_tag
srt_bitmap
layout
info_label
=
entryLblToInfoLbl
entry_label
(
srt_label
,
srt_bitmap
)
=
case
srt
of
NoC_SRT
->
(
[]
,
0
)
(
C_SRT
lbl
off
bitmap
)
->
([
makeRelativeRefTo
info_label
(
cmmLabelOffW
lbl
off
)],
bitmap
)
(
srt_label
,
srt_bitmap
)
=
mkSRTLit
info_label
srt
layout
=
packHalfWordsCLit
ptrs
nptrs
-- | A selector thunk.
CmmInfo
(
ProfilingInfo
ty_prof
cl_prof
)
_
type_tag
(
ThunkSelectorInfo
offset
srt
)
->
mkInfoTableAndCode
info_label
std_info
srt_label
entry_label
arguments
blocks
mkInfoTableAndCode
info_label
std_info
srt_label
entry_label
arguments
blocks
where
std_info
=
mkStdInfoTable
ty_prof
cl_prof
type_tag
srt_bitmap
(
mkWordCLit
offset
)
info_label
=
entryLblToInfoLbl
entry_label
(
srt_label
,
srt_bitmap
)
=
case
srt
of
NoC_SRT
->
(
[]
,
0
)
(
C_SRT
lbl
off
bitmap
)
->
([
makeRelativeRefTo
info_label
(
cmmLabelOffW
lbl
off
)],
bitmap
)
(
srt_label
,
srt_bitmap
)
=
mkSRTLit
info_label
srt
-- A continuation/return-point.
CmmInfo
(
ProfilingInfo
ty_prof
cl_prof
)
_
type_tag
(
ContInfo
stack_layout
srt
)
->
liveness_data
++
mkInfoTableAndCode
info_label
std_info
srt_label
entry_label
arguments
blocks
mkInfoTableAndCode
info_label
std_info
srt_label
entry_label
arguments
blocks
where
std_info
=
mkStdInfoTable
ty_prof
cl_prof
type_tag
srt_bitmap
liveness_lit
std_info
=
mkStdInfoTable
ty_prof
cl_prof
maybe_big_type_tag
srt_bitmap
(
makeRelativeRefTo
info_label
liveness_lit
)
info_label
=
entryLblToInfoLbl
entry_label
(
liveness_lit
,
liveness_data
)
=
mkLiveness
uniq
stack_layout
(
srt_label
,
srt_bitmap
)
=
case
srt
of
NoC_SRT
->
(
[]
,
0
)
(
C_SRT
lbl
off
bitmap
)
->
([
makeRelativeRefTo
info_label
(
cmmLabelOffW
lbl
off
)],
bitmap
)
(
liveness_lit
,
liveness_data
,
liveness_tag
)
=
mkLiveness
uniq
stack_layout
maybe_big_type_tag
=
if
type_tag
==
rET_SMALL
then
liveness_tag
else
type_tag
(
srt_label
,
srt_bitmap
)
=
mkSRTLit
info_label
srt
-- Handle the differences between tables-next-to-code
-- and not tables-next-to-code
mkInfoTableAndCode
::
CLabel
->
[
CmmLit
]
->
[
CmmLit
]
->
CLabel
->
CmmFormals
->
[
CmmBasicBlock
]
->
[
RawCmmTop
]
mkInfoTableAndCode
info_lbl
std_info
extra_bits
entry_lbl
args
blocks
|
tablesNextToCode
-- Reverse the extra_bits; and emit the top-level proc
=
[
CmmProc
(
map
CmmStaticLit
(
reverse
extra_bits
++
std_info
))
entry_lbl
args
blocks
]
=
[
CmmProc
(
map
CmmStaticLit
(
reverse
extra_bits
++
std_info
))
entry_lbl
args
blocks
]
|
null
blocks
-- No actual code; only the info table is significant
=
-- Use a zero place-holder in place of the
...
...
@@ -113,27 +168,108 @@ mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
[
mkDataLits
info_lbl
(
CmmLabel
entry_lbl
:
std_info
++
extra_bits
),
CmmProc
[]
entry_lbl
args
blocks
]
mkSRTLit
::
CLabel
->
C_SRT
->
([
CmmLit
],
-- srt_label
StgHalfWord
)
-- srt_bitmap
mkSRTLit
info_label
NoC_SRT
=
(
[]
,
0
)
mkSRTLit
info_label
(
C_SRT
lbl
off
bitmap
)
=
([
makeRelativeRefTo
info_label
(
cmmLabelOffW
lbl
off
)],
bitmap
)
-------------------------------------------------------------------------
--
-- Build a liveness mask for the stack layout
--
-------------------------------------------------------------------------
-- There are four kinds of things on the stack:
--
-- - pointer variables (bound in the environment)
-- - non-pointer variables (bound in the environment)
-- - free slots (recorded in the stack free list)
-- - non-pointer data slots (recorded in the stack free list)
--
-- The first two are represented with a 'Just' of a 'LocalReg'.
-- The last two with one or more 'Nothing' constructors.
-- Each 'Nothing' represents one used word.
--
-- The head of the stack layout is the top of the stack and
-- the least-significant bit.
-- TODO: refactor to use utility functions
mkLiveness
::
Unique
->
[
Maybe
LocalReg
]
->
(
CmmLit
,
[
GenCmmTop
CmmStatic
[
CmmStatic
]
CmmStmt
])
mkLiveness
uniq
live
=
if
length
live
>
mAX_SMALL_BITMAP_SIZE
then
(
CmmLabel
big_liveness
,
[
data_lits
])
-- does not fit in one word
else
(
mkWordCLit
small_liveness
,
[]
)
-- fits in one word
-- TODO: combine with CgCallConv.mkLiveness (see comment there)
mkLiveness
::
Unique
->
[
Maybe
LocalReg
]
->
(
CmmLit
,
-- ^ The bitmap (literal value or label)
[
RawCmmTop
],
-- ^ Large bitmap CmmData if needed
ClosureTypeTag
)
-- ^ rET_SMALL or rET_BIG
mkLiveness
uniq
live
=
if
length
bits
>
mAX_SMALL_BITMAP_SIZE
-- does not fit in one word
then
(
CmmLabel
big_liveness
,
[
data_lits
],
rET_BIG
)
-- fits in one word
else
(
mkWordCLit
small_liveness
,
[]
,
rET_SMALL
)
where
size
=
length
live
mkBits
[]
=
[]
mkBits
(
reg
:
regs
)
=
take
sizeW
bits
++
mkBits
regs
where
sizeW
=
case
reg
of
Nothing
->
1
Just
r
->
machRepByteWidth
(
localRegRep
r
)
`
quot
`
wORD_SIZE
bits
=
repeat
$
is_non_ptr
reg
-- True <=> Non Ptr
bits
=
mkBitmap
(
map
is_non_ptr
live
)
is_non_ptr
Nothing
=
True
is_non_ptr
(
Just
reg
)
|
localRegGCFollow
reg
==
KindNonPtr
=
True
is_non_ptr
(
Just
reg
)
|
localRegGCFollow
reg
==
KindPtr
=
False
is_non_ptr
(
Just
reg
)
=
case
localRegGCFollow
reg
of
KindNonPtr
->
True
KindPtr
->
False
bi
g_liveness
=
mkBitmapLabel
uniq
data_l
its
=
mk
RODataLits
big_liveness
lits
lits
=
mkWordCLit
(
fromIntegral
size
)
:
map
mkWordCLit
bits
small_liveness
=
fromIntegral
size
.|.
(
small_bits
`
shiftL
`
bITMAP_BITS_SHIFT
)
small_bit
s
=
case
bit
s
of
bi
ts
::
[
Bool
]
b
its
=
mk
Bits
live
bitmap
::
Bitmap
bitmap
=
mkBitmap
bits
small_bit
map
=
case
bit
map
of
[]
->
0
[
b
]
->
fromIntegral
b
_
->
panic
"mkLiveness"
small_liveness
=
fromIntegral
(
length
bits
)
.|.
(
small_bitmap
`
shiftL
`
bITMAP_BITS_SHIFT
)
big_liveness
=
mkBitmapLabel
uniq
lits
=
mkWordCLit
(
fromIntegral
(
length
bits
))
:
map
mkWordCLit
bitmap
data_lits
=
mkRODataLits
big_liveness
lits
-------------------------------------------------------------------------
--
-- Generating a standard info table
--
-------------------------------------------------------------------------
-- The standard bits of an info table. This part of the info table
-- corresponds to the StgInfoTable type defined in InfoTables.h.
--
-- Its shape varies with ticky/profiling/tables next to code etc
-- so we can't use constant offsets from Constants
mkStdInfoTable
::
CmmLit
-- closure type descr (profiling)
->
CmmLit
-- closure descr (profiling)
->
StgHalfWord
-- closure type
->
StgHalfWord
-- SRT length
->
CmmLit
-- layout field
->
[
CmmLit
]
mkStdInfoTable
type_descr
closure_descr
cl_type
srt_len
layout_lit
=
-- Parallel revertible-black hole field
prof_info
-- Ticky info (none at present)
-- Debug info (none at present)
++
[
layout_lit
,
type_lit
]
where
prof_info
|
opt_SccProfilingOn
=
[
type_descr
,
closure_descr
]
|
otherwise
=
[]
type_lit
=
packHalfWordsCLit
cl_type
srt_len
compiler/cmm/CmmParse.y
View file @
d31dfb32
...
...
@@ -231,7 +231,9 @@ info :: { ExtFCode (CLabel, CmmInfo) }
{ do prof <- profilingInfo $11 $13
return (mkRtsInfoLabelFS $3,
CmmInfo prof Nothing (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0 (panic "INFO_TABLE_FUN:ArgDesr") (panic "INFO_TABLE_FUN:SlowEntry"))) }
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
(ArgSpec 0)
zeroCLit)) }
-- we leave most of the fields zero here. This is only used
-- to generate the BCO info table in the RTS at the moment.
...
...
@@ -258,7 +260,7 @@ info :: { ExtFCode (CLabel, CmmInfo) }
CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5)
(ContInfo [] NoC_SRT)) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals ')'
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals
0
')'
-- closure type, live regs
{ do live <- sequence (map (liftM Just) $7)
return (mkRtsInfoLabelFS $3,
...
...
@@ -792,48 +794,6 @@ forkLabelledCodeEC ec = do
stmts <- getCgStmtsEC ec
code (forkCgStmts stmts)
retInfo name size live_bits cl_type = do
let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
info_lbl = mkRtsRetInfoLabelFS name
(info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT
(fromIntegral cl_type)
return (info_lbl, info1, info2)
stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
basicInfo name (packHalfWordsCLit ptrs nptrs)
srt_bitmap cl_type desc_str ty_str
conInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str = do
(lbl, info1, _) <- basicInfo name (packHalfWordsCLit ptrs nptrs)
srt_bitmap cl_type desc_str ty_str
desc_lit <- code $ mkStringCLit desc_str
let desc_field = makeRelativeRefTo lbl desc_lit
return (lbl, info1, [desc_field])
basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
let info_lbl = mkRtsInfoLabelFS name
lit1 <- if opt_SccProfilingOn
then code $ do lit <- mkStringCLit desc_str
return (makeRelativeRefTo info_lbl lit)
else return (mkIntCLit 0)
lit2 <- if opt_SccProfilingOn
then code $ do lit <- mkStringCLit ty_str
return (makeRelativeRefTo info_lbl lit)
else return (mkIntCLit 0)
let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type)
(fromIntegral srt_bitmap)
layout
return (info_lbl, info1, [])
funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
(label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
cl_type desc_str ty_str
let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero
-- we leave most of the fields zero here. This is only used
-- to generate the BCO info table in the RTS at the moment.
return (label,info1,info2)
where
zero = mkIntCLit 0
profilingInfo desc_str ty_str = do
lit1 <- if opt_SccProfilingOn
...
...
@@ -907,6 +867,7 @@ emitRetUT args = do
emitStmts stmts
when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
-- TODO (when using CPS): emitStmt (CmmReturn (map snd args))
-- -----------------------------------------------------------------------------
-- If-then-else and boolean expressions
...
...
compiler/cmm/PprC.hs
View file @
d31dfb32
...
...
@@ -199,11 +199,11 @@ pprStmt stmt = case stmt of
where
rep
=
cmmExprRep
src
CmmCall
(
CmmForeignCall
fn
cconv
)
results
args
s
rt
->
CmmCall
(
CmmForeignCall
fn
cconv
)
results
args
s
afety
->
-- Controversial: leave this out for now.
-- pprUndef fn $$
pprCall
ppr_fn
cconv
results
args
s
rt
pprCall
ppr_fn
cconv
results
args
s
afety
where
ppr_fn
=
case
fn
of
CmmLit
(
CmmLabel
lbl
)
->
pprCLabel
lbl
...
...
@@ -220,8 +220,8 @@ pprStmt stmt = case stmt of
ptext
SLIT
(
"#undef"
)
<+>
pprCLabel
lbl
pprUndef
_
=
empty
CmmCall
(
CmmPrim
op
)
results
args
s
rt
->
pprCall
ppr_fn
CCallConv
results
args
s
rt
CmmCall
(
CmmPrim
op
)
results
args
s
afety
->
pprCall
ppr_fn
CCallConv
results
args
s
afety
where
ppr_fn
=
pprCallishMachOp_for_C
op
...
...
@@ -719,7 +719,7 @@ pprLocalReg (LocalReg uniq _ _) = char '_' <> ppr uniq
-- -----------------------------------------------------------------------------
-- Foreign Calls
pprCall
::
SDoc
->
CCallConv
->
CmmHintFormals
->
CmmActuals
->
C
_SRT
pprCall
::
SDoc
->
CCallConv
->
CmmHintFormals
->
CmmActuals
->
C
mmSafety
->
SDoc
pprCall
ppr_fn
cconv
results
args
_
...
...
compiler/cmm/PprCmm.hs
View file @
d31dfb32
...
...
@@ -117,7 +117,10 @@ pprTop (CmmData section ds) =
(
hang
(
pprSection
section
<+>
lbrace
)
4
(
vcat
(
map
pprStatic
ds
)))
$$
rbrace
-- --------------------------------------------------------------------------
instance
Outputable
CmmSafety
where
ppr
CmmUnsafe
=
ptext
SLIT
(
"_unsafe_call_"
)
ppr
(
CmmSafe
srt
)
=
ppr
srt
-- --------------------------------------------------------------------------
-- Info tables. The current pretty printer needs refinement
...
...
@@ -128,13 +131,15 @@ pprTop (CmmData section ds) =
-- and were labelled with the procedure name ++ "_info".
pprInfo
(
CmmNonInfo
gc_target
)
=
ptext
SLIT
(
"gc_target: "
)
<>
maybe
(
ptext
SLIT
(
"<none>"
))
pprBlockId
gc_target
ptext
SLIT
(
"TODO"
)
--maybe (ptext SLIT("<none>")) pprBlockId gc_target
-- ^ gc_target is currently unused and wired to a panic
pprInfo
(
CmmInfo
(
ProfilingInfo
closure_type
closure_desc
)
gc_target
tag
info
)
=
vcat
[
ptext
SLIT
(
"type: "
)
<>
pprLit
closure_type
,
ptext
SLIT
(
"desc: "
)
<>
pprLit
closure_desc
,
ptext
SLIT
(
"gc_target: "
)
<>
maybe
(
ptext
SLIT
(
"<none>"
))
pprBlockId
gc_target
,
ptext
SLIT
(
"TODO"
),
--maybe (ptext SLIT("<none>")) pprBlockId gc_target,
-- ^ gc_target is currently unused and wired to a panic
ptext
SLIT
(
"tag: "
)
<>
integer
(
toInteger
tag
),
pprTypeInfo
info
]
...
...
@@ -192,7 +197,7 @@ pprStmt stmt = case stmt of
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
CmmCall
(
CmmForeignCall
fn
cconv
)
results
args
s
rt
->
CmmCall
(
CmmForeignCall
fn
cconv
)
results
args
s
afety
->
hcat
[
if
null
results
then
empty
else
parens
(
commafy
$
map
ppr
results
)
<>
...
...
@@ -200,14 +205,14 @@ pprStmt stmt = case stmt of
ptext
SLIT
(
"call"
),
space
,
doubleQuotes
(
ppr
cconv
),
space
,
target
fn
,
parens
(
commafy
$
map
ppr
args
),
brackets
(
ppr
s
rt
),
semi
]
brackets
(
ppr
s
afety
),
semi
]
where
target
(
CmmLit
lit
)
=
pprLit
lit
target
fn'
=
parens
(
ppr
fn'
)
CmmCall
(
CmmPrim
op
)
results
args
s
rt
->
CmmCall
(
CmmPrim
op
)
results
args
s
afety
->
pprStmt
(
CmmCall
(
CmmForeignCall
(
CmmLit
lbl
)
CCallConv
)
results
args
s
rt
)
results
args
s
afety
)
where
lbl
=
CmmLabel
(
mkForeignLabel
(
mkFastString
(
show
op
))
Nothing
False
)
...
...
compiler/codeGen/CgBindery.lhs
View file @
d31dfb32
...
...
@@ -19,6 +19,7 @@ module CgBindery (
nukeVolatileBinds,
nukeDeadBindings,
getLiveStackSlots,
getLiveStackBindings,
bindArgsToStack, rebindToStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
...
...
@@ -494,3 +495,14 @@ getLiveStackSlots
cg_rep = rep } <- varEnvElts binds,
isFollowableArg rep] }
\end{code}
\begin{code}
getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)]
getLiveStackBindings
= do { binds <- getBinds
; return [(off, bind) |
bind <- varEnvElts binds,
CgIdInfo { cg_stb = VirStkLoc off,
cg_rep = rep} <- [bind],
isFollowableArg rep] }
\end{code}
compiler/codeGen/CgCallConv.hs
View file @
d31dfb32
...
...
@@ -15,7 +15,7 @@ module CgCallConv (
mkArgDescr
,
argDescrType
,
-- Liveness