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