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
cf02909e
Commit
cf02909e
authored
Sep 15, 2012
by
Simon Peyton Jones
Browse files
Merge remote branch 'origin/master'
parents
7d83fdea
c3f4c6fa
Changes
170
Expand all
Hide whitespace changes
Inline
Side-by-side
aclocal.m4
View file @
cf02909e
...
...
@@ -226,7 +226,10 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
haiku)
test -z "[$]2" || eval "[$]2=OSHaiku"
;;
dragonfly|osf1|osf3|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix)
osf3)
test -z "[$]2" || eval "[$]2=OSOsf3"
;;
dragonfly|osf1|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix)
test -z "[$]2" || eval "[$]2=OSUnknown"
;;
*)
...
...
compiler/cmm/Bitmap.hs
View file @
cf02909e
...
...
@@ -25,6 +25,7 @@ module Bitmap (
import
SMRep
import
Constants
import
DynFlags
import
Util
import
Data.Bits
...
...
@@ -37,10 +38,10 @@ generated code which need to be emitted as sequences of StgWords.
type
Bitmap
=
[
StgWord
]
-- | Make a bitmap from a sequence of bits
mkBitmap
::
[
Bool
]
->
Bitmap
mkBitmap
[]
=
[]
mkBitmap
stuff
=
chunkToBitmap
chunk
:
mkBitmap
rest
where
(
chunk
,
rest
)
=
splitAt
wORD_SIZE_IN_BITS
stuff
mkBitmap
::
DynFlags
->
[
Bool
]
->
Bitmap
mkBitmap
_
[]
=
[]
mkBitmap
dflags
stuff
=
chunkToBitmap
chunk
:
mkBitmap
dflags
rest
where
(
chunk
,
rest
)
=
splitAt
(
wORD_SIZE_IN_BITS
dflags
)
stuff
chunkToBitmap
::
[
Bool
]
->
StgWord
chunkToBitmap
chunk
=
...
...
@@ -50,31 +51,31 @@ chunkToBitmap chunk =
-- eg. @[0,1,3], size 4 ==> 0xb@.
--
-- The list of @Int@s /must/ be already sorted.
intsToBitmap
::
Int
->
[
Int
]
->
Bitmap
intsToBitmap
size
slots
{- must be sorted -}
intsToBitmap
::
DynFlags
->
Int
->
[
Int
]
->
Bitmap
intsToBitmap
dflags
size
slots
{- must be sorted -}
|
size
<=
0
=
[]
|
otherwise
=
(
foldr
(
.|.
)
0
(
map
(
1
`
shiftL
`)
these
))
:
intsToBitmap
(
size
-
wORD_SIZE_IN_BITS
)
(
map
(
\
x
->
x
-
wORD_SIZE_IN_BITS
)
rest
)
where
(
these
,
rest
)
=
span
(
<
wORD_SIZE_IN_BITS
)
slots
intsToBitmap
dflags
(
size
-
wORD_SIZE_IN_BITS
dflags
)
(
map
(
\
x
->
x
-
wORD_SIZE_IN_BITS
dflags
)
rest
)
where
(
these
,
rest
)
=
span
(
<
wORD_SIZE_IN_BITS
dflags
)
slots
-- | Make a bitmap where the slots specified are the /zeros/ in the bitmap.
-- eg. @[0,1,3], size 4 ==> 0x4@ (we leave any bits outside the size as zero,
-- just to make the bitmap easier to read).
--
-- The list of @Int@s /must/ be already sorted and duplicate-free.
intsToReverseBitmap
::
Int
->
[
Int
]
->
Bitmap
intsToReverseBitmap
size
slots
{- must be sorted -}
intsToReverseBitmap
::
DynFlags
->
Int
->
[
Int
]
->
Bitmap
intsToReverseBitmap
dflags
size
slots
{- must be sorted -}
|
size
<=
0
=
[]
|
otherwise
=
(
foldr
xor
init
(
map
(
1
`
shiftL
`)
these
))
:
intsToReverseBitmap
(
size
-
wORD_SIZE_IN_BITS
)
(
map
(
\
x
->
x
-
wORD_SIZE_IN_BITS
)
rest
)
where
(
these
,
rest
)
=
span
(
<
wORD_SIZE_IN_BITS
)
slots
init
|
size
>=
wORD_SIZE_IN_BITS
=
complement
0
|
otherwise
=
(
1
`
shiftL
`
size
)
-
1
(
foldr
xor
init
(
map
(
1
`
shiftL
`)
these
))
:
intsToReverseBitmap
dflags
(
size
-
wORD_SIZE_IN_BITS
dflags
)
(
map
(
\
x
->
x
-
wORD_SIZE_IN_BITS
dflags
)
rest
)
where
(
these
,
rest
)
=
span
(
<
wORD_SIZE_IN_BITS
dflags
)
slots
init
|
size
>=
wORD_SIZE_IN_BITS
dflags
=
complement
0
|
otherwise
=
(
1
`
shiftL
`
size
)
-
1
{- |
Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h.
...
...
compiler/cmm/CmmBuildInfoTables.hs
View file @
cf02909e
...
...
@@ -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
...
...
@@ -219,22 +220,22 @@ procpointSRT top_srt top_table entries =
offset
=
head
sorted_ints
bitmap_entries
=
map
(
subtract
offset
)
sorted_ints
len
=
P
.
last
bitmap_entries
+
1
bitmap
=
intsToBitmap
len
bitmap_entries
bitmap
=
intsToBitmap
dflags
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 @
cf02909e
...
...
@@ -46,12 +46,12 @@ assignArgumentsPos dflags conv arg_ty reps = assignments
regs
=
case
(
reps
,
conv
)
of
(
_
,
NativeNodeCall
)
->
getRegsWithNode
dflags
(
_
,
NativeDirectCall
)
->
getRegsWithoutNode
dflags
([
_
],
NativeReturn
)
->
allRegs
([
_
],
NativeReturn
)
->
allRegs
dflags
(
_
,
NativeReturn
)
->
getRegsWithNode
dflags
-- GC calling convention *must* put values in registers
(
_
,
GC
)
->
allRegs
(
_
,
PrimOpCall
)
->
allRegs
([
_
],
PrimOpReturn
)
->
allRegs
(
_
,
GC
)
->
allRegs
dflags
(
_
,
PrimOpCall
)
->
allRegs
dflags
([
_
],
PrimOpReturn
)
->
allRegs
dflags
(
_
,
PrimOpReturn
)
->
getRegsWithNode
dflags
(
_
,
Slow
)
->
noRegs
-- The calling conventions first assign arguments to registers,
...
...
@@ -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'
...
...
@@ -111,46 +111,51 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
-- that are guaranteed to map to machine registers.
getRegsWithoutNode
,
getRegsWithNode
::
DynFlags
->
AvailRegs
getRegsWithoutNode
_
dflags
=
(
filter
(
\
r
->
r
VGcPtr
/=
node
)
realVanillaRegs
,
realFloatRegs
,
realDoubleRegs
,
realLongRegs
)
getRegsWithoutNode
dflags
=
(
filter
(
\
r
->
r
VGcPtr
/=
node
)
(
realVanillaRegs
dflags
)
,
realFloatRegs
dflags
,
realDoubleRegs
dflags
,
realLongRegs
dflags
)
-- getRegsWithNode uses R1/node even if it isn't a register
getRegsWithNode
_dflags
=
(
if
null
realVanillaRegs
then
[
VanillaReg
1
]
else
realVanillaRegs
,
realFloatRegs
,
realDoubleRegs
,
realLongRegs
)
allFloatRegs
,
allDoubleRegs
,
allLongRegs
::
[
GlobalReg
]
allVanillaRegs
::
[
VGcPtr
->
GlobalReg
]
allVanillaRegs
=
map
VanillaReg
$
regList
mAX_Vanilla_REG
allFloatRegs
=
map
FloatReg
$
regList
mAX_Float_REG
allDoubleRegs
=
map
DoubleReg
$
regList
mAX_Double_REG
allLongRegs
=
map
LongReg
$
regList
mAX_Long_REG
realFloatRegs
,
realDoubleRegs
,
realLongRegs
::
[
GlobalReg
]
realVanillaRegs
::
[
VGcPtr
->
GlobalReg
]
realVanillaRegs
=
map
VanillaReg
$
regList
mAX_Real_Vanilla_REG
realFloatRegs
=
map
FloatReg
$
regList
mAX_Real_Float_REG
realDoubleRegs
=
map
DoubleReg
$
regList
mAX_Real_Double_REG
realLongRegs
=
map
LongReg
$
regList
mAX_Real_Long_REG
getRegsWithNode
dflags
=
(
if
null
(
realVanillaRegs
dflags
)
then
[
VanillaReg
1
]
else
realVanillaRegs
dflags
,
realFloatRegs
dflags
,
realDoubleRegs
dflags
,
realLongRegs
dflags
)
allFloatRegs
,
allDoubleRegs
,
allLongRegs
::
DynFlags
->
[
GlobalReg
]
allVanillaRegs
::
DynFlags
->
[
VGcPtr
->
GlobalReg
]
allVanillaRegs
dflags
=
map
VanillaReg
$
regList
(
mAX_Vanilla_REG
dflags
)
allFloatRegs
dflags
=
map
FloatReg
$
regList
(
mAX_Float_REG
dflags
)
allDoubleRegs
dflags
=
map
DoubleReg
$
regList
(
mAX_Double_REG
dflags
)
allLongRegs
dflags
=
map
LongReg
$
regList
(
mAX_Long_REG
dflags
)
realFloatRegs
,
realDoubleRegs
,
realLongRegs
::
DynFlags
->
[
GlobalReg
]
realVanillaRegs
::
DynFlags
->
[
VGcPtr
->
GlobalReg
]
realVanillaRegs
dflags
=
map
VanillaReg
$
regList
(
mAX_Real_Vanilla_REG
dflags
)
realFloatRegs
dflags
=
map
FloatReg
$
regList
(
mAX_Real_Float_REG
dflags
)
realDoubleRegs
dflags
=
map
DoubleReg
$
regList
(
mAX_Real_Double_REG
dflags
)
realLongRegs
dflags
=
map
LongReg
$
regList
(
mAX_Real_Long_REG
dflags
)
regList
::
Int
->
[
Int
]
regList
n
=
[
1
..
n
]
allRegs
::
AvailRegs
allRegs
=
(
allVanillaRegs
,
allFloatRegs
,
allDoubleRegs
,
allLongRegs
)
allRegs
::
DynFlags
->
AvailRegs
allRegs
dflags
=
(
allVanillaRegs
dflags
,
allFloatRegs
dflags
,
allDoubleRegs
dflags
,
allLongRegs
dflags
)
noRegs
::
AvailRegs
noRegs
=
(
[]
,
[]
,
[]
,
[]
)
globalArgRegs
::
[
GlobalReg
]
globalArgRegs
=
map
(
$
VGcPtr
)
allVanillaRegs
++
allFloatRegs
++
allDoubleRegs
++
allLongRegs
globalArgRegs
::
DynFlags
->
[
GlobalReg
]
globalArgRegs
dflags
=
map
(
$
VGcPtr
)
(
allVanillaRegs
dflags
)
++
allFloatRegs
dflags
++
allDoubleRegs
dflags
++
allLongRegs
dflags
compiler/cmm/CmmExpr.hs
View file @
cf02909e
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module
CmmExpr
(
CmmExpr
(
..
),
cmmExprType
,
cmmExprWidth
,
maybeInvertCmmExpr
,
CmmReg
(
..
),
cmmRegType
,
CmmLit
(
..
),
cmmLitType
,
LocalReg
(
..
),
localRegType
,
GlobalReg
(
..
),
globalRegType
,
spReg
,
hpReg
,
spLimReg
,
nodeReg
,
node
,
baseReg
,
VGcPtr
(
..
),
vgcFlag
-- Temporary!
,
VGcPtr
(
..
),
vgcFlag
-- Temporary!
,
DefinerOfLocalRegs
,
UserOfLocalRegs
,
foldRegsDefd
,
foldRegsUsed
,
filterRegsUsed
,
RegSet
,
emptyRegSet
,
elemRegSet
,
extendRegSet
,
deleteFromRegSet
,
mkRegSet
,
plusRegSet
,
minusRegSet
,
timesRegSet
,
sizeRegSet
,
nullRegSet
...
...
@@ -30,13 +23,14 @@ import CmmType
import
CmmMachOp
import
BlockId
import
CLabel
import
DynFlags
import
Unique
import
Data.Set
(
Set
)
import
qualified
Data.Set
as
Set
-----------------------------------------------------------------------------
--
CmmExpr
--
CmmExpr
-- An expression. Expressions have no side effects.
-----------------------------------------------------------------------------
...
...
@@ -48,19 +42,19 @@ data CmmExpr
|
CmmStackSlot
Area
{-# UNPACK #-}
!
Int
-- addressing expression of a stack slot
|
CmmRegOff
!
CmmReg
Int
-- CmmRegOff reg i
-- ** is shorthand only, meaning **
-- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
--
where rep = typeWidth (cmmRegType reg)
instance
Eq
CmmExpr
where
-- Equality ignores the types
CmmLit
l1
==
CmmLit
l2
=
l1
==
l2
CmmLoad
e1
_
==
CmmLoad
e2
_
=
e1
==
e2
CmmReg
r1
==
CmmReg
r2
=
r1
==
r2
CmmRegOff
r1
i1
==
CmmRegOff
r2
i2
=
r1
==
r2
&&
i1
==
i2
CmmMachOp
op1
es1
==
CmmMachOp
op2
es2
=
op1
==
op2
&&
es1
==
es2
-- CmmRegOff reg i
-- ** is shorthand only, meaning **
-- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
--
where rep = typeWidth (cmmRegType reg)
instance
Eq
CmmExpr
where
-- Equality ignores the types
CmmLit
l1
==
CmmLit
l2
=
l1
==
l2
CmmLoad
e1
_
==
CmmLoad
e2
_
=
e1
==
e2
CmmReg
r1
==
CmmReg
r2
=
r1
==
r2
CmmRegOff
r1
i1
==
CmmRegOff
r2
i2
=
r1
==
r2
&&
i1
==
i2
CmmMachOp
op1
es1
==
CmmMachOp
op2
es2
=
op1
==
op2
&&
es1
==
es2
CmmStackSlot
a1
i1
==
CmmStackSlot
a2
i2
=
a1
==
a2
&&
i1
==
i2
_e1
==
_e2
=
False
_e1
==
_e2
=
False
data
CmmReg
=
CmmLocal
{-# UNPACK #-}
!
LocalReg
...
...
@@ -75,14 +69,14 @@ data Area
-- See Note [Continuation BlockId] in CmmNode.
deriving
(
Eq
,
Ord
)
{- Note [Old Area]
{- Note [Old Area]
~~~~~~~~~~~~~~~~~~
There is a single call area 'Old', allocated at the extreme old
end of the stack frame (ie just younger than the return address)
which holds:
* incoming (overflow) parameters,
* incoming (overflow) parameters,
* outgoing (overflow) parameter to tail calls,
* outgoing (overflow) result values
* outgoing (overflow) result values
* the update frame (if any)
Its size is the max of all these requirements. On entry, the stack
...
...
@@ -93,22 +87,22 @@ End of note -}
data
CmmLit
=
CmmInt
!
Integer
Width
-- Interpretation: the 2's complement representation of the value
-- is truncated to the specified size. This is easier than trying
-- to keep the value within range, because we don't know whether
-- it will be used as a signed or unsigned value (the CmmType doesn't
-- distinguish between signed & unsigned).
-- Interpretation: the 2's complement representation of the value
-- is truncated to the specified size. This is easier than trying
-- to keep the value within range, because we don't know whether
-- it will be used as a signed or unsigned value (the CmmType doesn't
-- distinguish between signed & unsigned).
|
CmmFloat
Rational
Width
|
CmmLabel
CLabel
-- Address of label
|
CmmLabelOff
CLabel
Int
-- Address of label + byte offset
|
CmmLabel
CLabel
-- Address of label
|
CmmLabelOff
CLabel
Int
-- Address of label + byte offset
-- Due to limitations in the C backend, the following
-- MUST ONLY be used inside the info table indicated by label2
-- (label2 must be the info label), and label1 must be an
-- SRT, a slow entrypoint or a large bitmap (see the Mangler)
-- Don't use it at all unless tablesNextToCode.
-- It is also used inside the NCG during when generating
-- position-independent code.
-- position-independent code.
|
CmmLabelDiffOff
CLabel
CLabel
Int
-- label1 - label2 + offset
|
CmmBlock
{-# UNPACK #-}
!
BlockId
-- Code label
...
...
@@ -118,31 +112,32 @@ data CmmLit
|
CmmHighStackMark
-- stands for the max stack space used during a procedure
deriving
Eq
cmmExprType
::
CmmExpr
->
CmmType
cmmExprType
(
CmmLit
lit
)
=
cmmLitType
lit
cmmExprType
(
CmmLoad
_
rep
)
=
rep
cmmExprType
(
CmmReg
reg
)
=
cmmRegType
reg
cmmExprType
(
CmmMachOp
op
args
)
=
machOpResultType
op
(
map
cmmExprType
args
)
cmmExprType
(
CmmRegOff
reg
_
)
=
cmmRegType
reg
cmmExprType
(
CmmStackSlot
_
_
)
=
bWord
-- an address
cmmExprType
::
DynFlags
->
CmmExpr
->
CmmType
cmmExprType
dflags
(
CmmLit
lit
)
=
cmmLitType
dflags
lit
cmmExprType
_
(
CmmLoad
_
rep
)
=
rep
cmmExprType
dflags
(
CmmReg
reg
)
=
cmmRegType
dflags
reg
cmmExprType
dflags
(
CmmMachOp
op
args
)
=
machOpResultType
dflags
op
(
map
(
cmmExprType
dflags
)
args
)
cmmExprType
dflags
(
CmmRegOff
reg
_
)
=
cmmRegType
dflags
reg
cmmExprType
dflags
(
CmmStackSlot
_
_
)
=
bWord
dflags
-- an address
-- Careful though: what is stored at the stack slot may be bigger than
-- an address
cmmLitType
::
CmmLit
->
CmmType
cmmLitType
(
CmmInt
_
width
)
=
cmmBits
width
cmmLitType
(
CmmFloat
_
width
)
=
cmmFloat
width
cmmLitType
(
CmmLabel
lbl
)
=
cmmLabelType
lbl
cmmLitType
(
CmmLabelOff
lbl
_
)
=
cmmLabelType
lbl
cmmLitType
(
CmmLabelDiffOff
{})
=
bWord
cmmLitType
(
CmmBlock
_
)
=
bWord
cmmLitType
(
CmmHighStackMark
)
=
bWord
cmmLitType
::
DynFlags
->
CmmLit
->
CmmType
cmmLitType
_
(
CmmInt
_
width
)
=
cmmBits
width
cmmLitType
_
(
CmmFloat
_
width
)
=
cmmFloat
width
cmmLitType
dflags
(
CmmLabel
lbl
)
=
cmmLabelType
dflags
lbl
cmmLitType
dflags
(
CmmLabelOff
lbl
_
)
=
cmmLabelType
dflags
lbl
cmmLitType
dflags
(
CmmLabelDiffOff
{})
=
bWord
dflags
cmmLitType
dflags
(
CmmBlock
_
)
=
bWord
dflags
cmmLitType
dflags
(
CmmHighStackMark
)
=
bWord
dflags
cmmLabelType
::
CLabel
->
CmmType
cmmLabelType
lbl
|
isGcPtrLabel
lbl
=
gcWord
|
otherwise
=
bWord
cmmLabelType
::
DynFlags
->
CLabel
->
CmmType
cmmLabelType
dflags
lbl
|
isGcPtrLabel
lbl
=
gcWord
dflags
|
otherwise
=
bWord
dflags
cmmExprWidth
::
CmmExpr
->
Width
cmmExprWidth
e
=
typeWidth
(
cmmExprType
e
)
cmmExprWidth
::
DynFlags
->
CmmExpr
->
Width
cmmExprWidth
dflags
e
=
typeWidth
(
cmmExprType
dflags
e
)
--------
--- Negation for conditional branches
...
...
@@ -153,7 +148,7 @@ maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
maybeInvertCmmExpr
_
=
Nothing
-----------------------------------------------------------------------------
--
Local registers
--
Local registers
-----------------------------------------------------------------------------
data
LocalReg
...
...
@@ -171,15 +166,15 @@ instance Ord LocalReg where
instance
Uniquable
LocalReg
where
getUnique
(
LocalReg
uniq
_
)
=
uniq
cmmRegType
::
CmmReg
->
CmmType
cmmRegType
(
CmmLocal
reg
)
=
localRegType
reg
cmmRegType
(
CmmGlobal
reg
)
=
globalRegType
reg
cmmRegType
::
DynFlags
->
CmmReg
->
CmmType
cmmRegType
_
(
CmmLocal
reg
)
=
localRegType
reg
cmmRegType
dflags
(
CmmGlobal
reg
)
=
globalRegType
dflags
reg
localRegType
::
LocalReg
->
CmmType
localRegType
(
LocalReg
_
rep
)
=
rep
-----------------------------------------------------------------------------
-- Register-use information for expressions and other types
-- Register-use information for expressions and other types
-----------------------------------------------------------------------------
-- | Sets of local registers
...
...
@@ -270,58 +265,58 @@ instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
-- Another reg utility
regUsedIn
::
CmmReg
->
CmmExpr
->
Bool
_
`
regUsedIn
`
CmmLit
_
=
False
reg
`
regUsedIn
`
CmmLoad
e
_
=
reg
`
regUsedIn
`
e
reg
`
regUsedIn
`
CmmReg
reg'
=
reg
==
reg'
_
`
regUsedIn
`
CmmLit
_
=
False
reg
`
regUsedIn
`
CmmLoad
e
_
=
reg
`
regUsedIn
`
e
reg
`
regUsedIn
`
CmmReg
reg'
=
reg
==
reg'
reg
`
regUsedIn
`
CmmRegOff
reg'
_
=
reg
==
reg'
reg
`
regUsedIn
`
CmmMachOp
_
es
=
any
(
reg
`
regUsedIn
`)
es
_
`
regUsedIn
`
CmmStackSlot
_
_
=
False
-----------------------------------------------------------------------------
--
Global STG registers
--
Global STG registers
-----------------------------------------------------------------------------
data
VGcPtr
=
VGcPtr
|
VNonGcPtr
deriving
(
Eq
,
Show
)
-- TEMPORARY!!!
-- TEMPORARY!!!
-----------------------------------------------------------------------------
--
Global STG registers
--
Global STG registers
-----------------------------------------------------------------------------
vgcFlag
::
CmmType
->
VGcPtr
vgcFlag
ty
|
isGcPtrType
ty
=
VGcPtr
|
otherwise
=
VNonGcPtr
|
otherwise
=
VNonGcPtr
data
GlobalReg
-- Argument and return registers
=
VanillaReg
-- pointers, unboxed ints and chars
{-# UNPACK #-}
!
Int
-- its number
VGcPtr
=
VanillaReg
-- pointers, unboxed ints and chars
{-# UNPACK #-}
!
Int
-- its number
VGcPtr
|
FloatReg
-- single-precision floating-point registers
{-# UNPACK #-}
!
Int
-- its number
|
FloatReg
-- single-precision floating-point registers
{-# UNPACK #-}
!
Int
-- its number
|
DoubleReg
-- double-precision floating-point registers
{-# UNPACK #-}
!
Int
-- its number
|
DoubleReg
-- double-precision floating-point registers
{-# UNPACK #-}
!
Int
-- its number
|
LongReg
-- long int registers (64-bit, really)
{-# UNPACK #-}
!
Int
-- its number
|
LongReg
-- long int registers (64-bit, really)
{-# UNPACK #-}
!
Int
-- its number
-- STG registers
|
Sp
-- Stack ptr; points to last occupied stack location.
|
SpLim
-- Stack limit
|
Hp
-- Heap ptr; points to last occupied heap location.
|
HpLim
-- Heap limit register
|
Sp
-- Stack ptr; points to last occupied stack location.
|
SpLim
-- Stack limit
|
Hp
-- Heap ptr; points to last occupied heap location.
|
HpLim
-- Heap limit register
|
CCCS
-- Current cost-centre stack
|
CurrentTSO
-- pointer to current thread's TSO
|
CurrentNursery
-- pointer to allocation area
|
HpAlloc
-- allocation count for heap check failure
|
CurrentNursery
-- pointer to allocation area
|
HpAlloc
-- allocation count for heap check failure
-- We keep the address of some commonly-called
-- functions in the register table, to keep code
-- size down:
-- We keep the address of some commonly-called
-- functions in the register table, to keep code
-- size down:
|
EagerBlackholeInfo
-- stg_EAGER_BLACKHOLE_info
|
GCEnter1
-- stg_gc_enter_1
|
GCFun
-- stg_gc_fun
|
GCEnter1
-- stg_gc_enter_1