Revert "Remove ArchUnknown"
[ghc.git] / compiler / nativeGen / RegAlloc / Linear / Main.hs
1 -----------------------------------------------------------------------------
2 --
3 -- The register allocator
4 --
5 -- (c) The University of Glasgow 2004
6 --
7 -----------------------------------------------------------------------------
8
9 {-
10 The algorithm is roughly:
11
12 1) Compute strongly connected components of the basic block list.
13
14 2) Compute liveness (mapping from pseudo register to
15 point(s) of death?).
16
17 3) Walk instructions in each basic block. We keep track of
18 (a) Free real registers (a bitmap?)
19 (b) Current assignment of temporaries to machine registers and/or
20 spill slots (call this the "assignment").
21 (c) Partial mapping from basic block ids to a virt-to-loc mapping.
22 When we first encounter a branch to a basic block,
23 we fill in its entry in this table with the current mapping.
24
25 For each instruction:
26 (a) For each real register clobbered by this instruction:
27 If a temporary resides in it,
28 If the temporary is live after this instruction,
29 Move the temporary to another (non-clobbered & free) reg,
30 or spill it to memory. Mark the temporary as residing
31 in both memory and a register if it was spilled (it might
32 need to be read by this instruction).
33 (ToDo: this is wrong for jump instructions?)
34
35 (b) For each temporary *read* by the instruction:
36 If the temporary does not have a real register allocation:
37 - Allocate a real register from the free list. If
38 the list is empty:
39 - Find a temporary to spill. Pick one that is
40 not used in this instruction (ToDo: not
41 used for a while...)
42 - generate a spill instruction
43 - If the temporary was previously spilled,
44 generate an instruction to read the temp from its spill loc.
45 (optimisation: if we can see that a real register is going to
46 be used soon, then don't use it for allocation).
47
48 (c) Update the current assignment
49
50 (d) If the instruction is a branch:
51 if the destination block already has a register assignment,
52 Generate a new block with fixup code and redirect the
53 jump to the new block.
54 else,
55 Update the block id->assignment mapping with the current
56 assignment.
57
58 (e) Delete all register assignments for temps which are read
59 (only) and die here. Update the free register list.
60
61 (f) Mark all registers clobbered by this instruction as not free,
62 and mark temporaries which have been spilled due to clobbering
63 as in memory (step (a) marks then as in both mem & reg).
64
65 (g) For each temporary *written* by this instruction:
66 Allocate a real register as for (b), spilling something
67 else if necessary.
68 - except when updating the assignment, drop any memory
69 locations that the temporary was previously in, since
70 they will be no longer valid after this instruction.
71
72 (h) Delete all register assignments for temps which are
73 written and die here (there should rarely be any). Update
74 the free register list.
75
76 (i) Rewrite the instruction with the new mapping.
77
78 (j) For each spilled reg known to be now dead, re-add its stack slot
79 to the free list.
80
81 -}
82
83 module RegAlloc.Linear.Main (
84 regAlloc,
85 module RegAlloc.Linear.Base,
86 module RegAlloc.Linear.Stats
87 ) where
88
89 #include "HsVersions.h"
90
91
92 import RegAlloc.Linear.State
93 import RegAlloc.Linear.Base
94 import RegAlloc.Linear.StackMap
95 import RegAlloc.Linear.FreeRegs
96 import RegAlloc.Linear.Stats
97 import RegAlloc.Linear.JoinToTargets
98 import qualified RegAlloc.Linear.PPC.FreeRegs as PPC
99 import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC
100 import qualified RegAlloc.Linear.X86.FreeRegs as X86
101 import TargetReg
102 import RegAlloc.Liveness
103 import Instruction
104 import Reg
105
106 import BlockId
107 import OldCmm hiding (RegSet)
108
109 import Digraph
110 import DynFlags
111 import Unique
112 import UniqSet
113 import UniqFM
114 import UniqSupply
115 import Outputable
116 import Platform
117
118 import Data.Maybe
119 import Data.List
120 import Control.Monad
121
122 #include "../includes/stg/MachRegs.h"
123
124
125 -- -----------------------------------------------------------------------------
126 -- Top level of the register allocator
127
128 -- Allocate registers
129 regAlloc
130 :: (PlatformOutputable instr, Instruction instr)
131 => DynFlags
132 -> LiveCmmDecl statics instr
133 -> UniqSM (NatCmmDecl statics instr, Maybe RegAllocStats)
134
135 regAlloc _ (CmmData sec d)
136 = return
137 ( CmmData sec d
138 , Nothing )
139
140 regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl [])
141 = return ( CmmProc info lbl (ListGraph [])
142 , Nothing )
143
144 regAlloc dflags (CmmProc static lbl sccs)
145 | LiveInfo info (Just first_id) (Just block_live) _ <- static
146 = do
147 -- do register allocation on each component.
148 (final_blocks, stats)
149 <- linearRegAlloc dflags first_id block_live sccs
150
151 -- make sure the block that was first in the input list
152 -- stays at the front of the output
153 let ((first':_), rest')
154 = partition ((== first_id) . blockId) final_blocks
155
156 return ( CmmProc info lbl (ListGraph (first' : rest'))
157 , Just stats)
158
159 -- bogus. to make non-exhaustive match warning go away.
160 regAlloc _ (CmmProc _ _ _)
161 = panic "RegAllocLinear.regAlloc: no match"
162
163
164 -- -----------------------------------------------------------------------------
165 -- Linear sweep to allocate registers
166
167
168 -- | Do register allocation on some basic blocks.
169 -- But be careful to allocate a block in an SCC only if it has
170 -- an entry in the block map or it is the first block.
171 --
172 linearRegAlloc
173 :: (PlatformOutputable instr, Instruction instr)
174 => DynFlags
175 -> BlockId -- ^ the first block
176 -> BlockMap RegSet -- ^ live regs on entry to each basic block
177 -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
178 -> UniqSM ([NatBasicBlock instr], RegAllocStats)
179
180 linearRegAlloc dflags first_id block_live sccs
181 = let platform = targetPlatform dflags
182 in case platformArch platform of
183 ArchX86 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs
184 ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs
185 ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs
186 ArchPPC -> linearRegAlloc' platform (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs
187 ArchARM _ _ -> panic "linearRegAlloc ArchARM"
188 ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64"
189 ArchUnknown -> panic "linearRegAlloc ArchUnknown"
190
191 linearRegAlloc'
192 :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
193 => Platform
194 -> freeRegs
195 -> BlockId -- ^ the first block
196 -> BlockMap RegSet -- ^ live regs on entry to each basic block
197 -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
198 -> UniqSM ([NatBasicBlock instr], RegAllocStats)
199
200 linearRegAlloc' platform initFreeRegs first_id block_live sccs
201 = do us <- getUs
202 let (_, _, stats, blocks) =
203 runR emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap platform) us
204 $ linearRA_SCCs platform first_id block_live [] sccs
205 return (blocks, stats)
206
207
208 linearRA_SCCs :: (FR freeRegs, Instruction instr, PlatformOutputable instr)
209 => Platform
210 -> BlockId
211 -> BlockMap RegSet
212 -> [NatBasicBlock instr]
213 -> [SCC (LiveBasicBlock instr)]
214 -> RegM freeRegs [NatBasicBlock instr]
215
216 linearRA_SCCs _ _ _ blocksAcc []
217 = return $ reverse blocksAcc
218
219 linearRA_SCCs platform first_id block_live blocksAcc (AcyclicSCC block : sccs)
220 = do blocks' <- processBlock platform block_live block
221 linearRA_SCCs platform first_id block_live
222 ((reverse blocks') ++ blocksAcc)
223 sccs
224
225 linearRA_SCCs platform first_id block_live blocksAcc (CyclicSCC blocks : sccs)
226 = do
227 blockss' <- process platform first_id block_live blocks [] (return []) False
228 linearRA_SCCs platform first_id block_live
229 (reverse (concat blockss') ++ blocksAcc)
230 sccs
231
232 {- from John Dias's patch 2008/10/16:
233 The linear-scan allocator sometimes allocates a block
234 before allocating one of its predecessors, which could lead to
235 inconsistent allocations. Make it so a block is only allocated
236 if a predecessor has set the "incoming" assignments for the block, or
237 if it's the procedure's entry block.
238
239 BL 2009/02: Careful. If the assignment for a block doesn't get set for
240 some reason then this function will loop. We should probably do some
241 more sanity checking to guard against this eventuality.
242 -}
243
244 process :: (FR freeRegs, Instruction instr, PlatformOutputable instr)
245 => Platform
246 -> BlockId
247 -> BlockMap RegSet
248 -> [GenBasicBlock (LiveInstr instr)]
249 -> [GenBasicBlock (LiveInstr instr)]
250 -> [[NatBasicBlock instr]]
251 -> Bool
252 -> RegM freeRegs [[NatBasicBlock instr]]
253
254 process _ _ _ [] [] accum _
255 = return $ reverse accum
256
257 process platform first_id block_live [] next_round accum madeProgress
258 | not madeProgress
259
260 {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.
261 pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."
262 ( text "Unreachable blocks:"
263 $$ vcat (map ppr next_round)) -}
264 = return $ reverse accum
265
266 | otherwise
267 = process platform first_id block_live
268 next_round [] accum False
269
270 process platform first_id block_live (b@(BasicBlock id _) : blocks)
271 next_round accum madeProgress
272 = do
273 block_assig <- getBlockAssigR
274
275 if isJust (mapLookup id block_assig)
276 || id == first_id
277 then do
278 b' <- processBlock platform block_live b
279 process platform first_id block_live blocks
280 next_round (b' : accum) True
281
282 else process platform first_id block_live blocks
283 (b : next_round) accum madeProgress
284
285
286 -- | Do register allocation on this basic block
287 --
288 processBlock
289 :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
290 => Platform
291 -> BlockMap RegSet -- ^ live regs on entry to each basic block
292 -> LiveBasicBlock instr -- ^ block to do register allocation on
293 -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated
294
295 processBlock platform block_live (BasicBlock id instrs)
296 = do initBlock id
297 (instrs', fixups)
298 <- linearRA platform block_live [] [] id instrs
299 return $ BasicBlock id instrs' : fixups
300
301
302 -- | Load the freeregs and current reg assignment into the RegM state
303 -- for the basic block with this BlockId.
304 initBlock :: FR freeRegs => BlockId -> RegM freeRegs ()
305 initBlock id
306 = do block_assig <- getBlockAssigR
307 case mapLookup id block_assig of
308 -- no prior info about this block: assume everything is
309 -- free and the assignment is empty.
310 Nothing
311 -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
312
313 setFreeRegsR frInitFreeRegs
314 setAssigR emptyRegMap
315
316 -- load info about register assignments leading into this block.
317 Just (freeregs, assig)
318 -> do setFreeRegsR freeregs
319 setAssigR assig
320
321
322 -- | Do allocation for a sequence of instructions.
323 linearRA
324 :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
325 => Platform
326 -> BlockMap RegSet -- ^ map of what vregs are live on entry to each block.
327 -> [instr] -- ^ accumulator for instructions already processed.
328 -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code.
329 -> BlockId -- ^ id of the current block, for debugging.
330 -> [LiveInstr instr] -- ^ liveness annotated instructions in this block.
331
332 -> RegM freeRegs
333 ( [instr] -- instructions after register allocation
334 , [NatBasicBlock instr]) -- fresh blocks of fixup code.
335
336
337 linearRA _ _ accInstr accFixup _ []
338 = return
339 ( reverse accInstr -- instrs need to be returned in the correct order.
340 , accFixup) -- it doesn't matter what order the fixup blocks are returned in.
341
342
343 linearRA platform block_live accInstr accFixups id (instr:instrs)
344 = do
345 (accInstr', new_fixups)
346 <- raInsn platform block_live accInstr id instr
347
348 linearRA platform block_live accInstr' (new_fixups ++ accFixups) id instrs
349
350
351 -- | Do allocation for a single instruction.
352 raInsn
353 :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
354 => Platform
355 -> BlockMap RegSet -- ^ map of what vregs are love on entry to each block.
356 -> [instr] -- ^ accumulator for instructions already processed.
357 -> BlockId -- ^ the id of the current block, for debugging
358 -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info.
359 -> RegM freeRegs
360 ( [instr] -- new instructions
361 , [NatBasicBlock instr]) -- extra fixup blocks
362
363 raInsn _ _ new_instrs _ (LiveInstr ii Nothing)
364 | Just n <- takeDeltaInstr ii
365 = do setDeltaR n
366 return (new_instrs, [])
367
368 raInsn _ _ new_instrs _ (LiveInstr ii Nothing)
369 | isMetaInstr ii
370 = return (new_instrs, [])
371
372
373 raInsn platform block_live new_instrs id (LiveInstr (Instr instr) (Just live))
374 = do
375 assig <- getAssigR
376
377 -- If we have a reg->reg move between virtual registers, where the
378 -- src register is not live after this instruction, and the dst
379 -- register does not already have an assignment,
380 -- and the source register is assigned to a register, not to a spill slot,
381 -- then we can eliminate the instruction.
382 -- (we can't eliminate it if the source register is on the stack, because
383 -- we do not want to use one spill slot for different virtual registers)
384 case takeRegRegMoveInstr instr of
385 Just (src,dst) | src `elementOfUniqSet` (liveDieRead live),
386 isVirtualReg dst,
387 not (dst `elemUFM` assig),
388 Just (InReg _) <- (lookupUFM assig src) -> do
389 case src of
390 (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))
391 -- if src is a fixed reg, then we just map dest to this
392 -- reg in the assignment. src must be an allocatable reg,
393 -- otherwise it wouldn't be in r_dying.
394 _virt -> case lookupUFM assig src of
395 Nothing -> panic "raInsn"
396 Just loc ->
397 setAssigR (addToUFM (delFromUFM assig src) dst loc)
398
399 -- we have eliminated this instruction
400 {-
401 freeregs <- getFreeRegsR
402 assig <- getAssigR
403 pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
404 $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
405 -}
406 return (new_instrs, [])
407
408 _ -> genRaInsn platform block_live new_instrs id instr
409 (uniqSetToList $ liveDieRead live)
410 (uniqSetToList $ liveDieWrite live)
411
412
413 raInsn platform _ _ _ instr
414 = pprPanic "raInsn" (text "no match for:" <> pprPlatform platform instr)
415
416
417 genRaInsn :: (FR freeRegs, Instruction instr, PlatformOutputable instr)
418 => Platform
419 -> BlockMap RegSet
420 -> [instr]
421 -> BlockId
422 -> instr
423 -> [Reg]
424 -> [Reg]
425 -> RegM freeRegs ([instr], [NatBasicBlock instr])
426
427 genRaInsn platform block_live new_instrs block_id instr r_dying w_dying =
428 case regUsageOfInstr instr of { RU read written ->
429 do
430 let real_written = [ rr | (RegReal rr) <- written ]
431 let virt_written = [ vr | (RegVirtual vr) <- written ]
432
433 -- we don't need to do anything with real registers that are
434 -- only read by this instr. (the list is typically ~2 elements,
435 -- so using nub isn't a problem).
436 let virt_read = nub [ vr | (RegVirtual vr) <- read ]
437
438 -- (a) save any temporaries which will be clobbered by this instruction
439 clobber_saves <- saveClobberedTemps platform real_written r_dying
440
441 -- debugging
442 {- freeregs <- getFreeRegsR
443 assig <- getAssigR
444 pprTrace "genRaInsn"
445 (ppr instr
446 $$ text "r_dying = " <+> ppr r_dying
447 $$ text "w_dying = " <+> ppr w_dying
448 $$ text "virt_read = " <+> ppr virt_read
449 $$ text "virt_written = " <+> ppr virt_written
450 $$ text "freeregs = " <+> text (show freeregs)
451 $$ text "assig = " <+> ppr assig)
452 $ do
453 -}
454
455 -- (b), (c) allocate real regs for all regs read by this instruction.
456 (r_spills, r_allocd) <-
457 allocateRegsAndSpill platform True{-reading-} virt_read [] [] virt_read
458
459 -- (d) Update block map for new destinations
460 -- NB. do this before removing dead regs from the assignment, because
461 -- these dead regs might in fact be live in the jump targets (they're
462 -- only dead in the code that follows in the current basic block).
463 (fixup_blocks, adjusted_instr)
464 <- joinToTargets platform block_live block_id instr
465
466 -- (e) Delete all register assignments for temps which are read
467 -- (only) and die here. Update the free register list.
468 releaseRegs r_dying
469
470 -- (f) Mark regs which are clobbered as unallocatable
471 clobberRegs real_written
472
473 -- (g) Allocate registers for temporaries *written* (only)
474 (w_spills, w_allocd) <-
475 allocateRegsAndSpill platform False{-writing-} virt_written [] [] virt_written
476
477 -- (h) Release registers for temps which are written here and not
478 -- used again.
479 releaseRegs w_dying
480
481 let
482 -- (i) Patch the instruction
483 patch_map
484 = listToUFM
485 [ (t, RegReal r)
486 | (t, r) <- zip virt_read r_allocd
487 ++ zip virt_written w_allocd ]
488
489 patched_instr
490 = patchRegsOfInstr adjusted_instr patchLookup
491
492 patchLookup x
493 = case lookupUFM patch_map x of
494 Nothing -> x
495 Just y -> y
496
497
498 -- (j) free up stack slots for dead spilled regs
499 -- TODO (can't be bothered right now)
500
501 -- erase reg->reg moves where the source and destination are the same.
502 -- If the src temp didn't die in this instr but happened to be allocated
503 -- to the same real reg as the destination, then we can erase the move anyway.
504 let squashed_instr = case takeRegRegMoveInstr patched_instr of
505 Just (src, dst)
506 | src == dst -> []
507 _ -> [patched_instr]
508
509 let code = squashed_instr ++ w_spills ++ reverse r_spills
510 ++ clobber_saves ++ new_instrs
511
512 -- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
513 -- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do
514
515 return (code, fixup_blocks)
516
517 }
518
519 -- -----------------------------------------------------------------------------
520 -- releaseRegs
521
522 releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()
523 releaseRegs regs = do
524 assig <- getAssigR
525 free <- getFreeRegsR
526 loop assig free regs
527 where
528 loop _ free _ | free `seq` False = undefined
529 loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
530 loop assig free (RegReal rr : rs) = loop assig (frReleaseReg rr free) rs
531 loop assig free (r:rs) =
532 case lookupUFM assig r of
533 Just (InBoth real _) -> loop (delFromUFM assig r) (frReleaseReg real free) rs
534 Just (InReg real) -> loop (delFromUFM assig r) (frReleaseReg real free) rs
535 _other -> loop (delFromUFM assig r) free rs
536
537
538 -- -----------------------------------------------------------------------------
539 -- Clobber real registers
540
541 -- For each temp in a register that is going to be clobbered:
542 -- - if the temp dies after this instruction, do nothing
543 -- - otherwise, put it somewhere safe (another reg if possible,
544 -- otherwise spill and record InBoth in the assignment).
545 -- - for allocateRegs on the temps *read*,
546 -- - clobbered regs are allocatable.
547 --
548 -- for allocateRegs on the temps *written*,
549 -- - clobbered regs are not allocatable.
550 --
551 -- TODO: instead of spilling, try to copy clobbered
552 -- temps to another register if possible.
553 --
554
555
556 saveClobberedTemps
557 :: (PlatformOutputable instr, Instruction instr)
558 => Platform
559 -> [RealReg] -- real registers clobbered by this instruction
560 -> [Reg] -- registers which are no longer live after this insn
561 -> RegM freeRegs [instr] -- return: instructions to spill any temps that will
562 -- be clobbered.
563
564 saveClobberedTemps _ [] _
565 = return []
566
567 saveClobberedTemps platform clobbered dying
568 = do
569 assig <- getAssigR
570 let to_spill
571 = [ (temp,reg)
572 | (temp, InReg reg) <- ufmToList assig
573 , any (realRegsAlias reg) clobbered
574 , temp `notElem` map getUnique dying ]
575
576 (instrs,assig') <- clobber assig [] to_spill
577 setAssigR assig'
578 return instrs
579
580 where
581 clobber assig instrs []
582 = return (instrs, assig)
583
584 clobber assig instrs ((temp, reg) : rest)
585 = do
586 (spill, slot) <- spillR platform (RegReal reg) temp
587
588 -- record why this reg was spilled for profiling
589 recordSpill (SpillClobber temp)
590
591 let new_assign = addToUFM assig temp (InBoth reg slot)
592
593 clobber new_assign (spill : instrs) rest
594
595
596
597 -- | Mark all these real regs as allocated,
598 -- and kick out their vreg assignments.
599 --
600 clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()
601 clobberRegs []
602 = return ()
603
604 clobberRegs clobbered
605 = do
606 freeregs <- getFreeRegsR
607 setFreeRegsR $! foldr frAllocateReg freeregs clobbered
608
609 assig <- getAssigR
610 setAssigR $! clobber assig (ufmToList assig)
611
612 where
613 -- if the temp was InReg and clobbered, then we will have
614 -- saved it in saveClobberedTemps above. So the only case
615 -- we have to worry about here is InBoth. Note that this
616 -- also catches temps which were loaded up during allocation
617 -- of read registers, not just those saved in saveClobberedTemps.
618
619 clobber assig []
620 = assig
621
622 clobber assig ((temp, InBoth reg slot) : rest)
623 | any (realRegsAlias reg) clobbered
624 = clobber (addToUFM assig temp (InMem slot)) rest
625
626 clobber assig (_:rest)
627 = clobber assig rest
628
629 -- -----------------------------------------------------------------------------
630 -- allocateRegsAndSpill
631
632 -- Why are we performing a spill?
633 data SpillLoc = ReadMem StackSlot -- reading from register only in memory
634 | WriteNew -- writing to a new variable
635 | WriteMem -- writing to register only in memory
636 -- Note that ReadNew is not valid, since you don't want to be reading
637 -- from an uninitialized register. We also don't need the location of
638 -- the register in memory, since that will be invalidated by the write.
639 -- Technically, we could coalesce WriteNew and WriteMem into a single
640 -- entry as well. -- EZY
641
642 -- This function does several things:
643 -- For each temporary referred to by this instruction,
644 -- we allocate a real register (spilling another temporary if necessary).
645 -- We load the temporary up from memory if necessary.
646 -- We also update the register assignment in the process, and
647 -- the list of free registers and free stack slots.
648
649 allocateRegsAndSpill
650 :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
651 => Platform
652 -> Bool -- True <=> reading (load up spilled regs)
653 -> [VirtualReg] -- don't push these out
654 -> [instr] -- spill insns
655 -> [RealReg] -- real registers allocated (accum.)
656 -> [VirtualReg] -- temps to allocate
657 -> RegM freeRegs ( [instr] , [RealReg])
658
659 allocateRegsAndSpill _ _ _ spills alloc []
660 = return (spills, reverse alloc)
661
662 allocateRegsAndSpill platform reading keep spills alloc (r:rs)
663 = do assig <- getAssigR
664 let doSpill = allocRegsAndSpill_spill platform reading keep spills alloc r rs assig
665 case lookupUFM assig r of
666 -- case (1a): already in a register
667 Just (InReg my_reg) ->
668 allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs
669
670 -- case (1b): already in a register (and memory)
671 -- NB1. if we're writing this register, update its assignment to be
672 -- InReg, because the memory value is no longer valid.
673 -- NB2. This is why we must process written registers here, even if they
674 -- are also read by the same instruction.
675 Just (InBoth my_reg _)
676 -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
677 allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs
678
679 -- Not already in a register, so we need to find a free one...
680 Just (InMem slot) | reading -> doSpill (ReadMem slot)
681 | otherwise -> doSpill WriteMem
682 Nothing | reading ->
683 -- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
684 -- ToDo: This case should be a panic, but we
685 -- sometimes see an unreachable basic block which
686 -- triggers this because the register allocator
687 -- will start with an empty assignment.
688 doSpill WriteNew
689
690 | otherwise -> doSpill WriteNew
691
692
693 -- reading is redundant with reason, but we keep it around because it's
694 -- convenient and it maintains the recursive structure of the allocator. -- EZY
695 allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, PlatformOutputable instr)
696 => Platform
697 -> Bool
698 -> [VirtualReg]
699 -> [instr]
700 -> [RealReg]
701 -> VirtualReg
702 -> [VirtualReg]
703 -> UniqFM Loc
704 -> SpillLoc
705 -> RegM freeRegs ([instr], [RealReg])
706 allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc
707 = do
708 freeRegs <- getFreeRegsR
709 let freeRegs_thisClass = frGetFreeRegs (classOfVirtualReg r) freeRegs
710
711 case freeRegs_thisClass of
712
713 -- case (2): we have a free register
714 (my_reg : _) ->
715 do spills' <- loadTemp platform r spill_loc my_reg spills
716
717 setAssigR (addToUFM assig r $! newLocation spill_loc my_reg)
718 setFreeRegsR $ frAllocateReg my_reg freeRegs
719
720 allocateRegsAndSpill platform reading keep spills' (my_reg : alloc) rs
721
722
723 -- case (3): we need to push something out to free up a register
724 [] ->
725 do let keep' = map getUnique keep
726
727 -- the vregs we could kick out that are already in a slot
728 let candidates_inBoth
729 = [ (temp, reg, mem)
730 | (temp, InBoth reg mem) <- ufmToList assig
731 , temp `notElem` keep'
732 , targetClassOfRealReg platform reg == classOfVirtualReg r ]
733
734 -- the vregs we could kick out that are only in a reg
735 -- this would require writing the reg to a new slot before using it.
736 let candidates_inReg
737 = [ (temp, reg)
738 | (temp, InReg reg) <- ufmToList assig
739 , temp `notElem` keep'
740 , targetClassOfRealReg platform reg == classOfVirtualReg r ]
741
742 let result
743
744 -- we have a temporary that is in both register and mem,
745 -- just free up its register for use.
746 | (temp, my_reg, slot) : _ <- candidates_inBoth
747 = do spills' <- loadTemp platform r spill_loc my_reg spills
748 let assig1 = addToUFM assig temp (InMem slot)
749 let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
750
751 setAssigR assig2
752 allocateRegsAndSpill platform reading keep spills' (my_reg:alloc) rs
753
754 -- otherwise, we need to spill a temporary that currently
755 -- resides in a register.
756 | (temp_to_push_out, (my_reg :: RealReg)) : _
757 <- candidates_inReg
758 = do
759 (spill_insn, slot) <- spillR platform (RegReal my_reg) temp_to_push_out
760 let spill_store = (if reading then id else reverse)
761 [ -- COMMENT (fsLit "spill alloc")
762 spill_insn ]
763
764 -- record that this temp was spilled
765 recordSpill (SpillAlloc temp_to_push_out)
766
767 -- update the register assignment
768 let assig1 = addToUFM assig temp_to_push_out (InMem slot)
769 let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
770 setAssigR assig2
771
772 -- if need be, load up a spilled temp into the reg we've just freed up.
773 spills' <- loadTemp platform r spill_loc my_reg spills
774
775 allocateRegsAndSpill platform reading keep
776 (spill_store ++ spills')
777 (my_reg:alloc) rs
778
779
780 -- there wasn't anything to spill, so we're screwed.
781 | otherwise
782 = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
783 $ vcat
784 [ text "allocating vreg: " <> text (show r)
785 , text "assignment: " <> text (show $ ufmToList assig)
786 , text "freeRegs: " <> text (show freeRegs)
787 , text "initFreeRegs: " <> text (show (frInitFreeRegs `asTypeOf` freeRegs)) ]
788
789 result
790
791
792 -- | Calculate a new location after a register has been loaded.
793 newLocation :: SpillLoc -> RealReg -> Loc
794 -- if the tmp was read from a slot, then now its in a reg as well
795 newLocation (ReadMem slot) my_reg = InBoth my_reg slot
796 -- writes will always result in only the register being available
797 newLocation _ my_reg = InReg my_reg
798
799 -- | Load up a spilled temporary if we need to (read from memory).
800 loadTemp
801 :: (PlatformOutputable instr, Instruction instr)
802 => Platform
803 -> VirtualReg -- the temp being loaded
804 -> SpillLoc -- the current location of this temp
805 -> RealReg -- the hreg to load the temp into
806 -> [instr]
807 -> RegM freeRegs [instr]
808
809 loadTemp platform vreg (ReadMem slot) hreg spills
810 = do
811 insn <- loadR platform (RegReal hreg) slot
812 recordSpill (SpillLoad $ getUnique vreg)
813 return $ {- COMMENT (fsLit "spill load") : -} insn : spills
814
815 loadTemp _ _ _ _ spills =
816 return spills
817