ghc/compiler/nativeGen/AsmRegAlloc.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-2000
   3 %
   4 \section[AsmRegAlloc]{Register allocator}
   5
   6 \begin{code}
   7 module AsmRegAlloc ( runRegAllocate ) where
   8
   9 #include "HsVersions.h"
  10
  11 import MachCode         ( InstrBlock )
  12 import MachMisc         ( Instr(..) )
  13 import PprMach          ( pprInstr )    -- Just for debugging
  14 import MachRegs
  15 import RegAllocInfo
  16
  17 import FiniteMap        ( FiniteMap, emptyFM,
  18                           lookupFM, eltsFM, addToFM_C, addToFM,
  19                           listToFM, fmToList )
  20 import OrdList          ( fromOL )
  21 import Outputable
  22 import Unique           ( Unique, Uniquable(..), mkPseudoUnique3 )
  23 import CLabel           ( CLabel, pprCLabel )
  24 import FastTypes
  25
  26 import List             ( mapAccumL, nub, sort )
  27 import Array            ( Array, array, (!), bounds )
  28 \end{code}
  29
  30 This is the generic register allocator.  It does allocation for all
  31 architectures.  Details for specific architectures are given in
  32 RegAllocInfo.lhs.  In practice the allocator needs to know next to
  33 nothing about an architecture to do its job:
  34
  35 * It needs to be given a list of the registers it can allocate to.
  36
  37 * It needs to be able to find out which registers each insn reads and
  38   writes.
  39
  40 * It needs be able to change registers in instructions into other
  41   registers.
  42
  43 * It needs to be able to find out where execution could go after an
  44   in instruction.
  45
  46 * It needs to be able to discover sets of registers which can be
  47   used to attempt spilling.
  48
  49 First we try something extremely simple.  If that fails, we have to do
  50 things the hard way.
  51
  52 \begin{code}
  53 runRegAllocate
  54     :: [Reg]
  55     -> ([Instr] -> [[Reg]])
  56     -> InstrBlock
  57     -> [Instr]
  58
  59 runRegAllocate regs find_reserve_regs instrs
  60   = --trace ("runRegAllocate: " ++ show regs) (
  61     case simpleAlloc of
  62        Just simple -> --trace "SIMPLE"
  63                       simple
  64        Nothing     -> --trace "GENERAL"
  65                       (tryGeneral reserves)
  66     --)
  67   where
  68     tryGeneral []
  69        = pprPanic "nativeGen: spilling failed.  Workaround: compile with -fvia-C.\n"
  70             ( (text "reserves = " <> ppr reserves)
  71               $$
  72               (text "code = ")
  73               $$
  74               (vcat (map (docToSDoc.pprInstr) flatInstrs))
  75             )
  76     tryGeneral (resv:resvs)
  77        = case generalAlloc resv of
  78             Just success -> success
  79             Nothing      -> tryGeneral resvs
  80
  81     reserves           = find_reserve_regs flatInstrs
  82     flatInstrs         = fromOL instrs
  83     simpleAlloc        = doSimpleAlloc regs flatInstrs
  84     generalAlloc resvd = doGeneralAlloc regs resvd flatInstrs
  85 \end{code}
  86
  87 Rather than invoke the heavyweight machinery in @doGeneralAlloc@ for
  88 each and every code block, we first try using this simple, fast and
  89 utterly braindead allocator.  In practice it handles about 60\% of the
  90 code blocks really fast, even with only 3 integer registers available.
  91 Since we can always give up and fall back to @doGeneralAlloc@,
  92 @doSimpleAlloc@ is geared to handling the common case as fast as
  93 possible.  It will succeed only if:
  94
  95 * The code mentions registers only of integer class, not floating
  96   class.
  97
  98 * The code doesn't mention any real registers, so we don't have to
  99   think about dodging and weaving to work around fixed register uses.
 100
 101 * The code mentions at most N virtual registers, where N is the number
 102   of real registers for allocation.
 103
 104 If those conditions are satisfied, we simply trundle along the code,
 105 doling out a real register every time we see mention of a new virtual
 106 register.  We either succeed at this, or give up when one of the above
 107 three conditions is no longer satisfied.
 108
 109 \begin{code}
 110 doSimpleAlloc :: [Reg] -> [Instr] -> Maybe [Instr]
 111 doSimpleAlloc available_real_regs instrs
 112    = let available_iregs
 113             = filter ((== RcInteger).regClass) available_real_regs
 114
 115          trundle :: [( {-Virtual-}Reg, {-Real-}Reg )]
 116                     -> [ {-Real-}Reg ]
 117                     -> [Instr]
 118                     -> [Instr]
 119                     -> Maybe [Instr]
 120          trundle vreg_map uncommitted_rregs ris_done []
 121             = Just (reverse ris_done)
 122          trundle vreg_map uncommitted_rregs ris_done (i:is)
 123             = case regUsage i of
 124                  RU rds wrs
 125
 126                     -- Mentions no regs?  Move on quickly
 127                     |  null rds_l && null wrs_l
 128                     -> trundle vreg_map uncommitted_rregs (i:ris_done) is
 129
 130                     -- A case we can't be bothered to handle?
 131                     |  any isFloatingOrReal rds_l || any isFloatingOrReal wrs_l
 132                     -> Nothing
 133
 134                     -- Update the rreg commitments, and map the insn
 135                     |  otherwise
 136                     -> case upd_commitment (wrs_l++rds_l)
 137                                            vreg_map uncommitted_rregs of
 138                           Nothing -- out of rregs; give up
 139                              -> Nothing
 140                           Just (vreg_map2, uncommitted_rregs2)
 141                              -> let i2 = patchRegs i (subst_reg vreg_map2)
 142                                 in  trundle vreg_map2 uncommitted_rregs2
 143                                             (i2:ris_done) is
 144                        where
 145                           isFloatingOrReal reg
 146                              = isRealReg reg || regClass reg == RcFloat
 147                                              || regClass reg == RcDouble
 148
 149                           rds_l = regSetToList rds
 150                           wrs_l = regSetToList wrs
 151
 152                           upd_commitment [] vr_map uncomm
 153                              = Just (vr_map, uncomm)
 154                           upd_commitment (reg:regs) vr_map uncomm
 155                              | isRealReg reg
 156                              = upd_commitment regs vr_map uncomm
 157                              | reg `elem` (map fst vr_map)
 158                              = upd_commitment regs vr_map uncomm
 159                              | null uncomm
 160                              = Nothing
 161                              | otherwise
 162                              = upd_commitment regs ((reg, head uncomm):vr_map)
 163                                                    (tail uncomm)
 164
 165                           subst_reg vreg_map r
 166                              -- If it's a RealReg, it must be STG-specific one
 167                              -- (Hp,Sp,BaseReg,etc), since regUsage filters them out,
 168                              -- so isFloatingOrReal would not have objected to it.
 169                              | isRealReg r
 170                              = r
 171                              | otherwise
 172                              = case [rr | (vr,rr) <- vreg_map, vr == r] of
 173                                   [rr2] -> rr2
 174                                   other -> pprPanic
 175                                               "doSimpleAlloc: unmapped VirtualReg"
 176                                               (ppr r)
 177      in
 178          trundle [] available_iregs [] instrs
 179 \end{code}
 180
 181 From here onwards is the general register allocator and spiller.  For
 182 each flow edge (possible transition between instructions), we compute
 183 which virtual and real registers are live on that edge.  Then the
 184 mapping is inverted, to give a mapping from register (virtual+real) to
 185 sets of flow edges on which the register is live.  Finally, we can use
 186 those sets to decide whether a virtual reg v can be assigned to a real
 187 reg r, by checking that v's live-edge-set does not intersect with r's
 188 current live-edge-set.  Having made that assignment, we then augment
 189 r's current live-edge-set (its current commitment, you could say) with
 190 v's live-edge-set.
 191
 192 doGeneralAlloc takes reserve_regs as the regs to use as spill
 193 temporaries.  First it tries to allocate using all regs except
 194 reserve_regs.  If that fails, it inserts spill code and tries again to
 195 allocate regs, but this time with the spill temporaries available.
 196 Even this might not work if there are insufficient spill temporaries:
 197 in the worst case on x86, we'd need 3 of them, for insns like addl
 198 (%reg1,%reg2,4) %reg3, since this insn uses all 3 regs as input.
 199
 200 \begin{code}
 201 doGeneralAlloc
 202     :: [Reg]            -- all allocatable regs
 203     -> [Reg]            -- the reserve regs
 204     -> [Instr]          -- instrs in
 205     -> Maybe [Instr]    -- instrs out
 206
 207 doGeneralAlloc all_regs reserve_regs instrs
 208    -- succeeded without spilling
 209    | prespill_ok
 210    = Just prespill_insns
 211
 212    -- failed, and no spill regs avail, so pointless to attempt spilling
 213    | null reserve_regs  = Nothing
 214    -- success after spilling
 215    | postspill_ok       = maybetrace (spillMsg True) (Just postspill_insns)
 216    -- still not enough reserves after spilling; we have to give up
 217    | otherwise          = maybetrace (spillMsg False) Nothing
 218      where
 219          prespill_regs
 220             = filter (`notElem` reserve_regs) all_regs
 221          (prespill_ok, prespill_insns)
 222             = allocUsingTheseRegs instrs prespill_regs
 223          instrs_with_spill_code
 224             = insertSpillCode prespill_insns
 225          (postspill_ok, postspill_insns)
 226             = allocUsingTheseRegs instrs_with_spill_code all_regs
 227
 228          spillMsg success
 229             = "nativeGen: spilling "
 230               ++ (if success then "succeeded" else "failed   ")
 231               ++ " using "
 232               ++ showSDoc (hsep (map ppr reserve_regs))
 233
 234 #        ifdef NCG_DEBUG
 235          maybetrace msg x = trace msg x
 236 #        else
 237          maybetrace msg x = x
 238 #        endif
 239 \end{code}
 240
 241 Here we patch instructions that reference ``registers'' which are
 242 really in memory somewhere (the mapping is under the control of the
 243 machine-specific code generator).  We place the appropriate load
 244 sequences before any instructions that use memory registers as
 245 sources, and we place the appropriate spill sequences after any
 246 instructions that use memory registers as destinations.  The offending
 247 instructions are rewritten with new dynamic registers, so generalAlloc
 248 has to run register allocation again after all of this is said and
 249 done.
 250
 251 On some architectures (x86, currently), we do without a frame-pointer,
 252 and instead spill relative to the stack pointer (%esp on x86).
 253 Because the stack pointer may move, the patcher needs to keep track of
 254 the current stack pointer "delta".  That's easy, because all it needs
 255 to do is spot the DELTA bogus-insns which will have been inserted by
 256 the relevant insn selector precisely so as to notify the spiller of
 257 stack-pointer movement.  The delta is passed to loadReg and spillReg,
 258 since they generate the actual spill code.  We expect the final delta
 259 to be the same as the starting one (zero), reflecting the fact that
 260 changes to the stack pointer should not extend beyond a basic block.
 261
 262 Finally, there is the issue of mapping an arbitrary set of unallocated
 263 VirtualRegs into a contiguous sequence of spill slots.  The failed
 264 allocation will have left the code peppered with references to
 265 VirtualRegs, each of which contains a unique.  So we make an env which
 266 maps these VirtualRegs to integers, starting from zero, and pass that
 267 env through to loadReg and spillReg.  There, they are used to look up
 268 spill slot numbers for the uniques.
 269
 270 \begin{code}
 271 insertSpillCode :: [Instr] -> [Instr]
 272 insertSpillCode insns
 273    = let uniques_in_insns
 274             = map getUnique
 275                   (regSetToList
 276                      (foldl unionRegSets emptyRegSet
 277                             (map vregs_in_insn insns)))
 278          vregs_in_insn i
 279             = case regUsage i of
 280                  RU rds wrs -> filterRegSet isVirtualReg
 281                                              (rds `unionRegSets` wrs)
 282          vreg_to_slot_map :: FiniteMap Unique Int
 283          vreg_to_slot_map
 284             = listToFM (zip uniques_in_insns [0..])
 285
 286          ((final_stack_delta, final_ctr), insnss)
 287             = mapAccumL (patchInstr vreg_to_slot_map) (0,0) insns
 288      in
 289          if   final_stack_delta == 0
 290          then concat insnss
 291          else pprPanic "patchMem: non-zero final delta"
 292                        (int final_stack_delta)
 293
 294
 295 -- patchInstr has as a running state two Ints, one the current stack delta,
 296 -- needed to figure out offsets to stack slots on archs where we spill relative
 297 -- to the stack pointer, as opposed to the frame pointer.  The other is a
 298 -- counter, used to manufacture new temporary register names.
 299
 300 patchInstr :: FiniteMap Unique Int -> (Int,Int) -> Instr -> ((Int,Int), [Instr])
 301 patchInstr vreg_to_slot_map (delta,ctr) instr
 302
 303  | null memSrcs && null memDsts
 304  = ((delta',ctr), [instr])
 305
 306  | otherwise
 307  = ((delta',ctr'), loadSrcs ++ [instr'] ++ spillDsts)
 308    where
 309         delta' = case instr of DELTA d -> d ; _ -> delta
 310
 311         (RU srcs dsts) = regUsage instr
 312
 313         -- The instr being patched may mention several vregs -- those which
 314         -- could not be assigned real registers.  For each such vreg, we
 315         -- invent a new vreg, used only around this instruction and nowhere
 316         -- else.  These new vregs replace the unallocatable vregs; they are
 317         -- loaded from the spill area, the instruction is done with them,
 318         -- and results if any are then written back to the spill area.
 319         vregs_in_instr
 320            = nub (filter isVirtualReg
 321                          (regSetToList srcs ++ regSetToList dsts))
 322         n_vregs_in_instr
 323            = length vregs_in_instr
 324         ctr'
 325            = ctr + n_vregs_in_instr
 326         vreg_env
 327            = zip vregs_in_instr [ctr, ctr+1 ..]
 328
 329         mkTmpReg vreg
 330            | isVirtualReg vreg
 331            = case [vi | (vreg', vi) <- vreg_env, vreg' == vreg] of
 332                 [i] -> case regClass vreg of
 333                           RcInteger -> VirtualRegI (mkPseudoUnique3 i)
 334                           RcFloat   -> VirtualRegF (mkPseudoUnique3 i)
 335                           RcDouble  -> VirtualRegD (mkPseudoUnique3 i)
 336                 _   -> pprPanic "patchInstr: unmapped VReg" (ppr vreg)
 337            | otherwise
 338            = vreg
 339
 340         memSrcs   = filter isVirtualReg (regSetToList srcs)
 341         memDsts   = filter isVirtualReg (regSetToList dsts)
 342
 343         loadSrcs  = map load  memSrcs
 344         spillDsts = map spill memDsts
 345
 346         load mem  = loadReg  vreg_to_slot_map delta  mem (mkTmpReg mem)
 347         spill mem = spillReg vreg_to_slot_map delta' (mkTmpReg mem) mem
 348
 349         instr'    = patchRegs instr mkTmpReg
 350 \end{code}
 351
 352 allocUsingTheseRegs is the register allocator proper.  It attempts
 353 to allocate dynamic regs to real regs, given a list of real regs
 354 which it may use.  If it fails due to lack of real regs, the returned
 355 instructions use what real regs there are, but will retain uses of
 356 dynamic regs for which a real reg could not be found.  It is these
 357 leftover dynamic reg references which insertSpillCode will later
 358 assign to spill slots.
 359
 360 Some implementation notes.
 361 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 362 Instructions are numbered sequentially, starting at zero.
 363
 364 A flow edge (FE) is a pair of insn numbers (MkFE Int Int) denoting
 365 a possible flow of control from the first insn to the second.
 366
 367 The input to the register allocator is a list of instructions, which
 368 mention Regs.  A Reg can be a RealReg -- a real machine reg -- or a
 369 VirtualReg, which carries a unique.  After allocation, all the
 370 VirtualReg references will have been converted into RealRegs, and
 371 possible some spill code will have been inserted.
 372
 373 The heart of the register allocator works in four phases.
 374
 375 1.  (find_flow_edges) Calculate all the FEs for the code list.
 376     Return them not as a [FE], but implicitly, as a pair of
 377     Array Int [Int], being the successor and predecessor maps
 378     for instructions.
 379
 380 2.  (calc_liveness) Returns a FiniteMap FE RegSet.  For each
 381     FE, indicates the set of registers live on that FE.  Note
 382     that the set includes both RealRegs and VirtualRegs.  The
 383     former appear because the code could mention fixed register
 384     usages, and we need to take them into account from the start.
 385
 386 3.  (calc_live_range_sets) Invert the above mapping, giving a
 387     FiniteMap Reg FeSet, indicating, for each virtual and real
 388     reg mentioned in the code, which FEs it is live on.
 389
 390 4.  (calc_vreg_to_rreg_mapping) For virtual reg, try and find
 391     an allocatable real register for it.  Each real register has
 392     a "current commitment", indicating the set of FEs it is
 393     currently live on.  A virtual reg v can be assigned to
 394     real reg r iff v's live-fe-set does not intersect with r's
 395     current commitment fe-set.  If the assignment is made,
 396     v's live-fe-set is union'd into r's current commitment fe-set.
 397     There is also the minor restriction that v and r must be of
 398     the same register class (integer or floating).
 399
 400     Once this mapping is established, we simply apply it to the
 401     input insns, and that's it.
 402
 403     If no suitable real register can be found, the vreg is mapped
 404     to itself, and we deem allocation to have failed.  The partially
 405     allocated code is returned.  The higher echelons of the allocator
 406     (doGeneralAlloc and runRegAlloc) then cooperate to insert spill
 407     code and re-run allocation, until a successful allocation is found.
 408 \begin{code}
 409
 410 allocUsingTheseRegs :: [Instr] -> [Reg] -> (Bool, [Instr])
 411 allocUsingTheseRegs instrs available_real_regs
 412    = let (all_vregs_mapped, v_to_r_mapping)
 413             = calc_vreg_to_rreg_mapping instrs available_real_regs
 414          new_insns
 415             = map (flip patchRegs sr) instrs
 416          sr reg
 417             | isRealReg reg
 418             = reg
 419             | otherwise
 420             = case lookupFM v_to_r_mapping reg of
 421                  Just r  -> r
 422                  Nothing -> pprPanic "allocateUsingTheseRegs: unmapped vreg: "
 423                                      (ppr reg)
 424      in
 425          --trace ("allocUsingTheseRegs: " ++ show available_real_regs) (
 426          (all_vregs_mapped, new_insns)
 427          --)
 428
 429
 430 -- the heart of the matter.
 431 calc_vreg_to_rreg_mapping :: [Instr] -> [Reg] -> (Bool, FiniteMap Reg Reg)
 432 calc_vreg_to_rreg_mapping insns available_real_regs
 433    = let
 434          lr_sets  :: FiniteMap Reg FeSet
 435          lr_sets = calc_live_range_sets insns
 436
 437          -- lr_sets maps: vregs mentioned in insns to sets of live FEs
 438          -- and also:     rregs mentioned in insns to sets of live FEs
 439          -- We need to extract the rreg mapping, and use it as the
 440          -- initial real-register-commitment.  Also, add to the initial
 441          -- commitment, empty commitments for any real regs not
 442          -- mentioned in it.
 443
 444          -- which real regs do we want to keep track of in the running
 445          -- commitment mapping?  Precisely the available_real_regs.
 446          -- We don't care about real regs mentioned by insns which are
 447          -- not in this list, since we're not allocating to them.
 448          initial_rr_commitment :: FiniteMap Reg FeSet
 449          initial_rr_commitment
 450             = listToFM [(rreg,
 451                          case lookupFM lr_sets rreg of
 452                             Nothing            -> emptyFeSet
 453                             Just fixed_use_fes -> fixed_use_fes
 454                         )
 455                         | rreg <- available_real_regs]
 456
 457          -- These are the vregs for which we actually have to (try to)
 458          -- assign a real register. (ie, the whole reason we're here at all :)
 459          vreg_liveness_list :: [(Reg, FeSet)]
 460          vreg_liveness_list = filter (not.isRealReg.fst)
 461                                      (fmToList lr_sets)
 462
 463          -- A loop, which attempts to assign each vreg to a rreg.
 464          loop rr_commitment v_to_r_map []
 465             = v_to_r_map
 466          loop rr_commitment v_to_r_map ((vreg,vreg_live_fes):not_yet_done)
 467             = let
 468                   -- find a real reg which is not live for any of vreg_live_fes
 469                   cand_reals
 470                      = [rreg
 471                            | (rreg,rreg_live_FEs) <- fmToList rr_commitment,
 472                               regClass vreg == regClass rreg,
 473                               isEmptyFeSet (intersectionFeSets rreg_live_FEs
 474                                                                vreg_live_fes)
 475                        ]
 476               in
 477                  case cand_reals of
 478                     [] -> -- bummer.  No register is available.  Just go on to
 479                           -- the next vreg, mapping the vreg to itself.
 480                           loop rr_commitment (addToFM v_to_r_map vreg vreg)
 481                                not_yet_done
 482                     (r:_)
 483                        -> -- Hurrah!  Found a free reg of the right class.
 484                           -- Now we need to update the RR commitment.
 485                           loop rr_commitment2 (addToFM v_to_r_map vreg r)
 486                                not_yet_done
 487                           where
 488                              rr_commitment2
 489                                 = addToFM_C unionFeSets rr_commitment r
 490                                             vreg_live_fes
 491
 492          -- the final vreg to rreg mapping
 493          vreg_assignment
 494             = loop initial_rr_commitment emptyFM vreg_liveness_list
 495          -- did we succeed in mapping everyone to a real reg?
 496          allocation_succeeded
 497             = all isRealReg (eltsFM vreg_assignment)
 498      in
 499          (allocation_succeeded, vreg_assignment)
 500
 501
 502
 503 -- calculate liveness, then produce the live range info
 504 -- as a mapping of VRegs to the set of FEs on which they are live.
 505 -- The difficult part is inverting the mapping of Reg -> FeSet
 506 -- to produce a mapping FE -> RegSet.
 507
 508 calc_live_range_sets :: [Instr] -> FiniteMap Reg FeSet
 509 calc_live_range_sets insns
 510    = let
 511          -- this is the "original" (old) mapping
 512          lis :: FiniteMap FE RegSet
 513          lis = calc_liveness insns
 514
 515          -- establish the totality of reg names mentioned by the
 516          -- insns, by scanning over the insns.
 517          all_mentioned_regs :: RegSet
 518          all_mentioned_regs
 519             = foldl unionRegSets emptyRegSet
 520                     (map (\i -> case regUsage i of
 521                                    RU rds wrs -> unionRegSets rds wrs)
 522                          insns)
 523
 524          -- Initial inverted mapping, from Reg to sets of FEs
 525          initial_imap :: FiniteMap Reg FeSet
 526          initial_imap
 527             = listToFM [(reg, emptyFeSet)
 528                         | reg <- regSetToList all_mentioned_regs]
 529
 530          -- Update the new map with one element of the old map
 531          upd_imap :: FiniteMap Reg FeSet -> (FE, RegSet)
 532                      -> FiniteMap Reg FeSet
 533          upd_imap imap (fe, regset)
 534              = foldl upd_1_imap imap (regSetToList regset)
 535                where
 536                   upd_1_imap curr reg
 537                      = addToFM_C unionFeSets curr reg (unitFeSet fe)
 538
 539          -- the complete inverse mapping
 540          final_imap :: FiniteMap Reg FeSet
 541          final_imap
 542              = foldl upd_imap initial_imap (fmToList lis)
 543      in
 544          final_imap
 545
 546
 547
 548 -- Given the insns, calculate the FEs, and then doing fixpointing to
 549 -- figure out the set of live regs (virtual regs AND real regs) live
 550 -- on each FE.
 551
 552 calc_liveness :: [Instr] -> FiniteMap FE RegSet
 553 calc_liveness insns
 554    = let (pred_map, succ_map)
 555             = find_flow_edges insns
 556
 557          -- We use the convention that if the current approximation
 558          -- doesn't give a mapping for some FE, that FE maps to the
 559          -- empty set.
 560          initial_approx, fixpoint :: FiniteMap FE RegSet
 561          initial_approx
 562             = mk_initial_approx 0 insns succ_map emptyFM
 563          fixpoint
 564             = fix_set initial_approx 1
 565               -- If you want to live dangerously, and promise that the code
 566               -- doesn't contain any loops (ie, there are no back edges in
 567               -- the flow graph), you should be able to get away with this:
 568               -- = upd_liveness_info pred_map succ_map insn_array initial_approx
 569               -- But since I'm paranoid, and since it hardly makes any difference
 570               -- to the compiler run-time (about 0.1%), I prefer to do the
 571               -- the full fixpointing game.
 572
 573          insn_array
 574             = let n = length insns
 575               in  array (0, n-1) (zip [0..] insns)
 576
 577          sameSets []     []       = True
 578          sameSets (c:cs) (n:ns)   = eqRegSets c n && sameSets cs ns
 579          sameSets _      _        = False
 580
 581          fix_set curr_approx iter_number
 582             = let next_approx
 583                      = upd_liveness_info pred_map succ_map insn_array curr_approx
 584                   curr_sets
 585                      = eltsFM curr_approx
 586                   next_sets
 587                      = eltsFM next_approx
 588                   same
 589                      = sameSets curr_sets next_sets
 590                   final_approx
 591                      = if same then curr_approx
 592                                else fix_set next_approx (iter_number+1)
 593               in
 594                   --trace (let qqq (fe, regset)
 595                   --             = show fe ++ "  " ++ show (regSetToList regset)
 596                   --       in
 597                   --          "\n::iteration " ++ show iter_number ++ "\n"
 598                   --          ++ (unlines . map qqq . fmToList)
 599                   --                               next_approx ++"\n"
 600                   --      )
 601                   final_approx
 602      in
 603          fixpoint
 604
 605
 606 -- Create a correct initial approximation.  For each instruction that
 607 -- writes a register, we deem that the register is live on the
 608 -- flow edges leaving the instruction.  Subsequent iterations of
 609 -- the liveness AbI augment this based purely on reads of regs, not
 610 -- writes.  We need to start off with at least this minimal write-
 611 -- based information in order that writes to vregs which are never
 612 -- used have non-empty live ranges.  If we don't do that, we eventually
 613 -- wind up assigning such vregs to any old real reg, since they don't
 614 -- apparently conflict -- you can't conflict with an empty live range.
 615 -- This kludge is unfortunate, but we need to do it to cover not only
 616 -- writes to vregs which are never used, but also to deal correctly
 617 -- with the fact that calls to C will trash the callee saves registers.
 618
 619 mk_initial_approx :: Int -> [Instr] -> Array Int [Int]
 620                      -> FiniteMap FE RegSet
 621                      -> FiniteMap FE RegSet
 622 mk_initial_approx ino [] succ_map ia_so_far
 623    = ia_so_far
 624 mk_initial_approx ino (i:is) succ_map ia_so_far
 625    = let wrs
 626             = case regUsage i of RU rrr www -> www
 627          new_fes
 628             = [case iUnbox ino of      { inoh ->
 629                case iUnbox ino_succ of { ino_succh ->
 630                MkFE inoh ino_succh
 631                }}
 632                   | ino_succ <- succ_map ! ino]
 633
 634          loop [] ia = ia
 635          loop (fe:fes) ia
 636             = loop fes (addToFM_C unionRegSets ia fe wrs)
 637
 638          next_ia
 639             = loop new_fes ia_so_far
 640      in
 641          mk_initial_approx (ino+1) is succ_map next_ia
 642
 643
 644 -- Do one step in the liveness info calculation (AbI :).  Given the
 645 -- prior approximation (which tells you a subset of live VRegs+RRegs
 646 -- for each flow edge), calculate new information for all FEs.
 647 -- Rather than do this by iterating over FEs, it's easier to iterate
 648 -- over insns, and update their incoming FEs.
 649
 650 upd_liveness_info :: Array Int [Int]         -- instruction pred map
 651                      -> Array Int [Int]      -- instruction succ map
 652                      -> Array Int Instr      -- array of instructions
 653                      -> FiniteMap FE RegSet  -- previous approx
 654                      -> FiniteMap FE RegSet  -- improved approx
 655
 656 upd_liveness_info pred_map succ_map insn_array prev_approx
 657    = do_insns hi prev_approx
 658      where
 659         (lo, hi) = bounds insn_array
 660
 661         enquireMapFE :: FiniteMap FE RegSet -> FE
 662                         -> RegSet
 663         enquireMapFE fm fe
 664            = case lookupFM fm fe of
 665                 Just set -> set
 666                 Nothing  -> emptyRegSet
 667
 668         -- Work backwards, from the highest numbered insn to the lowest.
 669         -- This is a heuristic which causes faster convergence to the
 670         -- fixed point.  In particular, for straight-line code with no
 671         -- branches at all, arrives at the fixpoint in one iteration.
 672         do_insns ino approx
 673            | ino < lo
 674            = approx
 675            | otherwise
 676            = let fes_to_futures
 677                     = [case iUnbox ino of        { inoh ->
 678                        case iUnbox future_ino of { future_inoh ->
 679                        MkFE inoh future_inoh
 680                        }}
 681                           | future_ino <- succ_map ! ino]
 682                  future_lives
 683                     = map (enquireMapFE approx) fes_to_futures
 684                  future_live
 685                     = foldr unionRegSets emptyRegSet future_lives
 686
 687                  fes_from_histories
 688                     = [case iUnbox history_ino of { history_inoh ->
 689                        case iUnbox ino of         { inoh ->
 690                        MkFE history_inoh inoh
 691                        }}
 692                           | history_ino <- pred_map ! ino]
 693                  new_approx
 694                     = foldl update_one_history approx fes_from_histories
 695
 696                  insn
 697                     = insn_array ! ino
 698                  history_independent_component
 699                     = case regUsage insn of
 700                          RU rds wrs
 701                             -> unionRegSets rds
 702                                   (minusRegSets future_live wrs)
 703
 704                  update_one_history :: FiniteMap FE RegSet
 705                                        -> FE
 706                                        -> FiniteMap FE RegSet
 707                  update_one_history approx0 fe
 708                       = addToFM_C unionRegSets approx0 fe
 709                                   history_independent_component
 710
 711                  rest_done
 712                     = do_insns (ino-1) new_approx
 713              in
 714                  rest_done
 715
 716
 717
 718 -- Extract the flow edges from a list of insns.  Express the information
 719 -- as two mappings, from insn number to insn numbers of predecessors,
 720 -- and from insn number to insn numbers of successors.  (Since that's
 721 -- what we need to know when computing live ranges later).  Instructions
 722 -- are numbered starting at zero.  This function is long and complex
 723 -- in order to be efficient; it could equally well be shorter and slower.
 724
 725 find_flow_edges :: [Instr] -> (Array Int [Int],
 726                                Array Int [Int])
 727 find_flow_edges insns
 728    = let
 729          -- First phase: make a temp env which maps labels
 730          -- to insn numbers, so the second pass can know the insn
 731          -- numbers for jump targets.
 732
 733          label_env :: FiniteMap CLabel Int
 734
 735          mk_label_env n env [] = env
 736          mk_label_env n env ((LABEL clbl):is)
 737             = mk_label_env (n+1) (addToFM env clbl n) is
 738          mk_label_env n env (i:is)
 739             = mk_label_env (n+1) env is
 740
 741          label_env = mk_label_env 0 emptyFM insns
 742
 743          find_label :: CLabel -> Int
 744          find_label jmptarget
 745             = case lookupFM label_env jmptarget of
 746                  Just ino -> ino
 747                  Nothing  -> pprPanic "find_flow_edges: unmapped label"
 748                                       (pprCLabel jmptarget)
 749
 750          -- Second phase: traverse the insns, and make up the successor map.
 751
 752          least_ino, greatest_ino :: Int
 753          least_ino    = 0
 754          greatest_ino = length insns - 1
 755
 756          mk_succ_map :: Int -> [(Int, [Int])] -> [Instr] -> [(Int, [Int])]
 757
 758          mk_succ_map i_num rsucc_map []
 759             = reverse rsucc_map
 760
 761          mk_succ_map i_num rsucc_map (i:is)
 762             = let i_num_1 = i_num + 1
 763               in
 764               case insnFuture i of
 765
 766                  NoFuture
 767                     -> -- A non-local jump.  We can regard this insn as a terminal
 768                        -- insn in the graph, so we don't add any edges.
 769                        mk_succ_map i_num_1 ((i_num,[]):rsucc_map) is
 770
 771                  Next
 772                     |  null is -- this is the last insn, and it doesn't go anywhere
 773                                -- (a meaningless scenario); handle it anyway
 774                     -> mk_succ_map i_num_1 ((i_num,[]):rsucc_map) is
 775
 776                     |  otherwise -- flows to next insn; add fe i_num -> i_num+1
 777                     -> mk_succ_map i_num_1 ((i_num, [i_num_1]): rsucc_map)
 778                                            is
 779
 780                  Branch lab -- jmps to lab; add fe i_num -> i_target
 781                     -> let i_target = find_label lab
 782                        in
 783                        mk_succ_map i_num_1 ((i_num, [i_target]): rsucc_map) is
 784
 785                  NextOrBranch lab
 786                     |  null is   -- jmps to label, or falls through, and this is
 787                                  -- the last insn (a meaningless scenario);
 788                                  -- flag an error
 789                     -> error "find_flow_edges: NextOrBranch is last"
 790
 791                     |  otherwise -- add fes i_num -> i_num+1
 792                                  --     and i_num -> i_target
 793                     -> let i_target = find_label lab
 794                        in
 795                        mk_succ_map i_num_1 ((i_num, [i_num_1, i_target]):rsucc_map)
 796                                            is
 797                  MultiFuture labels
 798                     -> -- A jump, whose targets are listed explicitly.
 799                        -- (Generated from table-based switch translations).
 800                        -- Add fes  i_num -> x  for each x in labels
 801                        let is_target = nub (map find_label labels)
 802                        in
 803                        mk_succ_map i_num_1 ((i_num, is_target):rsucc_map) is
 804
 805          -- Third phase: invert the successor map to get the predecessor
 806          -- map, using an algorithm which is quadratic in the worst case,
 807          -- but runs in almost-linear time, because of the nature of our
 808          -- inputs: most insns have a single successor, the next insn.
 809
 810          invert :: [(Int, [Int])] -> [(Int, [Int])]
 811          invert fmap
 812             = let inverted_pairs
 813                      = concatMap ( \ (a, bs) -> [(b,a) | b <- bs] ) fmap
 814                   sorted_inverted_pairs
 815                      = isort inverted_pairs
 816
 817                   grp :: Int -> [Int] -> [(Int,Int)] -> [(Int,[Int])]
 818                   grp k vs [] = [(k, vs)]
 819                   grp k vs ((kk,vv):rest)
 820                      | k == kk   = grp k (vv:vs) rest
 821                      | otherwise = (k,vs) : grp kk [vv] rest
 822
 823                   grp_start []             = []
 824                   grp_start ((kk,vv):rest) = grp kk [vv] rest
 825
 826                   grouped
 827                      = grp_start sorted_inverted_pairs
 828
 829                   -- make sure that the reverse mapping maps all inos
 830                   add_empties ino []
 831                      | ino > greatest_ino  = []
 832                      | otherwise           = (ino,[]): add_empties (ino+1) []
 833                   add_empties ino ((k,vs):rest)
 834                      | ino <  k   = (ino,[]): add_empties (ino+1) ((k,vs):rest)
 835                      | ino == k   = (k,vs) : add_empties (ino+1) rest
 836
 837                   -- This is nearly linear provided that the fsts of the
 838                   -- list are nearly in order -- a critical assumption
 839                   -- for efficiency.
 840                   isort :: [(Int,Int)] -> [(Int,Int)]
 841                   isort []     = []
 842                   isort (x:xs) = insert x (isort xs)
 843
 844                   insert :: (Int,Int) -> [(Int,Int)] -> [(Int,Int)]
 845                   insert y []     = [y]
 846                   insert y (z:zs)
 847                      -- specifically, this first test should almost always
 848                      -- be True in order for the near-linearity to happen
 849                      | fst y <= fst z  = y:z:zs
 850                      | otherwise       = z: insert y zs
 851               in
 852                  add_empties least_ino grouped
 853
 854          -- Finally ...
 855
 856          succ_list
 857             = mk_succ_map 0 [] insns
 858          succ_map
 859             = array (least_ino, greatest_ino) succ_list
 860          pred_list
 861             = invert succ_list
 862          pred_map
 863             = array (least_ino, greatest_ino) pred_list
 864      in
 865          (pred_map, succ_map)
 866
 867
 868 -- That's all, folks!  From here on is just some dull supporting stuff.
 869
 870 -- A data type for flow edges
 871 data FE
 872    = MkFE FastInt FastInt deriving (Eq, Ord)
 873
 874 -- deriving Show on types with unboxed fields doesn't work
 875 instance Show FE where
 876     showsPrec _ (MkFE s d)
 877        = showString "MkFE" . shows (iBox s) . shows ' ' . shows (iBox d)
 878
 879 -- Blargh.  Use ghc stuff soon!  Or: perhaps that's not such a good
 880 -- idea.  Most of these sets are either empty or very small, and it
 881 -- might be that the overheads of the FiniteMap based set implementation
 882 -- is a net loss.  The same might be true of RegSets.
 883
 884 newtype FeSet = MkFeSet [FE]
 885
 886 feSetFromList xs
 887    = MkFeSet (nukeDups (sort xs))
 888      where nukeDups :: [FE] -> [FE]
 889            nukeDups []  = []
 890            nukeDups [x] = [x]
 891            nukeDups (x:y:xys)
 892               = if x == y then nukeDups (y:xys)
 893                           else x : nukeDups (y:xys)
 894
 895 feSetToList (MkFeSet xs)            = xs
 896 isEmptyFeSet (MkFeSet xs)           = null xs
 897 emptyFeSet                          = MkFeSet []
 898 eqFeSet (MkFeSet xs1) (MkFeSet xs2) = xs1 == xs2
 899 unitFeSet x                         = MkFeSet [x]
 900
 901 elemFeSet x (MkFeSet xs)
 902    = f xs
 903      where
 904         f []     = False
 905         f (y:ys) | x == y    = True
 906                  | x < y     = False
 907                  | otherwise = f ys
 908
 909 unionFeSets (MkFeSet xs1) (MkFeSet xs2)
 910    = MkFeSet (f xs1 xs2)
 911      where
 912         f [] bs = bs
 913         f as [] = as
 914         f (a:as) (b:bs)
 915            | a < b      = a : f as (b:bs)
 916            | a > b      = b : f (a:as) bs
 917            | otherwise  = a : f as bs
 918
 919 minusFeSets (MkFeSet xs1) (MkFeSet xs2)
 920    = MkFeSet (f xs1 xs2)
 921      where
 922         f [] bs = []
 923         f as [] = as
 924         f (a:as) (b:bs)
 925            | a < b      = a : f as (b:bs)
 926            | a > b      = f (a:as) bs
 927            | otherwise  = f as bs
 928
 929 intersectionFeSets (MkFeSet xs1) (MkFeSet xs2)
 930    = MkFeSet (f xs1 xs2)
 931      where
 932         f [] bs = []
 933         f as [] = []
 934         f (a:as) (b:bs)
 935            | a < b      = f as (b:bs)
 936            | a > b      = f (a:as) bs
 937            | otherwise  = a : f as bs
 938
 939 \end{code}