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