Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Glasgow Haskell Compiler
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
0
Merge Requests
0
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Packages & Registries
Packages & Registries
Package Registry
Container Registry
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
Shayne Fletcher
Glasgow Haskell Compiler
Commits
cbc96da0
Commit
cbc96da0
authored
Feb 02, 2009
by
Ben.Lippmeier@anu.edu.au
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
NCG: Split linear allocator into separate modules.
parent
d7d09c18
Changes
11
Hide whitespace changes
Inline
Side-by-side
Showing
11 changed files
with
749 additions
and
492 deletions
+749
-492
compiler/nativeGen/AsmCodeGen.lhs
compiler/nativeGen/AsmCodeGen.lhs
+3
-1
compiler/nativeGen/RegAlloc/Linear/Base.hs
compiler/nativeGen/RegAlloc/Linear/Base.hs
+128
-0
compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
+41
-0
compiler/nativeGen/RegAlloc/Linear/Main.hs
compiler/nativeGen/RegAlloc/Linear/Main.hs
+10
-490
compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
+54
-0
compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
+168
-0
compiler/nativeGen/RegAlloc/Linear/StackMap.hs
compiler/nativeGen/RegAlloc/Linear/StackMap.hs
+72
-0
compiler/nativeGen/RegAlloc/Linear/State.hs
compiler/nativeGen/RegAlloc/Linear/State.hs
+139
-0
compiler/nativeGen/RegAlloc/Linear/Stats.hs
compiler/nativeGen/RegAlloc/Linear/Stats.hs
+82
-0
compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
+40
-0
compiler/nativeGen/RegAllocInfo.hs
compiler/nativeGen/RegAllocInfo.hs
+12
-1
No files found.
compiler/nativeGen/AsmCodeGen.lhs
View file @
cbc96da0
...
...
@@ -28,7 +28,9 @@ import NCGMonad
import PositionIndependentCode
import RegLiveness
import RegCoalesce
import qualified RegAllocLinear as Linear
import qualified RegAlloc.Linear.Main as Linear
import qualified RegAllocColor as Color
import qualified RegAllocStats as Color
import qualified GraphColor as Color
...
...
compiler/nativeGen/RegAlloc/Linear/Base.hs
0 → 100644
View file @
cbc96da0
-- | Put common type definitions here to break recursive module dependencies.
module
RegAlloc.Linear.Base
(
BlockAssignment
,
Loc
(
..
),
-- for stats
SpillReason
(
..
),
RegAllocStats
(
..
),
-- the allocator monad
RA_State
(
..
),
RegM
(
..
)
)
where
import
RegAlloc.Linear.FreeRegs
import
RegAlloc.Linear.StackMap
import
RegLiveness
import
MachRegs
import
Outputable
import
Unique
import
UniqFM
import
UniqSupply
-- | Used to store the register assignment on entry to a basic block.
-- We use this to handle join points, where multiple branch instructions
-- target a particular label. We have to insert fixup code to make
-- the register assignments from the different sources match up.
--
type
BlockAssignment
=
BlockMap
(
FreeRegs
,
RegMap
Loc
)
-- | Where a vreg is currently stored
-- A temporary can be marked as living in both a register and memory
-- (InBoth), for example if it was recently loaded from a spill location.
-- This makes it cheap to spill (no save instruction required), but we
-- have to be careful to turn this into InReg if the value in the
-- register is changed.
-- This is also useful when a temporary is about to be clobbered. We
-- save it in a spill location, but mark it as InBoth because the current
-- instruction might still want to read it.
--
data
Loc
-- | vreg is in a register
=
InReg
{-# UNPACK #-}
!
RegNo
-- | vreg is held in a stack slot
|
InMem
{-# UNPACK #-}
!
StackSlot
-- | vreg is held in both a register and a stack slot
|
InBoth
{-# UNPACK #-}
!
RegNo
{-# UNPACK #-}
!
StackSlot
deriving
(
Eq
,
Show
,
Ord
)
instance
Outputable
Loc
where
ppr
l
=
text
(
show
l
)
-- | Reasons why instructions might be inserted by the spiller.
-- Used when generating stats for -ddrop-asm-stats.
--
data
SpillReason
-- | vreg was spilled to a slot so we could use its
-- current hreg for another vreg
=
SpillAlloc
!
Unique
-- | vreg was moved because its hreg was clobbered
|
SpillClobber
!
Unique
-- | vreg was loaded from a spill slot
|
SpillLoad
!
Unique
-- | reg-reg move inserted during join to targets
|
SpillJoinRR
!
Unique
-- | reg-mem move inserted during join to targets
|
SpillJoinRM
!
Unique
-- | Used to carry interesting stats out of the register allocator.
data
RegAllocStats
=
RegAllocStats
{
ra_spillInstrs
::
UniqFM
[
Int
]
}
-- | The register alloctor state
data
RA_State
=
RA_State
-- | the current mapping from basic blocks to
-- the register assignments at the beginning of that block.
{
ra_blockassig
::
BlockAssignment
-- | free machine registers
,
ra_freeregs
::
{-#UNPACK#-}
!
FreeRegs
-- | assignment of temps to locations
,
ra_assig
::
RegMap
Loc
-- | current stack delta
,
ra_delta
::
Int
-- | free stack slots for spilling
,
ra_stack
::
StackMap
-- | unique supply for generating names for join point fixup blocks.
,
ra_us
::
UniqSupply
-- | Record why things were spilled, for -ddrop-asm-stats.
-- Just keep a list here instead of a map of regs -> reasons.
-- We don't want to slow down the allocator if we're not going to emit the stats.
,
ra_spills
::
[
SpillReason
]
}
-- | The register allocator monad type.
newtype
RegM
a
=
RegM
{
unReg
::
RA_State
->
(
#
RA_State
,
a
#
)
}
compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
0 → 100644
View file @
cbc96da0
module
RegAlloc.Linear.FreeRegs
(
FreeRegs
(),
noFreeRegs
,
releaseReg
,
initFreeRegs
,
getFreeRegs
,
allocateReg
)
#include
"
HsVersions.h
"
where
-- -----------------------------------------------------------------------------
-- The free register set
-- This needs to be *efficient*
-- Here's an inefficient 'executable specification' of the FreeRegs data type:
--
-- type FreeRegs = [RegNo]
-- noFreeRegs = 0
-- releaseReg n f = if n `elem` f then f else (n : f)
-- initFreeRegs = allocatableRegs
-- getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
-- allocateReg f r = filter (/= r) f
#if defined(powerpc_TARGET_ARCH)
import RegAlloc.Linear.PPC.FreeRegs
#elif defined(sparc_TARGET_ARCH)
import RegAlloc.Linear.SPARC.FreeRegs
#elif defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH)
import RegAlloc.Linear.X86.FreeRegs
#else
#error "
RegAlloc
.
Linear
.
FreeRegs
not
defined
for
this
architecture
.
"
#endif
compiler/nativeGen/RegAlloc
Linear
.hs
→
compiler/nativeGen/RegAlloc
/Linear/Main
.hs
View file @
cbc96da0
...
...
@@ -81,13 +81,21 @@ The algorithm is roughly:
-}
module
RegAlloc
Linear
(
module
RegAlloc
.Linear.Main
(
regAlloc
,
RegAllocStats
,
pprStats
module
RegAlloc
.
Linear
.
Base
,
module
RegAlloc
.
Linear
.
Stats
)
where
#
include
"HsVersions.h"
import
RegAlloc.Linear.State
import
RegAlloc.Linear.Base
import
RegAlloc.Linear.StackMap
import
RegAlloc.Linear.FreeRegs
import
RegAlloc.Linear.Stats
import
BlockId
import
MachRegs
import
MachInstrs
...
...
@@ -101,296 +109,14 @@ import UniqSet
import
UniqFM
import
UniqSupply
import
Outputable
import
State
import
FastString
import
Data.Maybe
import
Data.List
import
Control.Monad
import
Data.Word
import
Data.Bits
#
include
"../includes/MachRegs.h"
-- -----------------------------------------------------------------------------
-- The free register set
-- This needs to be *efficient*
{- Here's an inefficient 'executable specification' of the FreeRegs data type:
type FreeRegs = [RegNo]
noFreeRegs = 0
releaseReg n f = if n `elem` f then f else (n : f)
initFreeRegs = allocatableRegs
getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
allocateReg f r = filter (/= r) f
-}
#
if
defined
(
powerpc_TARGET_ARCH
)
-- The PowerPC has 32 integer and 32 floating point registers.
-- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
-- better.
-- Note that when getFreeRegs scans for free registers, it starts at register
-- 31 and counts down. This is a hack for the PowerPC - the higher-numbered
-- registers are callee-saves, while the lower regs are caller-saves, so it
-- makes sense to start at the high end.
-- Apart from that, the code does nothing PowerPC-specific, so feel free to
-- add your favourite platform to the #if (if you have 64 registers but only
-- 32-bit words).
data
FreeRegs
=
FreeRegs
!
Word32
!
Word32
deriving
(
Show
)
-- The Show is used in an ASSERT
noFreeRegs
::
FreeRegs
noFreeRegs
=
FreeRegs
0
0
releaseReg
::
RegNo
->
FreeRegs
->
FreeRegs
releaseReg
r
(
FreeRegs
g
f
)
|
r
>
31
=
FreeRegs
g
(
f
.|.
(
1
`
shiftL
`
(
fromIntegral
r
-
32
)))
|
otherwise
=
FreeRegs
(
g
.|.
(
1
`
shiftL
`
fromIntegral
r
))
f
initFreeRegs
::
FreeRegs
initFreeRegs
=
foldr
releaseReg
noFreeRegs
allocatableRegs
getFreeRegs
::
RegClass
->
FreeRegs
->
[
RegNo
]
-- lazilly
getFreeRegs
cls
(
FreeRegs
g
f
)
|
RcDouble
<-
cls
=
go
f
(
0x80000000
)
63
|
RcInteger
<-
cls
=
go
g
(
0x80000000
)
31
|
otherwise
=
pprPanic
"RegAllocLinear.getFreeRegs: Bad register class"
(
ppr
cls
)
where
go
_
0
_
=
[]
go
x
m
i
|
x
.&.
m
/=
0
=
i
:
(
go
x
(
m
`
shiftR
`
1
)
$!
i
-
1
)
|
otherwise
=
go
x
(
m
`
shiftR
`
1
)
$!
i
-
1
allocateReg
::
RegNo
->
FreeRegs
->
FreeRegs
allocateReg
r
(
FreeRegs
g
f
)
|
r
>
31
=
FreeRegs
g
(
f
.&.
complement
(
1
`
shiftL
`
(
fromIntegral
r
-
32
)))
|
otherwise
=
FreeRegs
(
g
.&.
complement
(
1
`
shiftL
`
fromIntegral
r
))
f
#
elif
defined
(
sparc_TARGET_ARCH
)
--------------------------------------------------------------------------------
-- SPARC is like PPC, except for twinning of floating point regs.
-- When we allocate a double reg we must take an even numbered
-- float reg, as well as the one after it.
-- Holds bitmaps showing what registers are currently allocated.
-- The float and double reg bitmaps overlap, but we only alloc
-- float regs into the float map, and double regs into the double map.
--
-- Free regs have a bit set in the corresponding bitmap.
--
data
FreeRegs
=
FreeRegs
!
Word32
-- int reg bitmap regs 0..31
!
Word32
-- float reg bitmap regs 32..63
!
Word32
-- double reg bitmap regs 32..63
deriving
(
Show
)
-- | A reg map where no regs are free to be allocated.
noFreeRegs
::
FreeRegs
noFreeRegs
=
FreeRegs
0
0
0
-- | The initial set of free regs.
-- Don't treat the top half of reg pairs we're using as doubles as being free.
initFreeRegs
::
FreeRegs
initFreeRegs
=
regs
where
-- freeDouble = getFreeRegs RcDouble regs
regs
=
foldr
releaseReg
noFreeRegs
allocable
allocable
=
allocatableRegs
\\
doublePairs
doublePairs
=
[
43
,
45
,
47
,
49
,
51
,
53
]
-- | Get all the free registers of this class.
getFreeRegs
::
RegClass
->
FreeRegs
->
[
RegNo
]
-- lazilly
getFreeRegs
cls
(
FreeRegs
g
f
d
)
|
RcInteger
<-
cls
=
go
g
1
0
|
RcFloat
<-
cls
=
go
f
1
32
|
RcDouble
<-
cls
=
go
d
1
32
|
otherwise
=
pprPanic
"RegAllocLinear.getFreeRegs: Bad register class "
(
ppr
cls
)
where
go
_
0
_
=
[]
go
x
m
i
|
x
.&.
m
/=
0
=
i
:
(
go
x
(
m
`
shiftL
`
1
)
$!
i
+
1
)
|
otherwise
=
go
x
(
m
`
shiftL
`
1
)
$!
i
+
1
{-
showFreeRegs :: FreeRegs -> String
showFreeRegs regs
= "FreeRegs\n"
++ " integer: " ++ (show $ getFreeRegs RcInteger regs) ++ "\n"
++ " float: " ++ (show $ getFreeRegs RcFloat regs) ++ "\n"
++ " double: " ++ (show $ getFreeRegs RcDouble regs) ++ "\n"
-}
{-
-- | Check whether a reg is free
regIsFree :: RegNo -> FreeRegs -> Bool
regIsFree r (FreeRegs g f d)
-- a general purpose reg
| r <= 31
, mask <- 1 `shiftL` fromIntegral r
= g .&. mask /= 0
-- use the first 22 float regs as double precision
| r >= 32
, r <= 53
, mask <- 1 `shiftL` (fromIntegral r - 32)
= d .&. mask /= 0
-- use the last 10 float regs as single precision
| otherwise
, mask <- 1 `shiftL` (fromIntegral r - 32)
= f .&. mask /= 0
-}
-- | Grab a register.
grabReg
::
RegNo
->
FreeRegs
->
FreeRegs
grabReg
r
(
FreeRegs
g
f
d
)
-- a general purpose reg
|
r
<=
31
,
mask
<-
complement
(
1
`
shiftL
`
fromIntegral
r
)
=
FreeRegs
(
g
.&.
mask
)
f
d
-- use the first 22 float regs as double precision
|
r
>=
32
,
r
<=
53
,
mask
<-
complement
(
1
`
shiftL
`
(
fromIntegral
r
-
32
))
=
FreeRegs
g
f
(
d
.&.
mask
)
-- use the last 10 float regs as single precision
|
otherwise
,
mask
<-
complement
(
1
`
shiftL
`
(
fromIntegral
r
-
32
))
=
FreeRegs
g
(
f
.&.
mask
)
d
-- | Release a register from allocation.
-- The register liveness information says that most regs die after a C call,
-- but we still don't want to allocate to some of them.
--
releaseReg
::
RegNo
->
FreeRegs
->
FreeRegs
releaseReg
r
regs
@
(
FreeRegs
g
f
d
)
-- used by STG machine, or otherwise unavailable
|
r
>=
0
&&
r
<=
15
=
regs
|
r
>=
17
&&
r
<=
21
=
regs
|
r
>=
24
&&
r
<=
31
=
regs
|
r
>=
32
&&
r
<=
41
=
regs
|
r
>=
54
&&
r
<=
59
=
regs
-- never release the high part of double regs.
|
r
==
43
=
regs
|
r
==
45
=
regs
|
r
==
47
=
regs
|
r
==
49
=
regs
|
r
==
51
=
regs
|
r
==
53
=
regs
-- a general purpose reg
|
r
<=
31
,
mask
<-
1
`
shiftL
`
fromIntegral
r
=
FreeRegs
(
g
.|.
mask
)
f
d
-- use the first 22 float regs as double precision
|
r
>=
32
,
r
<=
53
,
mask
<-
1
`
shiftL
`
(
fromIntegral
r
-
32
)
=
FreeRegs
g
f
(
d
.|.
mask
)
-- use the last 10 float regs as single precision
|
otherwise
,
mask
<-
1
`
shiftL
`
(
fromIntegral
r
-
32
)
=
FreeRegs
g
(
f
.|.
mask
)
d
-- | Allocate a register in the map.
allocateReg
::
RegNo
->
FreeRegs
->
FreeRegs
allocateReg
r
regs
-- (FreeRegs g f d)
-- if the reg isn't actually free then we're in trouble
{- | not $ regIsFree r regs
= pprPanic
"RegAllocLinear.allocateReg"
(text "reg " <> ppr r <> text " is not free")
-}
|
otherwise
=
grabReg
r
regs
--------------------------------------------------------------------------------
-- If we have less than 32 registers, or if we have efficient 64-bit words,
-- we will just use a single bitfield.
#
else
#
if
defined
(
alpha_TARGET_ARCH
)
type
FreeRegs
=
Word64
#
else
type
FreeRegs
=
Word32
#
endif
noFreeRegs
::
FreeRegs
noFreeRegs
=
0
releaseReg
::
RegNo
->
FreeRegs
->
FreeRegs
releaseReg
n
f
=
f
.|.
(
1
`
shiftL
`
n
)
initFreeRegs
::
FreeRegs
initFreeRegs
=
foldr
releaseReg
noFreeRegs
allocatableRegs
getFreeRegs
::
RegClass
->
FreeRegs
->
[
RegNo
]
-- lazilly
getFreeRegs
cls
f
=
go
f
0
where
go
0
_
=
[]
go
n
m
|
n
.&.
1
/=
0
&&
regClass
(
RealReg
m
)
==
cls
=
m
:
(
go
(
n
`
shiftR
`
1
)
$!
(
m
+
1
))
|
otherwise
=
go
(
n
`
shiftR
`
1
)
$!
(
m
+
1
)
-- ToDo: there's no point looking through all the integer registers
-- in order to find a floating-point one.
allocateReg
::
RegNo
->
FreeRegs
->
FreeRegs
allocateReg
r
f
=
f
.&.
complement
(
1
`
shiftL
`
fromIntegral
r
)
#
endif
-- -----------------------------------------------------------------------------
-- The assignment of virtual registers to stack slots
-- We have lots of stack slots. Memory-to-memory moves are a pain on most
-- architectures. Therefore, we avoid having to generate memory-to-memory moves
-- by simply giving every virtual register its own stack slot.
-- The StackMap stack map keeps track of virtual register - stack slot
-- associations and of which stack slots are still free. Once it has been
-- associated, a stack slot is never "freed" or removed from the StackMap again,
-- it remains associated until we are done with the current CmmProc.
type
StackSlot
=
Int
data
StackMap
=
StackMap
[
StackSlot
]
(
UniqFM
StackSlot
)
emptyStackMap
::
StackMap
emptyStackMap
=
StackMap
[
0
..
maxSpillSlots
]
emptyUFM
getStackSlotFor
::
StackMap
->
Unique
->
(
StackMap
,
Int
)
getStackSlotFor
(
StackMap
[]
_
)
_
=
panic
"RegAllocLinear.getStackSlotFor: out of stack slots, try -fregs-graph"
-- This happens with darcs' SHA1.hs, see #1993
getStackSlotFor
fs
@
(
StackMap
(
freeSlot
:
stack'
)
reserved
)
reg
=
case
lookupUFM
reserved
reg
of
Just
slot
->
(
fs
,
slot
)
Nothing
->
(
StackMap
stack'
(
addToUFM
reserved
reg
freeSlot
),
freeSlot
)
-- -----------------------------------------------------------------------------
-- Top level of the register allocator
...
...
@@ -436,27 +162,6 @@ regAlloc (CmmProc _ _ _ _)
-- -----------------------------------------------------------------------------
-- Linear sweep to allocate registers
data
Loc
=
InReg
{-# UNPACK #-}
!
RegNo
|
InMem
{-# UNPACK #-}
!
Int
-- stack slot
|
InBoth
{-# UNPACK #-}
!
RegNo
{-# UNPACK #-}
!
Int
-- stack slot
deriving
(
Eq
,
Show
,
Ord
)
{-
A temporary can be marked as living in both a register and memory
(InBoth), for example if it was recently loaded from a spill location.
This makes it cheap to spill (no save instruction required), but we
have to be careful to turn this into InReg if the value in the
register is changed.
This is also useful when a temporary is about to be clobbered. We
save it in a spill location, but mark it as InBoth because the current
instruction might still want to read it.
-}
instance
Outputable
Loc
where
ppr
l
=
text
(
show
l
)
-- | Do register allocation on some basic blocks.
-- But be careful to allocate a block in an SCC only if it has
...
...
@@ -548,8 +253,6 @@ linearRA block_live instr_acc fixups (instr:instrs)
-- -----------------------------------------------------------------------------
-- Register allocation for a single instruction
type
BlockAssignment
=
BlockMap
(
FreeRegs
,
RegMap
Loc
)
raInsn
::
BlockMap
RegSet
-- Live temporaries at each basic block
->
[
Instr
]
-- new instructions (accum.)
->
LiveInstr
-- the instruction (with "deaths")
...
...
@@ -1101,189 +804,6 @@ handleComponent _ _ (CyclicSCC _)
-- -----------------------------------------------------------------------------
-- The register allocator's monad.
-- Here we keep all the state that the register allocator keeps track
-- of as it walks the instructions in a basic block.
data
RA_State
=
RA_State
{
ra_blockassig
::
BlockAssignment
,
-- The current mapping from basic blocks to
-- the register assignments at the beginning of that block.
ra_freeregs
::
{-#UNPACK#-}
!
FreeRegs
,
-- free machine registers
ra_assig
::
RegMap
Loc
,
-- assignment of temps to locations
ra_delta
::
Int
,
-- current stack delta
ra_stack
::
StackMap
,
-- free stack slots for spilling
ra_us
::
UniqSupply
,
-- unique supply for generating names
-- for fixup blocks.
-- Record why things were spilled, for -ddrop-asm-stats.
-- Just keep a list here instead of a map of regs -> reasons.
-- We don't want to slow down the allocator if we're not going to emit the stats.
ra_spills
::
[
SpillReason
]
}
newtype
RegM
a
=
RegM
{
unReg
::
RA_State
->
(
#
RA_State
,
a
#
)
}
instance
Monad
RegM
where
m
>>=
k
=
RegM
$
\
s
->
case
unReg
m
s
of
{
(
#
s
,
a
#
)
->
unReg
(
k
a
)
s
}
return
a
=
RegM
$
\
s
->
(
#
s
,
a
#
)
runR
::
BlockAssignment
->
FreeRegs
->
RegMap
Loc
->
StackMap
->
UniqSupply
->
RegM
a
->
(
BlockAssignment
,
StackMap
,
RegAllocStats
,
a
)
runR
block_assig
freeregs
assig
stack
us
thing
=
case
unReg
thing
(
RA_State
{
ra_blockassig
=
block_assig
,
ra_freeregs
=
freeregs
,
ra_assig
=
assig
,
ra_delta
=
0
{-???-}
,
ra_stack
=
stack
,
ra_us
=
us
,
ra_spills
=
[]
})
of
(
#
state'
@
RA_State
{
ra_blockassig
=
block_assig
,
ra_stack
=
stack'
},
returned_thing
#
)
->
(
block_assig
,
stack'
,
makeRAStats
state'
,
returned_thing
)
spillR
::
Reg
->
Unique
->
RegM
(
Instr
,
Int
)
spillR
reg
temp
=
RegM
$
\
s
@
RA_State
{
ra_delta
=
delta
,
ra_stack
=
stack
}
->
let
(
stack'
,
slot
)
=
getStackSlotFor
stack
temp
instr
=
mkSpillInstr
reg
delta
slot
in
(
#
s
{
ra_stack
=
stack'
},
(
instr
,
slot
)
#
)
loadR
::
Reg
->
Int
->
RegM
Instr
loadR
reg
slot
=
RegM
$
\
s
@
RA_State
{
ra_delta
=
delta
}
->
(
#
s
,
mkLoadInstr
reg
delta
slot
#
)
getFreeRegsR
::
RegM
FreeRegs
getFreeRegsR
=
RegM
$
\
s
@
RA_State
{
ra_freeregs
=
freeregs
}
->
(
#
s
,
freeregs
#
)
setFreeRegsR
::
FreeRegs
->
RegM
()
setFreeRegsR
regs
=
RegM
$
\
s
->
(
#
s
{
ra_freeregs
=
regs
},
()
#
)
getAssigR
::
RegM
(
RegMap
Loc
)
getAssigR
=
RegM
$
\
s
@
RA_State
{
ra_assig
=
assig
}
->
(
#
s
,
assig
#
)
setAssigR
::
RegMap
Loc
->
RegM
()
setAssigR
assig
=
RegM
$
\
s
->
(
#
s
{
ra_assig
=
assig
},
()
#
)
getBlockAssigR
::
RegM
BlockAssignment
getBlockAssigR
=
RegM
$
\
s
@
RA_State
{
ra_blockassig
=
assig
}
->
(
#
s
,
assig
#
)
setBlockAssigR
::
BlockAssignment
->
RegM
()
setBlockAssigR
assig
=
RegM
$
\
s
->
(
#
s
{
ra_blockassig
=
assig
},
()
#
)
setDeltaR
::
Int
->
RegM
()
setDeltaR
n
=
RegM
$
\
s
->
(
#
s
{
ra_delta
=
n
},
()
#
)
getDeltaR
::
RegM
Int
getDeltaR
=
RegM
$
\
s
->
(
#
s
,
ra_delta
s
#
)
getUniqueR
::
RegM
Unique
getUniqueR
=
RegM
$
\
s
->
case
splitUniqSupply
(
ra_us
s
)
of
(
us1
,
us2
)
->
(
#
s
{
ra_us
=
us2
},
uniqFromSupply
us1
#
)
-- | Record that a spill instruction was inserted, for profiling.
recordSpill
::
SpillReason
->
RegM
()