compiler/nativeGen/AsmCodeGen.lhs

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