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                 -- graph coloring register allocation
 231                 let ((alloced, regAllocStats), usAlloc)
 232                         = initUs usCoalesce
 233                         $ Color.regAlloc
 234                                 alloc_regs
 235                                 (mkUniqSet [0..maxSpillSlots])
 236                                 coalesced
 237
 238                 dumpIfSet_dyn dflags
 239                         Opt_D_dump_asm_regalloc "Registers allocated"
 240                         (vcat $ map (docToSDoc . pprNatCmmTop) alloced)
 241
 242                 dumpIfSet_dyn dflags
 243                         Opt_D_dump_asm_regalloc_stages "Build/spill stages"
 244                         (vcat   $ map (\(stage, stats)
 245                                         -> text "-- Stage " <> int stage
 246                                         $$ ppr stats)
 247                                 $ zip [0..] regAllocStats)
 248
 249                 return  ( alloced, usAlloc
 250                         , if dopt Opt_D_dump_asm_stats dflags
 251                            then Just regAllocStats else Nothing
 252                         , Nothing)
 253
 254           else do
 255                 -- do linear register allocation
 256                 let ((alloced, regAllocStats), usAlloc)
 257                         = initUs usLive
 258                         $ liftM unzip
 259                         $ mapUs Linear.regAlloc withLiveness
 260
 261                 dumpIfSet_dyn dflags
 262                         Opt_D_dump_asm_regalloc "Registers allocated"
 263                         (vcat $ map (docToSDoc . pprNatCmmTop) alloced)
 264
 265                 return  ( alloced, usAlloc
 266                         , Nothing
 267                         , if dopt Opt_D_dump_asm_stats dflags
 268                            then Just (catMaybes regAllocStats) else Nothing)
 269
 270         ---- shortcut branches
 271         let shorted     =
 272                 {-# SCC "shortcutBranches" #-}
 273                 shortcutBranches dflags alloced
 274
 275         ---- sequence blocks
 276         let sequenced   =
 277                 {-# SCC "sequenceBlocks" #-}
 278                 map sequenceTop shorted
 279
 280         ---- x86fp_kludge
 281         let final_mach_code =
 282 #if i386_TARGET_ARCH
 283                 {-# SCC "x86fp_kludge" #-}
 284                 map x86fp_kludge sequenced
 285 #else
 286                 sequenced
 287 #endif
 288
 289         return  ( usAlloc
 290                 , ( final_mach_code
 291                   , lastMinuteImports ++ imports
 292                   , ppr_raStatsColor
 293                   , ppr_raStatsLinear) )
 294
 295
 296 #if i386_TARGET_ARCH
 297 x86fp_kludge :: NatCmmTop -> NatCmmTop
 298 x86fp_kludge top@(CmmData _ _) = top
 299 x86fp_kludge top@(CmmProc info lbl params code) =
 300         CmmProc info lbl params (map bb_i386_insert_ffrees code)
 301         where
 302                 bb_i386_insert_ffrees (BasicBlock id instrs) =
 303                         BasicBlock id (i386_insert_ffrees instrs)
 304 #endif
 305
 306
 307 -- | Build assembler source file from native code and its imports.
 308 --
 309 makeAsmDoc :: [NatCmmTop] -> [CLabel] -> Pretty.Doc
 310 makeAsmDoc native imports
 311  =      Pretty.vcat (map pprNatCmmTop native)
 312         Pretty.$$ (Pretty.text "")
 313         Pretty.$$ dyld_stubs imports
 314
 315 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
 316                 -- On recent versions of Darwin, the linker supports
 317                 -- dead-stripping of code and data on a per-symbol basis.
 318                 -- There's a hack to make this work in PprMach.pprNatCmmTop.
 319             Pretty.$$ Pretty.text ".subsections_via_symbols"
 320 #endif
 321 #if HAVE_GNU_NONEXEC_STACK
 322                 -- On recent GNU ELF systems one can mark an object file
 323                 -- as not requiring an executable stack. If all objects
 324                 -- linked into a program have this note then the program
 325                 -- will not use an executable stack, which is good for
 326                 -- security. GHC generated code does not need an executable
 327                 -- stack so add the note in:
 328             Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
 329 #endif
 330 #if !defined(darwin_TARGET_OS)
 331                 -- And just because every other compiler does, lets stick in
 332                 -- an identifier directive: .ident "GHC x.y.z"
 333             Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
 334                                           Pretty.text cProjectVersion
 335                        in Pretty.text ".ident" Pretty.<+>
 336                           Pretty.doubleQuotes compilerIdent
 337 #endif
 338
 339  where
 340         -- Generate "symbol stubs" for all external symbols that might
 341         -- come from a dynamic library.
 342         dyld_stubs :: [CLabel] -> Pretty.Doc
 343 {-      dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
 344                                     map head $ group $ sort imps-}
 345
 346         -- (Hack) sometimes two Labels pretty-print the same, but have
 347         -- different uniques; so we compare their text versions...
 348         dyld_stubs imps
 349                 | needImportedSymbols
 350                 = Pretty.vcat $
 351                         (pprGotDeclaration :) $
 352                         map (pprImportedSymbol . fst . head) $
 353                         groupBy (\(_,a) (_,b) -> a == b) $
 354                         sortBy (\(_,a) (_,b) -> compare a b) $
 355                         map doPpr $
 356                         imps
 357                 | otherwise
 358                 = Pretty.empty
 359
 360         doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
 361         astyle = mkCodeStyle AsmStyle
 362
 363
 364 -- -----------------------------------------------------------------------------
 365 -- Sequencing the basic blocks
 366
 367 -- Cmm BasicBlocks are self-contained entities: they always end in a
 368 -- jump, either non-local or to another basic block in the same proc.
 369 -- In this phase, we attempt to place the basic blocks in a sequence
 370 -- such that as many of the local jumps as possible turn into
 371 -- fallthroughs.
 372
 373 sequenceTop :: NatCmmTop -> NatCmmTop
 374 sequenceTop top@(CmmData _ _) = top
 375 sequenceTop (CmmProc info lbl params blocks) =
 376   CmmProc info lbl params (makeFarBranches $ sequenceBlocks blocks)
 377
 378 -- The algorithm is very simple (and stupid): we make a graph out of
 379 -- the blocks where there is an edge from one block to another iff the
 380 -- first block ends by jumping to the second.  Then we topologically
 381 -- sort this graph.  Then traverse the list: for each block, we first
 382 -- output the block, then if it has an out edge, we move the
 383 -- destination of the out edge to the front of the list, and continue.
 384
 385 sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock]
 386 sequenceBlocks [] = []
 387 sequenceBlocks (entry:blocks) =
 388   seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
 389   -- the first block is the entry point ==> it must remain at the start.
 390
 391 sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])]
 392 sccBlocks blocks = stronglyConnCompR (map mkNode blocks)
 393
 394 getOutEdges :: [Instr] -> [Unique]
 395 getOutEdges instrs = case jumpDests (last instrs) [] of
 396                         [one] -> [getUnique one]
 397                         _many -> []
 398                 -- we're only interested in the last instruction of
 399                 -- the block, and only if it has a single destination.
 400
 401 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
 402
 403 seqBlocks [] = []
 404 seqBlocks ((block,_,[]) : rest)
 405   = block : seqBlocks rest
 406 seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
 407   | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
 408   | otherwise       = block : seqBlocks rest'
 409   where
 410         (can_fallthrough, rest') = reorder next [] rest
 411           -- TODO: we should do a better job for cycles; try to maximise the
 412           -- fallthroughs within a loop.
 413 seqBlocks _ = panic "AsmCodegen:seqBlocks"
 414
 415 reorder id accum [] = (False, reverse accum)
 416 reorder id accum (b@(block,id',out) : rest)
 417   | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
 418   | otherwise  = reorder id (b:accum) rest
 419
 420
 421 -- -----------------------------------------------------------------------------
 422 -- Making far branches
 423
 424 -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
 425 -- big, we have to work around this limitation.
 426
 427 makeFarBranches :: [NatBasicBlock] -> [NatBasicBlock]
 428
 429 #if powerpc_TARGET_ARCH
 430 makeFarBranches blocks
 431     | last blockAddresses < nearLimit = blocks
 432     | otherwise = zipWith handleBlock blockAddresses blocks
 433     where
 434         blockAddresses = scanl (+) 0 $ map blockLen blocks
 435         blockLen (BasicBlock _ instrs) = length instrs
 436
 437         handleBlock addr (BasicBlock id instrs)
 438                 = BasicBlock id (zipWith makeFar [addr..] instrs)
 439
 440         makeFar addr (BCC ALWAYS tgt) = BCC ALWAYS tgt
 441         makeFar addr (BCC cond tgt)
 442             | abs (addr - targetAddr) >= nearLimit
 443             = BCCFAR cond tgt
 444             | otherwise
 445             = BCC cond tgt
 446             where Just targetAddr = lookupUFM blockAddressMap tgt
 447         makeFar addr other            = other
 448
 449         nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
 450                          -- distance, as we have a few pseudo-insns that are
 451                          -- pretty-printed as multiple instructions,
 452                          -- and it's just not worth the effort to calculate
 453                          -- things exactly
 454
 455         blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
 456 #else
 457 makeFarBranches = id
 458 #endif
 459
 460 -- -----------------------------------------------------------------------------
 461 -- Shortcut branches
 462
 463 shortcutBranches :: DynFlags -> [NatCmmTop] -> [NatCmmTop]
 464 shortcutBranches dflags tops
 465   | optLevel dflags < 1 = tops    -- only with -O or higher
 466   | otherwise           = map (apply_mapping mapping) tops'
 467   where
 468     (tops', mappings) = mapAndUnzip build_mapping tops
 469     mapping = foldr plusUFM emptyUFM mappings
 470
 471 build_mapping top@(CmmData _ _) = (top, emptyUFM)
 472 build_mapping (CmmProc info lbl params [])
 473   = (CmmProc info lbl params [], emptyUFM)
 474 build_mapping (CmmProc info lbl params (head:blocks))
 475   = (CmmProc info lbl params (head:others), mapping)
 476         -- drop the shorted blocks, but don't ever drop the first one,
 477         -- because it is pointed to by a global label.
 478   where
 479     -- find all the blocks that just consist of a jump that can be
 480     -- shorted.
 481     (shortcut_blocks, others) = partitionWith split blocks
 482     split (BasicBlock id [insn]) | Just dest <- canShortcut insn
 483                                  = Left (id,dest)
 484     split other = Right other
 485
 486     -- build a mapping from BlockId to JumpDest for shorting branches
 487     mapping = foldl add emptyUFM shortcut_blocks
 488     add ufm (id,dest) = addToUFM ufm id dest
 489
 490 apply_mapping ufm (CmmData sec statics)
 491   = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
 492   -- we need to get the jump tables, so apply the mapping to the entries
 493   -- of a CmmData too.
 494 apply_mapping ufm (CmmProc info lbl params blocks)
 495   = CmmProc info lbl params (map short_bb blocks)
 496   where
 497     short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
 498     short_insn i = shortcutJump (lookupUFM ufm) i
 499                  -- shortcutJump should apply the mapping repeatedly,
 500                  -- just in case we can short multiple branches.
 501
 502 -- -----------------------------------------------------------------------------
 503 -- Instruction selection
 504
 505 -- Native code instruction selection for a chunk of stix code.  For
 506 -- this part of the computation, we switch from the UniqSM monad to
 507 -- the NatM monad.  The latter carries not only a Unique, but also an
 508 -- Int denoting the current C stack pointer offset in the generated
 509 -- code; this is needed for creating correct spill offsets on
 510 -- architectures which don't offer, or for which it would be
 511 -- prohibitively expensive to employ, a frame pointer register.  Viz,
 512 -- x86.
 513
 514 -- The offset is measured in bytes, and indicates the difference
 515 -- between the current (simulated) C stack-ptr and the value it was at
 516 -- the beginning of the block.  For stacks which grow down, this value
 517 -- should be either zero or negative.
 518
 519 -- Switching between the two monads whilst carrying along the same
 520 -- Unique supply breaks abstraction.  Is that bad?
 521
 522 genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
 523
 524 genMachCode dflags cmm_top
 525   = do  { initial_us <- getUs
 526         ; let initial_st           = mkNatM_State initial_us 0 dflags
 527               (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
 528               final_delta          = natm_delta final_st
 529               final_imports        = natm_imports final_st
 530         ; if   final_delta == 0
 531           then return (new_tops, final_imports)
 532           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
 533     }
 534
 535 -- -----------------------------------------------------------------------------
 536 -- Fixup assignments to global registers so that they assign to
 537 -- locations within the RegTable, if appropriate.
 538
 539 -- Note that we currently don't fixup reads here: they're done by
 540 -- the generic optimiser below, to avoid having two separate passes
 541 -- over the Cmm.
 542
 543 fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
 544 fixAssignsTop top@(CmmData _ _) = returnUs top
 545 fixAssignsTop (CmmProc info lbl params blocks) =
 546   mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
 547   returnUs (CmmProc info lbl params blocks')
 548
 549 fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
 550 fixAssignsBlock (BasicBlock id stmts) =
 551   fixAssigns stmts `thenUs` \ stmts' ->
 552   returnUs (BasicBlock id stmts')
 553
 554 fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt]
 555 fixAssigns stmts =
 556   mapUs fixAssign stmts `thenUs` \ stmtss ->
 557   returnUs (concat stmtss)
 558
 559 fixAssign :: CmmStmt -> UniqSM [CmmStmt]
 560 fixAssign (CmmAssign (CmmGlobal reg) src)
 561   | Left  realreg <- reg_or_addr
 562   = returnUs [CmmAssign (CmmGlobal reg) src]
 563   | Right baseRegAddr <- reg_or_addr
 564   = returnUs [CmmStore baseRegAddr src]
 565            -- Replace register leaves with appropriate StixTrees for
 566            -- the given target. GlobalRegs which map to a reg on this
 567            -- arch are left unchanged.  Assigning to BaseReg is always
 568            -- illegal, so we check for that.
 569   where
 570         reg_or_addr = get_GlobalReg_reg_or_addr reg
 571
 572 fixAssign other_stmt = returnUs [other_stmt]
 573
 574 -- -----------------------------------------------------------------------------
 575 -- Generic Cmm optimiser
 576
 577 {-
 578 Here we do:
 579
 580   (a) Constant folding
 581   (b) Simple inlining: a temporary which is assigned to and then
 582       used, once, can be shorted.
 583   (c) Replacement of references to GlobalRegs which do not have
 584       machine registers by the appropriate memory load (eg.
 585       Hp ==>  *(BaseReg + 34) ).
 586   (d) Position independent code and dynamic linking
 587         (i)  introduce the appropriate indirections
 588              and position independent refs
 589         (ii) compile a list of imported symbols
 590
 591 Ideas for other things we could do (ToDo):
 592
 593   - shortcut jumps-to-jumps
 594   - eliminate dead code blocks
 595   - simple CSE: if an expr is assigned to a temp, then replace later occs of
 596     that expr with the temp, until the expr is no longer valid (can push through
 597     temp assignments, and certain assigns to mem...)
 598 -}
 599
 600 cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
 601 cmmToCmm _ top@(CmmData _ _) = (top, [])
 602 cmmToCmm dflags (CmmProc info lbl params blocks) = runCmmOpt dflags $ do
 603   blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
 604   return $ CmmProc info lbl params blocks'
 605
 606 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
 607
 608 instance Monad CmmOptM where
 609   return x = CmmOptM $ \(imports, _) -> (# x,imports #)
 610   (CmmOptM f) >>= g =
 611     CmmOptM $ \(imports, dflags) ->
 612                 case f (imports, dflags) of
 613                   (# x, imports' #) ->
 614                     case g x of
 615                       CmmOptM g' -> g' (imports', dflags)
 616
 617 addImportCmmOpt :: CLabel -> CmmOptM ()
 618 addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #)
 619
 620 getDynFlagsCmmOpt :: CmmOptM DynFlags
 621 getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
 622
 623 runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
 624 runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
 625                         (# result, imports #) -> (result, imports)
 626
 627 cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
 628 cmmBlockConFold (BasicBlock id stmts) = do
 629   stmts' <- mapM cmmStmtConFold stmts
 630   return $ BasicBlock id stmts'
 631
 632 cmmStmtConFold stmt
 633    = case stmt of
 634         CmmAssign reg src
 635            -> do src' <- cmmExprConFold DataReference src
 636                  return $ case src' of
 637                    CmmReg reg' | reg == reg' -> CmmNop
 638                    new_src -> CmmAssign reg new_src
 639
 640         CmmStore addr src
 641            -> do addr' <- cmmExprConFold DataReference addr
 642                  src'  <- cmmExprConFold DataReference src
 643                  return $ CmmStore addr' src'
 644
 645         CmmJump addr regs
 646            -> do addr' <- cmmExprConFold JumpReference addr
 647                  return $ CmmJump addr' regs
 648
 649         CmmCall target regs args srt returns
 650            -> do target' <- case target of
 651                               CmmCallee e conv -> do
 652                                 e' <- cmmExprConFold CallReference e
 653                                 return $ CmmCallee e' conv
 654                               other -> return other
 655                  args' <- mapM (\(arg, hint) -> do
 656                                   arg' <- cmmExprConFold DataReference arg
 657                                   return (arg', hint)) args
 658                  return $ CmmCall target' regs args' srt returns
 659
 660         CmmCondBranch test dest
 661            -> do test' <- cmmExprConFold DataReference test
 662                  return $ case test' of
 663                    CmmLit (CmmInt 0 _) ->
 664                      CmmComment (mkFastString ("deleted: " ++
 665                                         showSDoc (pprStmt stmt)))
 666
 667                    CmmLit (CmmInt n _) -> CmmBranch dest
 668                    other -> CmmCondBranch test' dest
 669
 670         CmmSwitch expr ids
 671            -> do expr' <- cmmExprConFold DataReference expr
 672                  return $ CmmSwitch expr' ids
 673
 674         other
 675            -> return other
 676
 677
 678 cmmExprConFold referenceKind expr
 679    = case expr of
 680         CmmLoad addr rep
 681            -> do addr' <- cmmExprConFold DataReference addr
 682                  return $ CmmLoad addr' rep
 683
 684         CmmMachOp mop args
 685            -- For MachOps, we first optimize the children, and then we try
 686            -- our hand at some constant-folding.
 687            -> do args' <- mapM (cmmExprConFold DataReference) args
 688                  return $ cmmMachOpFold mop args'
 689
 690         CmmLit (CmmLabel lbl)
 691            -> do
 692                 dflags <- getDynFlagsCmmOpt
 693                 cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
 694         CmmLit (CmmLabelOff lbl off)
 695            -> do
 696                  dflags <- getDynFlagsCmmOpt
 697                  dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
 698                  return $ cmmMachOpFold (MO_Add wordRep) [
 699                      dynRef,
 700                      (CmmLit $ CmmInt (fromIntegral off) wordRep)
 701                    ]
 702
 703 #if powerpc_TARGET_ARCH
 704            -- On powerpc (non-PIC), it's easier to jump directly to a label than
 705            -- to use the register table, so we replace these registers
 706            -- with the corresponding labels:
 707         CmmReg (CmmGlobal GCEnter1)
 708           | not opt_PIC
 709           -> cmmExprConFold referenceKind $
 710              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
 711         CmmReg (CmmGlobal GCFun)
 712           | not opt_PIC
 713           -> cmmExprConFold referenceKind $
 714              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
 715 #endif
 716
 717         CmmReg (CmmGlobal mid)
 718            -- Replace register leaves with appropriate StixTrees for
 719            -- the given target.  MagicIds which map to a reg on this
 720            -- arch are left unchanged.  For the rest, BaseReg is taken
 721            -- to mean the address of the reg table in MainCapability,
 722            -- and for all others we generate an indirection to its
 723            -- location in the register table.
 724            -> case get_GlobalReg_reg_or_addr mid of
 725                  Left  realreg -> return expr
 726                  Right baseRegAddr
 727                     -> case mid of
 728                           BaseReg -> cmmExprConFold DataReference baseRegAddr
 729                           other   -> cmmExprConFold DataReference
 730                                         (CmmLoad baseRegAddr (globalRegRep mid))
 731            -- eliminate zero offsets
 732         CmmRegOff reg 0
 733            -> cmmExprConFold referenceKind (CmmReg reg)
 734
 735         CmmRegOff (CmmGlobal mid) offset
 736            -- RegOf leaves are just a shorthand form. If the reg maps
 737            -- to a real reg, we keep the shorthand, otherwise, we just
 738            -- expand it and defer to the above code.
 739            -> case get_GlobalReg_reg_or_addr mid of
 740                 Left  realreg -> return expr
 741                 Right baseRegAddr
 742                    -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordRep) [
 743                                         CmmReg (CmmGlobal mid),
 744                                         CmmLit (CmmInt (fromIntegral offset)
 745                                                        wordRep)])
 746         other
 747            -> return other
 748
 749 -- -----------------------------------------------------------------------------
 750 -- Utils
 751
 752 bind f x = x $! f
 753
 754 \end{code}
 755