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 the stats from all the spiller stages
 425                 let spillStats  = [ s   | s@RegAllocStatsSpill{}
 426                                         <- concat [ c | Just c <- map cdRegAllocStats dump]]
 427
 428                 -- build a map of how many spill load/stores were inserted for each vreg
 429                 let spillLS     = foldl' (plusUFM_C Spill.accSpillLS) emptyUFM
 430                                 $ map (Spill.spillLoadStore . raSpillStats) spillStats
 431
 432                 -- print the count of load/spills as a tuple so we can read back from the file easilly
 433                 let pprSpillLS :: (Reg, Int, Int) -> SDoc
 434                     pprSpillLS  (r, loads, stores) =
 435                         (parens $ (hcat $ punctuate (text ", ") [doubleQuotes (ppr r), int loads, int stores]))
 436
 437                 -- write out the file
 438                 let out         = showSDoc
 439                                 (  text "-- (spills-added)"
 440                                 $$ text "--    Spill instructions inserted for each virtual reg."
 441                                 $$ text "--    (reg name, spill loads added, spill stores added)."
 442                                 $$ (vcat $ map pprSpillLS $ eltsUFM spillLS)
 443                                 $$ text "\n")
 444
 445                 writeFile dropFile out
 446
 447                 return ()
 448
 449         return ()
 450
 451 -- -----------------------------------------------------------------------------
 452 -- Sequencing the basic blocks
 453
 454 -- Cmm BasicBlocks are self-contained entities: they always end in a
 455 -- jump, either non-local or to another basic block in the same proc.
 456 -- In this phase, we attempt to place the basic blocks in a sequence
 457 -- such that as many of the local jumps as possible turn into
 458 -- fallthroughs.
 459
 460 sequenceTop :: NatCmmTop -> NatCmmTop
 461 sequenceTop top@(CmmData _ _) = top
 462 sequenceTop (CmmProc info lbl params blocks) =
 463   CmmProc info lbl params (makeFarBranches $ sequenceBlocks blocks)
 464
 465 -- The algorithm is very simple (and stupid): we make a graph out of
 466 -- the blocks where there is an edge from one block to another iff the
 467 -- first block ends by jumping to the second.  Then we topologically
 468 -- sort this graph.  Then traverse the list: for each block, we first
 469 -- output the block, then if it has an out edge, we move the
 470 -- destination of the out edge to the front of the list, and continue.
 471
 472 sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock]
 473 sequenceBlocks [] = []
 474 sequenceBlocks (entry:blocks) =
 475   seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
 476   -- the first block is the entry point ==> it must remain at the start.
 477
 478 sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])]
 479 sccBlocks blocks = stronglyConnCompR (map mkNode blocks)
 480
 481 getOutEdges :: [Instr] -> [Unique]
 482 getOutEdges instrs = case jumpDests (last instrs) [] of
 483                         [one] -> [getUnique one]
 484                         _many -> []
 485                 -- we're only interested in the last instruction of
 486                 -- the block, and only if it has a single destination.
 487
 488 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
 489
 490 seqBlocks [] = []
 491 seqBlocks ((block,_,[]) : rest)
 492   = block : seqBlocks rest
 493 seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
 494   | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
 495   | otherwise       = block : seqBlocks rest'
 496   where
 497         (can_fallthrough, rest') = reorder next [] rest
 498           -- TODO: we should do a better job for cycles; try to maximise the
 499           -- fallthroughs within a loop.
 500 seqBlocks _ = panic "AsmCodegen:seqBlocks"
 501
 502 reorder id accum [] = (False, reverse accum)
 503 reorder id accum (b@(block,id',out) : rest)
 504   | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
 505   | otherwise  = reorder id (b:accum) rest
 506
 507
 508 -- -----------------------------------------------------------------------------
 509 -- Making far branches
 510
 511 -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
 512 -- big, we have to work around this limitation.
 513
 514 makeFarBranches :: [NatBasicBlock] -> [NatBasicBlock]
 515
 516 #if powerpc_TARGET_ARCH
 517 makeFarBranches blocks
 518     | last blockAddresses < nearLimit = blocks
 519     | otherwise = zipWith handleBlock blockAddresses blocks
 520     where
 521         blockAddresses = scanl (+) 0 $ map blockLen blocks
 522         blockLen (BasicBlock _ instrs) = length instrs
 523
 524         handleBlock addr (BasicBlock id instrs)
 525                 = BasicBlock id (zipWith makeFar [addr..] instrs)
 526
 527         makeFar addr (BCC ALWAYS tgt) = BCC ALWAYS tgt
 528         makeFar addr (BCC cond tgt)
 529             | abs (addr - targetAddr) >= nearLimit
 530             = BCCFAR cond tgt
 531             | otherwise
 532             = BCC cond tgt
 533             where Just targetAddr = lookupUFM blockAddressMap tgt
 534         makeFar addr other            = other
 535
 536         nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
 537                          -- distance, as we have a few pseudo-insns that are
 538                          -- pretty-printed as multiple instructions,
 539                          -- and it's just not worth the effort to calculate
 540                          -- things exactly
 541
 542         blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
 543 #else
 544 makeFarBranches = id
 545 #endif
 546
 547 -- -----------------------------------------------------------------------------
 548 -- Shortcut branches
 549
 550 shortcutBranches :: DynFlags -> [NatCmmTop] -> [NatCmmTop]
 551 shortcutBranches dflags tops
 552   | optLevel dflags < 1 = tops    -- only with -O or higher
 553   | otherwise           = map (apply_mapping mapping) tops'
 554   where
 555     (tops', mappings) = mapAndUnzip build_mapping tops
 556     mapping = foldr plusUFM emptyUFM mappings
 557
 558 build_mapping top@(CmmData _ _) = (top, emptyUFM)
 559 build_mapping (CmmProc info lbl params [])
 560   = (CmmProc info lbl params [], emptyUFM)
 561 build_mapping (CmmProc info lbl params (head:blocks))
 562   = (CmmProc info lbl params (head:others), mapping)
 563         -- drop the shorted blocks, but don't ever drop the first one,
 564         -- because it is pointed to by a global label.
 565   where
 566     -- find all the blocks that just consist of a jump that can be
 567     -- shorted.
 568     (shortcut_blocks, others) = partitionWith split blocks
 569     split (BasicBlock id [insn]) | Just dest <- canShortcut insn
 570                                  = Left (id,dest)
 571     split other = Right other
 572
 573     -- build a mapping from BlockId to JumpDest for shorting branches
 574     mapping = foldl add emptyUFM shortcut_blocks
 575     add ufm (id,dest) = addToUFM ufm id dest
 576
 577 apply_mapping ufm (CmmData sec statics)
 578   = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
 579   -- we need to get the jump tables, so apply the mapping to the entries
 580   -- of a CmmData too.
 581 apply_mapping ufm (CmmProc info lbl params blocks)
 582   = CmmProc info lbl params (map short_bb blocks)
 583   where
 584     short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
 585     short_insn i = shortcutJump (lookupUFM ufm) i
 586                  -- shortcutJump should apply the mapping repeatedly,
 587                  -- just in case we can short multiple branches.
 588
 589 -- -----------------------------------------------------------------------------
 590 -- Instruction selection
 591
 592 -- Native code instruction selection for a chunk of stix code.  For
 593 -- this part of the computation, we switch from the UniqSM monad to
 594 -- the NatM monad.  The latter carries not only a Unique, but also an
 595 -- Int denoting the current C stack pointer offset in the generated
 596 -- code; this is needed for creating correct spill offsets on
 597 -- architectures which don't offer, or for which it would be
 598 -- prohibitively expensive to employ, a frame pointer register.  Viz,
 599 -- x86.
 600
 601 -- The offset is measured in bytes, and indicates the difference
 602 -- between the current (simulated) C stack-ptr and the value it was at
 603 -- the beginning of the block.  For stacks which grow down, this value
 604 -- should be either zero or negative.
 605
 606 -- Switching between the two monads whilst carrying along the same
 607 -- Unique supply breaks abstraction.  Is that bad?
 608
 609 genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
 610
 611 genMachCode dflags cmm_top
 612   = do  { initial_us <- getUs
 613         ; let initial_st           = mkNatM_State initial_us 0 dflags
 614               (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
 615               final_delta          = natm_delta final_st
 616               final_imports        = natm_imports final_st
 617         ; if   final_delta == 0
 618           then return (new_tops, final_imports)
 619           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
 620     }
 621
 622 -- -----------------------------------------------------------------------------
 623 -- Fixup assignments to global registers so that they assign to
 624 -- locations within the RegTable, if appropriate.
 625
 626 -- Note that we currently don't fixup reads here: they're done by
 627 -- the generic optimiser below, to avoid having two separate passes
 628 -- over the Cmm.
 629
 630 fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
 631 fixAssignsTop top@(CmmData _ _) = returnUs top
 632 fixAssignsTop (CmmProc info lbl params blocks) =
 633   mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
 634   returnUs (CmmProc info lbl params blocks')
 635
 636 fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
 637 fixAssignsBlock (BasicBlock id stmts) =
 638   fixAssigns stmts `thenUs` \ stmts' ->
 639   returnUs (BasicBlock id stmts')
 640
 641 fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt]
 642 fixAssigns stmts =
 643   mapUs fixAssign stmts `thenUs` \ stmtss ->
 644   returnUs (concat stmtss)
 645
 646 fixAssign :: CmmStmt -> UniqSM [CmmStmt]
 647 fixAssign (CmmAssign (CmmGlobal reg) src)
 648   | Left  realreg <- reg_or_addr
 649   = returnUs [CmmAssign (CmmGlobal reg) src]
 650   | Right baseRegAddr <- reg_or_addr
 651   = returnUs [CmmStore baseRegAddr src]
 652            -- Replace register leaves with appropriate StixTrees for
 653            -- the given target. GlobalRegs which map to a reg on this
 654            -- arch are left unchanged.  Assigning to BaseReg is always
 655            -- illegal, so we check for that.
 656   where
 657         reg_or_addr = get_GlobalReg_reg_or_addr reg
 658
 659 fixAssign other_stmt = returnUs [other_stmt]
 660
 661 -- -----------------------------------------------------------------------------
 662 -- Generic Cmm optimiser
 663
 664 {-
 665 Here we do:
 666
 667   (a) Constant folding
 668   (b) Simple inlining: a temporary which is assigned to and then
 669       used, once, can be shorted.
 670   (c) Replacement of references to GlobalRegs which do not have
 671       machine registers by the appropriate memory load (eg.
 672       Hp ==>  *(BaseReg + 34) ).
 673   (d) Position independent code and dynamic linking
 674         (i)  introduce the appropriate indirections
 675              and position independent refs
 676         (ii) compile a list of imported symbols
 677
 678 Ideas for other things we could do (ToDo):
 679
 680   - shortcut jumps-to-jumps
 681   - eliminate dead code blocks
 682   - simple CSE: if an expr is assigned to a temp, then replace later occs of
 683     that expr with the temp, until the expr is no longer valid (can push through
 684     temp assignments, and certain assigns to mem...)
 685 -}
 686
 687 cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
 688 cmmToCmm _ top@(CmmData _ _) = (top, [])
 689 cmmToCmm dflags (CmmProc info lbl params blocks) = runCmmOpt dflags $ do
 690   blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
 691   return $ CmmProc info lbl params blocks'
 692
 693 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
 694
 695 instance Monad CmmOptM where
 696   return x = CmmOptM $ \(imports, _) -> (# x,imports #)
 697   (CmmOptM f) >>= g =
 698     CmmOptM $ \(imports, dflags) ->
 699                 case f (imports, dflags) of
 700                   (# x, imports' #) ->
 701                     case g x of
 702                       CmmOptM g' -> g' (imports', dflags)
 703
 704 addImportCmmOpt :: CLabel -> CmmOptM ()
 705 addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #)
 706
 707 getDynFlagsCmmOpt :: CmmOptM DynFlags
 708 getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
 709
 710 runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
 711 runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
 712                         (# result, imports #) -> (result, imports)
 713
 714 cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
 715 cmmBlockConFold (BasicBlock id stmts) = do
 716   stmts' <- mapM cmmStmtConFold stmts
 717   return $ BasicBlock id stmts'
 718
 719 cmmStmtConFold stmt
 720    = case stmt of
 721         CmmAssign reg src
 722            -> do src' <- cmmExprConFold DataReference src
 723                  return $ case src' of
 724                    CmmReg reg' | reg == reg' -> CmmNop
 725                    new_src -> CmmAssign reg new_src
 726
 727         CmmStore addr src
 728            -> do addr' <- cmmExprConFold DataReference addr
 729                  src'  <- cmmExprConFold DataReference src
 730                  return $ CmmStore addr' src'
 731
 732         CmmJump addr regs
 733            -> do addr' <- cmmExprConFold JumpReference addr
 734                  return $ CmmJump addr' regs
 735
 736         CmmCall target regs args srt returns
 737            -> do target' <- case target of
 738                               CmmCallee e conv -> do
 739                                 e' <- cmmExprConFold CallReference e
 740                                 return $ CmmCallee e' conv
 741                               other -> return other
 742                  args' <- mapM (\(arg, hint) -> do
 743                                   arg' <- cmmExprConFold DataReference arg
 744                                   return (arg', hint)) args
 745                  return $ CmmCall target' regs args' srt returns
 746
 747         CmmCondBranch test dest
 748            -> do test' <- cmmExprConFold DataReference test
 749                  return $ case test' of
 750                    CmmLit (CmmInt 0 _) ->
 751                      CmmComment (mkFastString ("deleted: " ++
 752                                         showSDoc (pprStmt stmt)))
 753
 754                    CmmLit (CmmInt n _) -> CmmBranch dest
 755                    other -> CmmCondBranch test' dest
 756
 757         CmmSwitch expr ids
 758            -> do expr' <- cmmExprConFold DataReference expr
 759                  return $ CmmSwitch expr' ids
 760
 761         other
 762            -> return other
 763
 764
 765 cmmExprConFold referenceKind expr
 766    = case expr of
 767         CmmLoad addr rep
 768            -> do addr' <- cmmExprConFold DataReference addr
 769                  return $ CmmLoad addr' rep
 770
 771         CmmMachOp mop args
 772            -- For MachOps, we first optimize the children, and then we try
 773            -- our hand at some constant-folding.
 774            -> do args' <- mapM (cmmExprConFold DataReference) args
 775                  return $ cmmMachOpFold mop args'
 776
 777         CmmLit (CmmLabel lbl)
 778            -> do
 779                 dflags <- getDynFlagsCmmOpt
 780                 cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
 781         CmmLit (CmmLabelOff lbl off)
 782            -> do
 783                  dflags <- getDynFlagsCmmOpt
 784                  dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
 785                  return $ cmmMachOpFold (MO_Add wordRep) [
 786                      dynRef,
 787                      (CmmLit $ CmmInt (fromIntegral off) wordRep)
 788                    ]
 789
 790 #if powerpc_TARGET_ARCH
 791            -- On powerpc (non-PIC), it's easier to jump directly to a label than
 792            -- to use the register table, so we replace these registers
 793            -- with the corresponding labels:
 794         CmmReg (CmmGlobal GCEnter1)
 795           | not opt_PIC
 796           -> cmmExprConFold referenceKind $
 797              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
 798         CmmReg (CmmGlobal GCFun)
 799           | not opt_PIC
 800           -> cmmExprConFold referenceKind $
 801              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
 802 #endif
 803
 804         CmmReg (CmmGlobal mid)
 805            -- Replace register leaves with appropriate StixTrees for
 806            -- the given target.  MagicIds which map to a reg on this
 807            -- arch are left unchanged.  For the rest, BaseReg is taken
 808            -- to mean the address of the reg table in MainCapability,
 809            -- and for all others we generate an indirection to its
 810            -- location in the register table.
 811            -> case get_GlobalReg_reg_or_addr mid of
 812                  Left  realreg -> return expr
 813                  Right baseRegAddr
 814                     -> case mid of
 815                           BaseReg -> cmmExprConFold DataReference baseRegAddr
 816                           other   -> cmmExprConFold DataReference
 817                                         (CmmLoad baseRegAddr (globalRegRep mid))
 818            -- eliminate zero offsets
 819         CmmRegOff reg 0
 820            -> cmmExprConFold referenceKind (CmmReg reg)
 821
 822         CmmRegOff (CmmGlobal mid) offset
 823            -- RegOf leaves are just a shorthand form. If the reg maps
 824            -- to a real reg, we keep the shorthand, otherwise, we just
 825            -- expand it and defer to the above code.
 826            -> case get_GlobalReg_reg_or_addr mid of
 827                 Left  realreg -> return expr
 828                 Right baseRegAddr
 829                    -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordRep) [
 830                                         CmmReg (CmmGlobal mid),
 831                                         CmmLit (CmmInt (fromIntegral offset)
 832                                                        wordRep)])
 833         other
 834            -> return other
 835
 836 -- -----------------------------------------------------------------------------
 837 -- Utils
 838
 839 bind f x = x $! f
 840
 841 \end{code}
 842