Main.hs 37.3 KB
 Ömer Sinan Ağacan committed Jun 27, 2016 1 ``````{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} `````` Herbert Valerio Riedel committed May 15, 2014 2 `````` `````` Tom Ellis committed Jan 27, 2020 3 4 ``````{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} `````` simonmar committed Aug 13, 2004 5 6 7 8 9 10 11 12 13 14 ``````----------------------------------------------------------------------------- -- -- The register allocator -- -- (c) The University of Glasgow 2004 -- ----------------------------------------------------------------------------- {- The algorithm is roughly: `````` Ian Lynagh committed May 31, 2011 15 `````` `````` simonmar committed Aug 13, 2004 16 17 18 19 20 21 `````` 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 `````` Ian Lynagh committed May 31, 2011 22 23 24 25 26 27 `````` (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. `````` simonmar committed Aug 13, 2004 28 29 `````` For each instruction: `````` Simon Marlow committed Jul 31, 2012 30 `````` (a) For each temporary *read* by the instruction: `````` Ian Lynagh committed May 31, 2011 31 32 33 34 35 36 37 38 39 40 `````` 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 `````` simonmar committed Aug 13, 2004 41 42 `````` be used soon, then don't use it for allocation). `````` Simon Marlow committed Jul 31, 2012 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 `````` (b) 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?) We do this after step (a), because if we start with movq v1, %rsi which is an instruction that clobbers %rsi, if v1 currently resides in %rsi we want to get movq %rsi, %freereg movq %rsi, %rsi -- will disappear instead of movq %rsi, %freereg movq %freereg, %rsi `````` Ian Lynagh committed May 31, 2011 63 `````` (c) Update the current assignment `````` simonmar committed Aug 13, 2004 64 `````` `````` Ian Lynagh committed May 31, 2011 65 66 67 68 69 70 71 `````` (d) If the instruction 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. `````` simonmar committed Aug 13, 2004 72 `````` `````` Ian Lynagh committed May 31, 2011 73 74 `````` (e) Delete all register assignments for temps which are read (only) and die here. Update the free register list. `````` simonmar committed Aug 13, 2004 75 `````` `````` Ian Lynagh committed May 31, 2011 76 77 78 `````` (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 Aug 13, 2004 79 `````` `````` Ian Lynagh committed May 31, 2011 80 81 82 83 84 85 `````` (g) For each temporary *written* by this instruction: Allocate a real register as for (b), spilling something else if necessary. - 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 86 `````` `````` Ian Lynagh committed May 31, 2011 87 88 89 `````` (h) Delete all register assignments for temps which are written and die here (there should rarely be any). Update the free register list. `````` simonmar committed Aug 13, 2004 90 `````` `````` Ian Lynagh committed May 31, 2011 91 `````` (i) Rewrite the instruction with the new mapping. `````` simonmar committed Aug 13, 2004 92 `````` `````` Ian Lynagh committed May 31, 2011 93 94 `````` (j) For each spilled reg known to be now dead, re-add its stack slot to the free list. `````` simonmar committed Aug 13, 2004 95 96 97 `````` -} `````` Ben.Lippmeier@anu.edu.au committed Feb 02, 2009 98 ``````module RegAlloc.Linear.Main ( `````` Ian Lynagh committed May 31, 2011 99 100 101 `````` regAlloc, module RegAlloc.Linear.Base, module RegAlloc.Linear.Stats `````` simonmar committed Aug 13, 2004 102 103 104 105 `````` ) where #include "HsVersions.h" `````` Ben.Lippmeier@anu.edu.au committed Feb 02, 2009 106 `````` `````` Herbert Valerio Riedel committed Sep 19, 2017 107 108 ``````import GhcPrelude `````` Ben.Lippmeier@anu.edu.au committed Feb 02, 2009 109 110 111 112 113 ``````import RegAlloc.Linear.State import RegAlloc.Linear.Base import RegAlloc.Linear.StackMap import RegAlloc.Linear.FreeRegs import RegAlloc.Linear.Stats `````` 114 ``````import RegAlloc.Linear.JoinToTargets `````` ian@well-typed.com committed Sep 10, 2012 115 116 117 118 ``````import qualified RegAlloc.Linear.PPC.FreeRegs as PPC import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC import qualified RegAlloc.Linear.X86.FreeRegs as X86 import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64 `````` Ben.Lippmeier@anu.edu.au committed Feb 15, 2009 119 ``````import TargetReg `````` Ben.Lippmeier@anu.edu.au committed Feb 04, 2009 120 ``````import RegAlloc.Liveness `````` Ben.Lippmeier@anu.edu.au committed Feb 15, 2009 121 122 ``````import Instruction import Reg `````` Ben.Lippmeier@anu.edu.au committed Feb 02, 2009 123 `````` `````` Sylvain Henry committed Jan 25, 2020 124 125 126 ``````import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections import GHC.Cmm hiding (RegSet) `````` simonmar committed Aug 13, 2004 127 128 `````` import Digraph `````` Ian Lynagh committed May 31, 2011 129 ``````import DynFlags `````` 130 ``````import Unique `````` simonmar committed Aug 13, 2004 131 ``````import UniqSet `````` Ian Lynagh committed Feb 07, 2008 132 ``````import UniqFM `````` wolfgang.thaller@gmx.net committed Feb 25, 2006 133 ``````import UniqSupply `````` simonmar committed Aug 13, 2004 134 ``````import Outputable `````` John Ericson committed Jun 19, 2019 135 ``````import GHC.Platform `````` simonmar committed Aug 13, 2004 136 `````` `````` Ian Lynagh committed Sep 08, 2007 137 138 139 ``````import Data.Maybe import Data.List import Control.Monad `````` simonmar committed Aug 13, 2004 140 141 142 143 `````` -- ----------------------------------------------------------------------------- -- Top level of the register allocator `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 144 ``````-- Allocate registers `````` Ian Lynagh committed May 31, 2011 145 ``````regAlloc `````` Ian Lynagh committed Jun 13, 2012 146 `````` :: (Outputable instr, Instruction instr) `````` Ian Lynagh committed May 31, 2011 147 `````` => DynFlags `````` Simon Peyton Jones committed Aug 25, 2011 148 `````` -> LiveCmmDecl statics instr `````` Simon Marlow committed Sep 20, 2012 149 150 151 `````` -> UniqSM ( NatCmmDecl statics instr , Maybe Int -- number of extra stack slots required, -- beyond maxSpillSlots `````` Andreas Klebinger committed Nov 17, 2018 152 153 `````` , Maybe RegAllocStats ) `````` Ian Lynagh committed May 31, 2011 154 `````` `````` Ian Lynagh committed May 31, 2011 155 ``````regAlloc _ (CmmData sec d) `````` Ian Lynagh committed May 31, 2011 156 157 `````` = return ( CmmData sec d `````` Simon Marlow committed Sep 20, 2012 158 `````` , Nothing `````` Ian Lynagh committed May 31, 2011 159 160 `````` , Nothing ) `````` gmainlan@microsoft.com committed Oct 30, 2012 161 162 ``````regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live []) = return ( CmmProc info lbl live (ListGraph []) `````` Simon Marlow committed Sep 20, 2012 163 `````` , Nothing `````` Ian Lynagh committed May 31, 2011 164 165 `````` , Nothing ) `````` gmainlan@microsoft.com committed Oct 30, 2012 166 ``````regAlloc dflags (CmmProc static lbl live sccs) `````` Andreas Klebinger committed Feb 15, 2019 167 `````` | LiveInfo info entry_ids@(first_id:_) block_live _ <- static `````` Ian Lynagh committed May 31, 2011 168 169 `````` = do -- do register allocation on each component. `````` Simon Marlow committed Sep 20, 2012 170 `````` (final_blocks, stats, stack_use) `````` Simon Marlow committed Jul 31, 2014 171 `````` <- linearRegAlloc dflags entry_ids block_live sccs `````` Ian Lynagh committed May 31, 2011 172 173 174 175 176 177 `````` -- 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 `````` Simon Marlow committed Sep 20, 2012 178 179 180 181 182 183 184 `````` let max_spill_slots = maxSpillSlots dflags extra_stack | stack_use > max_spill_slots = Just (stack_use - max_spill_slots) | otherwise = Nothing `````` gmainlan@microsoft.com committed Oct 30, 2012 185 `````` return ( CmmProc info lbl live (ListGraph (first' : rest')) `````` Simon Marlow committed Sep 20, 2012 186 `````` , extra_stack `````` Ian Lynagh committed May 31, 2011 187 188 `````` , Just stats) `````` Ben.Lippmeier@anu.edu.au committed Sep 05, 2007 189 ``````-- bogus. to make non-exhaustive match warning go away. `````` gmainlan@microsoft.com committed Oct 30, 2012 190 ``````regAlloc _ (CmmProc _ _ _ _) `````` Ian Lynagh committed May 31, 2011 191 `````` = panic "RegAllocLinear.regAlloc: no match" `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 192 `````` `````` wolfgang.thaller@gmx.net committed Feb 25, 2006 193 `````` `````` simonmar committed Aug 13, 2004 194 195 196 ``````-- ----------------------------------------------------------------------------- -- Linear sweep to allocate registers `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 197 198 `````` -- | Do register allocation on some basic blocks. `````` dias@eecs.harvard.edu committed Oct 16, 2008 199 200 ``````-- 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 201 ``````-- `````` simonmar committed Aug 13, 2004 202 ``````linearRegAlloc `````` Ian Lynagh committed Jun 13, 2012 203 `````` :: (Outputable instr, Instruction instr) `````` Ian Lynagh committed May 31, 2011 204 `````` => DynFlags `````` Simon Marlow committed Aug 01, 2014 205 206 207 208 209 `````` -> [BlockId] -- ^ entry points -> BlockMap RegSet -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" `````` Simon Marlow committed Sep 20, 2012 210 `````` -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 211 `````` `````` Simon Marlow committed Jul 31, 2014 212 ``````linearRegAlloc dflags entry_ids block_live sccs `````` Simon Marlow committed Aug 01, 2014 213 214 215 `````` = case platformArch platform of ArchX86 -> go \$ (frInitFreeRegs platform :: X86.FreeRegs) ArchX86_64 -> go \$ (frInitFreeRegs platform :: X86_64.FreeRegs) `````` Stefan Schulze Frielinghaus committed Oct 22, 2019 216 `````` ArchS390X -> panic "linearRegAlloc ArchS390X" `````` Simon Marlow committed Aug 01, 2014 217 `````` ArchSPARC -> go \$ (frInitFreeRegs platform :: SPARC.FreeRegs) `````` glaubitz committed Dec 19, 2015 218 `````` ArchSPARC64 -> panic "linearRegAlloc ArchSPARC64" `````` Simon Marlow committed Aug 01, 2014 219 220 221 `````` ArchPPC -> go \$ (frInitFreeRegs platform :: PPC.FreeRegs) ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" ArchARM64 -> panic "linearRegAlloc ArchARM64" `````` Peter Trommler committed Jul 03, 2015 222 `````` ArchPPC_64 _ -> go \$ (frInitFreeRegs platform :: PPC.FreeRegs) `````` Simon Marlow committed Aug 01, 2014 223 224 225 `````` ArchAlpha -> panic "linearRegAlloc ArchAlpha" ArchMipseb -> panic "linearRegAlloc ArchMipseb" ArchMipsel -> panic "linearRegAlloc ArchMipsel" `````` thoughtpolice committed Sep 06, 2013 226 `````` ArchJavaScript -> panic "linearRegAlloc ArchJavaScript" `````` Simon Marlow committed Aug 01, 2014 227 228 229 230 `````` ArchUnknown -> panic "linearRegAlloc ArchUnknown" where go f = linearRegAlloc' dflags f entry_ids block_live sccs platform = targetPlatform dflags `````` Ian Lynagh committed May 31, 2011 231 232 `````` linearRegAlloc' `````` Ian Lynagh committed Jun 13, 2012 233 `````` :: (FR freeRegs, Outputable instr, Instruction instr) `````` ian@well-typed.com committed Sep 14, 2012 234 `````` => DynFlags `````` Ian Lynagh committed Jul 15, 2011 235 `````` -> freeRegs `````` Simon Marlow committed Jul 31, 2014 236 `````` -> [BlockId] -- ^ entry points `````` Ian Lynagh committed May 31, 2011 237 238 `````` -> BlockMap RegSet -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" `````` Simon Marlow committed Sep 20, 2012 239 `````` -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) `````` Ian Lynagh committed May 31, 2011 240 `````` `````` Simon Marlow committed Jul 31, 2014 241 ``````linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs `````` thomie committed Sep 27, 2014 242 `````` = do us <- getUniqueSupplyM `````` Simon Marlow committed Sep 20, 2012 243 `````` let (_, stack, stats, blocks) = `````` Michal Terepeta committed Nov 29, 2016 244 `````` runR dflags mapEmpty initFreeRegs emptyRegMap (emptyStackMap dflags) us `````` Simon Marlow committed Jul 31, 2014 245 `````` \$ linearRA_SCCs entry_ids block_live [] sccs `````` Simon Marlow committed Sep 20, 2012 246 `````` return (blocks, stats, getStackUse stack) `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 247 `````` `````` Ian Lynagh committed May 31, 2011 248 `````` `````` Ian Lynagh committed Jun 13, 2012 249 ``````linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) `````` Simon Marlow committed Jul 31, 2014 250 `````` => [BlockId] `````` Ian Lynagh committed May 31, 2011 251 252 253 `````` -> BlockMap RegSet -> [NatBasicBlock instr] -> [SCC (LiveBasicBlock instr)] `````` Ian Lynagh committed May 31, 2011 254 `````` -> RegM freeRegs [NatBasicBlock instr] `````` Ian Lynagh committed May 31, 2011 255 `````` `````` ian@well-typed.com committed Sep 14, 2012 256 ``````linearRA_SCCs _ _ blocksAcc [] `````` Ian Lynagh committed May 31, 2011 257 `````` = return \$ reverse blocksAcc `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 258 `````` `````` Simon Marlow committed Jul 31, 2014 259 ``````linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs) `````` ian@well-typed.com committed Sep 14, 2012 260 `````` = do blocks' <- processBlock block_live block `````` Simon Marlow committed Jul 31, 2014 261 `````` linearRA_SCCs entry_ids block_live `````` Ian Lynagh committed May 31, 2011 262 263 `````` ((reverse blocks') ++ blocksAcc) sccs `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 264 `````` `````` Simon Marlow committed Jul 31, 2014 265 ``````linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs) `````` Ben.Lippmeier@anu.edu.au committed Feb 13, 2009 266 `````` = do `````` Simon Marlow committed Jul 31, 2014 267 268 `````` blockss' <- process entry_ids block_live blocks [] (return []) False linearRA_SCCs entry_ids block_live `````` Ian Lynagh committed May 31, 2011 269 270 `````` (reverse (concat blockss') ++ blocksAcc) sccs `````` Ben.Lippmeier@anu.edu.au committed Feb 13, 2009 271 272 273 `````` {- from John Dias's patch 2008/10/16: The linear-scan allocator sometimes allocates a block `````` Ian Lynagh committed May 31, 2011 274 `````` before allocating one of its predecessors, which could lead to `````` Ben.Lippmeier@anu.edu.au committed Feb 13, 2009 275 276 277 278 279 `````` inconsistent allocations. Make it so a block is only allocated if a predecessor has set the "incoming" assignments for the block, or if it's the procedure's entry block. BL 2009/02: Careful. If the assignment for a block doesn't get set for `````` Ian Lynagh committed May 31, 2011 280 `````` some reason then this function will loop. We should probably do some `````` Ben.Lippmeier@anu.edu.au committed Feb 13, 2009 281 282 `````` more sanity checking to guard against this eventuality. -} `````` benl@ouroborus.net committed Jun 23, 2010 283 `````` `````` Ian Lynagh committed Jun 13, 2012 284 ``````process :: (FR freeRegs, Instruction instr, Outputable instr) `````` Simon Marlow committed Jul 31, 2014 285 `````` => [BlockId] `````` Ian Lynagh committed May 31, 2011 286 287 288 289 290 `````` -> BlockMap RegSet -> [GenBasicBlock (LiveInstr instr)] -> [GenBasicBlock (LiveInstr instr)] -> [[NatBasicBlock instr]] -> Bool `````` Ian Lynagh committed May 31, 2011 291 `````` -> RegM freeRegs [[NatBasicBlock instr]] `````` Ian Lynagh committed May 31, 2011 292 `````` `````` ian@well-typed.com committed Sep 14, 2012 293 ``````process _ _ [] [] accum _ `````` Ian Lynagh committed May 31, 2011 294 `````` = return \$ reverse accum `````` Ben.Lippmeier@anu.edu.au committed Feb 13, 2009 295 `````` `````` Simon Marlow committed Jul 31, 2014 296 ``````process entry_ids block_live [] next_round accum madeProgress `````` Ian Lynagh committed May 31, 2011 297 298 299 300 301 302 303 304 305 `````` | not madeProgress {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out." ( text "Unreachable blocks:" \$\$ vcat (map ppr next_round)) -} = return \$ reverse accum | otherwise `````` Simon Marlow committed Jul 31, 2014 306 `````` = process entry_ids block_live `````` Ian Lynagh committed May 31, 2011 307 308 `````` next_round [] accum False `````` Simon Marlow committed Jul 31, 2014 309 ``````process entry_ids block_live (b@(BasicBlock id _) : blocks) `````` Ian Lynagh committed May 31, 2011 310 311 312 313 314 `````` next_round accum madeProgress = do block_assig <- getBlockAssigR if isJust (mapLookup id block_assig) `````` Simon Marlow committed Jul 31, 2014 315 `````` || id `elem` entry_ids `````` Ian Lynagh committed May 31, 2011 316 `````` then do `````` ian@well-typed.com committed Sep 14, 2012 317 `````` b' <- processBlock block_live b `````` Simon Marlow committed Jul 31, 2014 318 `````` process entry_ids block_live blocks `````` Ian Lynagh committed May 31, 2011 319 `````` next_round (b' : accum) True `````` Ben.Lippmeier@anu.edu.au committed Feb 13, 2009 320 `````` `````` Simon Marlow committed Jul 31, 2014 321 `````` else process entry_ids block_live blocks `````` Ian Lynagh committed May 31, 2011 322 `````` (b : next_round) accum madeProgress `````` Ben.Lippmeier@anu.edu.au committed Feb 13, 2009 323 `````` `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 324 325 326 327 `````` -- | Do register allocation on this basic block -- processBlock `````` Ian Lynagh committed Jun 13, 2012 328 `````` :: (FR freeRegs, Outputable instr, Instruction instr) `````` ian@well-typed.com committed Sep 14, 2012 329 `````` => BlockMap RegSet -- ^ live regs on entry to each basic block `````` Ian Lynagh committed May 31, 2011 330 `````` -> LiveBasicBlock instr -- ^ block to do register allocation on `````` Ian Lynagh committed May 31, 2011 331 `````` -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 332 `````` `````` ian@well-typed.com committed Sep 14, 2012 333 334 ``````processBlock block_live (BasicBlock id instrs) = do initBlock id block_live `````` Ian Lynagh committed May 31, 2011 335 `````` (instrs', fixups) `````` ian@well-typed.com committed Sep 14, 2012 336 `````` <- linearRA block_live [] [] id instrs `````` Ian Lynagh committed May 31, 2011 337 `````` return \$ BasicBlock id instrs' : fixups `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 338 339 340 `````` -- | Load the freeregs and current reg assignment into the RegM state `````` Ian Lynagh committed May 31, 2011 341 ``````-- for the basic block with this BlockId. `````` ian@well-typed.com committed Aug 21, 2012 342 ``````initBlock :: FR freeRegs `````` ian@well-typed.com committed Sep 14, 2012 343 344 345 346 347 `````` => BlockId -> BlockMap RegSet -> RegM freeRegs () initBlock id block_live = do dflags <- getDynFlags let platform = targetPlatform dflags block_assig <- getBlockAssigR `````` Ian Lynagh committed May 31, 2011 348 `````` case mapLookup id block_assig of `````` Simon Marlow committed Jul 06, 2012 349 350 351 352 353 `````` -- no prior info about this block: we must consider -- any fixed regs to be allocated, but we can ignore -- virtual regs (presumably this is part of a loop, -- and we'll iterate again). The assignment begins -- empty. `````` Ian Lynagh committed May 31, 2011 354 355 `````` Nothing -> do -- pprTrace "initFreeRegs" (text \$ show initFreeRegs) (return ()) `````` Simon Marlow committed Jul 06, 2012 356 357 `````` case mapLookup id block_live of Nothing -> `````` ian@well-typed.com committed Aug 21, 2012 358 `````` setFreeRegsR (frInitFreeRegs platform) `````` Simon Marlow committed Jul 06, 2012 359 `````` Just live -> `````` Ben Gamari committed Jan 24, 2017 360 `````` setFreeRegsR \$ foldl' (flip \$ frAllocateReg platform) (frInitFreeRegs platform) `````` David Feuer committed Mar 01, 2017 361 `````` [ r | RegReal r <- nonDetEltsUniqSet live ] `````` niteria committed Jul 01, 2016 362 `````` -- See Note [Unique Determinism and code generation] `````` Ian Lynagh committed May 31, 2011 363 364 365 366 367 368 `````` setAssigR emptyRegMap -- load info about register assignments leading into this block. Just (freeregs, assig) -> do setFreeRegsR freeregs setAssigR assig `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 369 370 `````` `````` 371 ``````-- | Do allocation for a sequence of instructions. `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 372 ``````linearRA `````` Ian Lynagh committed Jun 13, 2012 373 `````` :: (FR freeRegs, Outputable instr, Instruction instr) `````` ian@well-typed.com committed Sep 14, 2012 374 `````` => BlockMap RegSet -- ^ map of what vregs are live on entry to each block. `````` Ian Lynagh committed May 31, 2011 375 376 377 378 `````` -> [instr] -- ^ accumulator for instructions already processed. -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code. -> BlockId -- ^ id of the current block, for debugging. -> [LiveInstr instr] -- ^ liveness annotated instructions in this block. `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 379 `````` `````` Ian Lynagh committed May 31, 2011 380 `````` -> RegM freeRegs `````` Ian Lynagh committed May 31, 2011 381 `````` ( [instr] -- instructions after register allocation `````` Ian Lynagh committed May 31, 2011 382 `````` , [NatBasicBlock instr]) -- fresh blocks of fixup code. `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 383 `````` `````` simonmar committed Aug 13, 2004 384 `````` `````` ian@well-typed.com committed Sep 14, 2012 385 ``````linearRA _ accInstr accFixup _ [] `````` Ian Lynagh committed May 31, 2011 386 387 388 `````` = 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. `````` 389 390 `````` `````` ian@well-typed.com committed Sep 14, 2012 391 ``````linearRA block_live accInstr accFixups id (instr:instrs) `````` 392 `````` = do `````` ian@well-typed.com committed Sep 14, 2012 393 `````` (accInstr', new_fixups) <- raInsn block_live accInstr id instr `````` 394 `````` `````` ian@well-typed.com committed Sep 14, 2012 395 `````` linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs `````` simonmar committed Aug 13, 2004 396 397 `````` `````` 398 ``````-- | Do allocation for a single instruction. `````` Ian Lynagh committed May 31, 2011 399 ``````raInsn `````` Ian Lynagh committed Jun 13, 2012 400 `````` :: (FR freeRegs, Outputable instr, Instruction instr) `````` ian@well-typed.com committed Sep 14, 2012 401 `````` => BlockMap RegSet -- ^ map of what vregs are love on entry to each block. `````` Ian Lynagh committed May 31, 2011 402 403 404 `````` -> [instr] -- ^ accumulator for instructions already processed. -> BlockId -- ^ the id of the current block, for debugging -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. `````` Ian Lynagh committed May 31, 2011 405 `````` -> RegM freeRegs `````` Ian Lynagh committed May 31, 2011 406 407 `````` ( [instr] -- new instructions , [NatBasicBlock instr]) -- extra fixup blocks `````` Ben.Lippmeier@anu.edu.au committed Feb 15, 2009 408 `````` `````` ian@well-typed.com committed Sep 14, 2012 409 ``````raInsn _ new_instrs _ (LiveInstr ii Nothing) `````` Ian Lynagh committed May 31, 2011 410 411 412 413 `````` | Just n <- takeDeltaInstr ii = do setDeltaR n return (new_instrs, []) `````` Peter Wortmann committed Dec 16, 2014 414 ``````raInsn _ new_instrs _ (LiveInstr ii@(Instr i) Nothing) `````` Ian Lynagh committed May 31, 2011 415 `````` | isMetaInstr ii `````` Peter Wortmann committed Dec 16, 2014 416 `````` = return (i : new_instrs, []) `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 417 `````` `````` simonmar committed Aug 13, 2004 418 `````` `````` ian@well-typed.com committed Sep 14, 2012 419 ``````raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 420 `````` = do `````` simonmar committed Aug 13, 2004 421 422 423 424 `````` 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 `````` 425 426 427 `````` -- 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. `````` Edward Z. Yang committed Apr 04, 2011 428 `````` -- (we can't eliminate it if the source register is on the stack, because `````` 429 `````` -- we do not want to use one spill slot for different virtual registers) `````` Ben.Lippmeier@anu.edu.au committed Feb 15, 2009 430 `````` case takeRegRegMoveInstr instr of `````` Ian Lynagh committed May 31, 2011 431 432 433 `````` Just (src,dst) | src `elementOfUniqSet` (liveDieRead live), isVirtualReg dst, not (dst `elemUFM` assig), `````` Simon Marlow committed Jul 06, 2012 434 `````` isRealReg src || isInReg src assig -> do `````` Ian Lynagh committed May 31, 2011 435 436 437 438 439 440 441 442 443 444 445 `````` case src of (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr)) -- 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) -- we have eliminated this instruction `````` dias@eecs.harvard.edu committed Oct 16, 2008 446 `````` {- `````` Ian Lynagh committed May 31, 2011 447 448 449 450 `````` freeregs <- getFreeRegsR assig <- getAssigR 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 451 `````` -} `````` Ian Lynagh committed May 31, 2011 452 `````` return (new_instrs, []) `````` simonmar committed Aug 13, 2004 453 `````` `````` ian@well-typed.com committed Sep 14, 2012 454 `````` _ -> genRaInsn block_live new_instrs id instr `````` David Feuer committed Mar 01, 2017 455 456 `````` (nonDetEltsUniqSet \$ liveDieRead live) (nonDetEltsUniqSet \$ liveDieWrite live) `````` niteria committed Jul 01, 2016 457 `````` -- See Note [Unique Determinism and code generation] `````` Ben.Lippmeier@anu.edu.au committed Aug 14, 2007 458 `````` `````` ian@well-typed.com committed Sep 14, 2012 459 ``````raInsn _ _ _ instr `````` Ian Lynagh committed Jun 13, 2012 460 `````` = pprPanic "raInsn" (text "no match for:" <> ppr instr) `````` 461 `````` `````` Simon Marlow committed Oct 08, 2012 462 463 464 465 466 467 468 469 470 471 472 473 ``````-- ToDo: what can we do about -- -- R1 = x -- jump I64[x] // [R1] -- -- where x is mapped to the same reg as R1. We want to coalesce x and -- R1, but the register allocator doesn't know whether x will be -- assigned to again later, in which case x and R1 should be in -- different registers. Right now we assume the worst, and the -- assignment to R1 will clobber x, so we'll spill x into another reg, -- generating another reg->reg move. `````` 474 `````` `````` Simon Marlow committed Jul 06, 2012 475 476 477 478 479 ``````isInReg :: Reg -> RegMap Loc -> Bool isInReg src assig | Just (InReg _) <- lookupUFM assig src = True | otherwise = False `````` Ian Lynagh committed Jun 13, 2012 480 ``````genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) `````` ian@well-typed.com committed Sep 14, 2012 481 `````` => BlockMap RegSet `````` Ian Lynagh committed May 31, 2011 482 483 484 485 486 `````` -> [instr] -> BlockId -> instr -> [Reg] -> [Reg] `````` Ian Lynagh committed May 31, 2011 487 `````` -> RegM freeRegs ([instr], [NatBasicBlock instr]) `````` simonmar committed Aug 13, 2004 488 `````` `````` ian@well-typed.com committed Sep 14, 2012 489 490 491 492 ``````genRaInsn block_live new_instrs block_id instr r_dying w_dying = do dflags <- getDynFlags let platform = targetPlatform dflags case regUsageOfInstr platform instr of { RU read written -> `````` simonmar committed Jul 26, 2005 493 `````` do `````` Ian Lynagh committed May 31, 2011 494 495 `````` let real_written = [ rr | (RegReal rr) <- written ] let virt_written = [ vr | (RegVirtual vr) <- written ] `````` simonmar committed Aug 13, 2004 496 `````` `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 497 498 499 `````` -- 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). `````` Ian Lynagh committed May 31, 2011 500 `````` let virt_read = nub [ vr | (RegVirtual vr) <- read ] `````` simonmar committed Aug 13, 2004 501 `````` `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 502 `````` -- debugging `````` benl@ouroborus.net committed Jun 23, 2010 503 ``````{- freeregs <- getFreeRegsR `````` Ben.Lippmeier@anu.edu.au committed Feb 13, 2009 504 `````` assig <- getAssigR `````` Moritz Angermann committed Sep 06, 2017 505 `````` pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform } undefined) trace "genRaInsn" `````` Ian Lynagh committed May 31, 2011 506 507 508 509 510 511 512 513 `````` (ppr instr \$\$ text "r_dying = " <+> ppr r_dying \$\$ text "w_dying = " <+> ppr w_dying \$\$ text "virt_read = " <+> ppr virt_read \$\$ text "virt_written = " <+> ppr virt_written \$\$ text "freeregs = " <+> text (show freeregs) \$\$ text "assig = " <+> ppr assig) \$ do `````` Ben.Lippmeier@anu.edu.au committed Jan 14, 2009 514 ``````-} `````` simonmar committed Aug 13, 2004 515 `````` `````` Simon Marlow committed Jul 31, 2012 516 `````` -- (a), (b) allocate real regs for all regs read by this instruction. `````` Ian Lynagh committed May 31, 2011 517 `````` (r_spills, r_allocd) <- `````` ian@well-typed.com committed Sep 14, 2012 518 `````` allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read `````` simonmar committed Aug 13, 2004 519 `````` `````` Simon Marlow committed Aug 02, 2012 520 `````` -- (c) save any temporaries which will be clobbered by this instruction `````` ian@well-typed.com committed Sep 14, 2012 521 `````` clobber_saves <- saveClobberedTemps real_written r_dying `````` Simon Marlow committed Jul 31, 2012 522 `````` `````` simonmar committed Aug 13, 2004 523 524 525 526 527 `````` -- (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) `````` ian@well-typed.com committed Sep 14, 2012 528 `````` <- joinToTargets block_live block_id instr `````` simonmar committed Aug 13, 2004 529 `````` `````` Andreas Klebinger committed Nov 17, 2018 530 531 532 533 534 `````` -- Debugging - show places where the reg alloc inserted -- assignment fixup blocks. -- when (not \$ null fixup_blocks) \$ -- pprTrace "fixup_blocks" (ppr fixup_blocks) (return ()) `````` simonmar committed Aug 13, 2004 535 536 `````` -- (e) Delete all register assignments for temps which are read -- (only) and die here. Update the free register list. `````` ian@well-typed.com committed Sep 14, 2012 537 `````` releaseRegs r_dying `````` simonmar committed Aug 13, 2004 538 539 `````` -- (f) Mark regs which are clobbered as unallocatable `````` ian@well-typed.com committed Sep 14, 2012 540 `````` clobberRegs real_written `````` simonmar committed Aug 13, 2004 541 542 `````` -- (g) Allocate registers for temporaries *written* (only) `````` Ian Lynagh committed May 31, 2011 543 `````` (w_spills, w_allocd) <- `````` ian@well-typed.com committed Sep 14, 2012 544 `````` allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written `````` simonmar committed Aug 13, 2004 545 546 547 `````` -- (h) Release registers for temps which are written here and not -- used again. `````` ian@well-typed.com committed Sep 14, 2012 548 `````` releaseRegs w_dying `````` simonmar committed Aug 13, 2004 549 550 `````` let `````` Ian Lynagh committed May 31, 2011 551 552 553 554 555 556 `````` -- (i) Patch the instruction patch_map = listToUFM [ (t, RegReal r) | (t, r) <- zip virt_read r_allocd ++ zip virt_written w_allocd ] `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 557 `````` `````` Ian Lynagh committed May 31, 2011 558 559 `````` patched_instr = patchRegsOfInstr adjusted_instr patchLookup `````` simonmar committed Aug 13, 2004 560 `````` `````` Ian Lynagh committed May 31, 2011 561 562 563 564 `````` patchLookup x = case lookupUFM patch_map x of Nothing -> x Just y -> y `````` simonmar committed Aug 13, 2004 565 566 567 568 569 `````` -- (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 570 `````` -- erase reg->reg moves where the source and destination are the same. `````` Ian Lynagh committed May 31, 2011 571 572 573 574 575 576 `````` -- 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. let squashed_instr = case takeRegRegMoveInstr patched_instr of Just (src, dst) | src == dst -> [] _ -> [patched_instr] `````` Ben.Lippmeier@anu.edu.au committed Aug 23, 2007 577 `````` `````` Ben.Lippmeier@anu.edu.au committed Feb 13, 2009 578 `````` let code = squashed_instr ++ w_spills ++ reverse r_spills `````` Ian Lynagh committed May 31, 2011 579 `````` ++ clobber_saves ++ new_instrs `````` Ben.Lippmeier@anu.edu.au committed Feb 13, 2009 580 581 582 583 584 585 `````` -- pprTrace "patched-code" ((vcat \$ map (docToSDoc . pprInstr) code)) \$ do -- pprTrace "pached-fixup" ((ppr fixup_blocks)) \$ do return (code, fixup_blocks) `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 586 `````` } `````` simonmar committed Aug 13, 2004 587 588 589 590 `````` -- ----------------------------------------------------------------------------- -- releaseRegs `````` ian@well-typed.com committed Sep 14, 2012 591 592 593 594 ``````releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () releaseRegs regs = do dflags <- getDynFlags let platform = targetPlatform dflags `````` simonmar committed Aug 13, 2004 595 596 `````` assig <- getAssigR free <- getFreeRegsR `````` Ömer Sinan Ağacan committed Jun 27, 2016 597 598 599 `````` let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return () loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs loop assig !free (r:rs) = `````` ian@well-typed.com committed Sep 14, 2012 600 601 602 603 604 605 `````` case lookupUFM assig r of Just (InBoth real _) -> loop (delFromUFM assig r) (frReleaseReg platform real free) rs Just (InReg real) -> loop (delFromUFM assig r) (frReleaseReg platform real free) rs _ -> loop (delFromUFM assig r) free rs `````` Ian Lynagh committed May 31, 2011 606 `````` loop assig free regs `````` simonmar committed Aug 13, 2004 607 `````` `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 608 `````` `````` simonmar committed Aug 13, 2004 609 610 611 ``````-- ----------------------------------------------------------------------------- -- Clobber real registers `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 612 ``````-- For each temp in a register that is going to be clobbered: `````` Ian Lynagh committed May 31, 2011 613 614 615 616 617 ``````-- - 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. `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 618 ``````-- `````` Ian Lynagh committed May 31, 2011 619 620 ``````-- for allocateRegs on the temps *written*, -- - clobbered regs are not allocatable. `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 621 ``````-- `````` simonmar committed Aug 13, 2004 622 623 `````` saveClobberedTemps `````` 624 `````` :: (Instruction instr, FR freeRegs) `````` ian@well-typed.com committed Sep 14, 2012 625 `````` => [RealReg] -- real registers clobbered by this instruction `````` Ian Lynagh committed May 31, 2011 626 `````` -> [Reg] -- registers which are no longer live after this insn `````` Ian Lynagh committed May 31, 2011 627 `````` -> RegM freeRegs [instr] -- return: instructions to spill any temps that will `````` Ian Lynagh committed May 31, 2011 628 `````` -- be clobbered. `````` simonmar committed Aug 13, 2004 629 `````` `````` ian@well-typed.com committed Sep 14, 2012 630 ``````saveClobberedTemps [] _ `````` Ian Lynagh committed May 31, 2011 631 `````` = return [] `````` Ben.Lippmeier@anu.edu.au committed Jan 14, 2009 632 `````` `````` ian@well-typed.com committed Sep 14, 2012 633 ``````saveClobberedTemps clobbered dying `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 634 `````` = do `````` Ian Lynagh committed May 31, 2011 635 636 637 `````` assig <- getAssigR let to_spill = [ (temp,reg) `````` niteria committed Jun 30, 2016 638 639 640 641 `````` | (temp, InReg reg) <- nonDetUFMToList assig -- This is non-deterministic but we do not -- currently support deterministic code-generation. -- See Note [Unique Determinism and code generation] `````` Ian Lynagh committed May 31, 2011 642 643 `````` , any (realRegsAlias reg) clobbered , temp `notElem` map getUnique dying ] `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 644 `````` `````` Ian Lynagh committed May 31, 2011 645 646 647 `````` (instrs,assig') <- clobber assig [] to_spill setAssigR assig' return instrs `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 648 649 `````` where `````` Simon Marlow committed Jul 31, 2012 650 651 652 653 `````` clobber assig instrs [] = return (instrs, assig) clobber assig instrs ((temp, reg) : rest) `````` ian@well-typed.com committed Sep 14, 2012 654 655 656 `````` = do dflags <- getDynFlags let platform = targetPlatform dflags `````` Simon Marlow committed Jul 31, 2012 657 658 `````` freeRegs <- getFreeRegsR let regclass = targetClassOfRealReg platform reg `````` ian@well-typed.com committed Aug 21, 2012 659 `````` freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs `````` Simon Marlow committed Jul 31, 2012 660 661 662 663 664 665 666 `````` case filter (`notElem` clobbered) freeRegs_thisClass of -- (1) we have a free reg of the right class that isn't -- clobbered by this instruction; use it to save the -- clobbered value. (my_reg : _) -> do `````` ian@well-typed.com committed Aug 28, 2012 667 `````` setFreeRegsR (frAllocateReg platform my_reg freeRegs) `````` Simon Marlow committed Jul 31, 2012 668 669 670 671 672 673 674 675 676 `````` let new_assign = addToUFM assig temp (InReg my_reg) let instr = mkRegRegMoveInstr platform (RegReal reg) (RegReal my_reg) clobber new_assign (instr : instrs) rest -- (2) no free registers: spill the value [] -> do `````` ian@well-typed.com committed Sep 14, 2012 677 `````` (spill, slot) <- spillR (RegReal reg) temp `````` eir@cis.upenn.edu committed Dec 11, 2015 678 `````` `````` Simon Marlow committed Jul 31, 2012 679 680 `````` -- record why this reg was spilled for profiling recordSpill (SpillClobber temp) `````` eir@cis.upenn.edu committed Dec 11, 2015 681 `````` `````` Simon Marlow committed Jul 31, 2012 682 `````` let new_assign = addToUFM assig temp (InBoth reg slot) `````` eir@cis.upenn.edu committed Dec 11, 2015 683 `````` `````` Simon Marlow committed Jul 31, 2012 684 `````` clobber new_assign (spill : instrs) rest `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 685 686 687 `````` `````` Edward Z. Yang committed Apr 04, 2011 688 ``````-- | Mark all these real regs as allocated, `````` Ian Lynagh committed May 31, 2011 689 ``````-- and kick out their vreg assignments. `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 690 ``````-- `````` ian@well-typed.com committed Sep 14, 2012 691 692 ``````clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs () clobberRegs [] `````` Ian Lynagh committed May 31, 2011 693 `````` = return () `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 694 `````` `````` ian@well-typed.com committed Sep 14, 2012 695 696 697 698 ``````clobberRegs clobbered = do dflags <- getDynFlags let platform = targetPlatform dflags `````` Ian Lynagh committed May 31, 2011 699 `````` freeregs <- getFreeRegsR `````` Ben Gamari committed Jan 24, 2017 700 `````` setFreeRegsR \$! foldl' (flip \$ frAllocateReg platform) freeregs clobbered `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 701 `````` `````` Ian Lynagh committed May 31, 2011 702 `````` assig <- getAssigR `````` niteria committed Jun 30, 2016 703 704 705 706 `````` setAssigR \$! clobber assig (nonDetUFMToList assig) -- This is non-deterministic but we do not -- currently support deterministic code-generation. -- See Note [Unique Determinism and code generation] `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 707 708 `````` where `````` Ian Lynagh committed May 31, 2011 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 `````` -- 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) | any (realRegsAlias reg) clobbered = clobber (addToUFM assig temp (InMem slot)) rest clobber assig (_:rest) = clobber assig rest `````` simonmar committed Aug 13, 2004 724 725 726 727 `````` -- ----------------------------------------------------------------------------- -- allocateRegsAndSpill `````` Edward Z. Yang committed Apr 05, 2011 728 729 730 731 732 733 734 735 736 737 ``````-- Why are we performing a spill? data SpillLoc = ReadMem StackSlot -- reading from register only in memory | WriteNew -- writing to a new variable | WriteMem -- writing to register only in memory -- Note that ReadNew is not valid, since you don't want to be reading -- from an uninitialized register. We also don't need the location of -- the register in memory, since that will be invalidated by the write. -- Technically, we could coalesce WriteNew and WriteMem into a single -- entry as well. -- EZY `````` simonmar committed Aug 13, 2004 738 739 740 741 742 743 744 745 ``````-- 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 `````` Ian Lynagh committed Jun 13, 2012 746 `````` :: (FR freeRegs, Outputable instr, Instruction instr) `````` ian@well-typed.com committed Sep 14, 2012 747 `````` => Bool -- True <=> reading (load up spilled regs) `````` Ian Lynagh committed May 31, 2011 748 749 750 751 `````` -> [VirtualReg] -- don't push these out -> [instr] -- spill insns -> [RealReg] -- real registers allocated (accum.) -> [VirtualReg] -- temps to allocate `````` Ian Lynagh committed May 31, 2011 752 `````` -> RegM freeRegs ( [instr] , [RealReg]) `````` simonmar committed Aug 13, 2004 753 `````` `````` ian@well-typed.com committed Sep 14, 2012 754 ``````allocateRegsAndSpill _ _ spills alloc [] `````` Ian Lynagh committed May 31, 2011 755 756 `````` = return (spills, reverse alloc) `````` ian@well-typed.com committed Sep 14, 2012 757 ``````allocateRegsAndSpill reading keep spills alloc (r:rs) `````` Ian Lynagh committed May 31, 2011 758 `````` = do assig <- getAssigR `````` ian@well-typed.com committed Sep 14, 2012 759 `````` let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig `````` Ian Lynagh committed May 31, 2011 760 761 762 `````` case lookupUFM assig r of -- case (1a): already in a register Just (InReg my_reg) -> `````` ian@well-typed.com committed Sep 14, 2012 763 `````` allocateRegsAndSpill reading keep spills (my_reg:alloc) rs `````` Ian Lynagh committed May 31, 2011 764 765 766 767 768 769 770 771 `````` -- case (1b): already in a register (and memory) -- NB1. if we're writing this register, update its assignment to be -- InReg, because the memory value is no longer valid. -- NB2. This is why we must process written registers here, even if they -- are also read by the same instruction. Just (InBoth my_reg _) -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) `````` ian@well-typed.com committed Sep 14, 2012 772 `````` allocateRegsAndSpill reading keep spills (my_reg:alloc) rs `````` Ian Lynagh committed May 31, 2011 773 774 775 776 `````` -- Not already in a register, so we need to find a free one... Just (InMem slot) | reading -> doSpill (ReadMem slot) | otherwise -> doSpill WriteMem `````` Simon Marlow committed Apr 05, 2011 777 `````` Nothing | reading -> `````` Simon Marlow committed Nov 12, 2012 778 779 780 781 `````` pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r) -- NOTE: if the input to the NCG contains some -- unreachable blocks with junk code, this panic -- might be triggered. Make sure you only feed `````` Sylvain Henry committed Jan 25, 2020 782 `````` -- sensible code into the NCG. In GHC.Cmm.Pipeline we `````` Simon Marlow committed Nov 12, 2012 783 784 `````` -- call removeUnreachableBlocks at the end for this -- reason. `````` Simon Marlow committed Apr 05, 2011 785 `````` `````` Ian Lynagh committed May 31, 2011 786 787 `````` | otherwise -> doSpill WriteNew `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 788 `````` `````` Edward Z. Yang committed Apr 05, 2011 789 790 ``````-- reading is redundant with reason, but we keep it around because it's -- convenient and it maintains the recursive structure of the allocator. -- EZY `````` Ian Lynagh committed Jun 13, 2012 791 ``````allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) `````` ian@well-typed.com committed Sep 14, 2012 792 `````` => Bool `````` Ian Lynagh committed May 31, 2011 793 794 795 796 797 798 799 `````` -> [VirtualReg] -> [instr] -> [RealReg] -> VirtualReg -> [VirtualReg] -> UniqFM Loc -> SpillLoc `````` Ian Lynagh committed May 31, 2011 800 `````` -> RegM freeRegs ([instr], [RealReg]) `````` ian@well-typed.com committed Sep 14, 2012 801 802 803 ``````allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc = do dflags <- getDynFlags let platform = targetPlatform dflags `````` Ian Lynagh committed May 31, 2011 804 `````` freeRegs <- getFreeRegsR `````` ian@well-typed.com committed Aug 21, 2012 805 `````` let freeRegs_thisClass = frGetFreeRegs platform (classOfVirtualReg r) freeRegs `````` Ben.Lippmeier@anu.edu.au committed May 18, 2009 806 807 808 `````` case freeRegs_thisClass of `````` Ian Lynagh committed May 31, 2011 809 810 `````` -- case (2): we have a free register (my_reg : _) -> `````` ian@well-typed.com committed Sep 14, 2012 811 `````` do spills' <- loadTemp r spill_loc my_reg spills `````` Ian Lynagh committed May 31, 2011 812 813 `````` setAssigR (addToUFM assig r \$! newLocation spill_loc my_reg) `````` ian@well-typed.com committed Aug 28, 2012 814 `````` setFreeRegsR \$ frAllocateReg platform my_reg freeRegs `````` Ian Lynagh committed May 31, 2011 815 `````` `````` ian@well-typed.com committed Sep 14, 2012 816 `````` allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs `````` Ian Lynagh committed May 31, 2011 817 818 819 820 `````` -- case (3): we need to push something out to free up a register [] -> `````` Tobias Dammers committed Oct 25, 2017 821 822 823 824 825 826 827 828 829 830 831 `````` do let inRegOrBoth (InReg _) = True inRegOrBoth (InBoth _ _) = True inRegOrBoth _ = False let candidates' = flip delListFromUFM keep \$ filterUFM inRegOrBoth \$ assig -- This is non-deterministic but we do not -- currently support deterministic code-generation. -- See Note [Unique Determinism and code generation] let candidates = nonDetUFMToList candidates' `````` Ian Lynagh committed May 31, 2011 832 833 834 835 `````` -- the vregs we could kick out that are already in a slot let candidates_inBoth = [ (temp, reg, mem) `````` Tobias Dammers committed Oct 25, 2017 836 `````` | (temp, InBoth reg mem) <- candidates `````` niteria committed Jun 30, 2016 837 `````` , targetClassOfRealReg platform reg == classOfVirtualReg r ] `````` Ian Lynagh committed May 31, 2011 838 839 840 841 842 `````` -- the vregs we could kick out that are only in a reg -- this would require writing the reg to a new slot before using it. let candidates_inReg = [ (temp, reg) `````` Tobias Dammers committed Oct 25, 2017 843 `````` | (temp, InReg reg) <- candidates `````` niteria committed Jun 30, 2016 844 `````` , targetClassOfRealReg platform reg == classOfVirtualReg r ] `````` Ian Lynagh committed May 31, 2011 845 846 847 848 849 850 `````` let result -- we have a temporary that is in both register and mem, -- just free up its register for use. | (temp, my_reg, slot) : _ <- candidates_inBoth `````` ian@well-typed.com committed Sep 14, 2012 851 `````` = do spills' <- loadTemp r spill_loc my_reg spills `````` Ian Lynagh committed May 31, 2011 852 853 854 855 `````` let assig1 = addToUFM assig temp (InMem slot) let assig2 = addToUFM assig1 r \$! newLocation spill_loc my_reg setAssigR assig2 `````` ian@well-typed.com committed Sep 14, 2012 856 `````` allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs `````` Ian Lynagh committed May 31, 2011 857 858 859 860 861 862 `````` -- otherwise, we need to spill a temporary that currently -- resides in a register. | (temp_to_push_out, (my_reg :: RealReg)) : _ <- candidates_inReg = do `````` ian@well-typed.com committed Sep 14, 2012 863 `````` (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out `````` Ian Lynagh committed May 31, 2011 864 865 866 867 868 869 870 871 872 873 874 875 876 `````` let spill_store = (if reading then id else reverse) [ -- COMMENT (fsLit "spill alloc") 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 \$! newLocation spill_loc my_reg setAssigR assig2 -- if need be, load up a spilled temp into the reg we've just freed up. `````` ian@well-typed.com committed Sep 14, 2012 877 `````` spills' <- loadTemp r spill_loc my_reg spills `````` Ian Lynagh committed May 31, 2011 878 `````` `````` ian@well-typed.com committed Sep 14, 2012 879 `````` allocateRegsAndSpill reading keep `````` Ian Lynagh committed May 31, 2011 880 881 882 883 884 885 886 887 888 `````` (spill_store ++ spills') (my_reg:alloc) rs -- there wasn't anything to spill, so we're screwed. | otherwise = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n") \$ vcat [ text "allocating vreg: " <> text (show r) `````` niteria committed Jun 30, 2016 889 `````` , text "assignment: " <> ppr assig `````` Ben Gamari committed Jul 16, 2019 890 891 `````` , text "freeRegs: " <> text (show freeRegs) , text "initFreeRegs: " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ] `````` Ian Lynagh committed May 31, 2011 892 893 894 `````` result `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 895 `````` `````` Edward Z. Yang committed Apr 05, 2011 896 897 898 899 900 901 902 903 ``````-- | Calculate a new location after a register has been loaded. newLocation :: SpillLoc -> RealReg -> Loc -- if the tmp was read from a slot, then now its in a reg as well newLocation (ReadMem slot) my_reg = InBoth my_reg slot -- writes will always result in only the register being available newLocation _ my_reg = InReg my_reg -- | Load up a spilled temporary if we need to (read from memory). `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 904 ``````loadTemp `````` 905 `````` :: (Instruction instr) `````` ian@well-typed.com committed Sep 14, 2012 906 `````` => VirtualReg -- the temp being loaded `````` Ian Lynagh committed May 31, 2011 907 908 909 `````` -> SpillLoc -- the current location of this temp -> RealReg -- the hreg to load the temp into -> [instr] `````` Ian Lynagh committed May 31, 2011 910 `````` -> RegM freeRegs [instr] `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 911 `````` `````` ian@well-typed.com committed Sep 14, 2012 912 ``````loadTemp vreg (ReadMem slot) hreg spills `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 913 `````` = do `````` ian@well-typed.com committed Sep 14, 2012 914 `````` insn <- loadR (RegReal hreg) slot `````` Ian Lynagh committed May 31, 2011 915 916 `````` recordSpill (SpillLoad \$ getUnique vreg) return \$ {- COMMENT (fsLit "spill load") : -} insn : spills `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 917 `````` `````` ian@well-typed.com committed Sep 14, 2012 918 ``````loadTemp _ _ _ spills = `````` Ben.Lippmeier@anu.edu.au committed Aug 21, 2007 919 920 `````` return spills ``````