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,247
Issues
4,247
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
398
Merge Requests
398
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
2b7319a6
Commit
2b7319a6
authored
Sep 12, 2012
by
ian@well-typed.com
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Pass DynFlags down to wordWidth
parent
44b5f471
Changes
41
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
41 changed files
with
1123 additions
and
1083 deletions
+1123
-1083
compiler/cmm/CmmBuildInfoTables.hs
compiler/cmm/CmmBuildInfoTables.hs
+24
-22
compiler/cmm/CmmCallConv.hs
compiler/cmm/CmmCallConv.hs
+2
-2
compiler/cmm/CmmInfo.hs
compiler/cmm/CmmInfo.hs
+19
-19
compiler/cmm/CmmLayoutStack.hs
compiler/cmm/CmmLayoutStack.hs
+11
-11
compiler/cmm/CmmLint.hs
compiler/cmm/CmmLint.hs
+8
-7
compiler/cmm/CmmMachOp.hs
compiler/cmm/CmmMachOp.hs
+58
-55
compiler/cmm/CmmOpt.hs
compiler/cmm/CmmOpt.hs
+42
-43
compiler/cmm/CmmParse.y
compiler/cmm/CmmParse.y
+2
-2
compiler/cmm/CmmPipeline.hs
compiler/cmm/CmmPipeline.hs
+1
-1
compiler/cmm/CmmRewriteAssignments.hs
compiler/cmm/CmmRewriteAssignments.hs
+4
-6
compiler/cmm/CmmType.hs
compiler/cmm/CmmType.hs
+7
-6
compiler/cmm/CmmUtils.hs
compiler/cmm/CmmUtils.hs
+42
-43
compiler/cmm/MkGraph.hs
compiler/cmm/MkGraph.hs
+3
-3
compiler/cmm/OldCmmLint.hs
compiler/cmm/OldCmmLint.hs
+7
-7
compiler/cmm/PprC.hs
compiler/cmm/PprC.hs
+79
-69
compiler/cmm/PprCmmExpr.hs
compiler/cmm/PprCmmExpr.hs
+3
-2
compiler/codeGen/CgClosure.lhs
compiler/codeGen/CgClosure.lhs
+6
-5
compiler/codeGen/CgCon.lhs
compiler/codeGen/CgCon.lhs
+1
-1
compiler/codeGen/CgForeignCall.hs
compiler/codeGen/CgForeignCall.hs
+5
-5
compiler/codeGen/CgHeapery.lhs
compiler/codeGen/CgHeapery.lhs
+35
-32
compiler/codeGen/CgInfoTbls.hs
compiler/codeGen/CgInfoTbls.hs
+5
-5
compiler/codeGen/CgPrimOp.hs
compiler/codeGen/CgPrimOp.hs
+251
-245
compiler/codeGen/CgProf.hs
compiler/codeGen/CgProf.hs
+30
-30
compiler/codeGen/CgTailCall.lhs
compiler/codeGen/CgTailCall.lhs
+3
-3
compiler/codeGen/CgTicky.hs
compiler/codeGen/CgTicky.hs
+9
-9
compiler/codeGen/CgUtils.hs
compiler/codeGen/CgUtils.hs
+38
-32
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmBind.hs
+4
-4
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmExpr.hs
+3
-3
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmForeign.hs
+4
-4
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmHeap.hs
+39
-40
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmLayout.hs
+2
-2
compiler/codeGen/StgCmmMonad.hs
compiler/codeGen/StgCmmMonad.hs
+10
-8
compiler/codeGen/StgCmmPrim.hs
compiler/codeGen/StgCmmPrim.hs
+253
-249
compiler/codeGen/StgCmmProf.hs
compiler/codeGen/StgCmmProf.hs
+41
-41
compiler/codeGen/StgCmmTicky.hs
compiler/codeGen/StgCmmTicky.hs
+9
-9
compiler/codeGen/StgCmmUtils.hs
compiler/codeGen/StgCmmUtils.hs
+31
-27
compiler/nativeGen/AsmCodeGen.lhs
compiler/nativeGen/AsmCodeGen.lhs
+7
-7
compiler/nativeGen/PIC.hs
compiler/nativeGen/PIC.hs
+5
-4
compiler/nativeGen/PPC/CodeGen.hs
compiler/nativeGen/PPC/CodeGen.hs
+5
-5
compiler/nativeGen/SPARC/CodeGen.hs
compiler/nativeGen/SPARC/CodeGen.hs
+5
-5
compiler/nativeGen/X86/CodeGen.hs
compiler/nativeGen/X86/CodeGen.hs
+10
-10
No files found.
compiler/cmm/CmmBuildInfoTables.hs
View file @
2b7319a6
...
...
@@ -33,6 +33,7 @@ import CLabel
import
Cmm
import
CmmUtils
import
Data.List
import
DynFlags
import
Maybes
import
Module
import
Outputable
...
...
@@ -166,17 +167,17 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
-- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
-- 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.
buildSRT
::
TopSRT
->
CAFSet
->
UniqSM
(
TopSRT
,
Maybe
CmmDecl
,
C_SRT
)
buildSRT
topSRT
cafs
=
buildSRT
::
DynFlags
->
TopSRT
->
CAFSet
->
UniqSM
(
TopSRT
,
Maybe
CmmDecl
,
C_SRT
)
buildSRT
dflags
topSRT
cafs
=
do
let
-- For each label referring to a function f without a static closure,
-- replace it with the CAFs that are reachable from f.
sub_srt
topSRT
localCafs
=
let
cafs
=
Set
.
elems
localCafs
mkSRT
topSRT
=
do
localSRTs
<-
procpointSRT
(
lbl
topSRT
)
(
elt_map
topSRT
)
cafs
do
localSRTs
<-
procpointSRT
dflags
(
lbl
topSRT
)
(
elt_map
topSRT
)
cafs
return
(
topSRT
,
localSRTs
)
in
if
length
cafs
>
maxBmpSize
then
in
if
length
cafs
>
maxBmpSize
dflags
then
mkSRT
(
foldl
add_if_missing
topSRT
cafs
)
else
-- make sure all the cafs are near the bottom of the srt
mkSRT
(
add_if_too_far
topSRT
cafs
)
...
...
@@ -196,7 +197,7 @@ buildSRT topSRT cafs =
add
srt
[]
=
srt
add
srt
@
(
TopSRT
{
next_elt
=
next
})
(
caf
:
rst
)
=
case
cafOffset
srt
caf
of
Just
ix
->
if
next
-
ix
>
maxBmpSize
then
Just
ix
->
if
next
-
ix
>
maxBmpSize
dflags
then
add
(
addCAF
caf
srt
)
rst
else
srt
Nothing
->
add
(
addCAF
caf
srt
)
rst
...
...
@@ -206,12 +207,12 @@ buildSRT topSRT cafs =
-- Construct an SRT bitmap.
-- Adapted from simpleStg/SRT.lhs, which expects Id's.
procpointSRT
::
CLabel
->
Map
CLabel
Int
->
[
CLabel
]
->
procpointSRT
::
DynFlags
->
CLabel
->
Map
CLabel
Int
->
[
CLabel
]
->
UniqSM
(
Maybe
CmmDecl
,
C_SRT
)
procpointSRT
_
_
[]
=
procpointSRT
_
_
_
[]
=
return
(
Nothing
,
NoC_SRT
)
procpointSRT
top_srt
top_table
entries
=
do
(
top
,
srt
)
<-
bitmap
`
seq
`
to_SRT
top_srt
offset
len
bitmap
procpointSRT
dflags
top_srt
top_table
entries
=
do
(
top
,
srt
)
<-
bitmap
`
seq
`
to_SRT
dflags
top_srt
offset
len
bitmap
return
(
top
,
srt
)
where
ints
=
map
(
expectJust
"constructSRT"
.
flip
Map
.
lookup
top_table
)
entries
...
...
@@ -221,20 +222,20 @@ procpointSRT top_srt top_table entries =
len
=
P
.
last
bitmap_entries
+
1
bitmap
=
intsToBitmap
len
bitmap_entries
maxBmpSize
::
Int
maxBmpSize
=
widthInBits
wordWidth
`
div
`
2
maxBmpSize
::
DynFlags
->
Int
maxBmpSize
dflags
=
widthInBits
(
wordWidth
dflags
)
`
div
`
2
-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
to_SRT
::
CLabel
->
Int
->
Int
->
Bitmap
->
UniqSM
(
Maybe
CmmDecl
,
C_SRT
)
to_SRT
top_srt
off
len
bmp
|
len
>
maxBmpSize
||
bmp
==
[
fromIntegral
srt_escape
]
to_SRT
::
DynFlags
->
CLabel
->
Int
->
Int
->
Bitmap
->
UniqSM
(
Maybe
CmmDecl
,
C_SRT
)
to_SRT
dflags
top_srt
off
len
bmp
|
len
>
maxBmpSize
dflags
||
bmp
==
[
fromIntegral
srt_escape
]
=
do
id
<-
getUniqueM
let
srt_desc_lbl
=
mkLargeSRTLabel
id
tbl
=
CmmData
RelocatableReadOnlyData
$
Statics
srt_desc_lbl
$
map
CmmStaticLit
(
cmmLabelOffW
top_srt
off
:
mkWordCLit
(
fromIntegral
len
)
:
map
mkWordCLit
bmp
)
:
mkWordCLit
dflags
(
fromIntegral
len
)
:
map
(
mkWordCLit
dflags
)
bmp
)
return
(
Just
tbl
,
C_SRT
srt_desc_lbl
0
srt_escape
)
|
otherwise
=
return
(
Nothing
,
C_SRT
top_srt
off
(
fromIntegral
(
head
bmp
)))
...
...
@@ -318,11 +319,12 @@ flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
localCAFs
=
unzipWith
localCAFInfo
zipped
flatmap
=
mkTopCAFInfo
localCAFs
-- transitive closure of localCAFs
doSRTs
::
TopSRT
doSRTs
::
DynFlags
->
TopSRT
->
[(
CAFEnv
,
[
CmmDecl
])]
->
IO
(
TopSRT
,
[
CmmDecl
])
doSRTs
topSRT
tops
doSRTs
dflags
topSRT
tops
=
do
let
caf_decls
=
flattenCAFSets
tops
us
<-
mkSplitUniqSupply
'u'
...
...
@@ -330,19 +332,19 @@ doSRTs topSRT tops
return
(
topSRT'
,
reverse
gs'
{- Note [reverse gs] -}
)
where
setSRT
(
topSRT
,
rst
)
(
caf_map
,
decl
@
(
CmmProc
{}))
=
do
(
topSRT
,
srt_tables
,
srt_env
)
<-
buildSRTs
topSRT
caf_map
(
topSRT
,
srt_tables
,
srt_env
)
<-
buildSRTs
dflags
topSRT
caf_map
let
decl'
=
updInfoSRTs
srt_env
decl
return
(
topSRT
,
decl'
:
srt_tables
++
rst
)
setSRT
(
topSRT
,
rst
)
(
_
,
decl
)
=
return
(
topSRT
,
decl
:
rst
)
buildSRTs
::
TopSRT
->
BlockEnv
CAFSet
buildSRTs
::
DynFlags
->
TopSRT
->
BlockEnv
CAFSet
->
UniqSM
(
TopSRT
,
[
CmmDecl
],
BlockEnv
C_SRT
)
buildSRTs
top_srt
caf_map
buildSRTs
dflags
top_srt
caf_map
=
foldM
doOne
(
top_srt
,
[]
,
mapEmpty
)
(
mapToList
caf_map
)
where
doOne
(
top_srt
,
decls
,
srt_env
)
(
l
,
cafs
)
=
do
(
top_srt
,
mb_decl
,
srt
)
<-
buildSRT
top_srt
cafs
=
do
(
top_srt
,
mb_decl
,
srt
)
<-
buildSRT
dflags
top_srt
cafs
return
(
top_srt
,
maybeToList
mb_decl
++
decls
,
mapInsert
l
srt
srt_env
)
...
...
compiler/cmm/CmmCallConv.hs
View file @
2b7319a6
...
...
@@ -78,9 +78,9 @@ assignArgumentsPos dflags conv arg_ty reps = assignments
_
->
(
assts
,
(
r
:
rs
))
int
=
case
(
w
,
regs
)
of
(
W128
,
_
)
->
panic
"W128 unsupported register type"
(
_
,
(
v
:
vs
,
fs
,
ds
,
ls
))
|
widthInBits
w
<=
widthInBits
wordWidth
(
_
,
(
v
:
vs
,
fs
,
ds
,
ls
))
|
widthInBits
w
<=
widthInBits
(
wordWidth
dflags
)
->
k
(
RegisterParam
(
v
gcp
),
(
vs
,
fs
,
ds
,
ls
))
(
_
,
(
vs
,
fs
,
ds
,
l
:
ls
))
|
widthInBits
w
>
widthInBits
wordWidth
(
_
,
(
vs
,
fs
,
ds
,
l
:
ls
))
|
widthInBits
w
>
widthInBits
(
wordWidth
dflags
)
->
k
(
RegisterParam
l
,
(
vs
,
fs
,
ds
,
ls
))
_
->
(
assts
,
(
r
:
rs
))
k
(
asst
,
regs'
)
=
assign_regs
((
r
,
asst
)
:
assts
)
rs
regs'
...
...
compiler/cmm/CmmInfo.hs
View file @
2b7319a6
...
...
@@ -114,8 +114,8 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
-- Use a zero place-holder in place of the
-- entry-label in the info table
return
(
top_decls
++
[
mkRODataLits
info_lbl
(
zeroCLit
:
rel_std_info
++
rel_extra_bits
)])
[
mkRODataLits
info_lbl
(
zeroCLit
dflags
:
rel_std_info
++
rel_extra_bits
)])
_nonempty
->
-- Separately emit info table (with the function entry
-- point as first entry) and the entry code
...
...
@@ -172,9 +172,9 @@ mkInfoTableContents dflags
-- (which in turn came from a handwritten .cmm file)
|
StackRep
frame
<-
smrep
=
do
{
(
prof_lits
,
prof_data
)
<-
mkProfLits
prof
=
do
{
(
prof_lits
,
prof_data
)
<-
mkProfLits
dflags
prof
;
let
(
srt_label
,
srt_bitmap
)
=
mkSRTLit
srt
;
(
liveness_lit
,
liveness_data
)
<-
mkLivenessBits
frame
;
(
liveness_lit
,
liveness_data
)
<-
mkLivenessBits
dflags
frame
;
let
std_info
=
mkStdInfoTable
dflags
prof_lits
rts_tag
srt_bitmap
liveness_lit
rts_tag
|
Just
tag
<-
mb_rts_tag
=
tag
...
...
@@ -184,8 +184,8 @@ mkInfoTableContents dflags
;
return
(
prof_data
++
liveness_data
,
(
std_info
,
srt_label
))
}
|
HeapRep
_
ptrs
nonptrs
closure_type
<-
smrep
=
do
{
let
layout
=
packHalfWordsCLit
ptrs
nonptrs
;
(
prof_lits
,
prof_data
)
<-
mkProfLits
prof
=
do
{
let
layout
=
packHalfWordsCLit
dflags
ptrs
nonptrs
;
(
prof_lits
,
prof_data
)
<-
mkProfLits
dflags
prof
;
let
(
srt_label
,
srt_bitmap
)
=
mkSRTLit
srt
;
(
mb_srt_field
,
mb_layout
,
extra_bits
,
ct_data
)
<-
mk_pieces
closure_type
srt_label
...
...
@@ -208,24 +208,24 @@ mkInfoTableContents dflags
=
return
(
Nothing
,
Nothing
,
srt_label
,
[]
)
mk_pieces
(
ThunkSelector
offset
)
_no_srt
=
return
(
Just
0
,
Just
(
mkWordCLit
offset
),
[]
,
[]
)
=
return
(
Just
0
,
Just
(
mkWordCLit
dflags
offset
),
[]
,
[]
)
-- Layout known (one free var); we use the layout field for offset
mk_pieces
(
Fun
arity
(
ArgSpec
fun_type
))
srt_label
=
do
{
let
extra_bits
=
packHalfWordsCLit
fun_type
arity
:
srt_label
=
do
{
let
extra_bits
=
packHalfWordsCLit
dflags
fun_type
arity
:
srt_label
;
return
(
Nothing
,
Nothing
,
extra_bits
,
[]
)
}
mk_pieces
(
Fun
arity
(
ArgGen
arg_bits
))
srt_label
=
do
{
(
liveness_lit
,
liveness_data
)
<-
mkLivenessBits
arg_bits
=
do
{
(
liveness_lit
,
liveness_data
)
<-
mkLivenessBits
dflags
arg_bits
;
let
fun_type
|
null
liveness_data
=
aRG_GEN
|
otherwise
=
aRG_GEN_BIG
extra_bits
=
[
packHalfWordsCLit
fun_type
arity
extra_bits
=
[
packHalfWordsCLit
dflags
fun_type
arity
,
srt_lit
,
liveness_lit
,
slow_entry
]
;
return
(
Nothing
,
Nothing
,
extra_bits
,
liveness_data
)
}
where
slow_entry
=
CmmLabel
(
toSlowEntryLbl
info_lbl
)
srt_lit
=
case
srt_label
of
[]
->
mkIntCLit
0
[]
->
mkIntCLit
dflags
0
(
lit
:
_rest
)
->
ASSERT
(
null
_rest
)
lit
mk_pieces
BlackHole
_
=
panic
"mk_pieces: BlackHole"
...
...
@@ -297,12 +297,12 @@ makeRelativeRefTo _ _ lit = lit
-- The head of the stack layout is the top of the stack and
-- the least-significant bit.
mkLivenessBits
::
Liveness
->
UniqSM
(
CmmLit
,
[
RawCmmDecl
])
mkLivenessBits
::
DynFlags
->
Liveness
->
UniqSM
(
CmmLit
,
[
RawCmmDecl
])
-- ^ Returns:
-- 1. The bitmap (literal value or label)
-- 2. Large bitmap CmmData if needed
mkLivenessBits
liveness
mkLivenessBits
dflags
liveness
|
n_bits
>
mAX_SMALL_BITMAP_SIZE
-- does not fit in one word
=
do
{
uniq
<-
getUniqueUs
;
let
bitmap_lbl
=
mkBitmapLabel
uniq
...
...
@@ -310,7 +310,7 @@ mkLivenessBits liveness
[
mkRODataLits
bitmap_lbl
lits
])
}
|
otherwise
-- Fits in one word
=
return
(
mkWordCLit
bitmap_word
,
[]
)
=
return
(
mkWordCLit
dflags
bitmap_word
,
[]
)
where
n_bits
=
length
liveness
...
...
@@ -324,7 +324,7 @@ mkLivenessBits liveness
bitmap_word
=
fromIntegral
n_bits
.|.
(
small_bitmap
`
shiftL
`
bITMAP_BITS_SHIFT
)
lits
=
mkWordCLit
(
fromIntegral
n_bits
)
:
map
mkWordCLit
bitmap
lits
=
mkWordCLit
dflags
(
fromIntegral
n_bits
)
:
map
(
mkWordCLit
dflags
)
bitmap
-- The first word is the size. The structure must match
-- StgLargeBitmap in includes/rts/storage/InfoTable.h
...
...
@@ -361,7 +361,7 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
|
dopt
Opt_SccProfilingOn
dflags
=
[
type_descr
,
closure_descr
]
|
otherwise
=
[]
type_lit
=
packHalfWordsCLit
cl_type
srt_len
type_lit
=
packHalfWordsCLit
dflags
cl_type
srt_len
-------------------------------------------------------------------------
--
...
...
@@ -369,9 +369,9 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
--
-------------------------------------------------------------------------
mkProfLits
::
ProfilingInfo
->
UniqSM
((
CmmLit
,
CmmLit
),
[
RawCmmDecl
])
mkProfLits
NoProfilingInfo
=
return
((
zeroCLit
,
zeroCLit
),
[]
)
mkProfLits
(
ProfilingInfo
td
cd
)
mkProfLits
::
DynFlags
->
ProfilingInfo
->
UniqSM
((
CmmLit
,
CmmLit
),
[
RawCmmDecl
])
mkProfLits
dflags
NoProfilingInfo
=
return
((
zeroCLit
dflags
,
zeroCLit
dflags
),
[]
)
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
])
}
...
...
compiler/cmm/CmmLayoutStack.hs
View file @
2b7319a6
...
...
@@ -776,12 +776,12 @@ arguments.
areaToSp
::
DynFlags
->
ByteOff
->
ByteOff
->
(
Area
->
StackLoc
)
->
CmmExpr
->
CmmExpr
areaToSp
dflags
sp_old
_sp_hwm
area_off
(
CmmStackSlot
area
n
)
=
cmmOffset
dflags
(
CmmReg
spReg
)
(
sp_old
-
area_off
area
-
n
)
areaToSp
_
_
sp_hwm
_
(
CmmLit
CmmHighStackMark
)
=
mkIntExpr
sp_hwm
areaToSp
_
_
_
_
(
CmmMachOp
(
MO_U_Lt
_
)
-- Note [null stack check]
[
CmmMachOp
(
MO_Sub
_
)
[
CmmReg
(
CmmGlobal
Sp
)
,
CmmLit
(
CmmInt
0
_
)],
CmmReg
(
CmmGlobal
SpLim
)])
=
zeroExpr
areaToSp
dflags
_
sp_hwm
_
(
CmmLit
CmmHighStackMark
)
=
mkIntExpr
dflags
sp_hwm
areaToSp
dflags
_
_
_
(
CmmMachOp
(
MO_U_Lt
_
)
-- Note [null stack check]
[
CmmMachOp
(
MO_Sub
_
)
[
CmmReg
(
CmmGlobal
Sp
)
,
CmmLit
(
CmmInt
0
_
)],
CmmReg
(
CmmGlobal
SpLim
)])
=
zeroExpr
dflags
areaToSp
_
_
_
_
other
=
other
-- -----------------------------------------------------------------------------
...
...
@@ -920,7 +920,7 @@ lowerSafeForeignCall dflags block
load_stack
<-
newTemp
(
gcWord
dflags
)
let
suspend
=
saveThreadState
dflags
<*>
caller_save
<*>
mkMiddle
(
callSuspendThread
id
intrbl
)
mkMiddle
(
callSuspendThread
dflags
id
intrbl
)
midCall
=
mkUnsafeCall
tgt
res
args
resume
=
mkMiddle
(
callResumeThread
new_base
id
)
<*>
-- Assign the result to BaseReg: we
...
...
@@ -941,7 +941,7 @@ lowerSafeForeignCall dflags block
jump
=
CmmCall
{
cml_target
=
CmmLoad
(
CmmReg
spReg
)
(
bWord
dflags
)
,
cml_cont
=
Just
succ
,
cml_args_regs
=
regs
,
cml_args
=
widthInBytes
wordWidth
,
cml_args
=
widthInBytes
(
wordWidth
dflags
)
,
cml_ret_args
=
ret_args
,
cml_ret_off
=
updfr
}
...
...
@@ -966,12 +966,12 @@ foreignLbl name = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name))
newTemp
::
CmmType
->
UniqSM
LocalReg
newTemp
rep
=
getUniqueM
>>=
\
u
->
return
(
LocalReg
u
rep
)
callSuspendThread
::
LocalReg
->
Bool
->
CmmNode
O
O
callSuspendThread
id
intrbl
=
callSuspendThread
::
DynFlags
->
LocalReg
->
Bool
->
CmmNode
O
O
callSuspendThread
dflags
id
intrbl
=
CmmUnsafeForeignCall
(
ForeignTarget
(
foreignLbl
(
fsLit
"suspendThread"
))
(
ForeignConvention
CCallConv
[
AddrHint
,
NoHint
]
[
AddrHint
]))
[
id
]
[
CmmReg
(
CmmGlobal
BaseReg
),
mkIntExpr
(
fromEnum
intrbl
)]
[
id
]
[
CmmReg
(
CmmGlobal
BaseReg
),
mkIntExpr
dflags
(
fromEnum
intrbl
)]
callResumeThread
::
LocalReg
->
LocalReg
->
CmmNode
O
O
callResumeThread
new_base
id
=
...
...
compiler/cmm/CmmLint.hs
View file @
2b7319a6
...
...
@@ -88,9 +88,9 @@ lintCmmExpr (CmmLoad expr rep) = do
lintCmmExpr
expr
@
(
CmmMachOp
op
args
)
=
do
dflags
<-
getDynFlags
tys
<-
mapM
lintCmmExpr
args
if
map
(
typeWidth
.
cmmExprType
dflags
)
args
==
machOpArgReps
op
if
map
(
typeWidth
.
cmmExprType
dflags
)
args
==
machOpArgReps
dflags
op
then
cmmCheckMachOp
op
args
tys
else
cmmLintMachOpErr
expr
(
map
(
cmmExprType
dflags
)
args
)
(
machOpArgReps
op
)
else
cmmLintMachOpErr
expr
(
map
(
cmmExprType
dflags
)
args
)
(
machOpArgReps
dflags
op
)
lintCmmExpr
(
CmmRegOff
reg
offset
)
=
do
dflags
<-
getDynFlags
let
rep
=
typeWidth
(
cmmRegType
dflags
reg
)
...
...
@@ -158,9 +158,10 @@ lintCmmLast labels node = case node of
CmmBranch
id
->
checkTarget
id
CmmCondBranch
e
t
f
->
do
dflags
<-
getDynFlags
mapM_
checkTarget
[
t
,
f
]
_
<-
lintCmmExpr
e
checkCond
e
checkCond
dflags
e
CmmSwitch
e
branches
->
do
dflags
<-
getDynFlags
...
...
@@ -190,10 +191,10 @@ lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
lintTarget
(
PrimTarget
{})
=
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
checkCond
::
DynFlags
->
CmmExpr
->
CmmLint
()
checkCond
_
(
CmmMachOp
mop
_
)
|
isComparisonMachOp
mop
=
return
()
checkCond
dflags
(
CmmLit
(
CmmInt
x
t
))
|
x
==
0
||
x
==
1
,
t
==
wordWidth
dflags
=
return
()
-- constant values
checkCond
_
expr
=
cmmLintErr
(
hang
(
text
"expression is not a conditional:"
)
2
(
ppr
expr
))
...
...
compiler/cmm/CmmMachOp.hs
View file @
2b7319a6
...
...
@@ -123,59 +123,62 @@ mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
,
mo_wordSGe
,
mo_wordSLe
,
mo_wordSGt
,
mo_wordSLt
,
mo_wordUGe
,
mo_wordULe
,
mo_wordUGt
,
mo_wordULt
,
mo_wordAnd
,
mo_wordOr
,
mo_wordXor
,
mo_wordNot
,
mo_wordShl
,
mo_wordSShr
,
mo_wordUShr
,
mo_u_8To32
,
mo_s_8To32
,
mo_u_16To32
,
mo_s_16To32
,
mo_u_8ToWord
,
mo_s_8ToWord
,
mo_u_16ToWord
,
mo_s_16ToWord
,
mo_u_32ToWord
,
mo_s_32ToWord
,
mo_32To8
,
mo_32To16
,
mo_WordTo8
,
mo_WordTo16
,
mo_WordTo32
,
mo_WordTo64
,
mo_WordTo8
,
mo_WordTo16
,
mo_WordTo32
,
mo_WordTo64
::
DynFlags
->
MachOp
mo_u_8To32
,
mo_s_8To32
,
mo_u_16To32
,
mo_s_16To32
,
mo_32To8
,
mo_32To16
::
MachOp
mo_wordAdd
=
MO_Add
wordWidth
mo_wordSub
=
MO_Sub
wordWidth
mo_wordEq
=
MO_Eq
wordWidth
mo_wordNe
=
MO_Ne
wordWidth
mo_wordMul
=
MO_Mul
wordWidth
mo_wordSQuot
=
MO_S_Quot
wordWidth
mo_wordSRem
=
MO_S_Rem
wordWidth
mo_wordSNeg
=
MO_S_Neg
wordWidth
mo_wordUQuot
=
MO_U_Quot
wordWidth
mo_wordURem
=
MO_U_Rem
wordWidth
mo_wordSGe
=
MO_S_Ge
wordWidth
mo_wordSLe
=
MO_S_Le
wordWidth
mo_wordSGt
=
MO_S_Gt
wordWidth
mo_wordSLt
=
MO_S_Lt
wordWidth
mo_wordUGe
=
MO_U_Ge
wordWidth
mo_wordULe
=
MO_U_Le
wordWidth
mo_wordUGt
=
MO_U_Gt
wordWidth
mo_wordULt
=
MO_U_Lt
wordWidth
mo_wordAnd
=
MO_And
wordWidth
mo_wordOr
=
MO_Or
wordWidth
mo_wordXor
=
MO_Xor
wordWidth
mo_wordNot
=
MO_Not
wordWidth
mo_wordShl
=
MO_Shl
wordWidth
mo_wordSShr
=
MO_S_Shr
wordWidth
mo_wordUShr
=
MO_U_Shr
wordWidth
mo_u_8To32
=
MO_UU_Conv
W8
W32
mo_s_8To32
=
MO_SS_Conv
W8
W32
mo_u_16To32
=
MO_UU_Conv
W16
W32
mo_s_16To32
=
MO_SS_Conv
W16
W32
mo_u_8ToWord
=
MO_UU_Conv
W8
wordWidth
mo_s_8ToWord
=
MO_SS_Conv
W8
wordWidth
mo_u_16ToWord
=
MO_UU_Conv
W16
wordWidth
mo_s_16ToWord
=
MO_SS_Conv
W16
wordWidth
mo_s_32ToWord
=
MO_SS_Conv
W32
wordWidth
mo_u_32ToWord
=
MO_UU_Conv
W32
wordWidth
mo_WordTo8
=
MO_UU_Conv
wordWidth
W8
mo_WordTo16
=
MO_UU_Conv
wordWidth
W16
mo_WordTo32
=
MO_UU_Conv
wordWidth
W32
mo_WordTo64
=
MO_UU_Conv
wordWidth
W64
mo_32To8
=
MO_UU_Conv
W32
W8
mo_32To16
=
MO_UU_Conv
W32
W16
mo_wordAdd
dflags
=
MO_Add
(
wordWidth
dflags
)
mo_wordSub
dflags
=
MO_Sub
(
wordWidth
dflags
)
mo_wordEq
dflags
=
MO_Eq
(
wordWidth
dflags
)
mo_wordNe
dflags
=
MO_Ne
(
wordWidth
dflags
)
mo_wordMul
dflags
=
MO_Mul
(
wordWidth
dflags
)
mo_wordSQuot
dflags
=
MO_S_Quot
(
wordWidth
dflags
)
mo_wordSRem
dflags
=
MO_S_Rem
(
wordWidth
dflags
)
mo_wordSNeg
dflags
=
MO_S_Neg
(
wordWidth
dflags
)
mo_wordUQuot
dflags
=
MO_U_Quot
(
wordWidth
dflags
)
mo_wordURem
dflags
=
MO_U_Rem
(
wordWidth
dflags
)
mo_wordSGe
dflags
=
MO_S_Ge
(
wordWidth
dflags
)
mo_wordSLe
dflags
=
MO_S_Le
(
wordWidth
dflags
)
mo_wordSGt
dflags
=
MO_S_Gt
(
wordWidth
dflags
)
mo_wordSLt
dflags
=
MO_S_Lt
(
wordWidth
dflags
)
mo_wordUGe
dflags
=
MO_U_Ge
(
wordWidth
dflags
)
mo_wordULe
dflags
=
MO_U_Le
(
wordWidth
dflags
)
mo_wordUGt
dflags
=
MO_U_Gt
(
wordWidth
dflags
)
mo_wordULt
dflags
=
MO_U_Lt
(
wordWidth
dflags
)
mo_wordAnd
dflags
=
MO_And
(
wordWidth
dflags
)
mo_wordOr
dflags
=
MO_Or
(
wordWidth
dflags
)
mo_wordXor
dflags
=
MO_Xor
(
wordWidth
dflags
)
mo_wordNot
dflags
=
MO_Not
(
wordWidth
dflags
)
mo_wordShl
dflags
=
MO_Shl
(
wordWidth
dflags
)
mo_wordSShr
dflags
=
MO_S_Shr
(
wordWidth
dflags
)
mo_wordUShr
dflags
=
MO_U_Shr
(
wordWidth
dflags
)
mo_u_8To32
=
MO_UU_Conv
W8
W32
mo_s_8To32
=
MO_SS_Conv
W8
W32
mo_u_16To32
=
MO_UU_Conv
W16
W32
mo_s_16To32
=
MO_SS_Conv
W16
W32
mo_u_8ToWord
dflags
=
MO_UU_Conv
W8
(
wordWidth
dflags
)
mo_s_8ToWord
dflags
=
MO_SS_Conv
W8
(
wordWidth
dflags
)
mo_u_16ToWord
dflags
=
MO_UU_Conv
W16
(
wordWidth
dflags
)
mo_s_16ToWord
dflags
=
MO_SS_Conv
W16
(
wordWidth
dflags
)
mo_s_32ToWord
dflags
=
MO_SS_Conv
W32
(
wordWidth
dflags
)
mo_u_32ToWord
dflags
=
MO_UU_Conv
W32
(
wordWidth
dflags
)
mo_WordTo8
dflags
=
MO_UU_Conv
(
wordWidth
dflags
)
W8
mo_WordTo16
dflags
=
MO_UU_Conv
(
wordWidth
dflags
)
W16
mo_WordTo32
dflags
=
MO_UU_Conv
(
wordWidth
dflags
)
W32
mo_WordTo64
dflags
=
MO_UU_Conv
(
wordWidth
dflags
)
W64
mo_32To8
=
MO_UU_Conv
W32
W8
mo_32To16
=
MO_UU_Conv
W32
W16
-- ----------------------------------------------------------------------------
...
...
@@ -350,8 +353,8 @@ comparisonResultRep = bWord -- is it?
-- its arguments are the same as the MachOp expects. This is used when
-- linting a CmmExpr.
machOpArgReps
::
MachOp
->
[
Width
]
machOpArgReps
op
=
machOpArgReps
::
DynFlags
->
MachOp
->
[
Width
]
machOpArgReps
dflags
op
=
case
op
of
MO_Add
r
->
[
r
,
r
]
MO_Sub
r
->
[
r
,
r
]
...
...
@@ -392,9 +395,9 @@ machOpArgReps op =
MO_Or
r
->
[
r
,
r
]
MO_Xor
r
->
[
r
,
r
]
MO_Not
r
->
[
r
]
MO_Shl
r
->
[
r
,
wordWidth
]
MO_U_Shr
r
->
[
r
,
wordWidth
]
MO_S_Shr
r
->
[
r
,
wordWidth
]
MO_Shl
r
->
[
r
,
wordWidth
dflags
]
MO_U_Shr
r
->
[
r
,
wordWidth
dflags
]
MO_S_Shr
r
->
[
r
,
wordWidth
dflags
]
MO_SS_Conv
from
_
->
[
from
]
MO_UU_Conv
from
_
->
[
from
]
...
...
compiler/cmm/CmmOpt.hs
View file @
2b7319a6
...
...
@@ -183,8 +183,7 @@ cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr)
-- not CmmLocal: that might invalidate the usage analysis results
isTiny
_
=
False
platform
=
targetPlatform
dflags
foldExp
(
CmmMachOp
op
args
)
=
cmmMachOpFold
platform
op
args
foldExp
(
CmmMachOp
op
args
)
=
cmmMachOpFold
dflags
op
args
foldExp
e
=
e
ncgDebugTrace
str
x
=
if
ncgDebugIsOn
then
trace
str
x
else
x
...
...
@@ -302,17 +301,17 @@ inlineExpr _ _ other_expr = other_expr
-- been optimized and folded.
cmmMachOpFold
::
Platform
::
DynFlags
->
MachOp
-- The operation from an CmmMachOp
->
[
CmmExpr
]
-- The optimized arguments
->
CmmExpr
cmmMachOpFold
platform
op
args
=
fromMaybe
(
CmmMachOp
op
args
)
(
cmmMachOpFoldM
platform
op
args
)
cmmMachOpFold
dflags
op
args
=
fromMaybe
(
CmmMachOp
op
args
)
(
cmmMachOpFoldM
dflags
op
args
)
-- Returns Nothing if no changes, useful for Hoopl, also reduces
-- allocation!
cmmMachOpFoldM
::
Platform
::
DynFlags
->
MachOp
->
[
CmmExpr
]
->
Maybe
CmmExpr
...
...
@@ -338,7 +337,7 @@ cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
cmmMachOpFoldM
_
(
MO_UU_Conv
rep1
rep2
)
[
x
]
|
rep1
==
rep2
=
Just
x
-- Eliminate nested conversions where possible
cmmMachOpFoldM
platform
conv_outer
[
CmmMachOp
conv_inner
[
x
]]
cmmMachOpFoldM
dflags
conv_outer
[
CmmMachOp
conv_inner
[
x
]]
|
Just
(
rep1
,
rep2
,
signed1
)
<-
isIntConversion
conv_inner
,
Just
(
_
,
rep3
,
signed2
)
<-
isIntConversion
conv_outer
=
case
()
of
...
...
@@ -348,13 +347,13 @@ cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]]
-- but remember to use the signedness from the widening, just in case
-- the final conversion is a widen.
|
rep1
<
rep2
&&
rep2
>
rep3
->
Just
$
cmmMachOpFold
platform
(
intconv
signed1
rep1
rep3
)
[
x
]
Just
$
cmmMachOpFold
dflags
(
intconv
signed1
rep1
rep3
)
[
x
]
-- Nested widenings: collapse if the signedness is the same
|
rep1
<
rep2
&&
rep2
<
rep3
&&
signed1
==
signed2
->
Just
$
cmmMachOpFold
platform
(
intconv
signed1
rep1
rep3
)
[
x
]
Just
$
cmmMachOpFold
dflags
(
intconv
signed1
rep1
rep3
)
[
x
]
-- Nested narrowings: collapse
|
rep1
>
rep2
&&
rep2
>
rep3
->
Just
$
cmmMachOpFold
platform
(
MO_UU_Conv
rep1
rep3
)
[
x
]
Just
$
cmmMachOpFold
dflags
(
MO_UU_Conv
rep1
rep3
)
[
x
]
|
otherwise
->
Nothing
where
...
...
@@ -371,22 +370,22 @@ cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]]
-- but what if the architecture only supports word-sized loads, should
-- we do the transformation anyway?
cmmMachOpFoldM
_
mop
[
CmmLit
(
CmmInt
x
xrep
),
CmmLit
(
CmmInt
y
_
)]
cmmMachOpFoldM
dflags
mop
[
CmmLit
(
CmmInt
x
xrep
),
CmmLit
(
CmmInt
y
_
)]
=
case
mop
of
-- for comparisons: don't forget to narrow the arguments before
-- comparing, since they might be out of range.
MO_Eq
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_u
==
y_u
then
1
else
0
)
wordWidth
)
MO_Ne
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_u
/=
y_u
then
1
else
0
)
wordWidth
)
MO_Eq
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_u
==
y_u
then
1
else
0
)
(
wordWidth
dflags
)
)
MO_Ne
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_u
/=
y_u
then
1
else
0
)
(
wordWidth
dflags
)
)
MO_U_Gt
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_u
>
y_u
then
1
else
0
)
wordWidth
)
MO_U_Ge
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_u
>=
y_u
then
1
else
0
)
wordWidth
)
MO_U_Lt
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_u
<
y_u
then
1
else
0
)
wordWidth
)
MO_U_Le
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_u
<=
y_u
then
1
else
0
)
wordWidth
)
MO_U_Gt
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_u
>
y_u
then
1
else
0
)
(
wordWidth
dflags
)
)
MO_U_Ge
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_u
>=
y_u
then
1
else
0
)
(
wordWidth
dflags
)
)
MO_U_Lt
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_u
<
y_u
then
1
else
0
)
(
wordWidth
dflags
)
)
MO_U_Le
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_u
<=
y_u
then
1
else
0
)
(
wordWidth
dflags
)
)
MO_S_Gt
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_s
>
y_s
then
1
else
0
)
wordWidth
)
MO_S_Ge
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_s
>=
y_s
then
1
else
0
)
wordWidth
)
MO_S_Lt
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_s
<
y_s
then
1
else
0
)
wordWidth
)
MO_S_Le
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_s
<=
y_s
then
1
else
0
)
wordWidth
)
MO_S_Gt
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_s
>
y_s
then
1
else
0
)
(
wordWidth
dflags
)
)
MO_S_Ge
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_s
>=
y_s
then
1
else
0
)
(
wordWidth
dflags
)
)
MO_S_Lt
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_s
<
y_s
then
1
else
0
)
(
wordWidth
dflags
)
)
MO_S_Le
_
->
Just
$
CmmLit
(
CmmInt
(
if
x_s
<=
y_s
then
1
else
0
)
(
wordWidth
dflags
)
)
MO_Add
r
->
Just
$
CmmLit
(
CmmInt
(
x
+
y
)
r
)
MO_Sub
r
->
Just
$
CmmLit
(
CmmInt
(
x
-
y
)
r
)
...
...
@@ -418,9 +417,9 @@ cmmMachOpFoldM _ mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
-- also assume that constants have been shifted to the right when
-- possible.
cmmMachOpFoldM
platform
op
[
x
@
(
CmmLit
_
),
y
]
cmmMachOpFoldM
dflags
op
[
x
@
(
CmmLit
_
),
y
]
|
not
(
isLit
y
)
&&
isCommutableMachOp
op
=
Just
(
cmmMachOpFold
platform
op
[
y
,
x
])
=
Just
(
cmmMachOpFold
dflags
op
[
y
,
x
])
-- Turn (a+b)+c into a+(b+c) where possible. Because literals are
-- moved to the right, it is more likely that we will find
...
...
@@ -438,19 +437,19 @@ cmmMachOpFoldM platform op [x@(CmmLit _), y]
-- Also don't do it if arg1 is PicBaseReg, so that we don't separate the
-- PicBaseReg from the corresponding label (or label difference).
--
cmmMachOpFoldM
platform
mop1
[
CmmMachOp
mop2
[
arg1
,
arg2
],
arg3
]
cmmMachOpFoldM
dflags
mop1
[
CmmMachOp
mop2
[
arg1
,
arg2
],
arg3
]
|
mop2
`
associates_with
`
mop1
&&
not
(
isLit
arg1
)
&&
not
(
isPicReg
arg1
)
=
Just
(
cmmMachOpFold
platform
mop2
[
arg1
,
cmmMachOpFold
platform
mop1
[
arg2
,
arg3
]])
=
Just
(
cmmMachOpFold
dflags
mop2
[
arg1
,
cmmMachOpFold
dflags
mop1
[
arg2
,
arg3
]])
where