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