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