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