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