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 DynFlags         ( DynFlags, DynFlag(..), dopt )
  40 import StaticFlags      ( opt_Static, 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         | dopt Opt_SplitObjs dflags = 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   - simple CSE: if an expr is assigned to a temp, then replace later occs of
 383     that expr with the temp, until the expr is no longer valid (can push through
 384     temp assignments, and certain assigns to mem...)
 385 -}
 386
 387 cmmToCmm :: CmmTop -> (CmmTop, [CLabel])
 388 cmmToCmm top@(CmmData _ _) = (top, [])
 389 cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
 390   blocks' <- mapM cmmBlockConFold (cmmPeep blocks)
 391   return $ CmmProc info lbl params blocks'
 392
 393 newtype CmmOptM a = CmmOptM ([CLabel] -> (# a, [CLabel] #))
 394
 395 instance Monad CmmOptM where
 396   return x = CmmOptM $ \imports -> (# x,imports #)
 397   (CmmOptM f) >>= g =
 398     CmmOptM $ \imports ->
 399                 case f imports of
 400                   (# x, imports' #) ->
 401                     case g x of
 402                       CmmOptM g' -> g' imports'
 403
 404 addImportCmmOpt :: CLabel -> CmmOptM ()
 405 addImportCmmOpt lbl = CmmOptM $ \imports -> (# (), lbl:imports #)
 406
 407 runCmmOpt :: CmmOptM a -> (a, [CLabel])
 408 runCmmOpt (CmmOptM f) = case f [] of
 409                         (# result, imports #) -> (result, imports)
 410
 411 cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
 412 cmmBlockConFold (BasicBlock id stmts) = do
 413   stmts' <- mapM cmmStmtConFold stmts
 414   return $ BasicBlock id stmts'
 415
 416 cmmStmtConFold stmt
 417    = case stmt of
 418         CmmAssign reg src
 419            -> do src' <- cmmExprConFold False src
 420                  return $ case src' of
 421                    CmmReg reg' | reg == reg' -> CmmNop
 422                    new_src -> CmmAssign reg new_src
 423
 424         CmmStore addr src
 425            -> do addr' <- cmmExprConFold False addr
 426                  src'  <- cmmExprConFold False src
 427                  return $ CmmStore addr' src'
 428
 429         CmmJump addr regs
 430            -> do addr' <- cmmExprConFold True addr
 431                  return $ CmmJump addr' regs
 432
 433         CmmCall target regs args vols
 434            -> do target' <- case target of
 435                               CmmForeignCall e conv -> do
 436                                 e' <- cmmExprConFold True e
 437                                 return $ CmmForeignCall e' conv
 438                               other -> return other
 439                  args' <- mapM (\(arg, hint) -> do
 440                                   arg' <- cmmExprConFold False arg
 441                                   return (arg', hint)) args
 442                  return $ CmmCall target' regs args' vols
 443
 444         CmmCondBranch test dest
 445            -> do test' <- cmmExprConFold False test
 446                  return $ case test' of
 447                    CmmLit (CmmInt 0 _) ->
 448                      CmmComment (mkFastString ("deleted: " ++
 449                                         showSDoc (pprStmt stmt)))
 450
 451                    CmmLit (CmmInt n _) -> CmmBranch dest
 452                    other -> CmmCondBranch test' dest
 453
 454         CmmSwitch expr ids
 455            -> do expr' <- cmmExprConFold False expr
 456                  return $ CmmSwitch expr' ids
 457
 458         other
 459            -> return other
 460
 461
 462 cmmExprConFold isJumpTarget expr
 463    = case expr of
 464         CmmLoad addr rep
 465            -> do addr' <- cmmExprConFold False addr
 466                  return $ CmmLoad addr' rep
 467
 468         CmmMachOp mop args
 469            -- For MachOps, we first optimize the children, and then we try
 470            -- our hand at some constant-folding.
 471            -> do args' <- mapM (cmmExprConFold False) args
 472                  return $ cmmMachOpFold mop args'
 473
 474         CmmLit (CmmLabel lbl)
 475            -> cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
 476         CmmLit (CmmLabelOff lbl off)
 477            -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
 478                  return $ cmmMachOpFold (MO_Add wordRep) [
 479                      dynRef,
 480                      (CmmLit $ CmmInt (fromIntegral off) wordRep)
 481                    ]
 482
 483 #if powerpc_TARGET_ARCH
 484            -- On powerpc (non-PIC), it's easier to jump directly to a label than
 485            -- to use the register table, so we replace these registers
 486            -- with the corresponding labels:
 487         CmmReg (CmmGlobal GCEnter1)
 488           | not opt_PIC
 489           -> cmmExprConFold isJumpTarget $
 490              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
 491         CmmReg (CmmGlobal GCFun)
 492           | not opt_PIC
 493           -> cmmExprConFold isJumpTarget $
 494              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
 495 #endif
 496
 497         CmmReg (CmmGlobal mid)
 498            -- Replace register leaves with appropriate StixTrees for
 499            -- the given target.  MagicIds which map to a reg on this
 500            -- arch are left unchanged.  For the rest, BaseReg is taken
 501            -- to mean the address of the reg table in MainCapability,
 502            -- and for all others we generate an indirection to its
 503            -- location in the register table.
 504            -> case get_GlobalReg_reg_or_addr mid of
 505                  Left  realreg -> return expr
 506                  Right baseRegAddr
 507                     -> case mid of
 508                           BaseReg -> cmmExprConFold False baseRegAddr
 509                           other   -> cmmExprConFold False (CmmLoad baseRegAddr
 510                                                         (globalRegRep mid))
 511            -- eliminate zero offsets
 512         CmmRegOff reg 0
 513            -> cmmExprConFold False (CmmReg reg)
 514
 515         CmmRegOff (CmmGlobal mid) offset
 516            -- RegOf leaves are just a shorthand form. If the reg maps
 517            -- to a real reg, we keep the shorthand, otherwise, we just
 518            -- expand it and defer to the above code.
 519            -> case get_GlobalReg_reg_or_addr mid of
 520                 Left  realreg -> return expr
 521                 Right baseRegAddr
 522                    -> cmmExprConFold False (CmmMachOp (MO_Add wordRep) [
 523                                         CmmReg (CmmGlobal mid),
 524                                         CmmLit (CmmInt (fromIntegral offset)
 525                                                        wordRep)])
 526         other
 527            -> return other
 528
 529
 530 -- -----------------------------------------------------------------------------
 531 -- MachOp constant folder
 532
 533 -- Now, try to constant-fold the MachOps.  The arguments have already
 534 -- been optimized and folded.
 535
 536 cmmMachOpFold
 537     :: MachOp           -- The operation from an CmmMachOp
 538     -> [CmmExpr]        -- The optimized arguments
 539     -> CmmExpr
 540
 541 cmmMachOpFold op arg@[CmmLit (CmmInt x rep)]
 542   = case op of
 543       MO_S_Neg r -> CmmLit (CmmInt (-x) rep)
 544       MO_Not r   -> CmmLit (CmmInt (complement x) rep)
 545
 546         -- these are interesting: we must first narrow to the
 547         -- "from" type, in order to truncate to the correct size.
 548         -- The final narrow/widen to the destination type
 549         -- is implicit in the CmmLit.
 550       MO_S_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
 551       MO_U_Conv from to -> CmmLit (CmmInt (narrowU from x) to)
 552       _  -> panic "cmmMachOpFold: unknown unary op"
 553
 554 -- Eliminate conversion NOPs
 555 cmmMachOpFold (MO_S_Conv rep1 rep2) [x] | rep1 == rep2 = x
 556 cmmMachOpFold (MO_U_Conv rep1 rep2) [x] | rep1 == rep2 = x
 557
 558 -- Eliminate nested conversions where possible
 559 cmmMachOpFold conv_outer args@[CmmMachOp conv_inner [x]]
 560   | Just (rep1,rep2,signed1) <- isIntConversion conv_inner,
 561     Just (_,   rep3,signed2) <- isIntConversion conv_outer
 562   = case () of
 563         -- widen then narrow to the same size is a nop
 564       _ | rep1 < rep2 && rep1 == rep3 -> x
 565         -- Widen then narrow to different size: collapse to single conversion
 566         -- but remember to use the signedness from the widening, just in case
 567         -- the final conversion is a widen.
 568         | rep1 < rep2 && rep2 > rep3 ->
 569             cmmMachOpFold (intconv signed1 rep1 rep3) [x]
 570         -- Nested widenings: collapse if the signedness is the same
 571         | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->
 572             cmmMachOpFold (intconv signed1 rep1 rep3) [x]
 573         -- Nested narrowings: collapse
 574         | rep1 > rep2 && rep2 > rep3 ->
 575             cmmMachOpFold (MO_U_Conv rep1 rep3) [x]
 576         | otherwise ->
 577             CmmMachOp conv_outer args
 578   where
 579         isIntConversion (MO_U_Conv rep1 rep2) = Just (rep1,rep2,False)
 580         isIntConversion (MO_S_Conv rep1 rep2) = Just (rep1,rep2,True)
 581         isIntConversion _ = Nothing
 582
 583         intconv True  = MO_S_Conv
 584         intconv False = MO_U_Conv
 585
 586 -- ToDo: a narrow of a load can be collapsed into a narrow load, right?
 587 -- but what if the architecture only supports word-sized loads, should
 588 -- we do the transformation anyway?
 589
 590 cmmMachOpFold mop args@[CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
 591   = case mop of
 592         -- for comparisons: don't forget to narrow the arguments before
 593         -- comparing, since they might be out of range.
 594         MO_Eq r   -> CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordRep)
 595         MO_Ne r   -> CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordRep)
 596
 597         MO_U_Gt r -> CmmLit (CmmInt (if x_u >  y_u then 1 else 0) wordRep)
 598         MO_U_Ge r -> CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordRep)
 599         MO_U_Lt r -> CmmLit (CmmInt (if x_u <  y_u then 1 else 0) wordRep)
 600         MO_U_Le r -> CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordRep)
 601
 602         MO_S_Gt r -> CmmLit (CmmInt (if x_s >  y_s then 1 else 0) wordRep)
 603         MO_S_Ge r -> CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordRep)
 604         MO_S_Lt r -> CmmLit (CmmInt (if x_s <  y_s then 1 else 0) wordRep)
 605         MO_S_Le r -> CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordRep)
 606
 607         MO_Add r -> CmmLit (CmmInt (x + y) r)
 608         MO_Sub r -> CmmLit (CmmInt (x - y) r)
 609         MO_Mul r -> CmmLit (CmmInt (x * y) r)
 610         MO_S_Quot r | y /= 0 -> CmmLit (CmmInt (x `quot` y) r)
 611         MO_S_Rem  r | y /= 0 -> CmmLit (CmmInt (x `rem` y) r)
 612
 613         MO_And   r -> CmmLit (CmmInt (x .&. y) r)
 614         MO_Or    r -> CmmLit (CmmInt (x .|. y) r)
 615         MO_Xor   r -> CmmLit (CmmInt (x `xor` y) r)
 616
 617         MO_Shl   r -> CmmLit (CmmInt (x `shiftL` fromIntegral y) r)
 618         MO_U_Shr r -> CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)
 619         MO_S_Shr r -> CmmLit (CmmInt (x `shiftR` fromIntegral y) r)
 620
 621         other      -> CmmMachOp mop args
 622
 623    where
 624         x_u = narrowU xrep x
 625         y_u = narrowU xrep y
 626         x_s = narrowS xrep x
 627         y_s = narrowS xrep y
 628
 629
 630 -- When possible, shift the constants to the right-hand side, so that we
 631 -- can match for strength reductions.  Note that the code generator will
 632 -- also assume that constants have been shifted to the right when
 633 -- possible.
 634
 635 cmmMachOpFold op [x@(CmmLit _), y]
 636    | not (isLit y) && isCommutableMachOp op
 637    = cmmMachOpFold op [y, x]
 638
 639 -- Turn (a+b)+c into a+(b+c) where possible.  Because literals are
 640 -- moved to the right, it is more likely that we will find
 641 -- opportunities for constant folding when the expression is
 642 -- right-associated.
 643 --
 644 -- ToDo: this appears to introduce a quadratic behaviour due to the
 645 -- nested cmmMachOpFold.  Can we fix this?
 646 --
 647 -- Why do we check isLit arg1?  If arg1 is a lit, it means that arg2
 648 -- is also a lit (otherwise arg1 would be on the right).  If we
 649 -- put arg1 on the left of the rearranged expression, we'll get into a
 650 -- loop:  (x1+x2)+x3 => x1+(x2+x3)  => (x2+x3)+x1 => x2+(x3+x1) ...
 651 --
 652 cmmMachOpFold mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
 653    | mop1 == mop2 && isAssociativeMachOp mop1 && not (isLit arg1)
 654    = cmmMachOpFold mop1 [arg1, cmmMachOpFold mop2 [arg2,arg3]]
 655
 656 -- Make a RegOff if we can
 657 cmmMachOpFold (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
 658   = CmmRegOff reg (fromIntegral (narrowS rep n))
 659 cmmMachOpFold (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
 660   = CmmRegOff reg (off + fromIntegral (narrowS rep n))
 661 cmmMachOpFold (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]
 662   = CmmRegOff reg (- fromIntegral (narrowS rep n))
 663 cmmMachOpFold (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
 664   = CmmRegOff reg (off - fromIntegral (narrowS rep n))
 665
 666 -- Fold label(+/-)offset into a CmmLit where possible
 667
 668 cmmMachOpFold (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
 669   = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
 670 cmmMachOpFold (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)]
 671   = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
 672 cmmMachOpFold (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
 673   = CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i))))
 674
 675 -- We can often do something with constants of 0 and 1 ...
 676
 677 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))]
 678   = case mop of
 679         MO_Add   r -> x
 680         MO_Sub   r -> x
 681         MO_Mul   r -> y
 682         MO_And   r -> y
 683         MO_Or    r -> x
 684         MO_Xor   r -> x
 685         MO_Shl   r -> x
 686         MO_S_Shr r -> x
 687         MO_U_Shr r -> x
 688         MO_Ne    r | isComparisonExpr x -> x
 689         MO_Eq    r | Just x' <- maybeInvertConditionalExpr x -> x'
 690         MO_U_Gt  r | isComparisonExpr x -> x
 691         MO_S_Gt  r | isComparisonExpr x -> x
 692         MO_U_Lt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
 693         MO_S_Lt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
 694         MO_U_Ge  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
 695         MO_S_Ge  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
 696         MO_U_Le  r | Just x' <- maybeInvertConditionalExpr x -> x'
 697         MO_S_Le  r | Just x' <- maybeInvertConditionalExpr x -> x'
 698         other    -> CmmMachOp mop args
 699
 700 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))]
 701   = case mop of
 702         MO_Mul    r -> x
 703         MO_S_Quot r -> x
 704         MO_U_Quot r -> x
 705         MO_S_Rem  r -> CmmLit (CmmInt 0 rep)
 706         MO_U_Rem  r -> CmmLit (CmmInt 0 rep)
 707         MO_Ne    r | Just x' <- maybeInvertConditionalExpr x -> x'
 708         MO_Eq    r | isComparisonExpr x -> x
 709         MO_U_Lt  r | Just x' <- maybeInvertConditionalExpr x -> x'
 710         MO_S_Lt  r | Just x' <- maybeInvertConditionalExpr x -> x'
 711         MO_U_Gt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
 712         MO_S_Gt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
 713         MO_U_Le  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
 714         MO_S_Le  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
 715         MO_U_Ge  r | isComparisonExpr x -> x
 716         MO_S_Ge  r | isComparisonExpr x -> x
 717         other       -> CmmMachOp mop args
 718
 719 -- Now look for multiplication/division by powers of 2 (integers).
 720
 721 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt n _))]
 722   = case mop of
 723         MO_Mul rep
 724            -> case exactLog2 n of
 725                  Nothing -> unchanged
 726                  Just p  -> CmmMachOp (MO_Shl rep) [x, CmmLit (CmmInt p rep)]
 727         MO_S_Quot rep
 728            -> case exactLog2 n of
 729                  Nothing -> unchanged
 730                  Just p  -> CmmMachOp (MO_S_Shr rep) [x, CmmLit (CmmInt p rep)]
 731         other
 732            -> unchanged
 733     where
 734        unchanged = CmmMachOp mop args
 735
 736 -- Anything else is just too hard.
 737
 738 cmmMachOpFold mop args = CmmMachOp mop args
 739
 740 -- -----------------------------------------------------------------------------
 741 -- exactLog2
 742
 743 -- This algorithm for determining the $\log_2$ of exact powers of 2 comes
 744 -- from GCC.  It requires bit manipulation primitives, and we use GHC
 745 -- extensions.  Tough.
 746 --
 747 -- Used to be in MachInstrs --SDM.
 748 -- ToDo: remove use of unboxery --SDM.
 749
 750 w2i x = word2Int# x
 751 i2w x = int2Word# x
 752
 753 exactLog2 :: Integer -> Maybe Integer
 754 exactLog2 x
 755   = if (x <= 0 || x >= 2147483648) then
 756        Nothing
 757     else
 758        case iUnbox (fromInteger x) of { x# ->
 759        if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then
 760           Nothing
 761        else
 762           Just (toInteger (iBox (pow2 x#)))
 763        }
 764   where
 765     pow2 x# | x# ==# 1# = 0#
 766             | otherwise = 1# +# pow2 (w2i (i2w x# `shiftRL#` 1#))
 767
 768
 769 -- -----------------------------------------------------------------------------
 770 -- widening / narrowing
 771
 772 narrowU :: MachRep -> Integer -> Integer
 773 narrowU I8  x = fromIntegral (fromIntegral x :: Word8)
 774 narrowU I16 x = fromIntegral (fromIntegral x :: Word16)
 775 narrowU I32 x = fromIntegral (fromIntegral x :: Word32)
 776 narrowU I64 x = fromIntegral (fromIntegral x :: Word64)
 777 narrowU _ _ = panic "narrowTo"
 778
 779 narrowS :: MachRep -> Integer -> Integer
 780 narrowS I8  x = fromIntegral (fromIntegral x :: Int8)
 781 narrowS I16 x = fromIntegral (fromIntegral x :: Int16)
 782 narrowS I32 x = fromIntegral (fromIntegral x :: Int32)
 783 narrowS I64 x = fromIntegral (fromIntegral x :: Int64)
 784 narrowS _ _ = panic "narrowTo"
 785
 786 -- -----------------------------------------------------------------------------
 787 -- The mini-inliner
 788
 789 -- This pass inlines assignments to temporaries that are used just
 790 -- once in the very next statement only.  Generalising this would be
 791 -- quite difficult (have to take into account aliasing of memory
 792 -- writes, and so on), but at the moment it catches a number of useful
 793 -- cases and lets the code generator generate much better code.
 794
 795 -- NB. This assumes that temporaries are single-assignment.
 796
 797 cmmPeep :: [CmmBasicBlock] -> [CmmBasicBlock]
 798 cmmPeep blocks = map do_inline blocks
 799   where
 800         blockUses (BasicBlock _ stmts)
 801          = foldr (plusUFM_C (+)) emptyUFM (map getStmtUses stmts)
 802
 803         uses = foldr (plusUFM_C (+)) emptyUFM (map blockUses blocks)
 804
 805         do_inline (BasicBlock id stmts)
 806          = BasicBlock id (cmmMiniInline uses stmts)
 807
 808
 809 cmmMiniInline :: UniqFM Int -> [CmmStmt] -> [CmmStmt]
 810 cmmMiniInline uses [] = []
 811 cmmMiniInline uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
 812   | Just 1 <- lookupUFM uses u,
 813     Just stmts' <- lookForInline u expr stmts
 814   =
 815 #ifdef NCG_DEBUG
 816      trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $
 817 #endif
 818      cmmMiniInline uses stmts'
 819
 820 cmmMiniInline uses (stmt:stmts)
 821   = stmt : cmmMiniInline uses stmts
 822
 823
 824 -- Try to inline a temporary assignment.  We can skip over assignments to
 825 -- other tempoararies, because we know that expressions aren't side-effecting
 826 -- and temporaries are single-assignment.
 827 lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _)) rhs) : rest)
 828   | u /= u'
 829   = case lookupUFM (getExprUses rhs) u of
 830         Just 1 -> Just (inlineStmt u expr stmt : rest)
 831         _other -> case lookForInline u expr rest of
 832                      Nothing    -> Nothing
 833                      Just stmts -> Just (stmt:stmts)
 834
 835 lookForInline u expr (CmmNop : rest)
 836   = lookForInline u expr rest
 837
 838 lookForInline u expr (stmt:stmts)
 839   = case lookupUFM (getStmtUses stmt) u of
 840         Just 1 -> Just (inlineStmt u expr stmt : stmts)
 841         _other -> Nothing
 842
 843 -- -----------------------------------------------------------------------------
 844 -- Boring Cmm traversals for collecting usage info and substitutions.
 845
 846 getStmtUses :: CmmStmt -> UniqFM Int
 847 getStmtUses (CmmAssign _ e) = getExprUses e
 848 getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2)
 849 getStmtUses (CmmCall target _ es _)
 850    = plusUFM_C (+) (uses target) (getExprsUses (map fst es))
 851    where uses (CmmForeignCall e _) = getExprUses e
 852          uses _ = emptyUFM
 853 getStmtUses (CmmCondBranch e _) = getExprUses e
 854 getStmtUses (CmmSwitch e _) = getExprUses e
 855 getStmtUses (CmmJump e _) = getExprUses e
 856 getStmtUses _ = emptyUFM
 857
 858 getExprUses :: CmmExpr -> UniqFM Int
 859 getExprUses (CmmReg (CmmLocal (LocalReg u _))) = unitUFM u 1
 860 getExprUses (CmmRegOff (CmmLocal (LocalReg u _)) _) = unitUFM u 1
 861 getExprUses (CmmLoad e _) = getExprUses e
 862 getExprUses (CmmMachOp _ es) = getExprsUses es
 863 getExprUses _other = emptyUFM
 864
 865 getExprsUses es = foldr (plusUFM_C (+)) emptyUFM (map getExprUses es)
 866
 867 inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
 868 inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
 869 inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
 870 inlineStmt u a (CmmCall target regs es vols)
 871    = CmmCall (infn target) regs es' vols
 872    where infn (CmmForeignCall fn cconv) = CmmForeignCall fn cconv
 873          infn (CmmPrim p) = CmmPrim p
 874          es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ]
 875 inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
 876 inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d
 877 inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d
 878 inlineStmt u a other_stmt = other_stmt
 879
 880 inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
 881 inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _)))
 882   | u == u' = a
 883   | otherwise = e
 884 inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off)
 885   | u == u' = CmmMachOp (MO_Add rep) [a, CmmLit (CmmInt (fromIntegral off) rep)]
 886   | otherwise = e
 887 inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep
 888 inlineExpr u a (CmmMachOp op es) = CmmMachOp op (map (inlineExpr u a) es)
 889 inlineExpr u a other_expr = other_expr
 890
 891 -- -----------------------------------------------------------------------------
 892 -- Utils
 893
 894 bind f x = x $! f
 895
 896 isLit (CmmLit _) = True
 897 isLit _          = False
 898
 899 isComparisonExpr :: CmmExpr -> Bool
 900 isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
 901 isComparisonExpr _other             = False
 902
 903 maybeInvertConditionalExpr :: CmmExpr -> Maybe CmmExpr
 904 maybeInvertConditionalExpr (CmmMachOp op args)
 905   | Just op' <- maybeInvertComparison op = Just (CmmMachOp op' args)
 906 maybeInvertConditionalExpr _ = Nothing
 907 \end{code}
 908