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