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