ghc/compiler/nativeGen/AsmCodeGen.lhs

   1 -- -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow 1993-2004
   4 --
   5 -- This is the top-level module in the native code generator.
   6 --
   7 -- -----------------------------------------------------------------------------
   8
   9 \begin{code}
  10 module AsmCodeGen ( nativeCodeGen ) where
  11
  12 #include "HsVersions.h"
  13 #include "NCG.h"
  14
  15 import MachInstrs
  16 import MachRegs
  17 import MachCodeGen
  18 import PprMach
  19 import RegisterAlloc
  20 import RegAllocInfo     ( jumpDests )
  21 import NCGMonad
  22 import PositionIndependentCode
  23
  24 import Cmm
  25 import PprCmm           ( pprStmt, pprCmms )
  26 import MachOp
  27 import CLabel           ( CLabel, mkSplitMarkerLabel, mkAsmTempLabel )
  28 #if powerpc_TARGET_ARCH
  29 import CLabel           ( mkRtsCodeLabel )
  30 #endif
  31
  32 import UniqFM
  33 import Unique           ( Unique, getUnique )
  34 import UniqSupply
  35 import FastTypes
  36 #if darwin_TARGET_OS || (powerpc_TARGET_ARCH && linux_TARGET_OS)
  37 import List             ( groupBy, sortBy )
  38 import CLabel           ( pprCLabel )
  39 #endif
  40 import ErrUtils         ( dumpIfSet_dyn )
  41 import CmdLineOpts      ( DynFlags, DynFlag(..), dopt, opt_Static,
  42                           opt_EnsureSplittableC, opt_PIC )
  43
  44 import Digraph
  45 import qualified Pretty
  46 import Outputable
  47 import FastString
  48
  49 -- DEBUGGING ONLY
  50 --import OrdList
  51
  52 #ifdef NCG_DEBUG
  53 import List             ( intersperse )
  54 #endif
  55
  56 import DATA_INT
  57 import DATA_WORD
  58 import DATA_BITS
  59 import GLAEXTS
  60
  61 {-
  62 The native-code generator has machine-independent and
  63 machine-dependent modules.
  64
  65 This module ("AsmCodeGen") is the top-level machine-independent
  66 module.  Before entering machine-dependent land, we do some
  67 machine-independent optimisations (defined below) on the
  68 'CmmStmts's.
  69
  70 We convert to the machine-specific 'Instr' datatype with
  71 'cmmCodeGen', assuming an infinite supply of registers.  We then use
  72 a machine-independent register allocator ('regAlloc') to rejoin
  73 reality.  Obviously, 'regAlloc' has machine-specific helper
  74 functions (see about "RegAllocInfo" below).
  75
  76 Finally, we order the basic blocks of the function so as to minimise
  77 the number of jumps between blocks, by utilising fallthrough wherever
  78 possible.
  79
  80 The machine-dependent bits break down as follows:
  81
  82   * ["MachRegs"]  Everything about the target platform's machine
  83     registers (and immediate operands, and addresses, which tend to
  84     intermingle/interact with registers).
  85
  86   * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should
  87     have a module of its own), plus a miscellany of other things
  88     (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
  89
  90   * ["MachCodeGen"]  is where 'Cmm' stuff turns into
  91     machine instructions.
  92
  93   * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
  94     a 'Doc').
  95
  96   * ["RegAllocInfo"] In the register allocator, we manipulate
  97     'MRegsState's, which are 'BitSet's, one bit per machine register.
  98     When we want to say something about a specific machine register
  99     (e.g., ``it gets clobbered by this instruction''), we set/unset
 100     its bit.  Obviously, we do this 'BitSet' thing for efficiency
 101     reasons.
 102
 103     The 'RegAllocInfo' module collects together the machine-specific
 104     info needed to do register allocation.
 105
 106    * ["RegisterAlloc"] The (machine-independent) register allocator.
 107 -}
 108
 109 -- -----------------------------------------------------------------------------
 110 -- Top-level of the native codegen
 111
 112 -- NB. We *lazilly* compile each block of code for space reasons.
 113
 114 nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc
 115 nativeCodeGen dflags cmms us
 116   = let ((ppr_cmms, insn_sdoc, imports), _) = initUs us $
 117            cgCmm (concat (map add_split cmms))
 118
 119         cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [CLabel])
 120         cgCmm tops =
 121            lazyMapUs (cmmNativeGen dflags) tops  `thenUs` \ results ->
 122            let (cmms,docs,imps) = unzip3 results in
 123            returnUs (Cmm cmms, my_vcat docs, concat imps)
 124     in do
 125     dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmms [ppr_cmms])
 126     return (insn_sdoc Pretty.$$ dyld_stubs imports)
 127
 128   where
 129
 130     add_split (Cmm tops)
 131         | opt_EnsureSplittableC = split_marker : tops
 132         | otherwise             = tops
 133
 134     split_marker = CmmProc [] mkSplitMarkerLabel [] []
 135
 136 #if darwin_TARGET_OS || (powerpc_TARGET_ARCH && linux_TARGET_OS)
 137          -- Generate "symbol stubs" for all external symbols that might
 138          -- come from a dynamic library.
 139 {-    dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
 140                                     map head $ group $ sort imps-}
 141
 142         -- (Hack) sometimes two Labels pretty-print the same, but have
 143         -- different uniques; so we compare their text versions...
 144     dyld_stubs imps
 145         | needImportedSymbols
 146           = Pretty.vcat $
 147             (pprGotDeclaration :) $
 148             map (pprImportedSymbol . fst . head) $
 149             groupBy (\(_,a) (_,b) -> a == b) $
 150             sortBy (\(_,a) (_,b) -> compare a b) $
 151             map doPpr $
 152             imps
 153         | otherwise
 154           = Pretty.empty
 155
 156         where doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
 157               astyle = mkCodeStyle AsmStyle
 158 #else
 159     dyld_stubs imps = Pretty.empty
 160 #endif
 161
 162 #ifndef NCG_DEBUG
 163     my_vcat sds = Pretty.vcat sds
 164 #else
 165     my_vcat sds = Pretty.vcat (
 166                       intersperse (
 167                          Pretty.char ' '
 168                             Pretty.$$ Pretty.ptext SLIT("# ___ncg_debug_marker")
 169                             Pretty.$$ Pretty.char ' '
 170                       )
 171                       sds
 172                    )
 173 #endif
 174
 175
 176 -- Complete native code generation phase for a single top-level chunk
 177 -- of Cmm.
 178
 179 cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [CLabel])
 180 cmmNativeGen dflags cmm
 181    = {-# SCC "fixAssigns"       #-}
 182         fixAssignsTop cmm            `thenUs` \ fixed_cmm ->
 183      {-# SCC "genericOpt"       #-}
 184         cmmToCmm fixed_cmm           `bind`   \ (cmm, imports) ->
 185         (if dopt Opt_D_dump_opt_cmm dflags  -- space leak avoidance
 186            then cmm
 187            else CmmData Text [])     `bind`   \ ppr_cmm ->
 188      {-# SCC "genMachCode"      #-}
 189         genMachCode cmm              `thenUs` \ (pre_regalloc, lastMinuteImports) ->
 190      {-# SCC "regAlloc"         #-}
 191         map regAlloc pre_regalloc    `bind`   \ with_regs ->
 192      {-# SCC "sequenceBlocks"   #-}
 193         map sequenceTop with_regs    `bind`   \ sequenced ->
 194      {-# SCC "x86fp_kludge"     #-}
 195         map x86fp_kludge sequenced   `bind`   \ final_mach_code ->
 196      {-# SCC "vcat"             #-}
 197         Pretty.vcat (map pprNatCmmTop final_mach_code)  `bind`   \ final_sdoc ->
 198
 199         returnUs (ppr_cmm, final_sdoc Pretty.$$ Pretty.text "", lastMinuteImports ++ imports)
 200      where
 201         x86fp_kludge :: NatCmmTop -> NatCmmTop
 202         x86fp_kludge top@(CmmData _ _) = top
 203 #if i386_TARGET_ARCH
 204         x86fp_kludge top@(CmmProc info lbl params code) =
 205                 CmmProc info lbl params (map bb_i386_insert_ffrees code)
 206                 where
 207                   bb_i386_insert_ffrees (BasicBlock id instrs) =
 208                         BasicBlock id (i386_insert_ffrees instrs)
 209 #else
 210         x86fp_kludge top =  top
 211 #endif
 212
 213 -- -----------------------------------------------------------------------------
 214 -- Sequencing the basic blocks
 215
 216 -- Cmm BasicBlocks are self-contained entities: they always end in a
 217 -- jump, either non-local or to another basic block in the same proc.
 218 -- In this phase, we attempt to place the basic blocks in a sequence
 219 -- such that as many of the local jumps as possible turn into
 220 -- fallthroughs.
 221
 222 sequenceTop :: NatCmmTop -> NatCmmTop
 223 sequenceTop top@(CmmData _ _) = top
 224 sequenceTop (CmmProc info lbl params blocks) =
 225   CmmProc info lbl params (sequenceBlocks blocks)
 226
 227 -- The algorithm is very simple (and stupid): we make a graph out of
 228 -- the blocks where there is an edge from one block to another iff the
 229 -- first block ends by jumping to the second.  Then we topologically
 230 -- sort this graph.  Then traverse the list: for each block, we first
 231 -- output the block, then if it has an out edge, we move the
 232 -- destination of the out edge to the front of the list, and continue.
 233
 234 sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock]
 235 sequenceBlocks [] = []
 236 sequenceBlocks (entry:blocks) =
 237   seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
 238   -- the first block is the entry point ==> it must remain at the start.
 239
 240 sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])]
 241 sccBlocks blocks = stronglyConnCompR (map mkNode blocks)
 242
 243 getOutEdges :: [Instr] -> [Unique]
 244 getOutEdges instrs = case jumpDests (last instrs) [] of
 245                         [one] -> [getUnique one]
 246                         _many -> []
 247                 -- we're only interested in the last instruction of
 248                 -- the block, and only if it has a single destination.
 249
 250 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
 251
 252 seqBlocks [] = []
 253 seqBlocks ((block,_,[]) : rest)
 254   = block : seqBlocks rest
 255 seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
 256   | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
 257   | otherwise       = block : seqBlocks rest'
 258   where
 259         (can_fallthrough, rest') = reorder next [] rest
 260           -- TODO: we should do a better job for cycles; try to maximise the
 261           -- fallthroughs within a loop.
 262 seqBlocks _ = panic "AsmCodegen:seqBlocks"
 263
 264 reorder id accum [] = (False, reverse accum)
 265 reorder id accum (b@(block,id',out) : rest)
 266   | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
 267   | otherwise  = reorder id (b:accum) rest
 268
 269 -- -----------------------------------------------------------------------------
 270 -- Instruction selection
 271
 272 -- Native code instruction selection for a chunk of stix code.  For
 273 -- this part of the computation, we switch from the UniqSM monad to
 274 -- the NatM monad.  The latter carries not only a Unique, but also an
 275 -- Int denoting the current C stack pointer offset in the generated
 276 -- code; this is needed for creating correct spill offsets on
 277 -- architectures which don't offer, or for which it would be
 278 -- prohibitively expensive to employ, a frame pointer register.  Viz,
 279 -- x86.
 280
 281 -- The offset is measured in bytes, and indicates the difference
 282 -- between the current (simulated) C stack-ptr and the value it was at
 283 -- the beginning of the block.  For stacks which grow down, this value
 284 -- should be either zero or negative.
 285
 286 -- Switching between the two monads whilst carrying along the same
 287 -- Unique supply breaks abstraction.  Is that bad?
 288
 289 genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel])
 290
 291 genMachCode cmm_top initial_us
 292   = let initial_st             = mkNatM_State initial_us 0
 293         (new_tops, final_st)   = initNat initial_st (cmmTopCodeGen cmm_top)
 294         final_us               = natm_us final_st
 295         final_delta            = natm_delta final_st
 296         final_imports          = natm_imports final_st
 297     in
 298         if   final_delta == 0
 299         then ((new_tops, final_imports), final_us)
 300         else pprPanic "genMachCode: nonzero final delta"
 301                       (int final_delta)
 302
 303 -- -----------------------------------------------------------------------------
 304 -- Fixup assignments to global registers so that they assign to
 305 -- locations within the RegTable, if appropriate.
 306
 307 -- Note that we currently don't fixup reads here: they're done by
 308 -- the generic optimiser below, to avoid having two separate passes
 309 -- over the Cmm.
 310
 311 fixAssignsTop :: CmmTop -> UniqSM CmmTop
 312 fixAssignsTop top@(CmmData _ _) = returnUs top
 313 fixAssignsTop (CmmProc info lbl params blocks) =
 314   mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
 315   returnUs (CmmProc info lbl params blocks')
 316
 317 fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
 318 fixAssignsBlock (BasicBlock id stmts) =
 319   fixAssigns stmts `thenUs` \ stmts' ->
 320   returnUs (BasicBlock id stmts')
 321
 322 fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt]
 323 fixAssigns stmts =
 324   mapUs fixAssign stmts `thenUs` \ stmtss ->
 325   returnUs (concat stmtss)
 326
 327 fixAssign :: CmmStmt -> UniqSM [CmmStmt]
 328 fixAssign (CmmAssign (CmmGlobal BaseReg) src)
 329    = panic "cmmStmtConFold: assignment to BaseReg";
 330
 331 fixAssign (CmmAssign (CmmGlobal reg) src)
 332   | Left  realreg <- reg_or_addr
 333   = returnUs [CmmAssign (CmmGlobal reg) src]
 334   | Right baseRegAddr <- reg_or_addr
 335   = returnUs [CmmStore baseRegAddr src]
 336            -- Replace register leaves with appropriate StixTrees for
 337            -- the given target. GlobalRegs which map to a reg on this
 338            -- arch are left unchanged.  Assigning to BaseReg is always
 339            -- illegal, so we check for that.
 340   where
 341         reg_or_addr = get_GlobalReg_reg_or_addr reg
 342
 343 fixAssign (CmmCall target results args vols)
 344   = mapAndUnzipUs fixResult results `thenUs` \ (results',stores) ->
 345     returnUs (CmmCall target results' args vols : concat stores)
 346   where
 347         fixResult g@(CmmGlobal reg,hint) =
 348           case get_GlobalReg_reg_or_addr reg of
 349                 Left realreg -> returnUs (g, [])
 350                 Right baseRegAddr ->
 351                     getUniqueUs `thenUs` \ uq ->
 352                     let local = CmmLocal (LocalReg uq (globalRegRep reg)) in
 353                     returnUs ((local,hint),
 354                               [CmmStore baseRegAddr (CmmReg local)])
 355         fixResult other =
 356           returnUs (other,[])
 357
 358 fixAssign other_stmt = returnUs [other_stmt]
 359
 360 -- -----------------------------------------------------------------------------
 361 -- Generic Cmm optimiser
 362
 363 {-
 364 Here we do:
 365
 366   (a) Constant folding
 367   (b) Simple inlining: a temporary which is assigned to and then
 368       used, once, can be shorted.
 369   (c) Replacement of references to GlobalRegs which do not have
 370       machine registers by the appropriate memory load (eg.
 371       Hp ==>  *(BaseReg + 34) ).
 372   (d) Position independent code and dynamic linking
 373         (i)  introduce the appropriate indirections
 374              and position independent refs
 375         (ii) compile a list of imported symbols
 376
 377 Ideas for other things we could do (ToDo):
 378
 379   - shortcut jumps-to-jumps
 380   - eliminate dead code blocks
 381 -}
 382
 383 cmmToCmm :: CmmTop -> (CmmTop, [CLabel])
 384 cmmToCmm top@(CmmData _ _) = (top, [])
 385 cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
 386   blocks' <- mapM cmmBlockConFold (cmmPeep blocks)
 387   return $ CmmProc info lbl params blocks'
 388
 389 newtype CmmOptM a = CmmOptM ([CLabel] -> (# a, [CLabel] #))
 390
 391 instance Monad CmmOptM where
 392   return x = CmmOptM $ \imports -> (# x,imports #)
 393   (CmmOptM f) >>= g =
 394     CmmOptM $ \imports ->
 395                 case f imports of
 396                   (# x, imports' #) ->
 397                     case g x of
 398                       CmmOptM g' -> g' imports'
 399
 400 addImportCmmOpt :: CLabel -> CmmOptM ()
 401 addImportCmmOpt lbl = CmmOptM $ \imports -> (# (), lbl:imports #)
 402
 403 runCmmOpt :: CmmOptM a -> (a, [CLabel])
 404 runCmmOpt (CmmOptM f) = case f [] of
 405                         (# result, imports #) -> (result, imports)
 406
 407 cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
 408 cmmBlockConFold (BasicBlock id stmts) = do
 409   stmts' <- mapM cmmStmtConFold stmts
 410   return $ BasicBlock id stmts'
 411
 412 cmmStmtConFold stmt
 413    = case stmt of
 414         CmmAssign reg src
 415            -> do src' <- cmmExprConFold False src
 416                  return $ case src' of
 417                    CmmReg reg' | reg == reg' -> CmmNop
 418                    new_src -> CmmAssign reg new_src
 419
 420         CmmStore addr src
 421            -> do addr' <- cmmExprConFold False addr
 422                  src'  <- cmmExprConFold False src
 423                  return $ CmmStore addr' src'
 424
 425         CmmJump addr regs
 426            -> do addr' <- cmmExprConFold True addr
 427                  return $ CmmJump addr' regs
 428
 429         CmmCall target regs args vols
 430            -> do target' <- case target of
 431                               CmmForeignCall e conv -> do
 432                                 e' <- cmmExprConFold True e
 433                                 return $ CmmForeignCall e' conv
 434                               other -> return other
 435                  args' <- mapM (\(arg, hint) -> do
 436                                   arg' <- cmmExprConFold False arg
 437                                   return (arg', hint)) args
 438                  return $ CmmCall target' regs args' vols
 439
 440         CmmCondBranch test dest
 441            -> do test' <- cmmExprConFold False test
 442                  return $ case test' of
 443                    CmmLit (CmmInt 0 _) ->
 444                      CmmComment (mkFastString ("deleted: " ++
 445                                         showSDoc (pprStmt stmt)))
 446
 447                    CmmLit (CmmInt n _) -> CmmBranch dest
 448                    other -> CmmCondBranch test' dest
 449
 450         CmmSwitch expr ids
 451            -> do expr' <- cmmExprConFold False expr
 452                  return $ CmmSwitch expr' ids
 453
 454         other
 455            -> return other
 456
 457
 458 cmmExprConFold isJumpTarget expr
 459    = case expr of
 460         CmmLoad addr rep
 461            -> do addr' <- cmmExprConFold False addr
 462                  return $ CmmLoad addr' rep
 463
 464         CmmMachOp mop args
 465            -- For MachOps, we first optimize the children, and then we try
 466            -- our hand at some constant-folding.
 467            -> do args' <- mapM (cmmExprConFold False) args
 468                  return $ cmmMachOpFold mop args'
 469
 470         CmmLit (CmmLabel lbl)
 471            -> cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
 472         CmmLit (CmmLabelOff lbl off)
 473            -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
 474                  return $ cmmMachOpFold (MO_Add wordRep) [
 475                      dynRef,
 476                      (CmmLit $ CmmInt (fromIntegral off) wordRep)
 477                    ]
 478
 479 #if powerpc_TARGET_ARCH
 480            -- On powerpc (non-PIC), it's easier to jump directly to a label than
 481            -- to use the register table, so we replace these registers
 482            -- with the corresponding labels:
 483         CmmReg (CmmGlobal GCEnter1)
 484           | not opt_PIC
 485           -> cmmExprConFold isJumpTarget $
 486              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
 487         CmmReg (CmmGlobal GCFun)
 488           | not opt_PIC
 489           -> cmmExprConFold isJumpTarget $
 490              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
 491 #endif
 492
 493         CmmReg (CmmGlobal mid)
 494            -- Replace register leaves with appropriate StixTrees for
 495            -- the given target.  MagicIds which map to a reg on this
 496            -- arch are left unchanged.  For the rest, BaseReg is taken
 497            -- to mean the address of the reg table in MainCapability,
 498            -- and for all others we generate an indirection to its
 499            -- location in the register table.
 500            -> case get_GlobalReg_reg_or_addr mid of
 501                  Left  realreg -> return expr
 502                  Right baseRegAddr
 503                     -> case mid of
 504                           BaseReg -> cmmExprConFold False baseRegAddr
 505                           other   -> cmmExprConFold False (CmmLoad baseRegAddr
 506                                                         (globalRegRep mid))
 507            -- eliminate zero offsets
 508         CmmRegOff reg 0
 509            -> cmmExprConFold False (CmmReg reg)
 510
 511         CmmRegOff (CmmGlobal mid) offset
 512            -- RegOf leaves are just a shorthand form. If the reg maps
 513            -- to a real reg, we keep the shorthand, otherwise, we just
 514            -- expand it and defer to the above code.
 515            -> case get_GlobalReg_reg_or_addr mid of
 516                 Left  realreg -> return expr
 517                 Right baseRegAddr
 518                    -> cmmExprConFold False (CmmMachOp (MO_Add wordRep) [
 519                                         CmmReg (CmmGlobal mid),
 520                                         CmmLit (CmmInt (fromIntegral offset)
 521                                                        wordRep)])
 522         other
 523            -> return other
 524
 525
 526 -- -----------------------------------------------------------------------------
 527 -- MachOp constant folder
 528
 529 -- Now, try to constant-fold the MachOps.  The arguments have already
 530 -- been optimized and folded.
 531
 532 cmmMachOpFold
 533     :: MachOp           -- The operation from an CmmMachOp
 534     -> [CmmExpr]        -- The optimized arguments
 535     -> CmmExpr
 536
 537 cmmMachOpFold op arg@[CmmLit (CmmInt x rep)]
 538   = case op of
 539       MO_S_Neg r -> CmmLit (CmmInt (-x) rep)
 540       MO_Not r   -> CmmLit (CmmInt (complement x) rep)
 541
 542         -- these are interesting: we must first narrow to the
 543         -- "from" type, in order to truncate to the correct size.
 544         -- The final narrow/widen to the destination type
 545         -- is implicit in the CmmLit.
 546       MO_S_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
 547       MO_U_Conv from to -> CmmLit (CmmInt (narrowU from x) to)
 548       _  -> panic "cmmMachOpFold: unknown unary op"
 549
 550 -- Eliminate conversion NOPs
 551 cmmMachOpFold (MO_S_Conv rep1 rep2) [x] | rep1 == rep2 = x
 552 cmmMachOpFold (MO_U_Conv rep1 rep2) [x] | rep1 == rep2 = x
 553
 554 -- ToDo: eliminate multiple conversions.  Be careful though: can't remove
 555 -- a narrowing, and can't remove conversions to/from floating point types.
 556
 557 -- ToDo: eliminate nested comparisons:
 558 --    CmmMachOp MO_Lt [CmmMachOp MO_Eq [x,y], CmmLit (CmmInt 0 _)]
 559 -- turns into a simple equality test.
 560
 561 cmmMachOpFold mop args@[CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
 562   = case mop of
 563         -- for comparisons: don't forget to narrow the arguments before
 564         -- comparing, since they might be out of range.
 565         MO_Eq r   -> CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordRep)
 566         MO_Ne r   -> CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordRep)
 567
 568         MO_U_Gt r -> CmmLit (CmmInt (if x_u >  y_u then 1 else 0) wordRep)
 569         MO_U_Ge r -> CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordRep)
 570         MO_U_Lt r -> CmmLit (CmmInt (if x_u <  y_u then 1 else 0) wordRep)
 571         MO_U_Le r -> CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordRep)
 572
 573         MO_S_Gt r -> CmmLit (CmmInt (if x_s >  y_s then 1 else 0) wordRep)
 574         MO_S_Ge r -> CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordRep)
 575         MO_S_Lt r -> CmmLit (CmmInt (if x_s <  y_s then 1 else 0) wordRep)
 576         MO_S_Le r -> CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordRep)
 577
 578         MO_Add r -> CmmLit (CmmInt (x + y) r)
 579         MO_Sub r -> CmmLit (CmmInt (x - y) r)
 580         MO_Mul r -> CmmLit (CmmInt (x * y) r)
 581         MO_S_Quot r | y /= 0 -> CmmLit (CmmInt (x `quot` y) r)
 582         MO_S_Rem  r | y /= 0 -> CmmLit (CmmInt (x `rem` y) r)
 583
 584         MO_And   r -> CmmLit (CmmInt (x .&. y) r)
 585         MO_Or    r -> CmmLit (CmmInt (x .|. y) r)
 586         MO_Xor   r -> CmmLit (CmmInt (x `xor` y) r)
 587
 588         MO_Shl   r -> CmmLit (CmmInt (x `shiftL` fromIntegral y) r)
 589         MO_U_Shr r -> CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)
 590         MO_S_Shr r -> CmmLit (CmmInt (x `shiftR` fromIntegral y) r)
 591
 592         other      -> CmmMachOp mop args
 593
 594    where
 595         x_u = narrowU xrep x
 596         y_u = narrowU xrep y
 597         x_s = narrowS xrep x
 598         y_s = narrowS xrep y
 599
 600
 601 -- When possible, shift the constants to the right-hand side, so that we
 602 -- can match for strength reductions.  Note that the code generator will
 603 -- also assume that constants have been shifted to the right when
 604 -- possible.
 605
 606 cmmMachOpFold op [x@(CmmLit _), y]
 607    | not (isLit y) && isCommutableMachOp op
 608    = cmmMachOpFold op [y, x]
 609
 610 -- Turn (a+b)+c into a+(b+c) where possible.  Because literals are
 611 -- moved to the right, it is more likely that we will find
 612 -- opportunities for constant folding when the expression is
 613 -- right-associated.
 614 --
 615 -- ToDo: this appears to introduce a quadratic behaviour due to the
 616 -- nested cmmMachOpFold.  Can we fix this?
 617 --
 618 -- Why do we check isLit arg1?  If arg1 is a lit, it means that arg2
 619 -- is also a lit (otherwise arg1 would be on the right).  If we
 620 -- put arg1 on the left of the rearranged expression, we'll get into a
 621 -- loop:  (x1+x2)+x3 => x1+(x2+x3)  => (x2+x3)+x1 => x2+(x3+x1) ...
 622 --
 623 cmmMachOpFold mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
 624    | mop1 == mop2 && isAssociativeMachOp mop1 && not (isLit arg1)
 625    = cmmMachOpFold mop1 [arg1, cmmMachOpFold mop2 [arg2,arg3]]
 626
 627 -- Make a RegOff if we can
 628 cmmMachOpFold (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
 629   = CmmRegOff reg (fromIntegral (narrowS rep n))
 630 cmmMachOpFold (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
 631   = CmmRegOff reg (off + fromIntegral (narrowS rep n))
 632 cmmMachOpFold (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]
 633   = CmmRegOff reg (- fromIntegral (narrowS rep n))
 634 cmmMachOpFold (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
 635   = CmmRegOff reg (off - fromIntegral (narrowS rep n))
 636
 637 -- Fold label(+/-)offset into a CmmLit where possible
 638
 639 cmmMachOpFold (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
 640   = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
 641 cmmMachOpFold (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)]
 642   = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
 643 cmmMachOpFold (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
 644   = CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i))))
 645
 646 -- We can often do something with constants of 0 and 1 ...
 647
 648 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))]
 649   = case mop of
 650         MO_Add   r -> x
 651         MO_Sub   r -> x
 652         MO_Mul   r -> y
 653         MO_And   r -> y
 654         MO_Or    r -> x
 655         MO_Xor   r -> x
 656         MO_Shl   r -> x
 657         MO_S_Shr r -> x
 658         MO_U_Shr r -> x
 659         MO_Ne    r | isComparisonExpr x -> x
 660         MO_Eq    r | Just x' <- maybeInvertConditionalExpr x -> x'
 661         MO_U_Gt  r | isComparisonExpr x -> x
 662         MO_S_Gt  r | isComparisonExpr x -> x
 663         MO_U_Lt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
 664         MO_S_Lt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
 665         MO_U_Ge  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
 666         MO_S_Ge  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
 667         MO_U_Le  r | Just x' <- maybeInvertConditionalExpr x -> x'
 668         MO_S_Le  r | Just x' <- maybeInvertConditionalExpr x -> x'
 669         other    -> CmmMachOp mop args
 670
 671 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))]
 672   = case mop of
 673         MO_Mul    r -> x
 674         MO_S_Quot r -> x
 675         MO_U_Quot r -> x
 676         MO_S_Rem  r -> CmmLit (CmmInt 0 rep)
 677         MO_U_Rem  r -> CmmLit (CmmInt 0 rep)
 678         MO_Ne    r | Just x' <- maybeInvertConditionalExpr x -> x'
 679         MO_Eq    r | isComparisonExpr x -> x
 680         MO_U_Lt  r | Just x' <- maybeInvertConditionalExpr x -> x'
 681         MO_S_Lt  r | Just x' <- maybeInvertConditionalExpr x -> x'
 682         MO_U_Gt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
 683         MO_S_Gt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
 684         MO_U_Le  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
 685         MO_S_Le  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
 686         MO_U_Ge  r | isComparisonExpr x -> x
 687         MO_S_Ge  r | isComparisonExpr x -> x
 688         other       -> CmmMachOp mop args
 689
 690 -- Now look for multiplication/division by powers of 2 (integers).
 691
 692 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt n _))]
 693   = case mop of
 694         MO_Mul rep
 695            -> case exactLog2 n of
 696                  Nothing -> unchanged
 697                  Just p  -> CmmMachOp (MO_Shl rep) [x, CmmLit (CmmInt p rep)]
 698         MO_S_Quot rep
 699            -> case exactLog2 n of
 700                  Nothing -> unchanged
 701                  Just p  -> CmmMachOp (MO_S_Shr rep) [x, CmmLit (CmmInt p rep)]
 702         other
 703            -> unchanged
 704     where
 705        unchanged = CmmMachOp mop args
 706
 707 -- Anything else is just too hard.
 708
 709 cmmMachOpFold mop args = CmmMachOp mop args
 710
 711 -- -----------------------------------------------------------------------------
 712 -- exactLog2
 713
 714 -- This algorithm for determining the $\log_2$ of exact powers of 2 comes
 715 -- from GCC.  It requires bit manipulation primitives, and we use GHC
 716 -- extensions.  Tough.
 717 --
 718 -- Used to be in MachInstrs --SDM.
 719 -- ToDo: remove use of unboxery --SDM.
 720
 721 w2i x = word2Int# x
 722 i2w x = int2Word# x
 723
 724 exactLog2 :: Integer -> Maybe Integer
 725 exactLog2 x
 726   = if (x <= 0 || x >= 2147483648) then
 727        Nothing
 728     else
 729        case iUnbox (fromInteger x) of { x# ->
 730        if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then
 731           Nothing
 732        else
 733           Just (toInteger (iBox (pow2 x#)))
 734        }
 735   where
 736     pow2 x# | x# ==# 1# = 0#
 737             | otherwise = 1# +# pow2 (w2i (i2w x# `shiftRL#` 1#))
 738
 739
 740 -- -----------------------------------------------------------------------------
 741 -- widening / narrowing
 742
 743 narrowU :: MachRep -> Integer -> Integer
 744 narrowU I8  x = fromIntegral (fromIntegral x :: Word8)
 745 narrowU I16 x = fromIntegral (fromIntegral x :: Word16)
 746 narrowU I32 x = fromIntegral (fromIntegral x :: Word32)
 747 narrowU I64 x = fromIntegral (fromIntegral x :: Word64)
 748 narrowU _ _ = panic "narrowTo"
 749
 750 narrowS :: MachRep -> Integer -> Integer
 751 narrowS I8  x = fromIntegral (fromIntegral x :: Int8)
 752 narrowS I16 x = fromIntegral (fromIntegral x :: Int16)
 753 narrowS I32 x = fromIntegral (fromIntegral x :: Int32)
 754 narrowS I64 x = fromIntegral (fromIntegral x :: Int64)
 755 narrowS _ _ = panic "narrowTo"
 756
 757 -- -----------------------------------------------------------------------------
 758 -- The mini-inliner
 759
 760 -- This pass inlines assignments to temporaries that are used just
 761 -- once in the very next statement only.  Generalising this would be
 762 -- quite difficult (have to take into account aliasing of memory
 763 -- writes, and so on), but at the moment it catches a number of useful
 764 -- cases and lets the code generator generate much better code.
 765
 766 -- NB. This assumes that temporaries are single-assignment.
 767
 768 cmmPeep :: [CmmBasicBlock] -> [CmmBasicBlock]
 769 cmmPeep blocks = map do_inline blocks
 770   where
 771         blockUses (BasicBlock _ stmts)
 772          = foldr (plusUFM_C (+)) emptyUFM (map getStmtUses stmts)
 773
 774         uses = foldr (plusUFM_C (+)) emptyUFM (map blockUses blocks)
 775
 776         do_inline (BasicBlock id stmts)
 777          = BasicBlock id (cmmMiniInline uses stmts)
 778
 779
 780 cmmMiniInline :: UniqFM Int -> [CmmStmt] -> [CmmStmt]
 781 cmmMiniInline uses [] = []
 782 cmmMiniInline uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
 783   | Just 1 <- lookupUFM uses u,
 784     Just stmts' <- lookForInline u expr stmts
 785   =
 786 #ifdef NCG_DEBUG
 787      trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $
 788 #endif
 789      cmmMiniInline uses stmts'
 790
 791 cmmMiniInline uses (stmt:stmts)
 792   = stmt : cmmMiniInline uses stmts
 793
 794
 795 -- Try to inline a temporary assignment.  We can skip over assignments to
 796 -- other tempoararies, because we know that expressions aren't side-effecting
 797 -- and temporaries are single-assignment.
 798 lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _)) rhs) : rest)
 799   | u /= u'
 800   = case lookupUFM (getExprUses rhs) u of
 801         Just 1 -> Just (inlineStmt u expr stmt : rest)
 802         _other -> case lookForInline u expr rest of
 803                      Nothing    -> Nothing
 804                      Just stmts -> Just (stmt:stmts)
 805
 806 lookForInline u expr (CmmNop : rest)
 807   = lookForInline u expr rest
 808
 809 lookForInline u expr (stmt:stmts)
 810   = case lookupUFM (getStmtUses stmt) u of
 811         Just 1 -> Just (inlineStmt u expr stmt : stmts)
 812         _other -> Nothing
 813
 814 -- -----------------------------------------------------------------------------
 815 -- Boring Cmm traversals for collecting usage info and substitutions.
 816
 817 getStmtUses :: CmmStmt -> UniqFM Int
 818 getStmtUses (CmmAssign _ e) = getExprUses e
 819 getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2)
 820 getStmtUses (CmmCall target _ es _)
 821    = plusUFM_C (+) (uses target) (getExprsUses (map fst es))
 822    where uses (CmmForeignCall e _) = getExprUses e
 823          uses _ = emptyUFM
 824 getStmtUses (CmmCondBranch e _) = getExprUses e
 825 getStmtUses (CmmSwitch e _) = getExprUses e
 826 getStmtUses (CmmJump e _) = getExprUses e
 827 getStmtUses _ = emptyUFM
 828
 829 getExprUses :: CmmExpr -> UniqFM Int
 830 getExprUses (CmmReg (CmmLocal (LocalReg u _))) = unitUFM u 1
 831 getExprUses (CmmRegOff (CmmLocal (LocalReg u _)) _) = unitUFM u 1
 832 getExprUses (CmmLoad e _) = getExprUses e
 833 getExprUses (CmmMachOp _ es) = getExprsUses es
 834 getExprUses _other = emptyUFM
 835
 836 getExprsUses es = foldr (plusUFM_C (+)) emptyUFM (map getExprUses es)
 837
 838 inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
 839 inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
 840 inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
 841 inlineStmt u a (CmmCall target regs es vols)
 842    = CmmCall (infn target) regs es' vols
 843    where infn (CmmForeignCall fn cconv) = CmmForeignCall fn cconv
 844          infn (CmmPrim p) = CmmPrim p
 845          es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ]
 846 inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
 847 inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d
 848 inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d
 849 inlineStmt u a other_stmt = other_stmt
 850
 851 inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
 852 inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _)))
 853   | u == u' = a
 854   | otherwise = e
 855 inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off)
 856   | u == u' = CmmMachOp (MO_Add rep) [a, CmmLit (CmmInt (fromIntegral off) rep)]
 857   | otherwise = e
 858 inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep
 859 inlineExpr u a (CmmMachOp op es) = CmmMachOp op (map (inlineExpr u a) es)
 860 inlineExpr u a other_expr = other_expr
 861
 862 -- -----------------------------------------------------------------------------
 863 -- Utils
 864
 865 bind f x = x $! f
 866
 867 isLit (CmmLit _) = True
 868 isLit _          = False
 869
 870 isComparisonExpr :: CmmExpr -> Bool
 871 isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
 872 isComparisonExpr _other             = False
 873
 874 maybeInvertConditionalExpr :: CmmExpr -> Maybe CmmExpr
 875 maybeInvertConditionalExpr (CmmMachOp op args)
 876   | Just op' <- maybeInvertComparison op = Just (CmmMachOp op' args)
 877 maybeInvertConditionalExpr _ = Nothing
 878 \end{code}
 879