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
  29 #elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
  30 import X86.CodeGen
  31 import X86.Regs
  32 import X86.RegInfo
  33 import X86.Instr
  34 import X86.Ppr
  35
  36 #elif sparc_TARGET_ARCH
  37 import SPARC.CodeGen
  38 import SPARC.Regs
  39 import SPARC.Instr
  40 import SPARC.Ppr
  41 import SPARC.ShortcutJump
  42
  43 #elif powerpc_TARGET_ARCH
  44 import PPC.CodeGen
  45 import PPC.Cond
  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         :: NatCmmTop Instr
 480         -> NatCmmTop Instr
 481
 482 sequenceTop top@(CmmData _ _) = top
 483 sequenceTop (CmmProc info lbl params (ListGraph blocks)) =
 484   CmmProc info lbl params (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
 485
 486 -- The algorithm is very simple (and stupid): we make a graph out of
 487 -- the blocks where there is an edge from one block to another iff the
 488 -- first block ends by jumping to the second.  Then we topologically
 489 -- sort this graph.  Then traverse the list: for each block, we first
 490 -- output the block, then if it has an out edge, we move the
 491 -- destination of the out edge to the front of the list, and continue.
 492
 493 -- FYI, the classic layout for basic blocks uses postorder DFS; this
 494 -- algorithm is implemented in cmm/ZipCfg.hs (NR 6 Sep 2007).
 495
 496 sequenceBlocks
 497         :: Instruction instr
 498         => [NatBasicBlock instr]
 499         -> [NatBasicBlock instr]
 500
 501 sequenceBlocks [] = []
 502 sequenceBlocks (entry:blocks) =
 503   seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
 504   -- the first block is the entry point ==> it must remain at the start.
 505
 506
 507 sccBlocks
 508         :: Instruction instr
 509         => [NatBasicBlock instr]
 510         -> [SCC ( NatBasicBlock instr
 511                 , Unique
 512                 , [Unique])]
 513
 514 sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
 515
 516 -- we're only interested in the last instruction of
 517 -- the block, and only if it has a single destination.
 518 getOutEdges
 519         :: Instruction instr
 520         => [instr] -> [Unique]
 521
 522 getOutEdges instrs
 523         = case jumpDestsOfInstr (last instrs) of
 524                 [one] -> [getUnique one]
 525                 _many -> []
 526
 527 mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
 528
 529 seqBlocks [] = []
 530 seqBlocks ((block,_,[]) : rest)
 531   = block : seqBlocks rest
 532 seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
 533   | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
 534   | otherwise       = block : seqBlocks rest'
 535   where
 536         (can_fallthrough, rest') = reorder next [] rest
 537           -- TODO: we should do a better job for cycles; try to maximise the
 538           -- fallthroughs within a loop.
 539 seqBlocks _ = panic "AsmCodegen:seqBlocks"
 540
 541 reorder id accum [] = (False, reverse accum)
 542 reorder id accum (b@(block,id',out) : rest)
 543   | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
 544   | otherwise  = reorder id (b:accum) rest
 545
 546
 547 -- -----------------------------------------------------------------------------
 548 -- Making far branches
 549
 550 -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
 551 -- big, we have to work around this limitation.
 552
 553 makeFarBranches
 554         :: [NatBasicBlock Instr]
 555         -> [NatBasicBlock Instr]
 556
 557 #if powerpc_TARGET_ARCH
 558 makeFarBranches blocks
 559     | last blockAddresses < nearLimit = blocks
 560     | otherwise = zipWith handleBlock blockAddresses blocks
 561     where
 562         blockAddresses = scanl (+) 0 $ map blockLen blocks
 563         blockLen (BasicBlock _ instrs) = length instrs
 564
 565         handleBlock addr (BasicBlock id instrs)
 566                 = BasicBlock id (zipWith makeFar [addr..] instrs)
 567
 568         makeFar addr (BCC ALWAYS tgt) = BCC ALWAYS tgt
 569         makeFar addr (BCC cond tgt)
 570             | abs (addr - targetAddr) >= nearLimit
 571             = BCCFAR cond tgt
 572             | otherwise
 573             = BCC cond tgt
 574             where Just targetAddr = lookupUFM blockAddressMap tgt
 575         makeFar addr other            = other
 576
 577         nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
 578                          -- distance, as we have a few pseudo-insns that are
 579                          -- pretty-printed as multiple instructions,
 580                          -- and it's just not worth the effort to calculate
 581                          -- things exactly
 582
 583         blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
 584 #else
 585 makeFarBranches = id
 586 #endif
 587
 588 -- -----------------------------------------------------------------------------
 589 -- Shortcut branches
 590
 591 shortcutBranches
 592         :: DynFlags
 593         -> [NatCmmTop Instr]
 594         -> [NatCmmTop Instr]
 595
 596 shortcutBranches dflags tops
 597   | optLevel dflags < 1 = tops    -- only with -O or higher
 598   | otherwise           = map (apply_mapping mapping) tops'
 599   where
 600     (tops', mappings) = mapAndUnzip build_mapping tops
 601     mapping = foldr plusUFM emptyUFM mappings
 602
 603 build_mapping top@(CmmData _ _) = (top, emptyUFM)
 604 build_mapping (CmmProc info lbl params (ListGraph []))
 605   = (CmmProc info lbl params (ListGraph []), emptyUFM)
 606 build_mapping (CmmProc info lbl params (ListGraph (head:blocks)))
 607   = (CmmProc info lbl params (ListGraph (head:others)), mapping)
 608         -- drop the shorted blocks, but don't ever drop the first one,
 609         -- because it is pointed to by a global label.
 610   where
 611     -- find all the blocks that just consist of a jump that can be
 612     -- shorted.
 613     (shortcut_blocks, others) = partitionWith split blocks
 614     split (BasicBlock id [insn]) | Just dest <- canShortcut insn
 615                                  = Left (id,dest)
 616     split other = Right other
 617
 618     -- build a mapping from BlockId to JumpDest for shorting branches
 619     mapping = foldl add emptyUFM shortcut_blocks
 620     add ufm (id,dest) = addToUFM ufm id dest
 621
 622 apply_mapping ufm (CmmData sec statics)
 623   = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
 624   -- we need to get the jump tables, so apply the mapping to the entries
 625   -- of a CmmData too.
 626 apply_mapping ufm (CmmProc info lbl params (ListGraph blocks))
 627   = CmmProc info lbl params (ListGraph $ map short_bb blocks)
 628   where
 629     short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
 630     short_insn i = shortcutJump (lookupUFM ufm) i
 631                  -- shortcutJump should apply the mapping repeatedly,
 632                  -- just in case we can short multiple branches.
 633
 634 -- -----------------------------------------------------------------------------
 635 -- Instruction selection
 636
 637 -- Native code instruction selection for a chunk of stix code.  For
 638 -- this part of the computation, we switch from the UniqSM monad to
 639 -- the NatM monad.  The latter carries not only a Unique, but also an
 640 -- Int denoting the current C stack pointer offset in the generated
 641 -- code; this is needed for creating correct spill offsets on
 642 -- architectures which don't offer, or for which it would be
 643 -- prohibitively expensive to employ, a frame pointer register.  Viz,
 644 -- x86.
 645
 646 -- The offset is measured in bytes, and indicates the difference
 647 -- between the current (simulated) C stack-ptr and the value it was at
 648 -- the beginning of the block.  For stacks which grow down, this value
 649 -- should be either zero or negative.
 650
 651 -- Switching between the two monads whilst carrying along the same
 652 -- Unique supply breaks abstraction.  Is that bad?
 653
 654 genMachCode
 655         :: DynFlags
 656         -> RawCmmTop
 657         -> UniqSM
 658                 ( [NatCmmTop Instr]
 659                 , [CLabel])
 660
 661 genMachCode dflags cmm_top
 662   = do  { initial_us <- getUs
 663         ; let initial_st           = mkNatM_State initial_us 0 dflags
 664               (new_tops, final_st) = initNat initial_st (cmmTopCodeGen dflags cmm_top)
 665               final_delta          = natm_delta final_st
 666               final_imports        = natm_imports final_st
 667         ; if   final_delta == 0
 668           then return (new_tops, final_imports)
 669           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
 670     }
 671
 672 -- -----------------------------------------------------------------------------
 673 -- Fixup assignments to global registers so that they assign to
 674 -- locations within the RegTable, if appropriate.
 675
 676 -- Note that we currently don't fixup reads here: they're done by
 677 -- the generic optimiser below, to avoid having two separate passes
 678 -- over the Cmm.
 679
 680 fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
 681 fixAssignsTop top@(CmmData _ _) = returnUs top
 682 fixAssignsTop (CmmProc info lbl params (ListGraph blocks)) =
 683   mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
 684   returnUs (CmmProc info lbl params (ListGraph blocks'))
 685
 686 fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
 687 fixAssignsBlock (BasicBlock id stmts) =
 688   fixAssigns stmts `thenUs` \ stmts' ->
 689   returnUs (BasicBlock id stmts')
 690
 691 fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt]
 692 fixAssigns stmts =
 693   mapUs fixAssign stmts `thenUs` \ stmtss ->
 694   returnUs (concat stmtss)
 695
 696 fixAssign :: CmmStmt -> UniqSM [CmmStmt]
 697 fixAssign (CmmAssign (CmmGlobal reg) src)
 698   | Left  realreg <- reg_or_addr
 699   = returnUs [CmmAssign (CmmGlobal reg) src]
 700   | Right baseRegAddr <- reg_or_addr
 701   = returnUs [CmmStore baseRegAddr src]
 702            -- Replace register leaves with appropriate StixTrees for
 703            -- the given target. GlobalRegs which map to a reg on this
 704            -- arch are left unchanged.  Assigning to BaseReg is always
 705            -- illegal, so we check for that.
 706   where
 707         reg_or_addr = get_GlobalReg_reg_or_addr reg
 708
 709 fixAssign other_stmt = returnUs [other_stmt]
 710
 711 -- -----------------------------------------------------------------------------
 712 -- Generic Cmm optimiser
 713
 714 {-
 715 Here we do:
 716
 717   (a) Constant folding
 718   (b) Simple inlining: a temporary which is assigned to and then
 719       used, once, can be shorted.
 720   (c) Replacement of references to GlobalRegs which do not have
 721       machine registers by the appropriate memory load (eg.
 722       Hp ==>  *(BaseReg + 34) ).
 723   (d) Position independent code and dynamic linking
 724         (i)  introduce the appropriate indirections
 725              and position independent refs
 726         (ii) compile a list of imported symbols
 727
 728 Ideas for other things we could do (ToDo):
 729
 730   - shortcut jumps-to-jumps
 731   - eliminate dead code blocks
 732   - simple CSE: if an expr is assigned to a temp, then replace later occs of
 733     that expr with the temp, until the expr is no longer valid (can push through
 734     temp assignments, and certain assigns to mem...)
 735 -}
 736
 737 cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
 738 cmmToCmm _ top@(CmmData _ _) = (top, [])
 739 cmmToCmm dflags (CmmProc info lbl params (ListGraph blocks)) = runCmmOpt dflags $ do
 740   blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
 741   return $ CmmProc info lbl params (ListGraph blocks')
 742
 743 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
 744
 745 instance Monad CmmOptM where
 746   return x = CmmOptM $ \(imports, _) -> (# x,imports #)
 747   (CmmOptM f) >>= g =
 748     CmmOptM $ \(imports, dflags) ->
 749                 case f (imports, dflags) of
 750                   (# x, imports' #) ->
 751                     case g x of
 752                       CmmOptM g' -> g' (imports', dflags)
 753
 754 addImportCmmOpt :: CLabel -> CmmOptM ()
 755 addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #)
 756
 757 getDynFlagsCmmOpt :: CmmOptM DynFlags
 758 getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
 759
 760 runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
 761 runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
 762                         (# result, imports #) -> (result, imports)
 763
 764 cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
 765 cmmBlockConFold (BasicBlock id stmts) = do
 766   stmts' <- mapM cmmStmtConFold stmts
 767   return $ BasicBlock id stmts'
 768
 769 cmmStmtConFold stmt
 770    = case stmt of
 771         CmmAssign reg src
 772            -> do src' <- cmmExprConFold DataReference src
 773                  return $ case src' of
 774                    CmmReg reg' | reg == reg' -> CmmNop
 775                    new_src -> CmmAssign reg new_src
 776
 777         CmmStore addr src
 778            -> do addr' <- cmmExprConFold DataReference addr
 779                  src'  <- cmmExprConFold DataReference src
 780                  return $ CmmStore addr' src'
 781
 782         CmmJump addr regs
 783            -> do addr' <- cmmExprConFold JumpReference addr
 784                  return $ CmmJump addr' regs
 785
 786         CmmCall target regs args srt returns
 787            -> do target' <- case target of
 788                               CmmCallee e conv -> do
 789                                 e' <- cmmExprConFold CallReference e
 790                                 return $ CmmCallee e' conv
 791                               other -> return other
 792                  args' <- mapM (\(CmmHinted arg hint) -> do
 793                                   arg' <- cmmExprConFold DataReference arg
 794                                   return (CmmHinted arg' hint)) args
 795                  return $ CmmCall target' regs args' srt returns
 796
 797         CmmCondBranch test dest
 798            -> do test' <- cmmExprConFold DataReference test
 799                  return $ case test' of
 800                    CmmLit (CmmInt 0 _) ->
 801                      CmmComment (mkFastString ("deleted: " ++
 802                                         showSDoc (pprStmt stmt)))
 803
 804                    CmmLit (CmmInt n _) -> CmmBranch dest
 805                    other -> CmmCondBranch test' dest
 806
 807         CmmSwitch expr ids
 808            -> do expr' <- cmmExprConFold DataReference expr
 809                  return $ CmmSwitch expr' ids
 810
 811         other
 812            -> return other
 813
 814
 815 cmmExprConFold referenceKind expr
 816    = case expr of
 817         CmmLoad addr rep
 818            -> do addr' <- cmmExprConFold DataReference addr
 819                  return $ CmmLoad addr' rep
 820
 821         CmmMachOp mop args
 822            -- For MachOps, we first optimize the children, and then we try
 823            -- our hand at some constant-folding.
 824            -> do args' <- mapM (cmmExprConFold DataReference) args
 825                  return $ cmmMachOpFold mop args'
 826
 827         CmmLit (CmmLabel lbl)
 828            -> do
 829                 dflags <- getDynFlagsCmmOpt
 830                 cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
 831         CmmLit (CmmLabelOff lbl off)
 832            -> do
 833                  dflags <- getDynFlagsCmmOpt
 834                  dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
 835                  return $ cmmMachOpFold (MO_Add wordWidth) [
 836                      dynRef,
 837                      (CmmLit $ CmmInt (fromIntegral off) wordWidth)
 838                    ]
 839
 840 #if powerpc_TARGET_ARCH
 841            -- On powerpc (non-PIC), it's easier to jump directly to a label than
 842            -- to use the register table, so we replace these registers
 843            -- with the corresponding labels:
 844         CmmReg (CmmGlobal EagerBlackholeInfo)
 845           | not opt_PIC
 846           -> cmmExprConFold referenceKind $
 847              CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_EAGER_BLACKHOLE_INFO")))
 848         CmmReg (CmmGlobal GCEnter1)
 849           | not opt_PIC
 850           -> cmmExprConFold referenceKind $
 851              CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_enter_1")))
 852         CmmReg (CmmGlobal GCFun)
 853           | not opt_PIC
 854           -> cmmExprConFold referenceKind $
 855              CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_fun")))
 856 #endif
 857
 858         CmmReg (CmmGlobal mid)
 859            -- Replace register leaves with appropriate StixTrees for
 860            -- the given target.  MagicIds which map to a reg on this
 861            -- arch are left unchanged.  For the rest, BaseReg is taken
 862            -- to mean the address of the reg table in MainCapability,
 863            -- and for all others we generate an indirection to its
 864            -- location in the register table.
 865            -> case get_GlobalReg_reg_or_addr mid of
 866                  Left  realreg -> return expr
 867                  Right baseRegAddr
 868                     -> case mid of
 869                           BaseReg -> cmmExprConFold DataReference baseRegAddr
 870                           other   -> cmmExprConFold DataReference
 871                                         (CmmLoad baseRegAddr (globalRegType mid))
 872            -- eliminate zero offsets
 873         CmmRegOff reg 0
 874            -> cmmExprConFold referenceKind (CmmReg reg)
 875
 876         CmmRegOff (CmmGlobal mid) offset
 877            -- RegOf leaves are just a shorthand form. If the reg maps
 878            -- to a real reg, we keep the shorthand, otherwise, we just
 879            -- expand it and defer to the above code.
 880            -> case get_GlobalReg_reg_or_addr mid of
 881                 Left  realreg -> return expr
 882                 Right baseRegAddr
 883                    -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordWidth) [
 884                                         CmmReg (CmmGlobal mid),
 885                                         CmmLit (CmmInt (fromIntegral offset)
 886                                                        wordWidth)])
 887         other
 888            -> return other
 889
 890 -- -----------------------------------------------------------------------------
 891 -- Utils
 892
 893 bind f x = x $! f
 894
 895 \end{code}
 896