never executed always true always false
1 {-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
2 {-# LANGUAGE ConstraintKinds #-}
3
4 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
5
6 -----------------------------------------------------------------------------
7 --
8 -- The register allocator
9 --
10 -- (c) The University of Glasgow 2004
11 --
12 -----------------------------------------------------------------------------
13
14 {-
15 The algorithm is roughly:
16
17 1) Compute strongly connected components of the basic block list.
18
19 2) Compute liveness (mapping from pseudo register to
20 point(s) of death?).
21
22 3) Walk instructions in each basic block. We keep track of
23 (a) Free real registers (a bitmap?)
24 (b) Current assignment of temporaries to machine registers and/or
25 spill slots (call this the "assignment").
26 (c) Partial mapping from basic block ids to a virt-to-loc mapping.
27 When we first encounter a branch to a basic block,
28 we fill in its entry in this table with the current mapping.
29
30 For each instruction:
31 (a) For each temporary *read* by the instruction:
32 If the temporary does not have a real register allocation:
33 - Allocate a real register from the free list. If
34 the list is empty:
35 - Find a temporary to spill. Pick one that is
36 not used in this instruction (ToDo: not
37 used for a while...)
38 - generate a spill instruction
39 - If the temporary was previously spilled,
40 generate an instruction to read the temp from its spill loc.
41 (optimisation: if we can see that a real register is going to
42 be used soon, then don't use it for allocation).
43
44 (b) For each real register clobbered by this instruction:
45 If a temporary resides in it,
46 If the temporary is live after this instruction,
47 Move the temporary to another (non-clobbered & free) reg,
48 or spill it to memory. Mark the temporary as residing
49 in both memory and a register if it was spilled (it might
50 need to be read by this instruction).
51
52 (ToDo: this is wrong for jump instructions?)
53
54 We do this after step (a), because if we start with
55 movq v1, %rsi
56 which is an instruction that clobbers %rsi, if v1 currently resides
57 in %rsi we want to get
58 movq %rsi, %freereg
59 movq %rsi, %rsi -- will disappear
60 instead of
61 movq %rsi, %freereg
62 movq %freereg, %rsi
63
64 (c) Update the current assignment
65
66 (d) If the instruction is a branch:
67 if the destination block already has a register assignment,
68 Generate a new block with fixup code and redirect the
69 jump to the new block.
70 else,
71 Update the block id->assignment mapping with the current
72 assignment.
73
74 (e) Delete all register assignments for temps which are read
75 (only) and die here. Update the free register list.
76
77 (f) Mark all registers clobbered by this instruction as not free,
78 and mark temporaries which have been spilled due to clobbering
79 as in memory (step (a) marks then as in both mem & reg).
80
81 (g) For each temporary *written* by this instruction:
82 Allocate a real register as for (b), spilling something
83 else if necessary.
84 - except when updating the assignment, drop any memory
85 locations that the temporary was previously in, since
86 they will be no longer valid after this instruction.
87
88 (h) Delete all register assignments for temps which are
89 written and die here (there should rarely be any). Update
90 the free register list.
91
92 (i) Rewrite the instruction with the new mapping.
93
94 (j) For each spilled reg known to be now dead, re-add its stack slot
95 to the free list.
96
97 -}
98
99 module GHC.CmmToAsm.Reg.Linear (
100 regAlloc,
101 module GHC.CmmToAsm.Reg.Linear.Base,
102 module GHC.CmmToAsm.Reg.Linear.Stats
103 ) where
104
105 import GHC.Prelude
106
107 import GHC.CmmToAsm.Reg.Linear.State
108 import GHC.CmmToAsm.Reg.Linear.Base
109 import GHC.CmmToAsm.Reg.Linear.StackMap
110 import GHC.CmmToAsm.Reg.Linear.FreeRegs
111 import GHC.CmmToAsm.Reg.Linear.Stats
112 import GHC.CmmToAsm.Reg.Linear.JoinToTargets
113 import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC
114 import qualified GHC.CmmToAsm.Reg.Linear.SPARC as SPARC
115 import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86
116 import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64
117 import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64
118 import GHC.CmmToAsm.Reg.Target
119 import GHC.CmmToAsm.Reg.Liveness
120 import GHC.CmmToAsm.Reg.Utils
121 import GHC.CmmToAsm.Instr
122 import GHC.CmmToAsm.Config
123 import GHC.CmmToAsm.Types
124 import GHC.Platform.Reg
125 import GHC.Platform.Reg.Class (RegClass(..))
126
127 import GHC.Cmm.BlockId
128 import GHC.Cmm.Dataflow.Collections
129 import GHC.Cmm hiding (RegSet)
130
131 import GHC.Data.Graph.Directed
132 import GHC.Types.Unique
133 import GHC.Types.Unique.Set
134 import GHC.Types.Unique.FM
135 import GHC.Types.Unique.Supply
136 import GHC.Utils.Outputable
137 import GHC.Utils.Panic
138 import GHC.Platform
139
140 import Data.Maybe
141 import Data.List (partition, nub)
142 import Control.Monad
143
144 -- -----------------------------------------------------------------------------
145 -- Top level of the register allocator
146
147 -- Allocate registers
148 regAlloc
149 :: Instruction instr
150 => NCGConfig
151 -> LiveCmmDecl statics instr
152 -> UniqSM ( NatCmmDecl statics instr
153 , Maybe Int -- number of extra stack slots required,
154 -- beyond maxSpillSlots
155 , Maybe RegAllocStats
156 )
157
158 regAlloc _ (CmmData sec d)
159 = return
160 ( CmmData sec d
161 , Nothing
162 , Nothing )
163
164 regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live [])
165 = return ( CmmProc info lbl live (ListGraph [])
166 , Nothing
167 , Nothing )
168
169 regAlloc config (CmmProc static lbl live sccs)
170 | LiveInfo info entry_ids@(first_id:_) block_live _ <- static
171 = do
172 -- do register allocation on each component.
173 !(!final_blocks, !stats, !stack_use)
174 <- linearRegAlloc config entry_ids block_live sccs
175
176 -- make sure the block that was first in the input list
177 -- stays at the front of the output
178 let !(!(!first':_), !rest')
179 = partition ((== first_id) . blockId) final_blocks
180
181 let max_spill_slots = maxSpillSlots config
182 extra_stack
183 | stack_use > max_spill_slots
184 = Just $! stack_use - max_spill_slots
185 | otherwise
186 = Nothing
187
188 return ( CmmProc info lbl live (ListGraph (first' : rest'))
189 , extra_stack
190 , Just stats)
191
192 -- bogus. to make non-exhaustive match warning go away.
193 regAlloc _ (CmmProc _ _ _ _)
194 = panic "RegAllocLinear.regAlloc: no match"
195
196
197 -- -----------------------------------------------------------------------------
198 -- Linear sweep to allocate registers
199
200
201 -- | Do register allocation on some basic blocks.
202 -- But be careful to allocate a block in an SCC only if it has
203 -- an entry in the block map or it is the first block.
204 --
205 linearRegAlloc
206 :: forall instr. (Instruction instr)
207 => NCGConfig
208 -> [BlockId] -- ^ entry points
209 -> BlockMap RegSet
210 -- ^ live regs on entry to each basic block
211 -> [SCC (LiveBasicBlock instr)]
212 -- ^ instructions annotated with "deaths"
213 -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
214
215 linearRegAlloc config entry_ids block_live sccs
216 = case platformArch platform of
217 ArchX86 -> go $ (frInitFreeRegs platform :: X86.FreeRegs)
218 ArchX86_64 -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs)
219 ArchS390X -> panic "linearRegAlloc ArchS390X"
220 ArchSPARC -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs)
221 ArchSPARC64 -> panic "linearRegAlloc ArchSPARC64"
222 ArchPPC -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
223 ArchARM _ _ _ -> panic "linearRegAlloc ArchARM"
224 ArchAArch64 -> go $ (frInitFreeRegs platform :: AArch64.FreeRegs)
225 ArchPPC_64 _ -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
226 ArchAlpha -> panic "linearRegAlloc ArchAlpha"
227 ArchMipseb -> panic "linearRegAlloc ArchMipseb"
228 ArchMipsel -> panic "linearRegAlloc ArchMipsel"
229 ArchRISCV64 -> panic "linearRegAlloc ArchRISCV64"
230 ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"
231 ArchUnknown -> panic "linearRegAlloc ArchUnknown"
232 where
233 go :: (FR regs, Outputable regs)
234 => regs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
235 go f = linearRegAlloc' config f entry_ids block_live sccs
236 platform = ncgPlatform config
237
238 -- | Constraints on the instruction instances used by the
239 -- linear allocator.
240 type OutputableRegConstraint freeRegs instr =
241 (FR freeRegs, Outputable freeRegs, Instruction instr)
242
243 linearRegAlloc'
244 :: OutputableRegConstraint freeRegs instr
245 => NCGConfig
246 -> freeRegs
247 -> [BlockId] -- ^ entry points
248 -> BlockMap RegSet -- ^ live regs on entry to each basic block
249 -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
250 -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
251
252 linearRegAlloc' config initFreeRegs entry_ids block_live sccs
253 = do us <- getUniqueSupplyM
254 let !(_, !stack, !stats, !blocks) =
255 runR config emptyBlockAssignment initFreeRegs emptyRegMap emptyStackMap us
256 $ linearRA_SCCs entry_ids block_live [] sccs
257 return (blocks, stats, getStackUse stack)
258
259
260 linearRA_SCCs :: OutputableRegConstraint freeRegs instr
261 => [BlockId]
262 -> BlockMap RegSet
263 -> [NatBasicBlock instr]
264 -> [SCC (LiveBasicBlock instr)]
265 -> RegM freeRegs [NatBasicBlock instr]
266
267 linearRA_SCCs _ _ blocksAcc []
268 = return $ reverse blocksAcc
269
270 linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs)
271 = do blocks' <- processBlock block_live block
272 linearRA_SCCs entry_ids block_live
273 ((reverse blocks') ++ blocksAcc)
274 sccs
275
276 linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs)
277 = do
278 blockss' <- process entry_ids block_live blocks
279 linearRA_SCCs entry_ids block_live
280 (reverse (concat blockss') ++ blocksAcc)
281 sccs
282
283 {- from John Dias's patch 2008/10/16:
284 The linear-scan allocator sometimes allocates a block
285 before allocating one of its predecessors, which could lead to
286 inconsistent allocations. Make it so a block is only allocated
287 if a predecessor has set the "incoming" assignments for the block, or
288 if it's the procedure's entry block.
289
290 BL 2009/02: Careful. If the assignment for a block doesn't get set for
291 some reason then this function will loop. We should probably do some
292 more sanity checking to guard against this eventuality.
293 -}
294
295 process :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)
296 => [BlockId]
297 -> BlockMap RegSet
298 -> [GenBasicBlock (LiveInstr instr)]
299 -> RegM freeRegs [[NatBasicBlock instr]]
300 process entry_ids block_live =
301 \blocks -> go blocks [] (return []) False
302 where
303 go :: [GenBasicBlock (LiveInstr instr)]
304 -> [GenBasicBlock (LiveInstr instr)]
305 -> [[NatBasicBlock instr]]
306 -> Bool
307 -> RegM freeRegs [[NatBasicBlock instr]]
308 go [] [] accum _madeProgress
309 = return $ reverse accum
310
311 go [] next_round accum madeProgress
312 | not madeProgress
313 {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.
314 pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."
315 ( text "Unreachable blocks:"
316 $$ vcat (map ppr next_round)) -}
317 = return $ reverse accum
318
319 | otherwise
320 = go next_round [] accum False
321
322 go (b@(BasicBlock id _) : blocks) next_round accum madeProgress
323 = do
324 block_assig <- getBlockAssigR
325 if isJust (lookupBlockAssignment id block_assig) || id `elem` entry_ids
326 then do b' <- processBlock block_live b
327 go blocks next_round (b' : accum) True
328
329 else do go blocks (b : next_round) accum madeProgress
330
331
332 -- | Do register allocation on this basic block
333 --
334 processBlock
335 :: OutputableRegConstraint freeRegs instr
336 => BlockMap RegSet -- ^ live regs on entry to each basic block
337 -> LiveBasicBlock instr -- ^ block to do register allocation on
338 -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated
339
340 processBlock block_live (BasicBlock id instrs)
341 = do -- pprTraceM "processBlock" $ text "" $$ ppr (BasicBlock id instrs)
342 initBlock id block_live
343
344 (instrs', fixups)
345 <- linearRA block_live id instrs
346 -- pprTraceM "blockResult" $ ppr (instrs', fixups)
347 return $ BasicBlock id instrs' : fixups
348
349
350 -- | Load the freeregs and current reg assignment into the RegM state
351 -- for the basic block with this BlockId.
352 initBlock :: FR freeRegs
353 => BlockId -> BlockMap RegSet -> RegM freeRegs ()
354 initBlock id block_live
355 = do platform <- getPlatform
356 block_assig <- getBlockAssigR
357 case lookupBlockAssignment id block_assig of
358 -- no prior info about this block: we must consider
359 -- any fixed regs to be allocated, but we can ignore
360 -- virtual regs (presumably this is part of a loop,
361 -- and we'll iterate again). The assignment begins
362 -- empty.
363 Nothing
364 -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
365 case mapLookup id block_live of
366 Nothing ->
367 setFreeRegsR (frInitFreeRegs platform)
368 Just live ->
369 setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform)
370 [ r | RegReal r <- nonDetEltsUniqSet live ]
371 -- See Note [Unique Determinism and code generation]
372 setAssigR emptyRegMap
373
374 -- load info about register assignments leading into this block.
375 Just (freeregs, assig)
376 -> do setFreeRegsR freeregs
377 setAssigR assig
378
379
380 -- | Do allocation for a sequence of instructions.
381 linearRA
382 :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)
383 => BlockMap RegSet -- ^ map of what vregs are live on entry to each block.
384 -> BlockId -- ^ id of the current block, for debugging.
385 -> [LiveInstr instr] -- ^ liveness annotated instructions in this block.
386 -> RegM freeRegs
387 ( [instr] -- instructions after register allocation
388 , [NatBasicBlock instr]) -- fresh blocks of fixup code.
389 linearRA block_live block_id = go [] []
390 where
391 go :: [instr] -- ^ accumulator for instructions already processed.
392 -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code.
393 -> [LiveInstr instr] -- ^ liveness annotated instructions in this block.
394 -> RegM freeRegs
395 ( [instr] -- instructions after register allocation
396 , [NatBasicBlock instr] ) -- fresh blocks of fixup code.
397 go !accInstr !accFixups [] = do
398 return ( reverse accInstr -- instrs need to be returned in the correct order.
399 , accFixups ) -- it doesn't matter what order the fixup blocks are returned in.
400
401 go accInstr accFixups (instr:instrs) = do
402 (accInstr', new_fixups) <- raInsn block_live accInstr block_id instr
403 go accInstr' (new_fixups ++ accFixups) instrs
404
405 -- | Do allocation for a single instruction.
406 raInsn
407 :: OutputableRegConstraint freeRegs instr
408 => BlockMap RegSet -- ^ map of what vregs are love on entry to each block.
409 -> [instr] -- ^ accumulator for instructions already processed.
410 -> BlockId -- ^ the id of the current block, for debugging
411 -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info.
412 -> RegM freeRegs
413 ( [instr] -- new instructions
414 , [NatBasicBlock instr]) -- extra fixup blocks
415
416 raInsn _ new_instrs _ (LiveInstr ii Nothing)
417 | Just n <- takeDeltaInstr ii
418 = do setDeltaR n
419 return (new_instrs, [])
420
421 raInsn _ new_instrs _ (LiveInstr ii@(Instr i) Nothing)
422 | isMetaInstr ii
423 = return (i : new_instrs, [])
424
425
426 raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
427 = do
428 assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)
429
430 -- If we have a reg->reg move between virtual registers, where the
431 -- src register is not live after this instruction, and the dst
432 -- register does not already have an assignment,
433 -- and the source register is assigned to a register, not to a spill slot,
434 -- then we can eliminate the instruction.
435 -- (we can't eliminate it if the source register is on the stack, because
436 -- we do not want to use one spill slot for different virtual registers)
437 case takeRegRegMoveInstr instr of
438 Just (src,dst) | src `elementOfUniqSet` (liveDieRead live),
439 isVirtualReg dst,
440 not (dst `elemUFM` assig),
441 isRealReg src || isInReg src assig -> do
442 case src of
443 (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))
444 -- if src is a fixed reg, then we just map dest to this
445 -- reg in the assignment. src must be an allocatable reg,
446 -- otherwise it wouldn't be in r_dying.
447 _virt -> case lookupUFM assig src of
448 Nothing -> panic "raInsn"
449 Just loc ->
450 setAssigR (addToUFM (delFromUFM assig src) dst loc)
451
452 -- we have eliminated this instruction
453 {-
454 freeregs <- getFreeRegsR
455 assig <- getAssigR
456 pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
457 $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
458 -}
459 return (new_instrs, [])
460
461 _ -> genRaInsn block_live new_instrs id instr
462 (nonDetEltsUniqSet $ liveDieRead live)
463 (nonDetEltsUniqSet $ liveDieWrite live)
464 -- See Note [Unique Determinism and code generation]
465
466 raInsn _ _ _ instr
467 = do
468 platform <- getPlatform
469 let instr' = fmap (pprInstr platform) instr
470 pprPanic "raInsn" (text "no match for:" <> ppr instr')
471
472 -- ToDo: what can we do about
473 --
474 -- R1 = x
475 -- jump I64[x] // [R1]
476 --
477 -- where x is mapped to the same reg as R1. We want to coalesce x and
478 -- R1, but the register allocator doesn't know whether x will be
479 -- assigned to again later, in which case x and R1 should be in
480 -- different registers. Right now we assume the worst, and the
481 -- assignment to R1 will clobber x, so we'll spill x into another reg,
482 -- generating another reg->reg move.
483
484
485 isInReg :: Reg -> RegMap Loc -> Bool
486 isInReg src assig | Just (InReg _) <- lookupUFM assig src = True
487 | otherwise = False
488
489
490 genRaInsn :: forall freeRegs instr.
491 (OutputableRegConstraint freeRegs instr)
492 => BlockMap RegSet
493 -> [instr]
494 -> BlockId
495 -> instr
496 -> [Reg]
497 -> [Reg]
498 -> RegM freeRegs ([instr], [NatBasicBlock instr])
499
500 genRaInsn block_live new_instrs block_id instr r_dying w_dying = do
501 -- pprTraceM "genRaInsn" $ ppr (block_id, instr)
502 platform <- getPlatform
503 case regUsageOfInstr platform instr of { RU read written ->
504 do
505 let real_written = [ rr | (RegReal rr) <- written ] :: [RealReg]
506 let virt_written = [ vr | (RegVirtual vr) <- written ]
507
508 -- we don't need to do anything with real registers that are
509 -- only read by this instr. (the list is typically ~2 elements,
510 -- so using nub isn't a problem).
511 let virt_read = nub [ vr | (RegVirtual vr) <- read ] :: [VirtualReg]
512
513 -- do
514 -- let real_read = nub [ rr | (RegReal rr) <- read]
515 -- freeregs <- getFreeRegsR
516 -- assig <- getAssigR
517
518 -- pprTraceM "genRaInsn"
519 -- ( text "block = " <+> ppr block_id
520 -- $$ text "instruction = " <+> ppr instr
521 -- $$ text "r_dying = " <+> ppr r_dying
522 -- $$ text "w_dying = " <+> ppr w_dying
523 -- $$ text "read = " <+> ppr real_read <+> ppr virt_read
524 -- $$ text "written = " <+> ppr real_written <+> ppr virt_written
525 -- $$ text "freeregs = " <+> ppr freeregs
526 -- $$ text "assign = " <+> ppr assig)
527
528 -- (a), (b) allocate real regs for all regs read by this instruction.
529 (r_spills, r_allocd) <-
530 allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
531
532 -- (c) save any temporaries which will be clobbered by this instruction
533 clobber_saves <- saveClobberedTemps real_written r_dying
534
535 -- (d) Update block map for new destinations
536 -- NB. do this before removing dead regs from the assignment, because
537 -- these dead regs might in fact be live in the jump targets (they're
538 -- only dead in the code that follows in the current basic block).
539 (fixup_blocks, adjusted_instr)
540 <- joinToTargets block_live block_id instr
541
542 -- when (not $ null fixup_blocks) $ pprTraceM "genRA:FixBlocks" $ ppr fixup_blocks
543
544 -- Debugging - show places where the reg alloc inserted
545 -- assignment fixup blocks.
546 -- when (not $ null fixup_blocks) $
547 -- pprTrace "fixup_blocks" (ppr fixup_blocks) (return ())
548
549 -- (e) Delete all register assignments for temps which are read
550 -- (only) and die here. Update the free register list.
551 releaseRegs r_dying
552
553 -- (f) Mark regs which are clobbered as unallocatable
554 clobberRegs real_written
555
556 -- (g) Allocate registers for temporaries *written* (only)
557 (w_spills, w_allocd) <-
558 allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
559
560 -- (h) Release registers for temps which are written here and not
561 -- used again.
562 releaseRegs w_dying
563
564 let
565 -- (i) Patch the instruction
566 patch_map :: UniqFM Reg Reg
567 patch_map
568 = toRegMap $ -- Cast key from VirtualReg to Reg
569 -- See Note [UniqFM and the register allocator]
570 listToUFM
571 [ (t, RegReal r)
572 | (t, r) <- zip virt_read r_allocd
573 ++ zip virt_written w_allocd ]
574
575 patched_instr :: instr
576 patched_instr
577 = patchRegsOfInstr adjusted_instr patchLookup
578
579 patchLookup :: Reg -> Reg
580 patchLookup x
581 = case lookupUFM patch_map x of
582 Nothing -> x
583 Just y -> y
584
585 -- (j) free up stack slots for dead spilled regs
586 -- TODO (can't be bothered right now)
587
588 -- erase reg->reg moves where the source and destination are the same.
589 -- If the src temp didn't die in this instr but happened to be allocated
590 -- to the same real reg as the destination, then we can erase the move anyway.
591 let squashed_instr = case takeRegRegMoveInstr patched_instr of
592 Just (src, dst)
593 | src == dst -> []
594 _ -> [patched_instr]
595
596 -- On the use of @reverse@ below.
597 -- Since we can have spills and reloads produce multiple instructions
598 -- we need to ensure they are emitted in the correct order. We used to only
599 -- emit single instructions in mkSpill/mkReload/mkRegRegMove.
600 -- As such order of spills and reloads didn't matter. However, with
601 -- mutliple instructions potentially issued by those functions we need to be
602 -- careful to not break execution order. Reversing the spills (clobber will
603 -- also spill), will ensure they are emitted in the right order.
604 --
605 -- See also Ticket 19910 for changing the return type from [] to OrdList.
606
607 -- For debugging, uncomment the follow line and the mkComment lines.
608 -- u <- getUniqueR
609 let code = concat [ -- mkComment (text "<genRaInsn(" <> ppr u <> text ")>")
610 -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):squashed>")]
611 squashed_instr
612 -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):w_spills>")
613 , reverse w_spills
614 -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):r_spills>")
615 , reverse r_spills
616 -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):clobber_saves>")
617 , reverse clobber_saves
618 -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):new_instrs>")
619 , new_instrs
620 -- ,mkComment (text "</genRaInsn(" <> ppr u <> text ")>")
621 ]
622
623 -- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
624 -- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do
625
626 return (code, fixup_blocks)
627
628 }
629
630 -- -----------------------------------------------------------------------------
631 -- releaseRegs
632
633 releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()
634 releaseRegs regs = do
635 platform <- getPlatform
636 assig <- getAssigR
637 free <- getFreeRegsR
638
639 let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return ()
640 loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs
641 loop assig !free (r:rs) =
642 case lookupUFM assig r of
643 Just (InBoth real _) -> loop (delFromUFM assig r)
644 (frReleaseReg platform real free) rs
645 Just (InReg real) -> loop (delFromUFM assig r)
646 (frReleaseReg platform real free) rs
647 _ -> loop (delFromUFM assig r) free rs
648 loop assig free regs
649
650
651 -- -----------------------------------------------------------------------------
652 -- Clobber real registers
653
654 -- For each temp in a register that is going to be clobbered:
655 -- - if the temp dies after this instruction, do nothing
656 -- - otherwise, put it somewhere safe (another reg if possible,
657 -- otherwise spill and record InBoth in the assignment).
658 -- - for allocateRegs on the temps *read*,
659 -- - clobbered regs are allocatable.
660 --
661 -- for allocateRegs on the temps *written*,
662 -- - clobbered regs are not allocatable.
663 --
664
665 saveClobberedTemps
666 :: forall instr freeRegs.
667 (Instruction instr, FR freeRegs)
668 => [RealReg] -- real registers clobbered by this instruction
669 -> [Reg] -- registers which are no longer live after this insn
670 -> RegM freeRegs [instr] -- return: instructions to spill any temps that will
671 -- be clobbered.
672
673 saveClobberedTemps [] _
674 = return []
675
676 saveClobberedTemps clobbered dying
677 = do
678 assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)
679 (assig',instrs) <- nonDetStrictFoldUFM_DirectlyM maybe_spill (assig,[]) assig
680 setAssigR assig'
681 return $ -- mkComment (text "<saveClobberedTemps>") ++
682 instrs
683 -- ++ mkComment (text "</saveClobberedTemps>")
684 where
685 -- Unique represents the VirtualReg
686 -- Here we separate the cases which we do want to spill from these we don't.
687 maybe_spill :: Unique -> (RegMap Loc,[instr]) -> (Loc) -> RegM freeRegs (RegMap Loc,[instr])
688 maybe_spill !temp !(assig,instrs) !loc =
689 case loc of
690 -- This is non-deterministic but we do not
691 -- currently support deterministic code-generation.
692 -- See Note [Unique Determinism and code generation]
693 InReg reg
694 | any (realRegsAlias reg) clobbered
695 , temp `notElem` map getUnique dying
696 -> clobber temp (assig,instrs) (reg)
697 _ -> return (assig,instrs)
698
699
700 -- See Note [UniqFM and the register allocator]
701 clobber :: Unique -> (RegMap Loc,[instr]) -> (RealReg) -> RegM freeRegs (RegMap Loc,[instr])
702 clobber temp (assig,instrs) (reg)
703 = do platform <- getPlatform
704
705 freeRegs <- getFreeRegsR
706 let regclass = targetClassOfRealReg platform reg
707 freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs
708
709 case filter (`notElem` clobbered) freeRegs_thisClass of
710
711 -- (1) we have a free reg of the right class that isn't
712 -- clobbered by this instruction; use it to save the
713 -- clobbered value.
714 (my_reg : _) -> do
715 setFreeRegsR (frAllocateReg platform my_reg freeRegs)
716
717 let new_assign = addToUFM_Directly assig temp (InReg my_reg)
718 let instr = mkRegRegMoveInstr platform
719 (RegReal reg) (RegReal my_reg)
720
721 return (new_assign,(instr : instrs))
722
723 -- (2) no free registers: spill the value
724 [] -> do
725 (spill, slot) <- spillR (RegReal reg) temp
726
727 -- record why this reg was spilled for profiling
728 recordSpill (SpillClobber temp)
729
730 let new_assign = addToUFM_Directly assig temp (InBoth reg slot)
731
732 return (new_assign, (spill ++ instrs))
733
734
735
736
737 -- | Mark all these real regs as allocated,
738 -- and kick out their vreg assignments.
739 --
740 clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()
741 clobberRegs []
742 = return ()
743
744 clobberRegs clobbered
745 = do platform <- getPlatform
746 freeregs <- getFreeRegsR
747
748 let gpRegs = frGetFreeRegs platform RcInteger freeregs :: [RealReg]
749 fltRegs = frGetFreeRegs platform RcFloat freeregs :: [RealReg]
750 dblRegs = frGetFreeRegs platform RcDouble freeregs :: [RealReg]
751
752 let extra_clobbered = [ r | r <- clobbered
753 , r `elem` (gpRegs ++ fltRegs ++ dblRegs) ]
754
755 setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs extra_clobbered
756
757 -- setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered
758
759 assig <- getAssigR
760 setAssigR $! clobber assig (nonDetUFMToList assig)
761 -- This is non-deterministic but we do not
762 -- currently support deterministic code-generation.
763 -- See Note [Unique Determinism and code generation]
764
765 where
766 -- if the temp was InReg and clobbered, then we will have
767 -- saved it in saveClobberedTemps above. So the only case
768 -- we have to worry about here is InBoth. Note that this
769 -- also catches temps which were loaded up during allocation
770 -- of read registers, not just those saved in saveClobberedTemps.
771
772 clobber :: RegMap Loc -> [(Unique,Loc)] -> RegMap Loc
773 clobber assig []
774 = assig
775
776 clobber assig ((temp, InBoth reg slot) : rest)
777 | any (realRegsAlias reg) clobbered
778 = clobber (addToUFM_Directly assig temp (InMem slot)) rest
779
780 clobber assig (_:rest)
781 = clobber assig rest
782
783 -- -----------------------------------------------------------------------------
784 -- allocateRegsAndSpill
785
786 -- Why are we performing a spill?
787 data SpillLoc = ReadMem StackSlot -- reading from register only in memory
788 | WriteNew -- writing to a new variable
789 | WriteMem -- writing to register only in memory
790 -- Note that ReadNew is not valid, since you don't want to be reading
791 -- from an uninitialized register. We also don't need the location of
792 -- the register in memory, since that will be invalidated by the write.
793 -- Technically, we could coalesce WriteNew and WriteMem into a single
794 -- entry as well. -- EZY
795
796 -- This function does several things:
797 -- For each temporary referred to by this instruction,
798 -- we allocate a real register (spilling another temporary if necessary).
799 -- We load the temporary up from memory if necessary.
800 -- We also update the register assignment in the process, and
801 -- the list of free registers and free stack slots.
802
803 allocateRegsAndSpill
804 :: forall freeRegs instr. (FR freeRegs, Instruction instr)
805 => Bool -- True <=> reading (load up spilled regs)
806 -> [VirtualReg] -- don't push these out
807 -> [instr] -- spill insns
808 -> [RealReg] -- real registers allocated (accum.)
809 -> [VirtualReg] -- temps to allocate
810 -> RegM freeRegs ( [instr] , [RealReg])
811
812 allocateRegsAndSpill _ _ spills alloc []
813 = return (spills, reverse alloc)
814
815 allocateRegsAndSpill reading keep spills alloc (r:rs)
816 = do assig <- toVRegMap <$> getAssigR
817 -- pprTraceM "allocateRegsAndSpill:assig" (ppr (r:rs) $$ ppr assig)
818 -- See Note [UniqFM and the register allocator]
819 let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
820 case lookupUFM assig r of
821 -- case (1a): already in a register
822 Just (InReg my_reg) ->
823 allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
824
825 -- case (1b): already in a register (and memory)
826 -- NB1. if we're writing this register, update its assignment to be
827 -- InReg, because the memory value is no longer valid.
828 -- NB2. This is why we must process written registers here, even if they
829 -- are also read by the same instruction.
830 Just (InBoth my_reg _)
831 -> do when (not reading) (setAssigR $ toRegMap (addToUFM assig r (InReg my_reg)))
832 allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
833
834 -- Not already in a register, so we need to find a free one...
835 Just (InMem slot) | reading -> doSpill (ReadMem slot)
836 | otherwise -> doSpill WriteMem
837 Nothing | reading ->
838 pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
839 -- NOTE: if the input to the NCG contains some
840 -- unreachable blocks with junk code, this panic
841 -- might be triggered. Make sure you only feed
842 -- sensible code into the NCG. In GHC.Cmm.Pipeline we
843 -- call removeUnreachableBlocks at the end for this
844 -- reason.
845
846 | otherwise -> doSpill WriteNew
847
848 -- | Given a virtual reg find a preferred real register.
849 -- The preferred register is simply the first one the variable
850 -- was assigned to (if any). This way when we allocate for a loop
851 -- variables are likely to end up in the same registers at the
852 -- end and start of the loop, avoiding redundant reg-reg moves.
853 -- Note: I tried returning a list of past assignments, but that
854 -- turned out to barely matter.
855 findPrefRealReg :: VirtualReg -> RegM freeRegs (Maybe RealReg)
856 findPrefRealReg vreg = do
857 bassig <- getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
858 return $ lookupFirstUsed vreg bassig
859
860 -- reading is redundant with reason, but we keep it around because it's
861 -- convenient and it maintains the recursive structure of the allocator. -- EZY
862 allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr)
863 => Bool
864 -> [VirtualReg]
865 -> [instr]
866 -> [RealReg]
867 -> VirtualReg
868 -> [VirtualReg]
869 -> UniqFM VirtualReg Loc
870 -> SpillLoc
871 -> RegM freeRegs ([instr], [RealReg])
872 allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
873 = do platform <- getPlatform
874 freeRegs <- getFreeRegsR
875 let freeRegs_thisClass = frGetFreeRegs platform (classOfVirtualReg r) freeRegs :: [RealReg]
876
877 -- Can we put the variable into a register it already was?
878 pref_reg <- findPrefRealReg r
879
880 case freeRegs_thisClass of
881 -- case (2): we have a free register
882 (first_free : _) ->
883 do let !final_reg
884 | Just reg <- pref_reg
885 , reg `elem` freeRegs_thisClass
886 = reg
887 | otherwise
888 = first_free
889 spills' <- loadTemp r spill_loc final_reg spills
890
891 setAssigR $ toRegMap
892 $ (addToUFM assig r $! newLocation spill_loc final_reg)
893 setFreeRegsR $ frAllocateReg platform final_reg freeRegs
894
895 allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs
896
897
898 -- case (3): we need to push something out to free up a register
899 [] ->
900 do let inRegOrBoth (InReg _) = True
901 inRegOrBoth (InBoth _ _) = True
902 inRegOrBoth _ = False
903 let candidates' :: UniqFM VirtualReg Loc
904 candidates' =
905 flip delListFromUFM keep $
906 filterUFM inRegOrBoth $
907 assig
908 -- This is non-deterministic but we do not
909 -- currently support deterministic code-generation.
910 -- See Note [Unique Determinism and code generation]
911 let candidates = nonDetUFMToList candidates'
912
913 -- the vregs we could kick out that are already in a slot
914 let candidates_inBoth :: [(Unique, RealReg, StackSlot)]
915 candidates_inBoth
916 = [ (temp, reg, mem)
917 | (temp, InBoth reg mem) <- candidates
918 , targetClassOfRealReg platform reg == classOfVirtualReg r ]
919
920 -- the vregs we could kick out that are only in a reg
921 -- this would require writing the reg to a new slot before using it.
922 let candidates_inReg
923 = [ (temp, reg)
924 | (temp, InReg reg) <- candidates
925 , targetClassOfRealReg platform reg == classOfVirtualReg r ]
926
927 let result
928
929 -- we have a temporary that is in both register and mem,
930 -- just free up its register for use.
931 | (temp, my_reg, slot) : _ <- candidates_inBoth
932 = do spills' <- loadTemp r spill_loc my_reg spills
933 let assig1 = addToUFM_Directly assig temp (InMem slot)
934 let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
935
936 setAssigR $ toRegMap assig2
937 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
938
939 -- otherwise, we need to spill a temporary that currently
940 -- resides in a register.
941 | (temp_to_push_out, (my_reg :: RealReg)) : _
942 <- candidates_inReg
943 = do
944 (spill_store, slot) <- spillR (RegReal my_reg) temp_to_push_out
945
946 -- record that this temp was spilled
947 recordSpill (SpillAlloc temp_to_push_out)
948
949 -- update the register assignment
950 let assig1 = addToUFM_Directly assig temp_to_push_out (InMem slot)
951 let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
952 setAssigR $ toRegMap assig2
953
954 -- if need be, load up a spilled temp into the reg we've just freed up.
955 spills' <- loadTemp r spill_loc my_reg spills
956
957 allocateRegsAndSpill reading keep
958 (spill_store ++ spills')
959 (my_reg:alloc) rs
960
961
962 -- there wasn't anything to spill, so we're screwed.
963 | otherwise
964 = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
965 $ vcat
966 [ text "allocating vreg: " <> text (show r)
967 , text "assignment: " <> ppr assig
968 , text "freeRegs: " <> text (show freeRegs)
969 , text "initFreeRegs: " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ]
970
971 result
972
973
974 -- | Calculate a new location after a register has been loaded.
975 newLocation :: SpillLoc -> RealReg -> Loc
976 -- if the tmp was read from a slot, then now its in a reg as well
977 newLocation (ReadMem slot) my_reg = InBoth my_reg slot
978 -- writes will always result in only the register being available
979 newLocation _ my_reg = InReg my_reg
980
981 -- | Load up a spilled temporary if we need to (read from memory).
982 loadTemp
983 :: (Instruction instr)
984 => VirtualReg -- the temp being loaded
985 -> SpillLoc -- the current location of this temp
986 -> RealReg -- the hreg to load the temp into
987 -> [instr]
988 -> RegM freeRegs [instr]
989
990 loadTemp vreg (ReadMem slot) hreg spills
991 = do
992 insn <- loadR (RegReal hreg) slot
993 recordSpill (SpillLoad $ getUnique vreg)
994 return $ {- mkComment (text "spill load") : -} insn ++ spills
995
996 loadTemp _ _ _ spills =
997 return spills