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 "nativeGen/NCG.h"
  14
  15 import MachInstrs
  16 import MachRegs
  17 import MachCodeGen
  18 import PprMach
  19 import RegAllocInfo
  20 import NCGMonad
  21 import PositionIndependentCode
  22 import RegLiveness
  23 import RegCoalesce
  24 import qualified RegAllocLinear as Linear
  25 import qualified RegAllocColor  as Color
  26 import qualified RegAllocStats  as Color
  27 import qualified GraphColor     as Color
  28
  29 import Cmm
  30 import CmmOpt           ( cmmMiniInline, cmmMachOpFold )
  31 import PprCmm           ( pprStmt, pprCmms, pprCmm )
  32 import MachOp
  33 import CLabel
  34 import State
  35
  36 import UniqFM
  37 import Unique           ( Unique, getUnique )
  38 import UniqSupply
  39 import FastTypes
  40 import List             ( groupBy, sortBy )
  41 import ErrUtils         ( dumpIfSet_dyn )
  42 import DynFlags
  43 import StaticFlags      ( opt_Static, opt_PIC )
  44 import Util
  45 import Config           ( cProjectVersion )
  46 import Module
  47
  48 import Digraph
  49 import qualified Pretty
  50 import Outputable
  51 import FastString
  52 import UniqSet
  53 import ErrUtils
  54
  55 -- DEBUGGING ONLY
  56 --import OrdList
  57
  58 import Data.List
  59 import Data.Int
  60 import Data.Word
  61 import Data.Bits
  62 import Data.Maybe
  63 import GHC.Exts
  64 import Control.Monad
  65
  66 {-
  67 The native-code generator has machine-independent and
  68 machine-dependent modules.
  69
  70 This module ("AsmCodeGen") is the top-level machine-independent
  71 module.  Before entering machine-dependent land, we do some
  72 machine-independent optimisations (defined below) on the
  73 'CmmStmts's.
  74
  75 We convert to the machine-specific 'Instr' datatype with
  76 'cmmCodeGen', assuming an infinite supply of registers.  We then use
  77 a machine-independent register allocator ('regAlloc') to rejoin
  78 reality.  Obviously, 'regAlloc' has machine-specific helper
  79 functions (see about "RegAllocInfo" below).
  80
  81 Finally, we order the basic blocks of the function so as to minimise
  82 the number of jumps between blocks, by utilising fallthrough wherever
  83 possible.
  84
  85 The machine-dependent bits break down as follows:
  86
  87   * ["MachRegs"]  Everything about the target platform's machine
  88     registers (and immediate operands, and addresses, which tend to
  89     intermingle/interact with registers).
  90
  91   * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should
  92     have a module of its own), plus a miscellany of other things
  93     (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
  94
  95   * ["MachCodeGen"]  is where 'Cmm' stuff turns into
  96     machine instructions.
  97
  98   * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
  99     a 'Doc').
 100
 101   * ["RegAllocInfo"] In the register allocator, we manipulate
 102     'MRegsState's, which are 'BitSet's, one bit per machine register.
 103     When we want to say something about a specific machine register
 104     (e.g., ``it gets clobbered by this instruction''), we set/unset
 105     its bit.  Obviously, we do this 'BitSet' thing for efficiency
 106     reasons.
 107
 108     The 'RegAllocInfo' module collects together the machine-specific
 109     info needed to do register allocation.
 110
 111    * ["RegisterAlloc"] The (machine-independent) register allocator.
 112 -}
 113
 114 -- -----------------------------------------------------------------------------
 115 -- Top-level of the native codegen
 116
 117 -- NB. We *lazilly* compile each block of code for space reasons.
 118
 119 --------------------
 120 nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc
 121 nativeCodeGen dflags cmms us
 122  = do
 123         -- do native code generation on all these cmm things
 124         (us', result)
 125                 <- mapAccumLM (cmmNativeGen dflags) us
 126                 $  concat $ map add_split cmms
 127
 128         let (native, imports, mColorStats, mLinearStats)
 129                 = unzip4 result
 130
 131         -- dump global NCG stats for graph coloring allocator
 132         (case concat $ catMaybes mColorStats of
 133           []    -> return ()
 134           stats -> do
 135                 -- build the global register conflict graph
 136                 let graphGlobal
 137                         = foldl Color.union Color.initGraph
 138                         $ [ Color.raGraph stat
 139                                 | stat@Color.RegAllocStatsStart{} <- stats]
 140
 141                 dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
 142                         $ Color.pprStats stats graphGlobal
 143
 144                 dumpIfSet_dyn dflags
 145                         Opt_D_dump_asm_conflicts "Register conflict graph"
 146                         $ Color.dotGraph Color.regDotColor trivColorable
 147                         $ graphGlobal)
 148
 149
 150         -- dump global NCG stats for linear allocator
 151         (case catMaybes mLinearStats of
 152                 []      -> return ()
 153                 stats   -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
 154                                 $ Linear.pprStats (concat stats))
 155
 156         return  $ makeAsmDoc (concat native) (concat imports)
 157
 158         where   add_split (Cmm tops)
 159                         | dopt Opt_SplitObjs dflags = split_marker : tops
 160                         | otherwise                 = tops
 161
 162                 split_marker = CmmProc [] mkSplitMarkerLabel [] []
 163
 164
 165 -- | Complete native code generation phase for a single top-level chunk of Cmm.
 166 --      Dumping the output of each stage along the way.
 167 --      Global conflict graph and NGC stats
 168 cmmNativeGen
 169         :: DynFlags
 170         -> UniqSupply
 171         -> RawCmmTop
 172         -> IO   ( UniqSupply
 173                 , ( [NatCmmTop]
 174                   , [CLabel]
 175                   , Maybe [Color.RegAllocStats]
 176                   , Maybe [Linear.RegAllocStats]))
 177
 178 cmmNativeGen dflags us cmm
 179  = do
 180         -- rewrite assignments to global regs
 181         let (fixed_cmm, usFix)  =
 182                 initUs us $ fixAssignsTop cmm
 183
 184         -- cmm to cmm optimisations
 185         let (opt_cmm, imports) =
 186                 cmmToCmm dflags fixed_cmm
 187
 188         dumpIfSet_dyn dflags
 189                 Opt_D_dump_opt_cmm "Optimised Cmm"
 190                 (pprCmm $ Cmm [opt_cmm])
 191
 192
 193         -- generate native code from cmm
 194         let ((native, lastMinuteImports), usGen) =
 195                 initUs usFix $ genMachCode dflags opt_cmm
 196
 197         dumpIfSet_dyn dflags
 198                 Opt_D_dump_asm_native "Native code"
 199                 (vcat $ map (docToSDoc . pprNatCmmTop) native)
 200
 201
 202         -- tag instructions with register liveness information
 203         let (withLiveness, usLive) =
 204                 initUs usGen $ mapUs regLiveness native
 205
 206         dumpIfSet_dyn dflags
 207                 Opt_D_dump_asm_liveness "Liveness annotations added"
 208                 (vcat $ map ppr withLiveness)
 209
 210
 211         -- allocate registers
 212         (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
 213          if dopt Opt_RegsGraph dflags
 214           then do
 215                 -- the regs usable for allocation
 216                 let alloc_regs
 217                         = foldr (\r -> plusUFM_C unionUniqSets
 218                                         $ unitUFM (regClass r) (unitUniqSet r))
 219                                 emptyUFM
 220                         $ map RealReg allocatableRegs
 221
 222                 -- aggressively coalesce moves between virtual regs
 223                 let (coalesced, usCoalesce)
 224                         = initUs usLive $ regCoalesce withLiveness
 225
 226                 dumpIfSet_dyn dflags
 227                         Opt_D_dump_asm_coalesce "Reg-Reg moves coalesced"
 228                         (vcat $ map ppr coalesced)
 229
 230                 -- if any of these dump flags are turned on we want to hang on to
 231                 --      intermediate structures in the allocator - otherwise ditch
 232                 --      them early so we don't end up creating space leaks.
 233                 let generateRegAllocStats = or
 234                         [ dopt Opt_D_dump_asm_regalloc_stages dflags
 235                         , dopt Opt_D_dump_asm_stats dflags
 236                         , dopt Opt_D_dump_asm_conflicts dflags ]
 237
 238                 -- graph coloring register allocation
 239                 let ((alloced, regAllocStats), usAlloc)
 240                         = initUs usCoalesce
 241                         $ Color.regAlloc
 242                                 generateRegAllocStats
 243                                 alloc_regs
 244                                 (mkUniqSet [0..maxSpillSlots])
 245                                 coalesced
 246
 247                 -- dump out what happened during register allocation
 248                 dumpIfSet_dyn dflags
 249                         Opt_D_dump_asm_regalloc "Registers allocated"
 250                         (vcat $ map (docToSDoc . pprNatCmmTop) alloced)
 251
 252                 dumpIfSet_dyn dflags
 253                         Opt_D_dump_asm_regalloc_stages "Build/spill stages"
 254                         (vcat   $ map (\(stage, stats)
 255                                         -> text "-- Stage " <> int stage
 256                                         $$ ppr stats)
 257                                 $ zip [0..] regAllocStats)
 258
 259                 return  ( alloced, usAlloc
 260                         , if dopt Opt_D_dump_asm_stats dflags
 261                            then Just regAllocStats else Nothing
 262                         , Nothing)
 263
 264           else do
 265                 -- do linear register allocation
 266                 let ((alloced, regAllocStats), usAlloc)
 267                         = initUs usLive
 268                         $ liftM unzip
 269                         $ mapUs Linear.regAlloc withLiveness
 270
 271                 dumpIfSet_dyn dflags
 272                         Opt_D_dump_asm_regalloc "Registers allocated"
 273                         (vcat $ map (docToSDoc . pprNatCmmTop) alloced)
 274
 275                 return  ( alloced, usAlloc
 276                         , Nothing
 277                         , if dopt Opt_D_dump_asm_stats dflags
 278                            then Just (catMaybes regAllocStats) else Nothing)
 279
 280         ---- shortcut branches
 281         let shorted     =
 282                 {-# SCC "shortcutBranches" #-}
 283                 shortcutBranches dflags alloced
 284
 285         ---- sequence blocks
 286         let sequenced   =
 287                 {-# SCC "sequenceBlocks" #-}
 288                 map sequenceTop shorted
 289
 290         ---- x86fp_kludge
 291         let final_mach_code =
 292 #if i386_TARGET_ARCH
 293                 {-# SCC "x86fp_kludge" #-}
 294                 map x86fp_kludge sequenced
 295 #else
 296                 sequenced
 297 #endif
 298
 299         return  ( usAlloc
 300                 , ( final_mach_code
 301                   , lastMinuteImports ++ imports
 302                   , ppr_raStatsColor
 303                   , ppr_raStatsLinear) )
 304
 305
 306 #if i386_TARGET_ARCH
 307 x86fp_kludge :: NatCmmTop -> NatCmmTop
 308 x86fp_kludge top@(CmmData _ _) = top
 309 x86fp_kludge top@(CmmProc info lbl params code) =
 310         CmmProc info lbl params (map bb_i386_insert_ffrees code)
 311         where
 312                 bb_i386_insert_ffrees (BasicBlock id instrs) =
 313                         BasicBlock id (i386_insert_ffrees instrs)
 314 #endif
 315
 316
 317 -- | Build assembler source file from native code and its imports.
 318 --
 319 makeAsmDoc :: [NatCmmTop] -> [CLabel] -> Pretty.Doc
 320 makeAsmDoc native imports
 321  =      Pretty.vcat (map pprNatCmmTop native)
 322         Pretty.$$ (Pretty.text "")
 323         Pretty.$$ dyld_stubs imports
 324
 325 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
 326                 -- On recent versions of Darwin, the linker supports
 327                 -- dead-stripping of code and data on a per-symbol basis.
 328                 -- There's a hack to make this work in PprMach.pprNatCmmTop.
 329             Pretty.$$ Pretty.text ".subsections_via_symbols"
 330 #endif
 331 #if HAVE_GNU_NONEXEC_STACK
 332                 -- On recent GNU ELF systems one can mark an object file
 333                 -- as not requiring an executable stack. If all objects
 334                 -- linked into a program have this note then the program
 335                 -- will not use an executable stack, which is good for
 336                 -- security. GHC generated code does not need an executable
 337                 -- stack so add the note in:
 338             Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
 339 #endif
 340 #if !defined(darwin_TARGET_OS)
 341                 -- And just because every other compiler does, lets stick in
 342                 -- an identifier directive: .ident "GHC x.y.z"
 343             Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
 344                                           Pretty.text cProjectVersion
 345                        in Pretty.text ".ident" Pretty.<+>
 346                           Pretty.doubleQuotes compilerIdent
 347 #endif
 348
 349  where
 350         -- Generate "symbol stubs" for all external symbols that might
 351         -- come from a dynamic library.
 352         dyld_stubs :: [CLabel] -> Pretty.Doc
 353 {-      dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
 354                                     map head $ group $ sort imps-}
 355
 356         -- (Hack) sometimes two Labels pretty-print the same, but have
 357         -- different uniques; so we compare their text versions...
 358         dyld_stubs imps
 359                 | needImportedSymbols
 360                 = Pretty.vcat $
 361                         (pprGotDeclaration :) $
 362                         map (pprImportedSymbol . fst . head) $
 363                         groupBy (\(_,a) (_,b) -> a == b) $
 364                         sortBy (\(_,a) (_,b) -> compare a b) $
 365                         map doPpr $
 366                         imps
 367                 | otherwise
 368                 = Pretty.empty
 369
 370         doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
 371         astyle = mkCodeStyle AsmStyle
 372
 373
 374 -- -----------------------------------------------------------------------------
 375 -- Sequencing the basic blocks
 376
 377 -- Cmm BasicBlocks are self-contained entities: they always end in a
 378 -- jump, either non-local or to another basic block in the same proc.
 379 -- In this phase, we attempt to place the basic blocks in a sequence
 380 -- such that as many of the local jumps as possible turn into
 381 -- fallthroughs.
 382
 383 sequenceTop :: NatCmmTop -> NatCmmTop
 384 sequenceTop top@(CmmData _ _) = top
 385 sequenceTop (CmmProc info lbl params blocks) =
 386   CmmProc info lbl params (makeFarBranches $ sequenceBlocks blocks)
 387
 388 -- The algorithm is very simple (and stupid): we make a graph out of
 389 -- the blocks where there is an edge from one block to another iff the
 390 -- first block ends by jumping to the second.  Then we topologically
 391 -- sort this graph.  Then traverse the list: for each block, we first
 392 -- output the block, then if it has an out edge, we move the
 393 -- destination of the out edge to the front of the list, and continue.
 394
 395 sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock]
 396 sequenceBlocks [] = []
 397 sequenceBlocks (entry:blocks) =
 398   seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
 399   -- the first block is the entry point ==> it must remain at the start.
 400
 401 sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])]
 402 sccBlocks blocks = stronglyConnCompR (map mkNode blocks)
 403
 404 getOutEdges :: [Instr] -> [Unique]
 405 getOutEdges instrs = case jumpDests (last instrs) [] of
 406                         [one] -> [getUnique one]
 407                         _many -> []
 408                 -- we're only interested in the last instruction of
 409                 -- the block, and only if it has a single destination.
 410
 411 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
 412
 413 seqBlocks [] = []
 414 seqBlocks ((block,_,[]) : rest)
 415   = block : seqBlocks rest
 416 seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
 417   | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
 418   | otherwise       = block : seqBlocks rest'
 419   where
 420         (can_fallthrough, rest') = reorder next [] rest
 421           -- TODO: we should do a better job for cycles; try to maximise the
 422           -- fallthroughs within a loop.
 423 seqBlocks _ = panic "AsmCodegen:seqBlocks"
 424
 425 reorder id accum [] = (False, reverse accum)
 426 reorder id accum (b@(block,id',out) : rest)
 427   | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
 428   | otherwise  = reorder id (b:accum) rest
 429
 430
 431 -- -----------------------------------------------------------------------------
 432 -- Making far branches
 433
 434 -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
 435 -- big, we have to work around this limitation.
 436
 437 makeFarBranches :: [NatBasicBlock] -> [NatBasicBlock]
 438
 439 #if powerpc_TARGET_ARCH
 440 makeFarBranches blocks
 441     | last blockAddresses < nearLimit = blocks
 442     | otherwise = zipWith handleBlock blockAddresses blocks
 443     where
 444         blockAddresses = scanl (+) 0 $ map blockLen blocks
 445         blockLen (BasicBlock _ instrs) = length instrs
 446
 447         handleBlock addr (BasicBlock id instrs)
 448                 = BasicBlock id (zipWith makeFar [addr..] instrs)
 449
 450         makeFar addr (BCC ALWAYS tgt) = BCC ALWAYS tgt
 451         makeFar addr (BCC cond tgt)
 452             | abs (addr - targetAddr) >= nearLimit
 453             = BCCFAR cond tgt
 454             | otherwise
 455             = BCC cond tgt
 456             where Just targetAddr = lookupUFM blockAddressMap tgt
 457         makeFar addr other            = other
 458
 459         nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
 460                          -- distance, as we have a few pseudo-insns that are
 461                          -- pretty-printed as multiple instructions,
 462                          -- and it's just not worth the effort to calculate
 463                          -- things exactly
 464
 465         blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
 466 #else
 467 makeFarBranches = id
 468 #endif
 469
 470 -- -----------------------------------------------------------------------------
 471 -- Shortcut branches
 472
 473 shortcutBranches :: DynFlags -> [NatCmmTop] -> [NatCmmTop]
 474 shortcutBranches dflags tops
 475   | optLevel dflags < 1 = tops    -- only with -O or higher
 476   | otherwise           = map (apply_mapping mapping) tops'
 477   where
 478     (tops', mappings) = mapAndUnzip build_mapping tops
 479     mapping = foldr plusUFM emptyUFM mappings
 480
 481 build_mapping top@(CmmData _ _) = (top, emptyUFM)
 482 build_mapping (CmmProc info lbl params [])
 483   = (CmmProc info lbl params [], emptyUFM)
 484 build_mapping (CmmProc info lbl params (head:blocks))
 485   = (CmmProc info lbl params (head:others), mapping)
 486         -- drop the shorted blocks, but don't ever drop the first one,
 487         -- because it is pointed to by a global label.
 488   where
 489     -- find all the blocks that just consist of a jump that can be
 490     -- shorted.
 491     (shortcut_blocks, others) = partitionWith split blocks
 492     split (BasicBlock id [insn]) | Just dest <- canShortcut insn
 493                                  = Left (id,dest)
 494     split other = Right other
 495
 496     -- build a mapping from BlockId to JumpDest for shorting branches
 497     mapping = foldl add emptyUFM shortcut_blocks
 498     add ufm (id,dest) = addToUFM ufm id dest
 499
 500 apply_mapping ufm (CmmData sec statics)
 501   = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
 502   -- we need to get the jump tables, so apply the mapping to the entries
 503   -- of a CmmData too.
 504 apply_mapping ufm (CmmProc info lbl params blocks)
 505   = CmmProc info lbl params (map short_bb blocks)
 506   where
 507     short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
 508     short_insn i = shortcutJump (lookupUFM ufm) i
 509                  -- shortcutJump should apply the mapping repeatedly,
 510                  -- just in case we can short multiple branches.
 511
 512 -- -----------------------------------------------------------------------------
 513 -- Instruction selection
 514
 515 -- Native code instruction selection for a chunk of stix code.  For
 516 -- this part of the computation, we switch from the UniqSM monad to
 517 -- the NatM monad.  The latter carries not only a Unique, but also an
 518 -- Int denoting the current C stack pointer offset in the generated
 519 -- code; this is needed for creating correct spill offsets on
 520 -- architectures which don't offer, or for which it would be
 521 -- prohibitively expensive to employ, a frame pointer register.  Viz,
 522 -- x86.
 523
 524 -- The offset is measured in bytes, and indicates the difference
 525 -- between the current (simulated) C stack-ptr and the value it was at
 526 -- the beginning of the block.  For stacks which grow down, this value
 527 -- should be either zero or negative.
 528
 529 -- Switching between the two monads whilst carrying along the same
 530 -- Unique supply breaks abstraction.  Is that bad?
 531
 532 genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
 533
 534 genMachCode dflags cmm_top
 535   = do  { initial_us <- getUs
 536         ; let initial_st           = mkNatM_State initial_us 0 dflags
 537               (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
 538               final_delta          = natm_delta final_st
 539               final_imports        = natm_imports final_st
 540         ; if   final_delta == 0
 541           then return (new_tops, final_imports)
 542           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
 543     }
 544
 545 -- -----------------------------------------------------------------------------
 546 -- Fixup assignments to global registers so that they assign to
 547 -- locations within the RegTable, if appropriate.
 548
 549 -- Note that we currently don't fixup reads here: they're done by
 550 -- the generic optimiser below, to avoid having two separate passes
 551 -- over the Cmm.
 552
 553 fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
 554 fixAssignsTop top@(CmmData _ _) = returnUs top
 555 fixAssignsTop (CmmProc info lbl params blocks) =
 556   mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
 557   returnUs (CmmProc info lbl params blocks')
 558
 559 fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
 560 fixAssignsBlock (BasicBlock id stmts) =
 561   fixAssigns stmts `thenUs` \ stmts' ->
 562   returnUs (BasicBlock id stmts')
 563
 564 fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt]
 565 fixAssigns stmts =
 566   mapUs fixAssign stmts `thenUs` \ stmtss ->
 567   returnUs (concat stmtss)
 568
 569 fixAssign :: CmmStmt -> UniqSM [CmmStmt]
 570 fixAssign (CmmAssign (CmmGlobal reg) src)
 571   | Left  realreg <- reg_or_addr
 572   = returnUs [CmmAssign (CmmGlobal reg) src]
 573   | Right baseRegAddr <- reg_or_addr
 574   = returnUs [CmmStore baseRegAddr src]
 575            -- Replace register leaves with appropriate StixTrees for
 576            -- the given target. GlobalRegs which map to a reg on this
 577            -- arch are left unchanged.  Assigning to BaseReg is always
 578            -- illegal, so we check for that.
 579   where
 580         reg_or_addr = get_GlobalReg_reg_or_addr reg
 581
 582 fixAssign other_stmt = returnUs [other_stmt]
 583
 584 -- -----------------------------------------------------------------------------
 585 -- Generic Cmm optimiser
 586
 587 {-
 588 Here we do:
 589
 590   (a) Constant folding
 591   (b) Simple inlining: a temporary which is assigned to and then
 592       used, once, can be shorted.
 593   (c) Replacement of references to GlobalRegs which do not have
 594       machine registers by the appropriate memory load (eg.
 595       Hp ==>  *(BaseReg + 34) ).
 596   (d) Position independent code and dynamic linking
 597         (i)  introduce the appropriate indirections
 598              and position independent refs
 599         (ii) compile a list of imported symbols
 600
 601 Ideas for other things we could do (ToDo):
 602
 603   - shortcut jumps-to-jumps
 604   - eliminate dead code blocks
 605   - simple CSE: if an expr is assigned to a temp, then replace later occs of
 606     that expr with the temp, until the expr is no longer valid (can push through
 607     temp assignments, and certain assigns to mem...)
 608 -}
 609
 610 cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
 611 cmmToCmm _ top@(CmmData _ _) = (top, [])
 612 cmmToCmm dflags (CmmProc info lbl params blocks) = runCmmOpt dflags $ do
 613   blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
 614   return $ CmmProc info lbl params blocks'
 615
 616 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
 617
 618 instance Monad CmmOptM where
 619   return x = CmmOptM $ \(imports, _) -> (# x,imports #)
 620   (CmmOptM f) >>= g =
 621     CmmOptM $ \(imports, dflags) ->
 622                 case f (imports, dflags) of
 623                   (# x, imports' #) ->
 624                     case g x of
 625                       CmmOptM g' -> g' (imports', dflags)
 626
 627 addImportCmmOpt :: CLabel -> CmmOptM ()
 628 addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #)
 629
 630 getDynFlagsCmmOpt :: CmmOptM DynFlags
 631 getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
 632
 633 runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
 634 runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
 635                         (# result, imports #) -> (result, imports)
 636
 637 cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
 638 cmmBlockConFold (BasicBlock id stmts) = do
 639   stmts' <- mapM cmmStmtConFold stmts
 640   return $ BasicBlock id stmts'
 641
 642 cmmStmtConFold stmt
 643    = case stmt of
 644         CmmAssign reg src
 645            -> do src' <- cmmExprConFold DataReference src
 646                  return $ case src' of
 647                    CmmReg reg' | reg == reg' -> CmmNop
 648                    new_src -> CmmAssign reg new_src
 649
 650         CmmStore addr src
 651            -> do addr' <- cmmExprConFold DataReference addr
 652                  src'  <- cmmExprConFold DataReference src
 653                  return $ CmmStore addr' src'
 654
 655         CmmJump addr regs
 656            -> do addr' <- cmmExprConFold JumpReference addr
 657                  return $ CmmJump addr' regs
 658
 659         CmmCall target regs args srt returns
 660            -> do target' <- case target of
 661                               CmmCallee e conv -> do
 662                                 e' <- cmmExprConFold CallReference e
 663                                 return $ CmmCallee e' conv
 664                               other -> return other
 665                  args' <- mapM (\(arg, hint) -> do
 666                                   arg' <- cmmExprConFold DataReference arg
 667                                   return (arg', hint)) args
 668                  return $ CmmCall target' regs args' srt returns
 669
 670         CmmCondBranch test dest
 671            -> do test' <- cmmExprConFold DataReference test
 672                  return $ case test' of
 673                    CmmLit (CmmInt 0 _) ->
 674                      CmmComment (mkFastString ("deleted: " ++
 675                                         showSDoc (pprStmt stmt)))
 676
 677                    CmmLit (CmmInt n _) -> CmmBranch dest
 678                    other -> CmmCondBranch test' dest
 679
 680         CmmSwitch expr ids
 681            -> do expr' <- cmmExprConFold DataReference expr
 682                  return $ CmmSwitch expr' ids
 683
 684         other
 685            -> return other
 686
 687
 688 cmmExprConFold referenceKind expr
 689    = case expr of
 690         CmmLoad addr rep
 691            -> do addr' <- cmmExprConFold DataReference addr
 692                  return $ CmmLoad addr' rep
 693
 694         CmmMachOp mop args
 695            -- For MachOps, we first optimize the children, and then we try
 696            -- our hand at some constant-folding.
 697            -> do args' <- mapM (cmmExprConFold DataReference) args
 698                  return $ cmmMachOpFold mop args'
 699
 700         CmmLit (CmmLabel lbl)
 701            -> do
 702                 dflags <- getDynFlagsCmmOpt
 703                 cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
 704         CmmLit (CmmLabelOff lbl off)
 705            -> do
 706                  dflags <- getDynFlagsCmmOpt
 707                  dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
 708                  return $ cmmMachOpFold (MO_Add wordRep) [
 709                      dynRef,
 710                      (CmmLit $ CmmInt (fromIntegral off) wordRep)
 711                    ]
 712
 713 #if powerpc_TARGET_ARCH
 714            -- On powerpc (non-PIC), it's easier to jump directly to a label than
 715            -- to use the register table, so we replace these registers
 716            -- with the corresponding labels:
 717         CmmReg (CmmGlobal GCEnter1)
 718           | not opt_PIC
 719           -> cmmExprConFold referenceKind $
 720              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
 721         CmmReg (CmmGlobal GCFun)
 722           | not opt_PIC
 723           -> cmmExprConFold referenceKind $
 724              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
 725 #endif
 726
 727         CmmReg (CmmGlobal mid)
 728            -- Replace register leaves with appropriate StixTrees for
 729            -- the given target.  MagicIds which map to a reg on this
 730            -- arch are left unchanged.  For the rest, BaseReg is taken
 731            -- to mean the address of the reg table in MainCapability,
 732            -- and for all others we generate an indirection to its
 733            -- location in the register table.
 734            -> case get_GlobalReg_reg_or_addr mid of
 735                  Left  realreg -> return expr
 736                  Right baseRegAddr
 737                     -> case mid of
 738                           BaseReg -> cmmExprConFold DataReference baseRegAddr
 739                           other   -> cmmExprConFold DataReference
 740                                         (CmmLoad baseRegAddr (globalRegRep mid))
 741            -- eliminate zero offsets
 742         CmmRegOff reg 0
 743            -> cmmExprConFold referenceKind (CmmReg reg)
 744
 745         CmmRegOff (CmmGlobal mid) offset
 746            -- RegOf leaves are just a shorthand form. If the reg maps
 747            -- to a real reg, we keep the shorthand, otherwise, we just
 748            -- expand it and defer to the above code.
 749            -> case get_GlobalReg_reg_or_addr mid of
 750                 Left  realreg -> return expr
 751                 Right baseRegAddr
 752                    -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordRep) [
 753                                         CmmReg (CmmGlobal mid),
 754                                         CmmLit (CmmInt (fromIntegral offset)
 755                                                        wordRep)])
 756         other
 757            -> return other
 758
 759 -- -----------------------------------------------------------------------------
 760 -- Utils
 761
 762 bind f x = x $! f
 763
 764 \end{code}
 765