Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
2b7319a6
Commit
2b7319a6
authored
Sep 12, 2012
by
ian@well-typed.com
Browse files
Pass DynFlags down to wordWidth
parent
44b5f471
Changes
41
Hide whitespace changes
Inline
Side-by-side
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