Fix CodingStyle#Warnings URLs
[ghc-hetmet.git] / compiler / nativeGen / RegSpill.hs
1
2 {-# OPTIONS -w #-}
3 -- The above warning supression flag is a temporary kludge.
4 -- While working on this module you are encouraged to remove it and fix
5 -- any warnings in the module. See
6 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
7 -- for details
8
9 module RegSpill (
10         regSpill,
11         SpillStats(..),
12         accSpillSL
13 )
14
15 where
16
17 #include "HsVersions.h"
18
19 import RegLiveness
20 import RegAllocInfo
21 import MachRegs
22 import MachInstrs
23 import Cmm
24
25 import State
26 import Unique
27 import UniqFM
28 import UniqSet
29 import UniqSupply
30 import Outputable
31
32 import Data.List
33 import Data.Maybe
34
35
36 -- | Spill all these virtual regs to memory
37 --      TODO:   see if we can split some of the live ranges instead of just globally
38 --              spilling the virtual reg.
39 --
40 --      TODO:   On ciscy x86 and x86_64 we don't nessesarally have to add a mov instruction
41 --              when making spills. If an instr is using a spilled virtual we may be able to
42 --              address the spill slot directly.
43 --
44 regSpill
45         :: [LiveCmmTop]                 -- ^ the code
46         -> UniqSet Int                  -- ^ available stack slots
47         -> UniqSet Reg                  -- ^ the regs to spill
48         -> UniqSM
49                 ([LiveCmmTop]           -- code will spill instructions
50                 , UniqSet Int           -- left over slots
51                 , SpillStats )          -- stats about what happened during spilling
52
53 regSpill code slotsFree regs
54
55         -- not enough slots to spill these regs
56         | sizeUniqSet slotsFree < sizeUniqSet regs
57         = pprPanic "regSpill: out of spill slots!"
58                 (  text "   regs to spill = " <> ppr (sizeUniqSet regs)
59                 $$ text "   slots left    = " <> ppr (sizeUniqSet slotsFree))
60
61         | otherwise
62         = do
63                 -- allocate a slot for each of the spilled regs
64                 let slots       = take (sizeUniqSet regs) $ uniqSetToList slotsFree
65                 let regSlotMap  = listToUFM
66                                 $ zip (uniqSetToList regs) slots
67
68                 -- grab the unique supply from the monad
69                 us      <- getUs
70
71                 -- run the spiller on all the blocks
72                 let (code', state')     =
73                         runState (mapM (mapBlockTopM (regSpill_block regSlotMap)) code)
74                                  (initSpillS us)
75
76                 return  ( code'
77                         , minusUniqSet slotsFree (mkUniqSet slots)
78                         , makeSpillStats state')
79
80
81 regSpill_block regSlotMap (BasicBlock i instrs)
82  = do   instrss'        <- mapM (regSpill_instr regSlotMap) instrs
83         return  $ BasicBlock i (concat instrss')
84
85 regSpill_instr _        li@(Instr _ Nothing)
86  = do   return [li]
87
88 regSpill_instr regSlotMap
89         (Instr instr (Just live))
90  = do
91         -- work out which regs are read and written in this instr
92         let RU rlRead rlWritten = regUsage instr
93
94         -- sometimes a register is listed as being read more than once,
95         --      nub this so we don't end up inserting two lots of spill code.
96         let rsRead_             = nub rlRead
97         let rsWritten_          = nub rlWritten
98
99         -- if a reg is modified, it appears in both lists, want to undo this..
100         let rsRead              = rsRead_    \\ rsWritten_
101         let rsWritten           = rsWritten_ \\ rsRead_
102         let rsModify            = intersect rsRead_ rsWritten_
103
104         -- work out if any of the regs being used are currently being spilled.
105         let rsSpillRead         = filter (\r -> elemUFM r regSlotMap) rsRead
106         let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten
107         let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify
108
109         -- rewrite the instr and work out spill code.
110         (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead
111         (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten
112         (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify
113
114         let (mPrefixes, mPostfixes)     = unzip (prepost1 ++ prepost2 ++ prepost3)
115         let prefixes                    = concat mPrefixes
116         let postfixes                   = concat mPostfixes
117
118         -- final code
119         let instrs'     =  map (\i -> Instr i Nothing) prefixes
120                         ++ [ Instr instr3 Nothing ]
121                         ++ map (\i -> Instr i Nothing) postfixes
122
123         return
124 {-              $ pprTrace "* regSpill_instr spill"
125                         (  text "instr  = " <> ppr instr
126                         $$ text "read   = " <> ppr rsSpillRead
127                         $$ text "write  = " <> ppr rsSpillWritten
128                         $$ text "mod    = " <> ppr rsSpillModify
129                         $$ text "-- out"
130                         $$ (vcat $ map ppr instrs')
131                         $$ text " ")
132 -}
133                 $ instrs'
134
135
136 spillRead regSlotMap instr reg
137         | Just slot     <- lookupUFM regSlotMap reg
138         = do    (instr', nReg)  <- patchInstr reg instr
139
140                 modify $ \s -> s
141                         { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
142
143                 return  ( instr'
144                         , ( [RELOAD slot nReg]
145                           , []) )
146
147         | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"
148
149 spillWrite regSlotMap instr reg
150         | Just slot     <- lookupUFM regSlotMap reg
151         = do    (instr', nReg)  <- patchInstr reg instr
152
153                 modify $ \s -> s
154                         { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
155
156                 return  ( instr'
157                         , ( []
158                           , [SPILL nReg slot]))
159
160         | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg"
161
162 spillModify regSlotMap instr reg
163         | Just slot     <- lookupUFM regSlotMap reg
164         = do    (instr', nReg)  <- patchInstr reg instr
165
166                 modify $ \s -> s
167                         { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
168
169                 return  ( instr'
170                         , ( [RELOAD slot nReg]
171                           , [SPILL nReg slot]))
172
173         | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg"
174
175
176
177 -- | rewrite uses of this virtual reg in an instr to use a different virtual reg
178 patchInstr :: Reg -> Instr -> SpillM (Instr, Reg)
179 patchInstr reg instr
180  = do   nUnique         <- newUnique
181         let nReg        = renameVirtualReg nUnique reg
182         let instr'      = patchReg1 reg nReg instr
183         return          (instr', nReg)
184
185 patchReg1 :: Reg -> Reg -> Instr -> Instr
186 patchReg1 old new instr
187  = let  patchF r
188                 | r == old      = new
189                 | otherwise     = r
190    in   patchRegs instr patchF
191
192
193 ------------------------------------------------------
194 -- Spiller monad
195
196 data SpillS
197         = SpillS
198         { stateUS       :: UniqSupply
199         , stateSpillSL  :: UniqFM (Reg, Int, Int) } -- ^ spilled reg vs number of times vreg was loaded, stored
200
201 initSpillS uniqueSupply
202         = SpillS
203         { stateUS       = uniqueSupply
204         , stateSpillSL  = emptyUFM }
205
206 type SpillM a   = State SpillS a
207
208 newUnique :: SpillM Unique
209 newUnique
210  = do   us      <- gets stateUS
211         case splitUniqSupply us of
212          (us1, us2)
213           -> do let uniq = uniqFromSupply us1
214                 modify $ \s -> s { stateUS = us2 }
215                 return uniq
216
217 accSpillSL (r1, s1, l1) (r2, s2, l2)
218         = (r1, s1 + s2, l1 + l2)
219
220
221 ----------------------------------------------------
222 -- Spiller stats
223
224 data SpillStats
225         = SpillStats
226         { spillStoreLoad        :: UniqFM (Reg, Int, Int) }
227
228 makeSpillStats :: SpillS -> SpillStats
229 makeSpillStats s
230         = SpillStats
231         { spillStoreLoad        = stateSpillSL s }
232
233 instance Outputable SpillStats where
234  ppr stats
235         = (vcat $ map (\(r, s, l) -> ppr r <+> int s <+> int l)
236                         $ eltsUFM (spillStoreLoad stats))
237