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