never executed always true always false
1 {-# LANGUAGE PatternSynonyms, DeriveFunctor #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 {-# LANGUAGE UnboxedTuples #-}
4
5 -- | State monad for the linear register allocator.
6
7 -- Here we keep all the state that the register allocator keeps track
8 -- of as it walks the instructions in a basic block.
9
10 module GHC.CmmToAsm.Reg.Linear.State (
11 RA_State(..),
12 RegM,
13 runR,
14
15 spillR,
16 loadR,
17
18 getFreeRegsR,
19 setFreeRegsR,
20
21 getAssigR,
22 setAssigR,
23
24 getBlockAssigR,
25 setBlockAssigR,
26
27 setDeltaR,
28 getDeltaR,
29
30 getUniqueR,
31 getConfig,
32 getPlatform,
33
34 recordSpill,
35 recordFixupBlock
36 )
37 where
38
39 import GHC.Prelude
40
41 import GHC.CmmToAsm.Reg.Linear.Stats
42 import GHC.CmmToAsm.Reg.Linear.StackMap
43 import GHC.CmmToAsm.Reg.Linear.Base
44 import GHC.CmmToAsm.Reg.Liveness
45 import GHC.CmmToAsm.Instr
46 import GHC.CmmToAsm.Config
47 import GHC.Platform.Reg
48 import GHC.Cmm.BlockId
49
50 import GHC.Platform
51 import GHC.Types.Unique
52 import GHC.Types.Unique.Supply
53 import GHC.Exts (oneShot)
54
55 import Control.Monad (ap)
56
57 type RA_Result freeRegs a = (# RA_State freeRegs, a #)
58
59 pattern RA_Result :: a -> b -> (# a, b #)
60 pattern RA_Result a b = (# a, b #)
61 {-# COMPLETE RA_Result #-}
62
63 -- | The register allocator monad type.
64 newtype RegM freeRegs a
65 = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }
66 deriving (Functor)
67
68 -- | Smart constructor for 'RegM', as described in Note [The one-shot state
69 -- monad trick] in GHC.Utils.Monad.
70 mkRegM :: (RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
71 mkRegM f = RegM (oneShot f)
72
73 instance Applicative (RegM freeRegs) where
74 pure a = mkRegM $ \s -> RA_Result s a
75 (<*>) = ap
76
77 instance Monad (RegM freeRegs) where
78 m >>= k = mkRegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }
79
80 -- | Get native code generator configuration
81 getConfig :: RegM a NCGConfig
82 getConfig = mkRegM $ \s -> RA_Result s (ra_config s)
83
84 -- | Get target platform from native code generator configuration
85 getPlatform :: RegM a Platform
86 getPlatform = ncgPlatform <$> getConfig
87
88 -- | Run a computation in the RegM register allocator monad.
89 runR :: NCGConfig
90 -> BlockAssignment freeRegs
91 -> freeRegs
92 -> RegMap Loc
93 -> StackMap
94 -> UniqSupply
95 -> RegM freeRegs a
96 -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
97
98 runR config block_assig freeregs assig stack us thing =
99 case unReg thing
100 (RA_State
101 { ra_blockassig = block_assig
102 , ra_freeregs = freeregs
103 , ra_assig = assig
104 , ra_delta = 0{-???-}
105 , ra_stack = stack
106 , ra_us = us
107 , ra_spills = []
108 , ra_config = config
109 , ra_fixups = [] })
110 of
111 RA_Result state returned_thing
112 -> (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing)
113
114
115 -- | Make register allocator stats from its final state.
116 makeRAStats :: RA_State freeRegs -> RegAllocStats
117 makeRAStats state
118 = RegAllocStats
119 { ra_spillInstrs = binSpillReasons (ra_spills state)
120 , ra_fixupList = ra_fixups state }
121
122
123 spillR :: Instruction instr
124 => Reg -> Unique -> RegM freeRegs ([instr], Int)
125
126 spillR reg temp = mkRegM $ \s ->
127 let (stack1,slot) = getStackSlotFor (ra_stack s) temp
128 instr = mkSpillInstr (ra_config s) reg (ra_delta s) slot
129 in
130 RA_Result s{ra_stack=stack1} (instr,slot)
131
132
133 loadR :: Instruction instr
134 => Reg -> Int -> RegM freeRegs [instr]
135
136 loadR reg slot = mkRegM $ \s ->
137 RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot)
138
139 getFreeRegsR :: RegM freeRegs freeRegs
140 getFreeRegsR = mkRegM $ \ s@RA_State{ra_freeregs = freeregs} ->
141 RA_Result s freeregs
142
143 setFreeRegsR :: freeRegs -> RegM freeRegs ()
144 setFreeRegsR regs = mkRegM $ \ s ->
145 RA_Result s{ra_freeregs = regs} ()
146
147 getAssigR :: RegM freeRegs (RegMap Loc)
148 getAssigR = mkRegM $ \ s@RA_State{ra_assig = assig} ->
149 RA_Result s assig
150
151 setAssigR :: RegMap Loc -> RegM freeRegs ()
152 setAssigR assig = mkRegM $ \ s ->
153 RA_Result s{ra_assig=assig} ()
154
155 getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
156 getBlockAssigR = mkRegM $ \ s@RA_State{ra_blockassig = assig} ->
157 RA_Result s assig
158
159 setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
160 setBlockAssigR assig = mkRegM $ \ s ->
161 RA_Result s{ra_blockassig = assig} ()
162
163 setDeltaR :: Int -> RegM freeRegs ()
164 setDeltaR n = mkRegM $ \ s ->
165 RA_Result s{ra_delta = n} ()
166
167 getDeltaR :: RegM freeRegs Int
168 getDeltaR = mkRegM $ \s -> RA_Result s (ra_delta s)
169
170 getUniqueR :: RegM freeRegs Unique
171 getUniqueR = mkRegM $ \s ->
172 case takeUniqFromSupply (ra_us s) of
173 (uniq, us) -> RA_Result s{ra_us = us} uniq
174
175
176 -- | Record that a spill instruction was inserted, for profiling.
177 recordSpill :: SpillReason -> RegM freeRegs ()
178 recordSpill spill
179 = mkRegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) ()
180
181 -- | Record a created fixup block
182 recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs ()
183 recordFixupBlock from between to
184 = mkRegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()