compiler/nativeGen/AsmCodeGen.lhs

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