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