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