ghc/compiler/nativeGen/AsmRegAlloc.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1995
   3 %
   4
   5 \begin{code}
   6 #include "HsVersions.h"
   7 #include "../../includes/platform.h"
   8 #include "../../includes/GhcConstants.h"
   9
  10 module AsmRegAlloc (
  11         FutureLive(..), RegLiveness(..), RegUsage(..), Reg(..),
  12         MachineRegisters(..), MachineCode(..),
  13
  14         mkReg, runRegAllocate,
  15         extractMappedRegNos,
  16
  17         -- And, for self-sufficiency
  18         CLabel, OrdList, PrimKind, UniqSet(..), UniqFM,
  19         FiniteMap, Unique
  20     ) where
  21
  22 IMPORT_Trace
  23
  24 import CLabelInfo       ( CLabel )
  25 import FiniteMap
  26 import MachDesc
  27 import Maybes           ( maybeToBool, Maybe(..) )
  28 import OrdList          -- ( mkUnitList, mkSeqList, mkParList, OrdList )
  29 import Outputable
  30 import Pretty
  31 import PrimKind         ( PrimKind(..) )
  32 import UniqSet
  33 import Unique
  34 import Util
  35
  36 #if ! OMIT_NATIVE_CODEGEN
  37
  38 #if sparc_TARGET_ARCH
  39 import SparcCode        -- ( SparcInstr, SparcRegs ) -- for specializing
  40
  41 {-# SPECIALIZE
  42     runRegAllocate :: SparcRegs -> [Int] -> (OrdList SparcInstr) -> [SparcInstr]
  43   #-}
  44 #endif
  45 #if alpha_TARGET_ARCH
  46 import AlphaCode        -- ( AlphaInstr, AlphaRegs ) -- for specializing
  47
  48 {-# SPECIALIZE
  49     runRegAllocate :: AlphaRegs -> [Int] -> (OrdList AlphaInstr) -> [AlphaInstr]
  50   #-}
  51 #endif
  52
  53 #endif
  54
  55 \end{code}
  56
  57 %************************************************************************
  58 %*                                                                      *
  59 \subsection[Reg]{Real registers}
  60 %*                                                                      *
  61 %************************************************************************
  62
  63 Static Registers correspond to actual machine registers.  These should
  64 be avoided until the last possible moment.
  65
  66 Dynamic registers are allocated on the fly, usually to represent a single
  67 value in the abstract assembly code (i.e. dynamic registers are usually
  68 single assignment).  Ultimately, they are mapped to available machine
  69 registers before spitting out the code.
  70
  71 \begin{code}
  72
  73 data Reg = FixedReg  FAST_INT           -- A pre-allocated machine register
  74
  75          | MappedReg FAST_INT           -- A dynamically allocated machine register
  76
  77          | MemoryReg Int PrimKind       -- A machine "register" actually held in a memory
  78                                         -- allocated table of registers which didn't fit
  79                                         -- in real registers.
  80
  81          | UnmappedReg Unique PrimKind  -- One of an infinite supply of registers,
  82                                         -- always mapped to one of the earlier two
  83                                         -- before we're done.
  84          -- No thanks: deriving (Eq)
  85
  86 mkReg :: Unique -> PrimKind -> Reg
  87 mkReg = UnmappedReg
  88
  89 instance Text Reg where
  90     showsPrec _ (FixedReg i)    = showString "%"  . shows IBOX(i)
  91     showsPrec _ (MappedReg i)   = showString "%"  . shows IBOX(i)
  92     showsPrec _ (MemoryReg i _) = showString "%M"  . shows i
  93     showsPrec _ (UnmappedReg i _) = showString "%U" . shows i
  94
  95 #ifdef DEBUG
  96 instance Outputable Reg where
  97     ppr sty r = ppStr (show r)
  98 #endif
  99
 100 cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i'
 101 cmpReg (MappedReg i) (MappedReg i') = cmp_ihash i i'
 102 cmpReg (MemoryReg i _) (MemoryReg i' _) = cmp_i i i'
 103 cmpReg (UnmappedReg u _) (UnmappedReg u' _) = cmpUnique u u'
 104 cmpReg r1 r2 =
 105     let tag1 = tagReg r1
 106         tag2 = tagReg r2
 107     in
 108         if tag1 _LT_ tag2 then LT_ else GT_
 109     where
 110         tagReg (FixedReg _)      = (ILIT(1) :: FAST_INT)
 111         tagReg (MappedReg _)     = ILIT(2)
 112         tagReg (MemoryReg _ _)   = ILIT(3)
 113         tagReg (UnmappedReg _ _) = ILIT(4)
 114
 115 cmp_i :: Int -> Int -> TAG_
 116 cmp_i a1 a2 = if a1 == a2 then EQ_ else if a1 < a2 then LT_ else GT_
 117
 118 cmp_ihash :: FAST_INT -> FAST_INT -> TAG_
 119 cmp_ihash a1 a2 = if a1 _EQ_ a2 then EQ_ else if a1 _LT_ a2 then LT_ else GT_
 120
 121 instance Eq Reg where
 122     a == b = case cmpReg a b of { EQ_ -> True;  _ -> False }
 123     a /= b = case cmpReg a b of { EQ_ -> False; _ -> True  }
 124
 125 instance Ord Reg where
 126     a <= b = case cmpReg a b of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 127     a <  b = case cmpReg a b of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 128     a >= b = case cmpReg a b of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 129     a >  b = case cmpReg a b of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 130 #ifdef __GLASGOW_HASKELL__
 131     _tagCmp a b = case cmpReg a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 132 #endif
 133
 134 instance NamedThing Reg where
 135     -- the *only* method that should be defined is "getTheUnique"!
 136     -- (so we can use UniqFMs/UniqSets on Regs
 137     getTheUnique (UnmappedReg u _) = u
 138     getTheUnique (FixedReg i)      = mkPseudoUnique1 IBOX(i)
 139     getTheUnique (MappedReg i)     = mkPseudoUnique2 IBOX(i)
 140     getTheUnique (MemoryReg i _)   = mkPseudoUnique3 i
 141 \end{code}
 142
 143 This is the generic register allocator.
 144
 145 %************************************************************************
 146 %*                                                                      *
 147 \subsection[RegPlace]{Map Stix registers to {\em real} registers}
 148 %*                                                                      *
 149 %************************************************************************
 150
 151 An important point:  The @regUsage@ function for a particular assembly language
 152 must not refer to fixed registers, such as Hp, SpA, etc.  The source and destination
 153 lists should only refer to dynamically allocated registers or static registers
 154 from the free list.  As far as we are concerned, the fixed registers simply don't
 155 exist (for allocation purposes, anyway).
 156
 157 \begin{code}
 158
 159 class MachineRegisters a where
 160     mkMRegs         :: [Int] -> a
 161     possibleMRegs   :: PrimKind -> a -> [Int]
 162     useMReg         :: a -> FAST_INT -> a
 163     useMRegs        :: a -> [Int] -> a
 164     freeMReg        :: a -> FAST_INT -> a
 165     freeMRegs       :: a -> [Int] -> a
 166
 167 type RegAssignment = FiniteMap Reg Reg
 168 type RegConflicts = FiniteMap Int (UniqSet Reg)
 169
 170 data FutureLive
 171   = FL  (UniqSet Reg)
 172         (FiniteMap CLabel (UniqSet Reg))
 173 fstFL (FL a b) = a
 174
 175 data RegHistory a
 176   = RH  a
 177         Int
 178         RegAssignment
 179
 180 data RegFuture
 181   = RF  (UniqSet Reg)   -- in use
 182         FutureLive      -- future
 183         RegConflicts
 184
 185 data RegInfo a
 186   = RI  (UniqSet Reg)   -- in use
 187         (UniqSet Reg)   -- sources
 188         (UniqSet Reg)   -- destinations
 189         [Reg]           -- last used
 190         RegConflicts
 191
 192 data RegUsage
 193   = RU  (UniqSet Reg)
 194         (UniqSet Reg)
 195
 196 data RegLiveness
 197   = RL  (UniqSet Reg)
 198         FutureLive
 199
 200 class MachineCode a where
 201 -- OLD:
 202 --    flatten       :: OrdList a -> [a]
 203       regUsage      :: a -> RegUsage
 204       regLiveness   :: a -> RegLiveness -> RegLiveness
 205       patchRegs     :: a -> (Reg -> Reg) -> a
 206       spillReg      :: Reg -> Reg -> OrdList a
 207       loadReg       :: Reg -> Reg -> OrdList a
 208
 209 \end{code}
 210
 211 First we try something extremely simple.
 212 If that fails, we have to do things the hard way.
 213
 214 \begin{code}
 215
 216 runRegAllocate
 217     :: (MachineRegisters a, MachineCode b)
 218     => a
 219     -> [Int]
 220     -> (OrdList b)
 221     -> [b]
 222
 223 runRegAllocate regs reserve_regs instrs =
 224     case simpleAlloc of
 225         Just x  -> x
 226         Nothing -> hairyAlloc
 227   where
 228     flatInstrs  = flattenOrdList instrs
 229     simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs
 230     hairyAlloc  = hairyRegAlloc regs reserve_regs flatInstrs
 231
 232 \end{code}
 233
 234 Here is the simple register allocator.  Just dole out registers until
 235 we run out, or until one gets clobbered before its last use.  Don't
 236 do anything fancy with branches.  Just pretend that you've got a block
 237 of straight-line code and hope for the best.  Experience indicates that
 238 this approach will suffice for about 96 percent of the code blocks that
 239 we generate.
 240
 241 \begin{code}
 242
 243 simpleRegAlloc
 244     :: (MachineRegisters a, MachineCode b)
 245     => a                -- registers to select from
 246     -> [Reg]            -- live static registers
 247     -> RegAssignment    -- mapping of dynamics to statics
 248     -> [b]              -- code
 249     -> Maybe [b]
 250
 251 simpleRegAlloc _ _ _ [] = Just []
 252 simpleRegAlloc free live env (instr:instrs) =
 253     if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then
 254         Just (instr3 : instrs3)
 255     else
 256         Nothing
 257   where
 258     instr3 = patchRegs instr (lookup env2)
 259
 260     (srcs, dsts) = case regUsage instr of { RU s d -> (uniqSetToList s, uniqSetToList d) }
 261
 262     lookup env x = case lookupFM env x of {Just y -> y; Nothing -> x}
 263
 264     deadSrcs = [r | r@(UnmappedReg _ _) <- srcs, lookup env r `not_elem` live]
 265     newDsts  = [r | r@(UnmappedReg _ _) <- dsts, r `not_elem` keysFM env]
 266
 267     newAlloc = foldr allocateNewReg (Just (free, [])) newDsts
 268     (free2, new) = case newAlloc of Just x -> x
 269
 270     env2 = env `addListToFM` new
 271
 272     live2 = map snd new ++ [x | x <- live, x `not_elem` dsts]
 273
 274     instrs2 = simpleRegAlloc free2 live2 env2 instrs
 275     instrs3 = case instrs2 of Just x -> x
 276
 277     allocateNewReg
 278         :: MachineRegisters a
 279         => Reg
 280         -> Maybe (a, [(Reg, Reg)])
 281         -> Maybe (a, [(Reg, Reg)])
 282
 283     allocateNewReg _ Nothing = Nothing
 284
 285     allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs)) =
 286         if null choices then Nothing
 287         else Just (free2, prs2)
 288       where
 289         choices = possibleMRegs pk free
 290         reg = head choices
 291         free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
 292         prs2 = ((d,  MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
 293
 294 \end{code}
 295
 296 Here is the ``clever'' bit. First go backward (i.e. left), looking for
 297 the last use of dynamic registers. Then go forward (i.e. right), filling
 298 registers with static placements.
 299
 300 \begin{code}
 301
 302 hairyRegAlloc
 303     :: (MachineRegisters a, MachineCode b)
 304     => a
 305     -> [Int]
 306     -> [b]
 307     -> [b]
 308
 309 hairyRegAlloc regs reserve_regs instrs =
 310     case mapAccumB (doRegAlloc reserve_regs)
 311             (RH regs' 1 emptyFM) noFuture instrs
 312     of (RH _ loc' _, _, instrs') ->
 313         if loc' == 1 then instrs' else
 314         case mapAccumB do_RegAlloc_Nil
 315                 (RH regs'' loc' emptyFM) noFuture (flattenOrdList (patchMem instrs'))
 316         of ((RH _ loc'' _),_,instrs'') ->
 317             if loc'' == loc' then instrs'' else panic "runRegAllocate"
 318   where
 319     regs' = regs `useMRegs` reserve_regs
 320     regs'' = mkMRegs reserve_regs `asTypeOf` regs
 321
 322 do_RegAlloc_Nil = doRegAlloc [] -- out here to avoid CAF (sigh)
 323 do_RegAlloc_Nil
 324     :: (MachineRegisters a, MachineCode b)
 325     => RegHistory a
 326     -> RegFuture
 327     -> b
 328     -> (RegHistory a, RegFuture, b)
 329
 330 noFuture :: RegFuture
 331 noFuture = RF emptyUniqSet (FL emptyUniqSet emptyFM) emptyFM
 332 \end{code}
 333
 334 Here we patch instructions that reference ``registers'' which are really in
 335 memory somewhere (the mapping is under the control of the machine-specific
 336 code generator).  We place the appropriate load sequences before any instructions
 337 that use memory registers as sources, and we place the appropriate spill sequences
 338 after any instructions that use memory registers as destinations.  The offending
 339 instructions are rewritten with new dynamic registers, so we have to run register
 340 allocation again after all of this is said and done.
 341
 342 \begin{code}
 343
 344 patchMem
 345     :: MachineCode a
 346     => [a]
 347     -> OrdList a
 348
 349 patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs
 350
 351 patchMem'
 352     :: MachineCode a
 353     => a
 354     -> OrdList a
 355
 356 patchMem' instr =
 357     if null memSrcs && null memDsts then mkUnitList instr
 358     else mkSeqList
 359             (foldr mkParList mkEmptyList loadSrcs)
 360             (mkSeqList instr'
 361                 (foldr mkParList mkEmptyList spillDsts))
 362
 363     where
 364         (RU srcs dsts) = regUsage instr
 365
 366         memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk
 367         memToDyn other            = other
 368
 369         memSrcs = [ r | r@(MemoryReg _ _) <- uniqSetToList srcs]
 370         memDsts = [ r | r@(MemoryReg _ _) <- uniqSetToList dsts]
 371
 372         loadSrcs = map load memSrcs
 373         spillDsts = map spill memDsts
 374
 375         load mem = loadReg mem (memToDyn mem)
 376         spill mem = spillReg (memToDyn mem) mem
 377
 378         instr' = mkUnitList (patchRegs instr memToDyn)
 379
 380 \end{code}
 381
 382 \begin{code}
 383
 384 doRegAlloc
 385     :: (MachineRegisters a, MachineCode b)
 386     => [Int]
 387     -> RegHistory a
 388     -> RegFuture
 389     -> b
 390     -> (RegHistory a, RegFuture, b)
 391
 392 doRegAlloc reserved_regs free_env in_use instr = (free_env', in_use', instr')
 393   where
 394       (free_env', instr') = doRegAlloc' reserved_regs free_env info instr
 395       (in_use', info) = getUsage in_use instr
 396
 397 \end{code}
 398
 399 \begin{code}
 400
 401 getUsage
 402     :: MachineCode a
 403     => RegFuture
 404     -> a
 405     -> (RegFuture, RegInfo a)
 406
 407 getUsage (RF next_in_use future reg_conflicts) instr =
 408     (RF in_use' future' reg_conflicts',
 409      RI in_use' srcs dsts last_used reg_conflicts')
 410          where (RU srcs dsts) = regUsage instr
 411                (RL in_use future') = regLiveness instr (RL next_in_use future)
 412                live_through = in_use `minusUniqSet` dsts
 413                last_used = [ r | r <- uniqSetToList srcs,
 414                              not (r `elementOfUniqSet` (fstFL future) || r `elementOfUniqSet` in_use)]
 415                in_use' = srcs `unionUniqSets` live_through
 416                reg_conflicts' = case new_conflicts of
 417                     [] -> reg_conflicts
 418                     _ -> addListToFM reg_conflicts new_conflicts
 419                new_conflicts = if isEmptyUniqSet live_dynamics then []
 420                                else [ (r, merge_conflicts r)
 421                                         | r <- extractMappedRegNos (uniqSetToList dsts) ]
 422                merge_conflicts reg = case lookupFM reg_conflicts reg of
 423                             Nothing -> live_dynamics
 424                             Just conflicts -> conflicts `unionUniqSets` live_dynamics
 425                live_dynamics = mkUniqSet
 426                             [ r | r@(UnmappedReg _ _) <- uniqSetToList live_through ]
 427
 428 doRegAlloc'
 429     :: (MachineRegisters a, MachineCode b)
 430     => [Int]
 431     -> RegHistory a
 432     -> RegInfo b
 433     -> b
 434     -> (RegHistory a, b)
 435
 436 doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) instr =
 437
 438     (RH frs'' loc' env'', patchRegs instr dynToStatic)
 439
 440     where
 441
 442       -- free up new registers
 443       free :: [Int]
 444       free = extractMappedRegNos (map dynToStatic lastu)
 445
 446       -- (1) free registers that are used last as source operands in this instruction
 447       frs_not_in_use = frs `useMRegs` (extractMappedRegNos (uniqSetToList in_use))
 448       frs' = (frs_not_in_use `freeMRegs` free) `useMRegs` reserved
 449
 450       -- (2) allocate new registers for the destination operands
 451       -- allocate registers for new dynamics
 452
 453       new_dynamix = [ r | r@(UnmappedReg _ _) <- uniqSetToList dsts, r `not_elem` keysFM env ]
 454
 455       (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix
 456
 457       env' = addListToFM env new
 458
 459       env'' = delListFromFM env' lastu
 460
 461       dynToStatic :: Reg -> Reg
 462       dynToStatic dyn@(UnmappedReg _ _) =
 463         case lookupFM env' dyn of
 464             Just r -> r
 465             Nothing -> trace "Lost register; possibly a floating point type error in a _ccall_?" dyn
 466       dynToStatic other = other
 467
 468       allocateNewRegs
 469         :: MachineRegisters a
 470         => Reg -> (a, Int, [(Reg, Reg)]) -> (a, Int, [(Reg, Reg)])
 471
 472       allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst)
 473         where (fs', f, mem') = case acceptable fs of
 474                 [] -> (fs, MemoryReg mem pk, mem + 1)
 475                 (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
 476
 477               acceptable regs = filter no_conflict (possibleMRegs pk regs)
 478               no_conflict reg = case lookupFM conflicts reg of
 479                     Nothing -> True
 480                     Just conflicts -> not (d `elementOfUniqSet` conflicts)
 481 \end{code}
 482
 483 \begin{code}
 484 extractMappedRegNos :: [Reg] -> [Int]
 485
 486 extractMappedRegNos regs
 487   = foldr ex [] regs
 488   where
 489     ex (MappedReg i) acc = IBOX(i) : acc  -- we'll take it
 490     ex _             acc = acc            -- leave it out
 491 \end{code}
 492
 493 We keep a local copy of the Prelude function \tr{notElem},
 494 so that it can be specialised.  (Hack me gently.  [WDP 94/11])
 495 \begin{code}
 496 not_elem x []       =  True
 497 not_elem x (y:ys)   =  x /= y && not_elem x ys
 498 \end{code}