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