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
ac7a7eb9
Commit
ac7a7eb9
authored
Oct 02, 2011
by
Ian Lynagh
Browse files
More CPP removal: pprDynamicLinkerAsmLabel in CLabel
And some knock-on changes
parent
d8d16174
Changes
45
Expand all
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CLabel.hs
View file @
ac7a7eb9
...
...
@@ -263,23 +263,23 @@ data ForeignLabelSource
-- We can't make a Show instance for CLabel because lots of its components don't have instances.
-- The regular Outputable instance only shows the label name, and not its other info.
--
pprDebugCLabel
::
CLabel
->
SDoc
pprDebugCLabel
lbl
pprDebugCLabel
::
Platform
->
CLabel
->
SDoc
pprDebugCLabel
platform
lbl
=
case
lbl
of
IdLabel
{}
->
ppr
lbl
<>
(
parens
$
text
"IdLabel"
)
IdLabel
{}
->
ppr
Platform
platform
lbl
<>
(
parens
$
text
"IdLabel"
)
CmmLabel
pkg
name
_info
->
ppr
lbl
<>
(
parens
$
text
"CmmLabel"
<+>
ppr
pkg
)
->
ppr
Platform
platform
lbl
<>
(
parens
$
text
"CmmLabel"
<+>
ppr
pkg
)
RtsLabel
{}
->
ppr
lbl
<>
(
parens
$
text
"RtsLabel"
)
RtsLabel
{}
->
ppr
Platform
platform
lbl
<>
(
parens
$
text
"RtsLabel"
)
ForeignLabel
name
mSuffix
src
funOrData
->
ppr
lbl
<>
(
parens
->
ppr
Platform
platform
lbl
<>
(
parens
$
text
"ForeignLabel"
<+>
ppr
mSuffix
<+>
ppr
src
<+>
ppr
funOrData
)
_
->
ppr
lbl
<>
(
parens
$
text
"other CLabel)"
)
_
->
ppr
Platform
platform
lbl
<>
(
parens
$
text
"other CLabel)"
)
-- True if a local IdLabel that we won't mark as exported
...
...
@@ -509,38 +509,38 @@ mkPlainModuleInitLabel mod = PlainModuleInitLabel mod
-- -----------------------------------------------------------------------------
-- Convert between different kinds of label
toClosureLbl
::
CLabel
->
CLabel
toClosureLbl
(
IdLabel
n
c
_
)
=
IdLabel
n
c
Closure
toClosureLbl
l
=
pprPanic
"toClosureLbl"
(
pprCLabel
l
)
toSlowEntryLbl
::
CLabel
->
CLabel
toSlowEntryLbl
(
IdLabel
n
c
_
)
=
IdLabel
n
c
Slow
toSlowEntryLbl
l
=
pprPanic
"toSlowEntryLbl"
(
pprCLabel
l
)
toRednCountsLbl
::
CLabel
->
CLabel
toRednCountsLbl
(
IdLabel
n
c
_
)
=
IdLabel
n
c
RednCounts
toRednCountsLbl
l
=
pprPanic
"toRednCountsLbl"
(
pprCLabel
l
)
toEntryLbl
::
CLabel
->
CLabel
toEntryLbl
(
IdLabel
n
c
LocalInfoTable
)
=
IdLabel
n
c
LocalEntry
toEntryLbl
(
IdLabel
n
c
ConInfoTable
)
=
IdLabel
n
c
ConEntry
toEntryLbl
(
IdLabel
n
c
StaticInfoTable
)
=
IdLabel
n
c
StaticConEntry
toEntryLbl
(
IdLabel
n
c
_
)
=
IdLabel
n
c
Entry
toEntryLbl
(
CaseLabel
n
CaseReturnInfo
)
=
CaseLabel
n
CaseReturnPt
toEntryLbl
(
CmmLabel
m
str
CmmInfo
)
=
CmmLabel
m
str
CmmEntry
toEntryLbl
(
CmmLabel
m
str
CmmRetInfo
)
=
CmmLabel
m
str
CmmRet
toEntryLbl
l
=
pprPanic
"toEntryLbl"
(
pprCLabel
l
)
toInfoLbl
::
CLabel
->
CLabel
toInfoLbl
(
IdLabel
n
c
Entry
)
=
IdLabel
n
c
InfoTable
toInfoLbl
(
IdLabel
n
c
LocalEntry
)
=
IdLabel
n
c
LocalInfoTable
toInfoLbl
(
IdLabel
n
c
ConEntry
)
=
IdLabel
n
c
ConInfoTable
toInfoLbl
(
IdLabel
n
c
StaticConEntry
)
=
IdLabel
n
c
StaticInfoTable
toInfoLbl
(
IdLabel
n
c
_
)
=
IdLabel
n
c
InfoTable
toInfoLbl
(
CaseLabel
n
CaseReturnPt
)
=
CaseLabel
n
CaseReturnInfo
toInfoLbl
(
CmmLabel
m
str
CmmEntry
)
=
CmmLabel
m
str
CmmInfo
toInfoLbl
(
CmmLabel
m
str
CmmRet
)
=
CmmLabel
m
str
CmmRetInfo
toInfoLbl
l
=
pprPanic
"CLabel.toInfoLbl"
(
pprCLabel
l
)
toClosureLbl
::
Platform
->
CLabel
->
CLabel
toClosureLbl
_
(
IdLabel
n
c
_
)
=
IdLabel
n
c
Closure
toClosureLbl
platform
l
=
pprPanic
"toClosureLbl"
(
pprCLabel
platform
l
)
toSlowEntryLbl
::
Platform
->
CLabel
->
CLabel
toSlowEntryLbl
_
(
IdLabel
n
c
_
)
=
IdLabel
n
c
Slow
toSlowEntryLbl
platform
l
=
pprPanic
"toSlowEntryLbl"
(
pprCLabel
platform
l
)
toRednCountsLbl
::
Platform
->
CLabel
->
CLabel
toRednCountsLbl
_
(
IdLabel
n
c
_
)
=
IdLabel
n
c
RednCounts
toRednCountsLbl
platform
l
=
pprPanic
"toRednCountsLbl"
(
pprCLabel
platform
l
)
toEntryLbl
::
Platform
->
CLabel
->
CLabel
toEntryLbl
_
(
IdLabel
n
c
LocalInfoTable
)
=
IdLabel
n
c
LocalEntry
toEntryLbl
_
(
IdLabel
n
c
ConInfoTable
)
=
IdLabel
n
c
ConEntry
toEntryLbl
_
(
IdLabel
n
c
StaticInfoTable
)
=
IdLabel
n
c
StaticConEntry
toEntryLbl
_
(
IdLabel
n
c
_
)
=
IdLabel
n
c
Entry
toEntryLbl
_
(
CaseLabel
n
CaseReturnInfo
)
=
CaseLabel
n
CaseReturnPt
toEntryLbl
_
(
CmmLabel
m
str
CmmInfo
)
=
CmmLabel
m
str
CmmEntry
toEntryLbl
_
(
CmmLabel
m
str
CmmRetInfo
)
=
CmmLabel
m
str
CmmRet
toEntryLbl
platform
l
=
pprPanic
"toEntryLbl"
(
pprCLabel
platform
l
)
toInfoLbl
::
Platform
->
CLabel
->
CLabel
toInfoLbl
_
(
IdLabel
n
c
Entry
)
=
IdLabel
n
c
InfoTable
toInfoLbl
_
(
IdLabel
n
c
LocalEntry
)
=
IdLabel
n
c
LocalInfoTable
toInfoLbl
_
(
IdLabel
n
c
ConEntry
)
=
IdLabel
n
c
ConInfoTable
toInfoLbl
_
(
IdLabel
n
c
StaticConEntry
)
=
IdLabel
n
c
StaticInfoTable
toInfoLbl
_
(
IdLabel
n
c
_
)
=
IdLabel
n
c
InfoTable
toInfoLbl
_
(
CaseLabel
n
CaseReturnPt
)
=
CaseLabel
n
CaseReturnInfo
toInfoLbl
_
(
CmmLabel
m
str
CmmEntry
)
=
CmmLabel
m
str
CmmInfo
toInfoLbl
_
(
CmmLabel
m
str
CmmRet
)
=
CmmLabel
m
str
CmmRetInfo
toInfoLbl
platform
l
=
pprPanic
"CLabel.toInfoLbl"
(
pprCLabel
platform
l
)
-- -----------------------------------------------------------------------------
-- Does a CLabel refer to a CAF?
...
...
@@ -891,14 +891,12 @@ Not exporting these Just_info labels reduces the number of symbols
somewhat.
-}
instance
Outputable
CLabel
where
ppr
=
pprCLabel
instance
PlatformOutputable
CLabel
where
pprPlatform
_
=
pprCLabel
pprPlatform
=
pprCLabel
pprCLabel
::
CLabel
->
SDoc
pprCLabel
::
Platform
->
CLabel
->
SDoc
pprCLabel
(
AsmTempLabel
u
)
pprCLabel
_
(
AsmTempLabel
u
)
|
cGhcWithNativeCodeGen
==
"YES"
=
getPprStyle
$
\
sty
->
if
asmStyle
sty
then
...
...
@@ -906,19 +904,19 @@ pprCLabel (AsmTempLabel u)
else
char
'_'
<>
pprUnique
u
pprCLabel
(
DynamicLinkerLabel
info
lbl
)
pprCLabel
platform
(
DynamicLinkerLabel
info
lbl
)
|
cGhcWithNativeCodeGen
==
"YES"
=
pprDynamicLinkerAsmLabel
info
lbl
=
pprDynamicLinkerAsmLabel
platform
info
lbl
pprCLabel
PicBaseLabel
pprCLabel
_
PicBaseLabel
|
cGhcWithNativeCodeGen
==
"YES"
=
ptext
(
sLit
"1b"
)
pprCLabel
(
DeadStripPreventer
lbl
)
pprCLabel
platform
(
DeadStripPreventer
lbl
)
|
cGhcWithNativeCodeGen
==
"YES"
=
pprCLabel
lbl
<>
ptext
(
sLit
"_dsp"
)
=
pprCLabel
platform
lbl
<>
ptext
(
sLit
"_dsp"
)
pprCLabel
lbl
pprCLabel
_
lbl
=
getPprStyle
$
\
sty
->
if
cGhcWithNativeCodeGen
==
"YES"
&&
asmStyle
sty
then
maybe_underscore
(
pprAsmCLbl
lbl
)
...
...
@@ -1072,63 +1070,40 @@ asmTempLabelPrefix =
(
sLit
".L"
)
#
endif
pprDynamicLinkerAsmLabel
::
DynamicLinkerLabelInfo
->
CLabel
->
SDoc
pprDynamicLinkerAsmLabel
::
Platform
->
DynamicLinkerLabelInfo
->
CLabel
->
SDoc
pprDynamicLinkerAsmLabel
platform
dllInfo
lbl
=
if
platform
==
Platform
ArchX86_64
OSDarwin
then
case
dllInfo
of
CodeStub
->
char
'L'
<>
pprCLabel
platform
lbl
<>
text
"$stub"
SymbolPtr
->
char
'L'
<>
pprCLabel
platform
lbl
<>
text
"$non_lazy_ptr"
GotSymbolPtr
->
pprCLabel
platform
lbl
<>
text
"@GOTPCREL"
GotSymbolOffset
->
pprCLabel
platform
lbl
_
->
panic
"pprDynamicLinkerAsmLabel"
else
if
platformOS
platform
==
OSDarwin
then
case
dllInfo
of
CodeStub
->
char
'L'
<>
pprCLabel
platform
lbl
<>
text
"$stub"
SymbolPtr
->
char
'L'
<>
pprCLabel
platform
lbl
<>
text
"$non_lazy_ptr"
_
->
panic
"pprDynamicLinkerAsmLabel"
else
if
platformArch
platform
==
ArchPPC
&&
osElfTarget
(
platformOS
platform
)
then
case
dllInfo
of
CodeStub
->
pprCLabel
platform
lbl
<>
text
"@plt"
SymbolPtr
->
text
".LC_"
<>
pprCLabel
platform
lbl
_
->
panic
"pprDynamicLinkerAsmLabel"
else
if
platformArch
platform
==
ArchX86_64
&&
osElfTarget
(
platformOS
platform
)
then
case
dllInfo
of
CodeStub
->
pprCLabel
platform
lbl
<>
text
"@plt"
GotSymbolPtr
->
pprCLabel
platform
lbl
<>
text
"@gotpcrel"
GotSymbolOffset
->
pprCLabel
platform
lbl
SymbolPtr
->
text
".LC_"
<>
pprCLabel
platform
lbl
else
if
osElfTarget
(
platformOS
platform
)
then
case
dllInfo
of
CodeStub
->
pprCLabel
platform
lbl
<>
text
"@plt"
SymbolPtr
->
text
".LC_"
<>
pprCLabel
platform
lbl
GotSymbolPtr
->
pprCLabel
platform
lbl
<>
text
"@got"
GotSymbolOffset
->
pprCLabel
platform
lbl
<>
text
"@gotoff"
else
if
platformOS
platform
==
OSMinGW32
then
case
dllInfo
of
SymbolPtr
->
text
"__imp_"
<>
pprCLabel
platform
lbl
_
->
panic
"pprDynamicLinkerAsmLabel"
else
panic
"pprDynamicLinkerAsmLabel"
#
if
x86_64_TARGET_ARCH
&&
darwin_TARGET_OS
pprDynamicLinkerAsmLabel
CodeStub
lbl
=
char
'L'
<>
pprCLabel
lbl
<>
text
"$stub"
pprDynamicLinkerAsmLabel
SymbolPtr
lbl
=
char
'L'
<>
pprCLabel
lbl
<>
text
"$non_lazy_ptr"
pprDynamicLinkerAsmLabel
GotSymbolPtr
lbl
=
pprCLabel
lbl
<>
text
"@GOTPCREL"
pprDynamicLinkerAsmLabel
GotSymbolOffset
lbl
=
pprCLabel
lbl
pprDynamicLinkerAsmLabel
_
_
=
panic
"pprDynamicLinkerAsmLabel"
#
elif
darwin_TARGET_OS
pprDynamicLinkerAsmLabel
CodeStub
lbl
=
char
'L'
<>
pprCLabel
lbl
<>
text
"$stub"
pprDynamicLinkerAsmLabel
SymbolPtr
lbl
=
char
'L'
<>
pprCLabel
lbl
<>
text
"$non_lazy_ptr"
pprDynamicLinkerAsmLabel
_
_
=
panic
"pprDynamicLinkerAsmLabel"
#
elif
powerpc_TARGET_ARCH
&&
elf_OBJ_FORMAT
pprDynamicLinkerAsmLabel
CodeStub
lbl
=
pprCLabel
lbl
<>
text
"@plt"
pprDynamicLinkerAsmLabel
SymbolPtr
lbl
=
text
".LC_"
<>
pprCLabel
lbl
pprDynamicLinkerAsmLabel
_
_
=
panic
"pprDynamicLinkerAsmLabel"
#
elif
x86_64_TARGET_ARCH
&&
elf_OBJ_FORMAT
pprDynamicLinkerAsmLabel
CodeStub
lbl
=
pprCLabel
lbl
<>
text
"@plt"
pprDynamicLinkerAsmLabel
GotSymbolPtr
lbl
=
pprCLabel
lbl
<>
text
"@gotpcrel"
pprDynamicLinkerAsmLabel
GotSymbolOffset
lbl
=
pprCLabel
lbl
pprDynamicLinkerAsmLabel
SymbolPtr
lbl
=
text
".LC_"
<>
pprCLabel
lbl
#
elif
elf_OBJ_FORMAT
pprDynamicLinkerAsmLabel
CodeStub
lbl
=
pprCLabel
lbl
<>
text
"@plt"
pprDynamicLinkerAsmLabel
SymbolPtr
lbl
=
text
".LC_"
<>
pprCLabel
lbl
pprDynamicLinkerAsmLabel
GotSymbolPtr
lbl
=
pprCLabel
lbl
<>
text
"@got"
pprDynamicLinkerAsmLabel
GotSymbolOffset
lbl
=
pprCLabel
lbl
<>
text
"@gotoff"
#
elif
mingw32_TARGET_OS
pprDynamicLinkerAsmLabel
SymbolPtr
lbl
=
text
"__imp_"
<>
pprCLabel
lbl
pprDynamicLinkerAsmLabel
_
_
=
panic
"pprDynamicLinkerAsmLabel"
#
else
pprDynamicLinkerAsmLabel
_
_
=
panic
"pprDynamicLinkerAsmLabel"
#
endif
compiler/cmm/CmmBuildInfoTables.hs
View file @
ac7a7eb9
...
...
@@ -44,6 +44,7 @@ import Control.Monad
import
Name
import
OptimizationFuel
import
Outputable
import
Platform
import
SMRep
import
UniqSupply
...
...
@@ -193,8 +194,8 @@ cafLattice = DataflowLattice "live cafs" Map.empty add
where
add
_
(
OldFact
old
)
(
NewFact
new
)
=
case
old
`
Map
.
union
`
new
of
new'
->
(
changeIf
$
Map
.
size
new'
>
Map
.
size
old
,
new'
)
cafTransfers
::
BwdTransfer
CmmNode
CAFSet
cafTransfers
=
mkBTransfer3
first
middle
last
cafTransfers
::
Platform
->
BwdTransfer
CmmNode
CAFSet
cafTransfers
platform
=
mkBTransfer3
first
middle
last
where
first
_
live
=
live
middle
m
live
=
foldExpDeep
addCaf
m
live
last
l
live
=
foldExpDeep
addCaf
l
(
joinOutFacts
cafLattice
l
live
)
...
...
@@ -203,10 +204,12 @@ cafTransfers = mkBTransfer3 first middle last
CmmLit
(
CmmLabelOff
c
_
)
->
add
c
set
CmmLit
(
CmmLabelDiffOff
c1
c2
_
)
->
add
c1
$
add
c2
set
_
->
set
add
l
s
=
if
hasCAF
l
then
Map
.
insert
(
toClosureLbl
l
)
()
s
else
s
add
l
s
=
if
hasCAF
l
then
Map
.
insert
(
toClosureLbl
platform
l
)
()
s
else
s
cafAnal
::
CmmGraph
->
FuelUniqSM
CAFEnv
cafAnal
g
=
liftM
snd
$
dataflowPassBwd
g
[]
$
analBwd
cafLattice
cafTransfers
cafAnal
::
Platform
->
CmmGraph
->
FuelUniqSM
CAFEnv
cafAnal
platform
g
=
liftM
snd
$
dataflowPassBwd
g
[]
$
analBwd
cafLattice
(
cafTransfers
platform
)
-----------------------------------------------------------------------
-- Building the SRTs
...
...
@@ -218,9 +221,12 @@ data TopSRT = TopSRT { lbl :: CLabel
,
rev_elts
::
[
CLabel
]
,
elt_map
::
Map
CLabel
Int
}
-- map: CLabel -> its last entry in the table
instance
Outputable
TopSRT
where
ppr
(
TopSRT
lbl
next
elts
eltmap
)
=
text
"TopSRT:"
<+>
ppr
lbl
<+>
ppr
next
<+>
ppr
elts
<+>
ppr
eltmap
instance
PlatformOutputable
TopSRT
where
pprPlatform
platform
(
TopSRT
lbl
next
elts
eltmap
)
=
text
"TopSRT:"
<+>
pprPlatform
platform
lbl
<+>
ppr
next
<+>
pprPlatform
platform
elts
<+>
pprPlatform
platform
eltmap
emptySRT
::
MonadUnique
m
=>
m
TopSRT
emptySRT
=
...
...
@@ -335,13 +341,13 @@ 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
->
CmmDecl
->
Maybe
(
CLabel
,
CAFSet
)
localCAFInfo
_
(
CmmData
_
_
)
=
Nothing
localCAFInfo
cafEnv
(
CmmProc
top_info
top_l
(
CmmGraph
{
g_entry
=
entry
}))
=
localCAFInfo
::
Platform
->
CAFEnv
->
CmmDecl
->
Maybe
(
CLabel
,
CAFSet
)
localCAFInfo
_
_
(
CmmData
_
_
)
=
Nothing
localCAFInfo
platform
cafEnv
(
CmmProc
top_info
top_l
(
CmmGraph
{
g_entry
=
entry
}))
=
case
info_tbl
top_info
of
CmmInfoTable
{
cit_rep
=
rep
}
|
not
(
isStaticRep
rep
)
->
Just
(
toClosureLbl
top_l
,
->
Just
(
toClosureLbl
platform
top_l
,
expectJust
"maybeBindCAFs"
$
mapLookup
entry
cafEnv
)
_
->
Nothing
...
...
compiler/cmm/CmmInfo.hs
View file @
ac7a7eb9
...
...
@@ -16,6 +16,7 @@ import Bitmap
import
Maybes
import
Constants
import
Panic
import
Platform
import
StaticFlags
import
UniqSupply
import
MonadUtils
...
...
@@ -30,10 +31,10 @@ mkEmptyContInfoTable info_lbl
,
cit_prof
=
NoProfilingInfo
,
cit_srt
=
NoC_SRT
}
cmmToRawCmm
::
[
Old
.
CmmGroup
]
->
IO
[
Old
.
RawCmmGroup
]
cmmToRawCmm
cmms
cmmToRawCmm
::
Platform
->
[
Old
.
CmmGroup
]
->
IO
[
Old
.
RawCmmGroup
]
cmmToRawCmm
platform
cmms
=
do
{
uniqs
<-
mkSplitUniqSupply
'i'
;
return
(
initUs_
uniqs
(
mapM
(
concatMapM
mkInfoTable
)
cmms
))
}
;
return
(
initUs_
uniqs
(
mapM
(
concatMapM
(
mkInfoTable
platform
)
)
cmms
))
}
-- 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
...
...
@@ -68,16 +69,16 @@ cmmToRawCmm cmms
--
-- * The SRT slot is only there if there is SRT info to record
mkInfoTable
::
CmmDecl
->
UniqSM
[
RawCmmDecl
]
mkInfoTable
(
CmmData
sec
dat
)
mkInfoTable
::
Platform
->
CmmDecl
->
UniqSM
[
RawCmmDecl
]
mkInfoTable
_
(
CmmData
sec
dat
)
=
return
[
CmmData
sec
dat
]
mkInfoTable
(
CmmProc
(
CmmInfo
_
_
info
)
entry_label
blocks
)
mkInfoTable
platform
(
CmmProc
(
CmmInfo
_
_
info
)
entry_label
blocks
)
|
CmmNonInfoTable
<-
info
-- Code without an info table. Easy.
=
return
[
CmmProc
Nothing
entry_label
blocks
]
|
CmmInfoTable
{
cit_lbl
=
info_lbl
}
<-
info
=
do
{
(
top_decls
,
info_cts
)
<-
mkInfoTableContents
info
Nothing
=
do
{
(
top_decls
,
info_cts
)
<-
mkInfoTableContents
platform
info
Nothing
;
return
(
top_decls
++
mkInfoTableAndCode
info_lbl
info_cts
entry_label
blocks
)
}
...
...
@@ -88,18 +89,20 @@ type InfoTableContents = ( [CmmLit] -- The standard part
,
[
CmmLit
]
)
-- The "extra bits"
-- These Lits have *not* had mkRelativeTo applied to them
mkInfoTableContents
::
CmmInfoTable
mkInfoTableContents
::
Platform
->
CmmInfoTable
->
Maybe
StgHalfWord
-- Override default RTS type tag?
->
UniqSM
([
RawCmmDecl
],
-- Auxiliary top decls
InfoTableContents
)
-- Info tbl + extra bits
mkInfoTableContents
info
@
(
CmmInfoTable
{
cit_lbl
=
info_lbl
mkInfoTableContents
platform
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
)
=
mkInfoTableContents
platform
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)
...
...
@@ -156,7 +159,7 @@ mkInfoTableContents info@(CmmInfoTable { cit_lbl = info_lbl
,
srt_lit
,
liveness_lit
,
slow_entry
]
;
return
(
Nothing
,
Nothing
,
extra_bits
,
liveness_data
)
}
where
slow_entry
=
CmmLabel
(
toSlowEntryLbl
info_lbl
)
slow_entry
=
CmmLabel
(
toSlowEntryLbl
platform
info_lbl
)
srt_lit
=
case
srt_label
of
[]
->
mkIntCLit
0
(
lit
:
_rest
)
->
ASSERT
(
null
_rest
)
lit
...
...
@@ -164,7 +167,7 @@ mkInfoTableContents info@(CmmInfoTable { cit_lbl = info_lbl
mk_pieces
BlackHole
_
=
panic
"mk_pieces: BlackHole"
mkInfoTableContents
_
_
=
panic
"mkInfoTableContents"
-- NonInfoTable dealt with earlier
mkInfoTableContents
_
_
_
=
panic
"mkInfoTableContents"
-- NonInfoTable dealt with earlier
mkSRTLit
::
C_SRT
->
([
CmmLit
],
-- srt_label, if any
...
...
compiler/cmm/CmmLint.hs
View file @
ac7a7eb9
...
...
@@ -30,13 +30,13 @@ import Data.Maybe
-- -----------------------------------------------------------------------------
-- Exported entry points:
cmmLint
::
(
Outputable
d
,
Outputable
h
)
cmmLint
::
(
Platform
Outputable
d
,
Platform
Outputable
h
)
=>
Platform
->
GenCmmGroup
d
h
(
ListGraph
CmmStmt
)
->
Maybe
SDoc
cmmLint
platform
tops
=
runCmmLint
platform
(
mapM_
lintCmmDecl
)
tops
cmmLint
platform
tops
=
runCmmLint
platform
(
mapM_
(
lintCmmDecl
platform
)
)
tops
cmmLintTop
::
(
Outputable
d
,
Outputable
h
)
cmmLintTop
::
(
Platform
Outputable
d
,
Platform
Outputable
h
)
=>
Platform
->
GenCmmDecl
d
h
(
ListGraph
CmmStmt
)
->
Maybe
SDoc
cmmLintTop
platform
top
=
runCmmLint
platform
lintCmmDecl
top
cmmLintTop
platform
top
=
runCmmLint
platform
(
lintCmmDecl
platform
)
top
runCmmLint
::
PlatformOutputable
a
=>
Platform
->
(
a
->
CmmLint
b
)
->
a
->
Maybe
SDoc
...
...
@@ -48,19 +48,19 @@ runCmmLint platform l p =
nest
2
(
pprPlatform
platform
p
)])
Right
_
->
Nothing
lintCmmDecl
::
(
GenCmmDecl
h
i
(
ListGraph
CmmStmt
))
->
CmmLint
()
lintCmmDecl
(
CmmProc
_
lbl
(
ListGraph
blocks
))
=
addLintInfo
(
text
"in proc "
<>
pprCLabel
lbl
)
$
lintCmmDecl
::
Platform
->
(
GenCmmDecl
h
i
(
ListGraph
CmmStmt
))
->
CmmLint
()
lintCmmDecl
platform
(
CmmProc
_
lbl
(
ListGraph
blocks
))
=
addLintInfo
(
text
"in proc "
<>
pprCLabel
platform
lbl
)
$
let
labels
=
foldl
(
\
s
b
->
setInsert
(
blockId
b
)
s
)
setEmpty
blocks
in
mapM_
(
lintCmmBlock
labels
)
blocks
in
mapM_
(
lintCmmBlock
platform
labels
)
blocks
lintCmmDecl
(
CmmData
{})
lintCmmDecl
_
(
CmmData
{})
=
return
()
lintCmmBlock
::
BlockSet
->
GenBasicBlock
CmmStmt
->
CmmLint
()
lintCmmBlock
labels
(
BasicBlock
id
stmts
)
lintCmmBlock
::
Platform
->
BlockSet
->
GenBasicBlock
CmmStmt
->
CmmLint
()
lintCmmBlock
platform
labels
(
BasicBlock
id
stmts
)
=
addLintInfo
(
text
"in basic block "
<>
ppr
id
)
$
mapM_
(
lintCmmStmt
labels
)
stmts
mapM_
(
lintCmmStmt
platform
labels
)
stmts
-- -----------------------------------------------------------------------------
-- lintCmmExpr
...
...
@@ -68,24 +68,24 @@ lintCmmBlock labels (BasicBlock id stmts)
-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
-- byte/word mismatches.
lintCmmExpr
::
CmmExpr
->
CmmLint
CmmType
lintCmmExpr
(
CmmLoad
expr
rep
)
=
do
_
<-
lintCmmExpr
expr
lintCmmExpr
::
Platform
->
CmmExpr
->
CmmLint
CmmType
lintCmmExpr
platform
(
CmmLoad
expr
rep
)
=
do
_
<-
lintCmmExpr
platform
expr
-- Disabled, if we have the inlining phase before the lint phase,
-- we can have funny offsets due to pointer tagging. -- EZY
-- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
-- cmmCheckWordAddress expr
return
rep
lintCmmExpr
expr
@
(
CmmMachOp
op
args
)
=
do
tys
<-
mapM
lintCmmExpr
args
lintCmmExpr
platform
expr
@
(
CmmMachOp
op
args
)
=
do
tys
<-
mapM
(
lintCmmExpr
platform
)
args
if
map
(
typeWidth
.
cmmExprType
)
args
==
machOpArgReps
op
then
cmmCheckMachOp
op
args
tys
else
cmmLintMachOpErr
expr
(
map
cmmExprType
args
)
(
machOpArgReps
op
)
lintCmmExpr
(
CmmRegOff
reg
offset
)
=
lintCmmExpr
(
CmmMachOp
(
MO_Add
rep
)
else
cmmLintMachOpErr
platform
expr
(
map
cmmExprType
args
)
(
machOpArgReps
op
)
lintCmmExpr
platform
(
CmmRegOff
reg
offset
)
=
lintCmmExpr
platform
(
CmmMachOp
(
MO_Add
rep
)
[
CmmReg
reg
,
CmmLit
(
CmmInt
(
fromIntegral
offset
)
rep
)])
where
rep
=
typeWidth
(
cmmRegType
reg
)
lintCmmExpr
expr
=
lintCmmExpr
_
expr
=
return
(
cmmExprType
expr
)
-- Check for some common byte/word mismatches (eg. Sp + 1)
...
...
@@ -102,14 +102,14 @@ isOffsetOp _ = False
-- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets.
_cmmCheckWordAddress
::
CmmExpr
->
CmmLint
()
_cmmCheckWordAddress
e
@
(
CmmMachOp
op
[
arg
,
CmmLit
(
CmmInt
i
_
)])
_cmmCheckWordAddress
::
Platform
->
CmmExpr
->
CmmLint
()
_cmmCheckWordAddress
platform
e
@
(
CmmMachOp
op
[
arg
,
CmmLit
(
CmmInt
i
_
)])
|
isOffsetOp
op
&&
notNodeReg
arg
&&
i
`
rem
`
fromIntegral
wORD_SIZE
/=
0
=
cmmLintDubiousWordOffset
e
_cmmCheckWordAddress
e
@
(
CmmMachOp
op
[
CmmLit
(
CmmInt
i
_
),
arg
])
=
cmmLintDubiousWordOffset
platform
e
_cmmCheckWordAddress
platform
e
@
(
CmmMachOp
op
[
CmmLit
(
CmmInt
i
_
),
arg
])
|
isOffsetOp
op
&&
notNodeReg
arg
&&
i
`
rem
`
fromIntegral
wORD_SIZE
/=
0
=
cmmLintDubiousWordOffset
e
_cmmCheckWordAddress
_
=
cmmLintDubiousWordOffset
platform
e
_cmmCheckWordAddress
_
_
=
return
()
-- No warnings for unaligned arithmetic with the node register,
...
...
@@ -118,46 +118,47 @@ notNodeReg :: CmmExpr -> Bool
notNodeReg
(
CmmReg
reg
)
|
reg
==
nodeReg
=
False
notNodeReg
_
=
True
lintCmmStmt
::
BlockSet
->
CmmStmt
->
CmmLint
()
lintCmmStmt
labels
=
lint
lintCmmStmt
::
Platform
->
BlockSet
->
CmmStmt
->
CmmLint
()
lintCmmStmt
platform
labels
=
lint
where
lint
(
CmmNop
)
=
return
()
lint
(
CmmComment
{})
=
return
()
lint
stmt
@
(
CmmAssign
reg
expr
)
=
do
erep
<-
lintCmmExpr
expr
erep
<-
lintCmmExpr
platform
expr
let
reg_ty
=
cmmRegType
reg
if
(
erep
`
cmmEqType_ignoring_ptrhood
`
reg_ty
)
then
return
()
else
cmmLintAssignErr
stmt
erep
reg_ty
else
cmmLintAssignErr
platform
stmt
erep
reg_ty
lint
(
CmmStore
l
r
)
=
do
_
<-
lintCmmExpr
l
_
<-
lintCmmExpr
r
_
<-
lintCmmExpr
platform
l
_
<-
lintCmmExpr
platform
r
return
()
lint
(
CmmCall
target
_res
args
_
_
)
=
lintTarget
target
>>
mapM_
(
lintCmmExpr
.
hintlessCmm
)
args
lint
(
CmmCondBranch
e
id
)
=
checkTarget
id
>>
lintCmmExpr
e
>>
checkCond
e
lintTarget
platform
target
>>
mapM_
(
lintCmmExpr
platform
.
hintlessCmm
)
args
lint
(
CmmCondBranch
e
id
)
=
checkTarget
id
>>
lintCmmExpr
platform
e
>>
checkCond
platform
e
lint
(
CmmSwitch
e
branches
)
=
do
mapM_
checkTarget
$
catMaybes
branches
erep
<-
lintCmmExpr
e
erep
<-
lintCmmExpr
platform
e
if
(
erep
`
cmmEqType_ignoring_ptrhood
`
bWord
)
then
return
()
else
cmmLintErr
(
text
"switch scrutinee is not a word: "
<>
ppr
e
<>
else
cmmLintErr
(
text
"switch scrutinee is not a word: "
<>
ppr
Platform
platform
e
<>
text
" :: "
<>
ppr
erep
)
lint
(
CmmJump
e
args
)
=
lintCmmExpr
e
>>
mapM_
(
lintCmmExpr
.
hintlessCmm
)
args
lint
(
CmmReturn
ress
)
=
mapM_
(
lintCmmExpr
.
hintlessCmm
)
ress
lint
(
CmmJump
e
args
)
=
lintCmmExpr
platform
e
>>
mapM_
(
lintCmmExpr
platform
.
hintlessCmm
)
args
lint
(
CmmReturn
ress
)
=
mapM_
(
lintCmmExpr
platform
.
hintlessCmm
)
ress
lint
(
CmmBranch
id
)
=
checkTarget
id
checkTarget
id
=
if
setMember
id
labels
then
return
()
else
cmmLintErr
(
text
"Branch to nonexistent id"
<+>
ppr
id
)
lintTarget
::
CmmCallTarget
->
CmmLint
()
lintTarget
(
CmmCallee
e
_
)
=
lintCmmExpr
e
>>
return
()
lintTarget
(
CmmPrim
{})
=
return
()
lintTarget
::
Platform
->
CmmCallTarget
->
CmmLint
()
lintTarget
platform
(
CmmCallee
e
_
)
=
lintCmmExpr
platform
e
>>
return
()
lintTarget
_
(
CmmPrim
{})
=
return
()
checkCond
::
CmmExpr
->
CmmLint
()
checkCond
(
CmmMachOp
mop
_
)
|
isComparisonMachOp
mop
=
return
()
checkCond
(
CmmLit
(
CmmInt
x
t
))
|
x
==
0
||
x
==
1
,
t
==
wordWidth
=
return
()
-- constant values
checkCond
expr
=
cmmLintErr
(
hang
(
text
"expression is not a conditional:"
)
2
(
ppr
expr
))
checkCond
::
Platform
->
CmmExpr
->
CmmLint
()
checkCond
_
(
CmmMachOp
mop
_
)
|
isComparisonMachOp
mop
=
return
()
checkCond
_
(
CmmLit
(
CmmInt
x
t
))
|
x
==
0
||
x
==
1
,
t
==
wordWidth
=
return
()
-- constant values
checkCond
platform
expr
=
cmmLintErr
(
hang
(
text
"expression is not a conditional:"
)
2
(
pprPlatform
platform
expr
))
-- -----------------------------------------------------------------------------
-- CmmLint monad
...
...
@@ -181,23 +182,23 @@ addLintInfo info thing = CmmLint $
Left
err
->
Left
(
hang
info
2
err
)
Right
a
->
Right
a
cmmLintMachOpErr
::
CmmExpr
->
[
CmmType
]
->
[
Width
]
->
CmmLint
a
cmmLintMachOpErr
expr
argsRep
opExpectsRep
cmmLintMachOpErr
::
Platform
->
CmmExpr
->
[
CmmType
]
->
[
Width
]
->
CmmLint
a
cmmLintMachOpErr
platform
expr
argsRep
opExpectsRep
=
cmmLintErr
(
text
"in MachOp application: "
$$
nest
2
(
ppr
expr
)
$$
nest
2
(
ppr
Platform
platform
expr
)
$$
(
text
"op is expecting: "
<+>
ppr
opExpectsRep
)
$$
(
text
"arguments provide: "
<+>
ppr
argsRep
))
cmmLintAssignErr
::
CmmStmt
->
CmmType
->
CmmType
->
CmmLint
a
cmmLintAssignErr
stmt
e_ty
r_ty
cmmLintAssignErr
::
Platform
->
CmmStmt
->
CmmType
->
CmmType
->
CmmLint
a
cmmLintAssignErr
platform
stmt
e_ty
r_ty
=
cmmLintErr
(
text
"in assignment: "
$$
nest
2
(
vcat
[
ppr
stmt
,
nest
2
(
vcat
[
ppr
Platform
platform
stmt
,
text
"Reg ty:"
<+>
ppr
r_ty
,
text
"Rhs ty:"
<+>
ppr
e_ty
]))
cmmLintDubiousWordOffset
::
CmmExpr
->
CmmLint
a
cmmLintDubiousWordOffset
expr