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