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