1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
{-# LANGUAGE UnboxedTuples #-}
-- | State monad for the linear register allocator.
-- Here we keep all the state that the register allocator keeps track
-- of as it walks the instructions in a basic block.
module RegAlloc.Linear.State (
RA_State(..),
RegM,
runR,
spillR,
loadR,
getFreeRegsR,
setFreeRegsR,
getAssigR,
setAssigR,
getBlockAssigR,
setBlockAssigR,
setDeltaR,
getDeltaR,
getUniqueR,
recordSpill
)
where
import RegAlloc.Linear.Stats
import RegAlloc.Linear.StackMap
import RegAlloc.Linear.Base
import RegAlloc.Liveness
import Instruction
import Reg
import DynFlags
import Unique
import UniqSupply
import Control.Monad (liftM, ap)
-- | The register allocator monad type.
newtype RegM freeRegs a
= RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) }
instance Functor (RegM freeRegs) where
fmap = liftM
instance Applicative (RegM freeRegs) where
pure a = RegM $ \s -> (# s, a #)
(<*>) = ap
instance Monad (RegM freeRegs) where
m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
instance HasDynFlags (RegM a) where
getDynFlags = RegM $ \s -> (# s, ra_DynFlags s #)
-- | Run a computation in the RegM register allocator monad.
runR :: DynFlags
-> BlockAssignment freeRegs
-> freeRegs
-> RegMap Loc
-> StackMap
-> UniqSupply
-> RegM freeRegs a
-> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
runR dflags 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 = []
, ra_DynFlags = dflags })
of
(# state'@RA_State
{ ra_blockassig = block_assig
, ra_stack = stack' }
, returned_thing #)
-> (block_assig, stack', makeRAStats state', returned_thing)
-- | Make register allocator stats from its final state.
makeRAStats :: RA_State freeRegs -> RegAllocStats
makeRAStats state
= RegAllocStats
{ ra_spillInstrs = binSpillReasons (ra_spills state) }
spillR :: Instruction instr
=> Reg -> Unique -> RegM freeRegs (instr, Int)
spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
let dflags = ra_DynFlags s
(stack',slot) = getStackSlotFor stack temp
instr = mkSpillInstr dflags reg delta slot
in
(# s{ra_stack=stack'}, (instr,slot) #)
loadR :: Instruction instr
=> Reg -> Int -> RegM freeRegs instr
loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
let dflags = ra_DynFlags s
in (# s, mkLoadInstr dflags reg delta slot #)
getFreeRegsR :: RegM freeRegs freeRegs
getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
(# s, freeregs #)
setFreeRegsR :: freeRegs -> RegM freeRegs ()
setFreeRegsR regs = RegM $ \ s ->
(# s{ra_freeregs = regs}, () #)
getAssigR :: RegM freeRegs (RegMap Loc)
getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
(# s, assig #)
setAssigR :: RegMap Loc -> RegM freeRegs ()
setAssigR assig = RegM $ \ s ->
(# s{ra_assig=assig}, () #)
getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
(# s, assig #)
setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
setBlockAssigR assig = RegM $ \ s ->
(# s{ra_blockassig = assig}, () #)
setDeltaR :: Int -> RegM freeRegs ()
setDeltaR n = RegM $ \ s ->
(# s{ra_delta = n}, () #)
getDeltaR :: RegM freeRegs Int
getDeltaR = RegM $ \s -> (# s, ra_delta s #)
getUniqueR :: RegM freeRegs Unique
getUniqueR = RegM $ \s ->
case takeUniqFromSupply (ra_us s) of
(uniq, us) -> (# s{ra_us = us}, uniq #)
-- | Record that a spill instruction was inserted, for profiling.
recordSpill :: SpillReason -> RegM freeRegs ()
recordSpill spill
= RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)
|
