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