Main.hs 21.1 KB
 Ian Lynagh committed Sep 21, 2007 1 ``````{-# OPTIONS -fno-warn-missing-signatures #-} `````` simonmar committed Aug 13, 2004 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 ``````----------------------------------------------------------------------------- -- -- The register allocator -- -- (c) The University of Glasgow 2004 -- ----------------------------------------------------------------------------- {- The algorithm is roughly: 1) Compute strongly connected components of the basic block list. 2) Compute liveness (mapping from pseudo register to point(s) of death?). 3) Walk instructions in each basic block. We keep track of (a) Free real registers (a bitmap?) (b) Current assignment of temporaries to machine registers and/or spill slots (call this the "assignment"). (c) Partial mapping from basic block ids to a virt-to-loc mapping. When we first encounter a branch to a basic block, we fill in its entry in this table with the current mapping. For each instruction: (a) For each real register clobbered by this instruction: If a temporary resides in it, If the temporary is live after this instruction, Move the temporary to another (non-clobbered & free) reg, or spill it to memory. Mark the temporary as residing in both memory and a register if it was spilled (it might need to be read by this instruction). (ToDo: this is wrong for jump instructions?) (b) For each temporary *read* by the instruction: If the temporary does not have a real register allocation: - Allocate a real register from the free list. If the list is empty: - Find a temporary to spill. Pick one that is not used in this instruction (ToDo: not used for a while...) - generate a spill instruction - If the temporary was previously spilled, generate an instruction to read the temp from its spill loc. (optimisation: if we can see that a real register is going to be used soon, then don't use it for allocation). (c) Update the current assignment (d) If the intstruction is a branch: if the destination block already has a register assignment, Generate a new block with fixup code and redirect the jump to the new block. else, Update the block id->assignment mapping with the current assignment. (e) Delete all register assignments for temps which are read (only) and die here. Update the free register list. (f) Mark all registers clobbered by this instruction as not free, and mark temporaries which have been spilled due to clobbering as in memory (step (a) marks then as in both mem & reg). `````` simonmar committed Jan 13, 2005 66 `````` (g) For each temporary *written* by this instruction: `````` simonmar committed Aug 13, 2004 67 68 `````` Allocate a real register as for (b), spilling something else if necessary. `````` simonmar committed Jan 13, 2005 69 70 71 `````` - except when updating the assignment, drop any memory locations that the temporary was previously in, since they will be no longer valid after this instruction. `````` simonmar committed Aug 13, 2004 72 73 74 75 76 77 78 79 80 81 82 83 `````` (h) Delete all register assignments for temps which are written and die here (there should rarely be any). Update the free register list. (i) Rewrite the instruction with the new mapping. (j) For each spilled reg known to be now dead, re-add its stack slot to the free list. -} `````` Ben.Lippmeier@anu.edu.au committed Feb 02, 2009 84 ``````module RegAlloc.Linear.Main ( `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 85 `````` regAlloc, `````` Ben.Lippmeier@anu.edu.au committed Feb 02, 2009 86 87 `````` module RegAlloc.Linear.Base, module RegAlloc.Linear.Stats `````` simonmar committed Aug 13, 2004 88 89 90 91 `````` ) where #include "HsVersions.h" `````` Ben.Lippmeier@anu.edu.au committed Feb 02, 2009 92 93 94 95 96 97 `````` import RegAlloc.Linear.State import RegAlloc.Linear.Base import RegAlloc.Linear.StackMap import RegAlloc.Linear.FreeRegs import RegAlloc.Linear.Stats `````` 98 ``````import RegAlloc.Linear.JoinToTargets `````` Ben.Lippmeier@anu.edu.au committed Feb 02, 2009 99 `````` `````` dias@eecs.harvard.edu committed May 29, 2008 100 ``````import BlockId `````` 101 102 ``````import Regs import Instrs `````` simonmar committed Aug 13, 2004 103 ``````import RegAllocInfo `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 104 ``````import RegLiveness `````` nr@eecs.harvard.edu committed Sep 07, 2007 105 ``````import Cmm hiding (RegSet) `````` simonmar committed Aug 13, 2004 106 107 `````` import Digraph `````` 108 ``````import Unique `````` simonmar committed Aug 13, 2004 109 ``````import UniqSet `````` Ian Lynagh committed Feb 07, 2008 110 ``````import UniqFM `````` wolfgang.thaller@gmx.net committed Feb 25, 2006 111 ``````import UniqSupply `````` simonmar committed Aug 13, 2004 112 ``````import Outputable `````` Ian Lynagh committed Mar 29, 2008 113 ``````import FastString `````` simonmar committed Aug 13, 2004 114 `````` `````` Ian Lynagh committed Sep 08, 2007 115 116 117 ``````import Data.Maybe import Data.List import Control.Monad `````` simonmar committed Aug 13, 2004 118 `````` `````` Ben.Lippmeier@anu.edu.au committed Jan 14, 2009 119 ``````#include "../includes/MachRegs.h" `````` simonmar committed Aug 13, 2004 120 `````` `````` wolfgang.thaller@gmx.net committed Feb 25, 2006 121 `````` `````` simonmar committed Aug 13, 2004 122 123 124 ``````-- ----------------------------------------------------------------------------- -- Top level of the register allocator `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 125 126 127 ``````-- Allocate registers regAlloc :: LiveCmmTop `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 128 `````` -> UniqSM (NatCmmTop, Maybe RegAllocStats) `````` simonmar committed Aug 13, 2004 129 `````` `````` Ben.Lippmeier@anu.edu.au committed Sep 05, 2007 130 ``````regAlloc (CmmData sec d) `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 131 132 133 `````` = return ( CmmData sec d , Nothing ) `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 134 `````` `````` nr@eecs.harvard.edu committed Sep 05, 2007 135 ``````regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph [])) `````` dias@eecs.harvard.edu committed Oct 13, 2008 136 137 `````` = return ( CmmProc info lbl params (ListGraph []) , Nothing ) `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 138 `````` `````` nr@eecs.harvard.edu committed Sep 05, 2007 139 ``````regAlloc (CmmProc static lbl params (ListGraph comps)) `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 140 141 142 143 `````` | LiveInfo info (Just first_id) block_live <- static = do -- do register allocation on each component. (final_blocks, stats) `````` dias@eecs.harvard.edu committed Oct 16, 2008 144 `````` <- linearRegAlloc first_id block_live `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 145 `````` \$ map (\b -> case b of `````` Ben.Lippmeier@anu.edu.au committed Sep 05, 2007 146 147 `````` BasicBlock _ [b] -> AcyclicSCC b BasicBlock _ bs -> CyclicSCC bs) `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 148 149 150 151 152 153 154 `````` \$ comps -- make sure the block that was first in the input list -- stays at the front of the output let ((first':_), rest') = partition ((== first_id) . blockId) final_blocks `````` nr@eecs.harvard.edu committed Sep 05, 2007 155 `````` return ( CmmProc info lbl params (ListGraph (first' : rest')) `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 156 `````` , Just stats) `````` simonmar committed Aug 13, 2004 157 `````` `````` Ben.Lippmeier@anu.edu.au committed Sep 05, 2007 158 159 160 ``````-- bogus. to make non-exhaustive match warning go away. regAlloc (CmmProc _ _ _ _) = panic "RegAllocLinear.regAlloc: no match" `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 161 `````` `````` wolfgang.thaller@gmx.net committed Feb 25, 2006 162 `````` `````` simonmar committed Aug 13, 2004 163 164 165 ``````-- ----------------------------------------------------------------------------- -- Linear sweep to allocate registers `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 166 167 `````` -- | Do register allocation on some basic blocks. `````` dias@eecs.harvard.edu committed Oct 16, 2008 168 169 ``````-- But be careful to allocate a block in an SCC only if it has -- an entry in the block map or it is the first block. `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 170 ``````-- `````` simonmar committed Aug 13, 2004 171 ``````linearRegAlloc `````` dias@eecs.harvard.edu committed Oct 16, 2008 172 173 `````` :: BlockId -- ^ the first block -> BlockMap RegSet -- ^ live regs on entry to each basic block `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 174 175 176 `````` -> [SCC LiveBasicBlock] -- ^ instructions annotated with "deaths" -> UniqSM ([NatBasicBlock], RegAllocStats) `````` dias@eecs.harvard.edu committed Oct 16, 2008 177 ``````linearRegAlloc first_id block_live sccs `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 178 `````` = do us <- getUs `````` Ben.Lippmeier@anu.edu.au committed Sep 05, 2007 179 `````` let (_, _, stats, blocks) = `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 180 `````` runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us `````` dias@eecs.harvard.edu committed Oct 16, 2008 181 `````` \$ linearRA_SCCs first_id block_live [] sccs `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 182 183 184 `````` return (blocks, stats) `````` dias@eecs.harvard.edu committed Oct 16, 2008 185 ``````linearRA_SCCs _ _ blocksAcc [] `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 186 187 `````` = return \$ reverse blocksAcc `````` dias@eecs.harvard.edu committed Oct 16, 2008 188 ``````linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 189 `````` = do blocks' <- processBlock block_live block `````` dias@eecs.harvard.edu committed Oct 16, 2008 190 `````` linearRA_SCCs first_id block_live `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 191 192 193 `````` ((reverse blocks') ++ blocksAcc) sccs `````` dias@eecs.harvard.edu committed Oct 16, 2008 194 195 196 197 198 199 200 201 202 203 204 ``````linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) = do let process [] [] accum = return \$ reverse accum process [] next_round accum = process next_round [] accum process (b@(BasicBlock id _) : blocks) next_round accum = do block_assig <- getBlockAssigR if isJust (lookupBlockEnv block_assig id) || id == first_id then do b' <- processBlock block_live b process blocks next_round (b' : accum) else process blocks (b : next_round) accum blockss' <- process blocks [] (return []) linearRA_SCCs first_id block_live `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 205 206 207 208 209 210 211 212 213 214 215 216 217 218 `````` (reverse (concat blockss') ++ blocksAcc) sccs -- | Do register allocation on this basic block -- processBlock :: BlockMap RegSet -- ^ live regs on entry to each basic block -> LiveBasicBlock -- ^ block to do register allocation on -> RegM [NatBasicBlock] -- ^ block with registers allocated processBlock block_live (BasicBlock id instrs) = do initBlock id (instrs', fixups) `````` 219 `````` <- linearRA block_live [] [] id instrs `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 220 221 222 223 224 225 226 227 228 `````` return \$ BasicBlock id instrs' : fixups -- | Load the freeregs and current reg assignment into the RegM state -- for the basic block with this BlockId. initBlock :: BlockId -> RegM () initBlock id = do block_assig <- getBlockAssigR `````` dias@eecs.harvard.edu committed Oct 13, 2008 229 `````` case lookupBlockEnv block_assig id of `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 230 231 232 233 234 235 236 237 238 239 240 241 `````` -- no prior info about this block: assume everything is -- free and the assignment is empty. Nothing -> do setFreeRegsR initFreeRegs setAssigR emptyRegMap -- load info about register assignments leading into this block. Just (freeregs, assig) -> do setFreeRegsR freeregs setAssigR assig `````` 242 ``````-- | Do allocation for a sequence of instructions. `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 243 ``````linearRA `````` 244 245 246 247 248 `````` :: BlockMap RegSet -- ^ map of what vregs are live on entry to each block. -> [Instr] -- ^ accumulator for instructions already processed. -> [NatBasicBlock] -- ^ accumulator for blocks of fixup code. -> BlockId -- ^ id of the current block, for debugging. -> [LiveInstr] -- ^ liveness annotated instructions in this block. `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 249 `````` `````` Ben.Lippmeier@anu.edu.au committed Feb 04, 2009 250 251 `````` -> RegM ( [Instr] -- instructions after register allocation , [NatBasicBlock]) -- fresh blocks of fixup code. `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 252 `````` `````` simonmar committed Aug 13, 2004 253 `````` `````` 254 255 256 257 258 259 260 261 262 263 264 265 ``````linearRA _ accInstr accFixup _ [] = return ( reverse accInstr -- instrs need to be returned in the correct order. , accFixup) -- it doesn't matter what order the fixup blocks are returned in. linearRA block_live accInstr accFixups id (instr:instrs) = do (accInstr', new_fixups) <- raInsn block_live accInstr id instr linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs `````` simonmar committed Aug 13, 2004 266 267 `````` `````` 268 269 270 271 272 273 274 275 276 277 278 ``````-- | Do allocation for a single instruction. raInsn :: BlockMap RegSet -- ^ map of what vregs are love on entry to each block. -> [Instr] -- ^ accumulator for instructions already processed. -> BlockId -- ^ the id of the current block, for debugging -> LiveInstr -- ^ the instr to have its regs allocated, with liveness info. -> RegM ( [Instr] -- new instructions , [NatBasicBlock]) -- extra fixup blocks raInsn _ new_instrs _ (Instr (COMMENT _) Nothing) `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 279 280 `````` = return (new_instrs, []) `````` 281 ``````raInsn _ new_instrs _ (Instr (DELTA n) Nothing) `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 282 `````` = do `````` simonmar committed Aug 13, 2004 283 284 285 `````` setDeltaR n return (new_instrs, []) `````` 286 ``````raInsn block_live new_instrs id (Instr instr (Just live)) `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 287 `````` = do `````` simonmar committed Aug 13, 2004 288 289 290 291 `````` assig <- getAssigR -- If we have a reg->reg move between virtual registers, where the -- src register is not live after this instruction, and the dst `````` 292 293 294 295 296 `````` -- register does not already have an assignment, -- and the source register is assigned to a register, not to a spill slot, -- then we can eliminate the instruction. -- (we can't eliminitate it if the source register is on the stack, because -- we do not want to use one spill slot for different virtual registers) `````` simonmar committed Aug 13, 2004 297 `````` case isRegRegMove instr of `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 298 `````` Just (src,dst) | src `elementOfUniqSet` (liveDieRead live), `````` Simon Marlow committed Jun 29, 2006 299 `````` isVirtualReg dst, `````` 300 301 `````` not (dst `elemUFM` assig), Just (InReg _) <- (lookupUFM assig src) -> do `````` Simon Marlow committed Jun 29, 2006 302 303 304 305 306 307 308 309 310 311 `````` case src of RealReg i -> setAssigR (addToUFM assig dst (InReg i)) -- if src is a fixed reg, then we just map dest to this -- reg in the assignment. src must be an allocatable reg, -- otherwise it wouldn't be in r_dying. _virt -> case lookupUFM assig src of Nothing -> panic "raInsn" Just loc -> setAssigR (addToUFM (delFromUFM assig src) dst loc) `````` dias@eecs.harvard.edu committed Oct 17, 2008 312 `````` -- we have eliminated this instruction `````` dias@eecs.harvard.edu committed Oct 16, 2008 313 `````` {- `````` dias@eecs.harvard.edu committed Oct 17, 2008 314 315 `````` freeregs <- getFreeRegsR assig <- getAssigR `````` 316 317 `````` pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) \$\$ ppr r_dying <+> ppr w_dying \$\$ text (show freeregs) \$\$ ppr assig) \$ do `````` dias@eecs.harvard.edu committed Oct 16, 2008 318 `````` -} `````` Simon Marlow committed Jun 29, 2006 319 `````` return (new_instrs, []) `````` simonmar committed Aug 13, 2004 320 `````` `````` 321 `````` _ -> genRaInsn block_live new_instrs id instr `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 322 323 324 325 `````` (uniqSetToList \$ liveDieRead live) (uniqSetToList \$ liveDieWrite live) `````` 326 327 328 329 ``````raInsn _ _ id instr = pprPanic "raInsn" (text "no match for:" <> ppr instr) `````` simonmar committed Aug 13, 2004 330 331 `````` `````` 332 ``````genRaInsn block_live new_instrs block_id instr r_dying w_dying = `````` simonmar committed Jul 26, 2005 333 334 335 `````` case regUsage instr of { RU read written -> case partition isRealReg written of { (real_written1,virt_written) -> do `````` simonmar committed Aug 13, 2004 336 337 338 339 340 341 342 343 344 345 `````` let real_written = [ r | RealReg r <- real_written1 ] -- we don't need to do anything with real registers that are -- only read by this instr. (the list is typically ~2 elements, -- so using nub isn't a problem). virt_read = nub (filter isVirtualReg read) -- in -- (a) save any temporaries which will be clobbered by this instruction `````` simonmar committed Jan 17, 2005 346 `````` clobber_saves <- saveClobberedTemps real_written r_dying `````` simonmar committed Aug 13, 2004 347 `````` `````` Ben.Lippmeier@anu.edu.au committed Jan 14, 2009 348 349 `````` {- freeregs <- getFreeRegsR `````` simonmar committed Jan 17, 2005 350 `````` assig <- getAssigR `````` Ben.Lippmeier@anu.edu.au committed Jan 14, 2009 351 352 353 354 355 `````` pprTrace "raInsn" (docToSDoc (pprInstr instr) \$\$ ppr r_dying <+> ppr w_dying \$\$ ppr virt_read <+> ppr virt_written \$\$ text (show freeregs) \$\$ ppr assig) \$ do -} `````` simonmar committed Aug 13, 2004 356 357 358 359 360 361 362 363 364 365 `````` -- (b), (c) allocate real regs for all regs read by this instruction. (r_spills, r_allocd) <- allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read -- (d) Update block map for new destinations -- NB. do this before removing dead regs from the assignment, because -- these dead regs might in fact be live in the jump targets (they're -- only dead in the code that follows in the current basic block). (fixup_blocks, adjusted_instr) `````` 366 `````` <- joinToTargets block_live block_id instr `````` simonmar committed Aug 13, 2004 367 368 369 370 371 372 `````` -- (e) Delete all register assignments for temps which are read -- (only) and die here. Update the free register list. releaseRegs r_dying -- (f) Mark regs which are clobbered as unallocatable `````` simonmar committed Jan 17, 2005 373 `````` clobberRegs real_written `````` simonmar committed Aug 13, 2004 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 `````` -- (g) Allocate registers for temporaries *written* (only) (w_spills, w_allocd) <- allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written -- (h) Release registers for temps which are written here and not -- used again. releaseRegs w_dying let -- (i) Patch the instruction patch_map = listToUFM [ (t,RealReg r) | (t,r) <- zip virt_read r_allocd ++ zip virt_written w_allocd ] patched_instr = patchRegs adjusted_instr patchLookup patchLookup x = case lookupUFM patch_map x of Nothing -> x Just y -> y -- in -- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) \$ do -- (j) free up stack slots for dead spilled regs -- TODO (can't be bothered right now) `````` Ben.Lippmeier@anu.edu.au committed Aug 23, 2007 400 401 402 403 404 405 406 407 408 `````` -- erase reg->reg moves where the source and destination are the same. -- If the src temp didn't die in this instr but happened to be allocated -- to the same real reg as the destination, then we can erase the move anyway. squashed_instr = case isRegRegMove patched_instr of Just (src, dst) | src == dst -> [] _ -> [patched_instr] return (squashed_instr ++ w_spills ++ reverse r_spills `````` simonmar committed Aug 13, 2004 409 410 `````` ++ clobber_saves ++ new_instrs, fixup_blocks) `````` simonmar committed Jul 26, 2005 411 `````` }} `````` simonmar committed Aug 13, 2004 412 413 414 415 416 417 418 419 420 `````` -- ----------------------------------------------------------------------------- -- releaseRegs releaseRegs regs = do assig <- getAssigR free <- getFreeRegsR loop assig free regs where `````` Ben.Lippmeier@anu.edu.au committed Sep 05, 2007 421 `````` loop _ free _ | free `seq` False = undefined `````` simonmar committed Aug 13, 2004 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 `````` loop assig free [] = do setAssigR assig; setFreeRegsR free; return () loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs loop assig free (r:rs) = case lookupUFM assig r of Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs _other -> loop (delFromUFM assig r) free rs -- ----------------------------------------------------------------------------- -- Clobber real registers {- For each temp in a register that is going to be clobbered: - if the temp dies after this instruction, do nothing - otherwise, put it somewhere safe (another reg if possible, otherwise spill and record InBoth in the assignment). for allocateRegs on the temps *read*, - clobbered regs are allocatable. for allocateRegs on the temps *written*, - clobbered regs are not allocatable. -} saveClobberedTemps :: [RegNo] -- real registers clobbered by this instruction -> [Reg] -- registers which are no longer live after this insn `````` simonmar committed Jan 17, 2005 449 450 `````` -> RegM [Instr] -- return: instructions to spill any temps that will -- be clobbered. `````` simonmar committed Aug 13, 2004 451 `````` `````` simonmar committed Jan 17, 2005 452 ``````saveClobberedTemps [] _ = return [] -- common case `````` simonmar committed Aug 13, 2004 453 454 455 456 457 458 459 ``````saveClobberedTemps clobbered dying = do assig <- getAssigR let to_spill = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig, reg `elem` clobbered, temp `notElem` map getUnique dying ] -- in `````` simonmar committed Jan 17, 2005 460 `````` (instrs,assig') <- clobber assig [] to_spill `````` simonmar committed Aug 13, 2004 461 `````` setAssigR assig' `````` simonmar committed Jan 17, 2005 462 `````` return instrs `````` simonmar committed Aug 13, 2004 463 `````` where `````` simonmar committed Jan 17, 2005 464 465 `````` clobber assig instrs [] = return (instrs,assig) clobber assig instrs ((temp,reg):rest) `````` simonmar committed Aug 13, 2004 466 467 `````` = do --ToDo: copy it to another register if possible `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 468 469 470 471 `````` (spill,slot) <- spillR (RealReg reg) temp recordSpill (SpillClobber temp) let new_assign = addToUFM assig temp (InBoth reg slot) `````` Ian Lynagh committed Apr 12, 2008 472 `````` clobber new_assign (spill : COMMENT (fsLit "spill clobber") : instrs) rest `````` simonmar committed Aug 13, 2004 473 `````` `````` simonmar committed Jan 17, 2005 474 475 476 ``````clobberRegs :: [RegNo] -> RegM () clobberRegs [] = return () -- common case clobberRegs clobbered = do `````` simonmar committed Aug 13, 2004 477 `````` freeregs <- getFreeRegsR `````` Ben.Lippmeier@anu.edu.au committed Jan 14, 2009 478 ``````-- setFreeRegsR \$! foldr grabReg freeregs clobbered `````` simonmar committed Jul 26, 2005 479 `````` setFreeRegsR \$! foldr allocateReg freeregs clobbered `````` Ben.Lippmeier@anu.edu.au committed Jan 14, 2009 480 `````` `````` simonmar committed Aug 13, 2004 481 `````` assig <- getAssigR `````` simonmar committed Jan 17, 2005 482 483 484 485 486 487 488 489 490 491 492 `````` setAssigR \$! clobber assig (ufmToList assig) where -- if the temp was InReg and clobbered, then we will have -- saved it in saveClobberedTemps above. So the only case -- we have to worry about here is InBoth. Note that this -- also catches temps which were loaded up during allocation -- of read registers, not just those saved in saveClobberedTemps. clobber assig [] = assig clobber assig ((temp, InBoth reg slot) : rest) | reg `elem` clobbered = clobber (addToUFM assig temp (InMem slot)) rest `````` Ben.Lippmeier@anu.edu.au committed Sep 05, 2007 493 `````` clobber assig (_:rest) `````` simonmar committed Jan 17, 2005 494 `````` = clobber assig rest `````` simonmar committed Aug 13, 2004 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 `````` -- ----------------------------------------------------------------------------- -- allocateRegsAndSpill -- This function does several things: -- For each temporary referred to by this instruction, -- we allocate a real register (spilling another temporary if necessary). -- We load the temporary up from memory if necessary. -- We also update the register assignment in the process, and -- the list of free registers and free stack slots. allocateRegsAndSpill :: Bool -- True <=> reading (load up spilled regs) -> [Reg] -- don't push these out -> [Instr] -- spill insns -> [RegNo] -- real registers allocated (accum.) -> [Reg] -- temps to allocate -> RegM ([Instr], [RegNo]) `````` Ben.Lippmeier@anu.edu.au committed Sep 05, 2007 514 ``````allocateRegsAndSpill _ _ spills alloc [] `````` simonmar committed Aug 13, 2004 515 516 517 518 519 520 521 522 523 524 `````` = return (spills,reverse alloc) allocateRegsAndSpill reading keep spills alloc (r:rs) = do assig <- getAssigR case lookupUFM assig r of -- case (1a): already in a register Just (InReg my_reg) -> allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- case (1b): already in a register (and memory) `````` simonmar committed Jan 13, 2005 525 `````` -- NB1. if we're writing this register, update its assignemnt to be `````` simonmar committed Aug 13, 2004 526 `````` -- InReg, because the memory value is no longer valid. `````` simonmar committed Jan 13, 2005 527 528 `````` -- NB2. This is why we must process written registers here, even if they -- are also read by the same instruction. `````` Ben.Lippmeier@anu.edu.au committed Sep 05, 2007 529 `````` Just (InBoth my_reg _) -> do `````` simonmar committed Jan 13, 2005 530 `````` when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) `````` simonmar committed Aug 13, 2004 531 532 533 534 535 536 537 538 539 `````` allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- Not already in a register, so we need to find a free one... loc -> do freeregs <- getFreeRegsR case getFreeRegs (regClass r) freeregs of -- case (2): we have a free register `````` Ben.Lippmeier@anu.edu.au committed Jan 20, 2009 540 `````` my_reg:_ -> {- pprTrace "alloc" (ppr r <+> ppr my_reg <+> ppr freeClass) \$ -} `````` Ben.Lippmeier@anu.edu.au committed Jan 14, 2009 541 `````` do `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 542 `````` spills' <- loadTemp reading r loc my_reg spills `````` simonmar committed Jan 13, 2005 543 544 545 `````` let new_loc | Just (InMem slot) <- loc, reading = InBoth my_reg slot | otherwise = InReg my_reg `````` simonmar committed Aug 13, 2004 546 `````` setAssigR (addToUFM assig r \$! new_loc) `````` Ben.Lippmeier@anu.edu.au committed Jan 14, 2009 547 `````` setFreeRegsR \$ allocateReg my_reg freeregs `````` simonmar committed Aug 13, 2004 548 549 550 551 552 553 554 555 556 557 558 559 560 `````` allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs -- case (3): we need to push something out to free up a register [] -> do let keep' = map getUnique keep candidates1 = [ (temp,reg,mem) | (temp, InBoth reg mem) <- ufmToList assig, temp `notElem` keep', regClass (RealReg reg) == regClass r ] candidates2 = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig, temp `notElem` keep', regClass (RealReg reg) == regClass r ] -- in `````` simonmar committed Apr 11, 2005 561 562 `````` ASSERT2(not (null candidates1 && null candidates2), text (show freeregs) <+> ppr r <+> ppr assig) do `````` simonmar committed Aug 13, 2004 563 564 565 566 567 568 569 `````` case candidates1 of -- we have a temporary that is in both register and mem, -- just free up its register for use. -- (temp,my_reg,slot):_ -> do `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 570 `````` spills' <- loadTemp reading r loc my_reg spills `````` simonmar committed Aug 13, 2004 571 572 573 574 575 576 577 578 579 `````` let assig1 = addToUFM assig temp (InMem slot) assig2 = addToUFM assig1 r (InReg my_reg) -- in setAssigR assig2 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs -- otherwise, we need to spill a temporary that currently -- resides in a register. `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 580 581 `````` `````` simonmar committed Aug 13, 2004 582 `````` [] -> do `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 583 584 585 586 587 `````` -- TODO: plenty of room for optimisation in choosing which temp -- to spill. We just pick the first one that isn't used in -- the current instruction for now. `````` Ben.Lippmeier@anu.edu.au committed Jan 10, 2009 588 589 `````` let (temp_to_push_out, my_reg) = case candidates2 of `````` Ben.Lippmeier@anu.edu.au committed Jan 14, 2009 590 591 `````` [] -> panic \$ "RegAllocLinear.allocRegsAndSpill: no spill candidates" ++ "assignment: " ++ show (ufmToList assig) ++ "\n" `````` Ben.Lippmeier@anu.edu.au committed Jan 10, 2009 592 593 `````` (x:_) -> x `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 594 595 `````` (spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out let spill_store = (if reading then id else reverse) `````` Ian Lynagh committed Apr 12, 2008 596 `````` [ COMMENT (fsLit "spill alloc") `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 597 598 599 600 601 602 603 604 `````` , spill_insn ] -- record that this temp was spilled recordSpill (SpillAlloc temp_to_push_out) -- update the register assignment let assig1 = addToUFM assig temp_to_push_out (InMem slot) let assig2 = addToUFM assig1 r (InReg my_reg) `````` simonmar committed Aug 13, 2004 605 `````` setAssigR assig2 `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 606 607 608 609 610 611 `````` -- if need be, load up a spilled temp into the reg we've just freed up. spills' <- loadTemp reading r loc my_reg spills allocateRegsAndSpill reading keep (spill_store ++ spills') `````` simonmar committed Aug 13, 2004 612 `````` (my_reg:alloc) rs `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 `````` -- | Load up a spilled temporary if we need to. loadTemp :: Bool -> Reg -- the temp being loaded -> Maybe Loc -- the current location of this temp -> RegNo -- the hreg to load the temp into -> [Instr] -> RegM [Instr] loadTemp True vreg (Just (InMem slot)) hreg spills = do insn <- loadR (RealReg hreg) slot recordSpill (SpillLoad \$ getUnique vreg) `````` Ian Lynagh committed Apr 12, 2008 628 `````` return \$ COMMENT (fsLit "spill load") : insn : spills `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 629 630 631 632 `````` loadTemp _ _ _ _ spills = return spills ``````