-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 1993-2004
--
-- This is the top-level module in the native code generator.
--
-- -----------------------------------------------------------------------------

{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms #-}

#if !defined(GHC_LOADED_INTO_GHCI)
{-# LANGUAGE UnboxedTuples #-}
#endif

module AsmCodeGen (
                    -- * Module entry point
                    nativeCodeGen

                    -- * Test-only exports: see trac #12744
                    -- used by testGraphNoSpills, which needs to access
                    -- the register allocator intermediate data structures
                    -- cmmNativeGen emits
                  , cmmNativeGen
                  , NcgImpl(..)
                  , x86NcgImpl
                  ) where

#include "HsVersions.h"
#include "nativeGen/NCG.h"


import GhcPrelude

import qualified X86.CodeGen
import qualified X86.Regs
import qualified X86.Instr
import qualified X86.Ppr

import qualified SPARC.CodeGen
import qualified SPARC.Regs
import qualified SPARC.Instr
import qualified SPARC.Ppr
import qualified SPARC.ShortcutJump
import qualified SPARC.CodeGen.Expand

import qualified PPC.CodeGen
import qualified PPC.Regs
import qualified PPC.RegInfo
import qualified PPC.Instr
import qualified PPC.Ppr

import RegAlloc.Liveness
import qualified RegAlloc.Linear.Main           as Linear

import qualified GraphColor                     as Color
import qualified RegAlloc.Graph.Main            as Color
import qualified RegAlloc.Graph.Stats           as Color
import qualified RegAlloc.Graph.TrivColorable   as Color

import AsmUtils
import TargetReg
import Platform
import BlockLayout
import Config
import Instruction
import PIC
import Reg
import NCGMonad
import CFG
import Dwarf
import Debug

import BlockId
import CgUtils          ( fixStgRegisters )
import Cmm
import CmmUtils
import Hoopl.Collections
import Hoopl.Label
import Hoopl.Block
import CmmOpt           ( cmmMachOpFold )
import PprCmm
import CLabel

import UniqFM
import UniqSupply
import DynFlags
import Util

import BasicTypes       ( Alignment )
import qualified Pretty
import BufWrite
import Outputable
import FastString
import UniqSet
import ErrUtils
import Module
import Stream (Stream)
import qualified Stream

-- DEBUGGING ONLY
--import OrdList

import Data.List
import Data.Maybe
import Data.Ord         ( comparing )
import Control.Exception
import Control.Monad
import System.IO

{-
The native-code generator has machine-independent and
machine-dependent modules.

This module ("AsmCodeGen") is the top-level machine-independent
module.  Before entering machine-dependent land, we do some
machine-independent optimisations (defined below) on the
'CmmStmts's.

We convert to the machine-specific 'Instr' datatype with
'cmmCodeGen', assuming an infinite supply of registers.  We then use
a machine-independent register allocator ('regAlloc') to rejoin
reality.  Obviously, 'regAlloc' has machine-specific helper
functions (see about "RegAllocInfo" below).

Finally, we order the basic blocks of the function so as to minimise
the number of jumps between blocks, by utilising fallthrough wherever
possible.

The machine-dependent bits break down as follows:

  * ["MachRegs"]  Everything about the target platform's machine
    registers (and immediate operands, and addresses, which tend to
    intermingle/interact with registers).

  * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should
    have a module of its own), plus a miscellany of other things
    (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)

  * ["MachCodeGen"]  is where 'Cmm' stuff turns into
    machine instructions.

  * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
    a 'SDoc').

  * ["RegAllocInfo"] In the register allocator, we manipulate
    'MRegsState's, which are 'BitSet's, one bit per machine register.
    When we want to say something about a specific machine register
    (e.g., ``it gets clobbered by this instruction''), we set/unset
    its bit.  Obviously, we do this 'BitSet' thing for efficiency
    reasons.

    The 'RegAllocInfo' module collects together the machine-specific
    info needed to do register allocation.

   * ["RegisterAlloc"] The (machine-independent) register allocator.
-}

--------------------
nativeCodeGen :: DynFlags -> Module -> ModLocation -> Handle -> UniqSupply
              -> Stream IO RawCmmGroup ()
              -> IO UniqSupply
nativeCodeGen :: DynFlags
-> Module
-> ModLocation
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> IO UniqSupply
nativeCodeGen dflags :: DynFlags
dflags this_mod :: Module
this_mod modLoc :: ModLocation
modLoc h :: Handle
h us :: UniqSupply
us cmms :: Stream IO RawCmmGroup ()
cmms
 = let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
       nCG' :: ( Outputable statics, Outputable instr
               , Outputable jumpDest, Instruction instr)
            => NcgImpl statics instr jumpDest -> IO UniqSupply
       nCG' :: NcgImpl statics instr jumpDest -> IO UniqSupply
nCG' ncgImpl :: NcgImpl statics instr jumpDest
ncgImpl = DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> IO UniqSupply
forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> IO UniqSupply
nativeCodeGen' DynFlags
dflags Module
this_mod ModLocation
modLoc NcgImpl statics instr jumpDest
ncgImpl Handle
h UniqSupply
us Stream IO RawCmmGroup ()
cmms
   in case Platform -> Arch
platformArch Platform
platform of
      ArchX86       -> NcgImpl (Alignment, CmmStatics) Instr JumpDest -> IO UniqSupply
forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO UniqSupply
nCG' (DynFlags -> NcgImpl (Alignment, CmmStatics) Instr JumpDest
x86NcgImpl    DynFlags
dflags)
      ArchX86_64    -> NcgImpl (Alignment, CmmStatics) Instr JumpDest -> IO UniqSupply
forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO UniqSupply
nCG' (DynFlags -> NcgImpl (Alignment, CmmStatics) Instr JumpDest
x86_64NcgImpl DynFlags
dflags)
      ArchPPC       -> NcgImpl CmmStatics Instr JumpDest -> IO UniqSupply
forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO UniqSupply
nCG' (DynFlags -> NcgImpl CmmStatics Instr JumpDest
ppcNcgImpl    DynFlags
dflags)
      ArchSPARC     -> NcgImpl CmmStatics Instr JumpDest -> IO UniqSupply
forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO UniqSupply
nCG' (DynFlags -> NcgImpl CmmStatics Instr JumpDest
sparcNcgImpl  DynFlags
dflags)
      ArchSPARC64   -> String -> IO UniqSupply
forall a. String -> a
panic "nativeCodeGen: No NCG for SPARC64"
      ArchARM {}    -> String -> IO UniqSupply
forall a. String -> a
panic "nativeCodeGen: No NCG for ARM"
      ArchARM64     -> String -> IO UniqSupply
forall a. String -> a
panic "nativeCodeGen: No NCG for ARM64"
      ArchPPC_64 _  -> NcgImpl CmmStatics Instr JumpDest -> IO UniqSupply
forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO UniqSupply
nCG' (DynFlags -> NcgImpl CmmStatics Instr JumpDest
ppcNcgImpl    DynFlags
dflags)
      ArchAlpha     -> String -> IO UniqSupply
forall a. String -> a
panic "nativeCodeGen: No NCG for Alpha"
      ArchMipseb    -> String -> IO UniqSupply
forall a. String -> a
panic "nativeCodeGen: No NCG for mipseb"
      ArchMipsel    -> String -> IO UniqSupply
forall a. String -> a
panic "nativeCodeGen: No NCG for mipsel"
      ArchUnknown   -> String -> IO UniqSupply
forall a. String -> a
panic "nativeCodeGen: No NCG for unknown arch"
      ArchJavaScript-> String -> IO UniqSupply
forall a. String -> a
panic "nativeCodeGen: No NCG for JavaScript"

x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics)
                                  X86.Instr.Instr X86.Instr.JumpDest
x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) Instr JumpDest
x86NcgImpl dflags :: DynFlags
dflags
 = (DynFlags -> NcgImpl (Alignment, CmmStatics) Instr JumpDest
x86_64NcgImpl DynFlags
dflags) { ncg_x86fp_kludge :: [NatCmmDecl (Alignment, CmmStatics) Instr]
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
ncg_x86fp_kludge = (NatCmmDecl (Alignment, CmmStatics) Instr
 -> NatCmmDecl (Alignment, CmmStatics) Instr)
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
forall a b. (a -> b) -> [a] -> [b]
map NatCmmDecl (Alignment, CmmStatics) Instr
-> NatCmmDecl (Alignment, CmmStatics) Instr
x86fp_kludge }

x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics)
                                  X86.Instr.Instr X86.Instr.JumpDest
x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) Instr JumpDest
x86_64NcgImpl dflags :: DynFlags
dflags
 = NcgImpl :: forall statics instr jumpDest.
(RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> (instr -> Maybe (NatCmmDecl statics instr))
-> (jumpDest -> Maybe BlockId)
-> (instr -> Maybe jumpDest)
-> ((BlockId -> Maybe jumpDest) -> statics -> statics)
-> ((BlockId -> Maybe jumpDest) -> instr -> instr)
-> (NatCmmDecl statics instr -> SDoc)
-> Alignment
-> [RealReg]
-> ([NatCmmDecl statics instr] -> [NatCmmDecl statics instr])
-> ([NatCmmDecl statics instr] -> [NatCmmDecl statics instr])
-> (Alignment
    -> NatCmmDecl statics instr
    -> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)]))
-> (LabelMap CmmStatics
    -> [NatBasicBlock instr] -> [NatBasicBlock instr])
-> ([instr] -> [UnwindPoint])
-> (Maybe CFG
    -> LabelMap CmmStatics
    -> [NatBasicBlock instr]
    -> [NatBasicBlock instr])
-> NcgImpl statics instr jumpDest
NcgImpl {
        cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
cmmTopCodeGen             = RawCmmDecl -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
X86.CodeGen.cmmTopCodeGen
       ,generateJumpTableForInstr :: Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)
generateJumpTableForInstr = DynFlags
-> Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)
X86.CodeGen.generateJumpTableForInstr DynFlags
dflags
       ,getJumpDestBlockId :: JumpDest -> Maybe BlockId
getJumpDestBlockId        = JumpDest -> Maybe BlockId
X86.Instr.getJumpDestBlockId
       ,canShortcut :: Instr -> Maybe JumpDest
canShortcut               = Instr -> Maybe JumpDest
X86.Instr.canShortcut
       ,shortcutStatics :: (BlockId -> Maybe JumpDest)
-> (Alignment, CmmStatics) -> (Alignment, CmmStatics)
shortcutStatics           = (BlockId -> Maybe JumpDest)
-> (Alignment, CmmStatics) -> (Alignment, CmmStatics)
X86.Instr.shortcutStatics
       ,shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
shortcutJump              = (BlockId -> Maybe JumpDest) -> Instr -> Instr
X86.Instr.shortcutJump
       ,pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc
pprNatCmmDecl             = NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc
X86.Ppr.pprNatCmmDecl
       ,maxSpillSlots :: Alignment
maxSpillSlots             = DynFlags -> Alignment
X86.Instr.maxSpillSlots DynFlags
dflags
       ,allocatableRegs :: [RealReg]
allocatableRegs           = Platform -> [RealReg]
X86.Regs.allocatableRegs Platform
platform
       ,ncg_x86fp_kludge :: [NatCmmDecl (Alignment, CmmStatics) Instr]
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
ncg_x86fp_kludge          = [NatCmmDecl (Alignment, CmmStatics) Instr]
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
forall a. a -> a
id
       ,ncgAllocMoreStack :: Alignment
-> NatCmmDecl (Alignment, CmmStatics) Instr
-> UniqSM
     (NatCmmDecl (Alignment, CmmStatics) Instr, [(BlockId, BlockId)])
ncgAllocMoreStack         = Platform
-> Alignment
-> NatCmmDecl (Alignment, CmmStatics) Instr
-> UniqSM
     (NatCmmDecl (Alignment, CmmStatics) Instr, [(BlockId, BlockId)])
forall statics.
Platform
-> Alignment
-> NatCmmDecl statics Instr
-> UniqSM (NatCmmDecl statics Instr, [(BlockId, BlockId)])
X86.Instr.allocMoreStack Platform
platform
       ,ncgExpandTop :: [NatCmmDecl (Alignment, CmmStatics) Instr]
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
ncgExpandTop              = [NatCmmDecl (Alignment, CmmStatics) Instr]
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
forall a. a -> a
id
       ,ncgMakeFarBranches :: LabelMap CmmStatics
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
ncgMakeFarBranches        = ([NatBasicBlock Instr] -> [NatBasicBlock Instr])
-> LabelMap CmmStatics
-> [NatBasicBlock Instr]
-> [NatBasicBlock Instr]
forall a b. a -> b -> a
const [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> a
id
       ,extractUnwindPoints :: [Instr] -> [UnwindPoint]
extractUnwindPoints       = [Instr] -> [UnwindPoint]
X86.CodeGen.extractUnwindPoints
       ,invertCondBranches :: Maybe CFG
-> LabelMap CmmStatics
-> [NatBasicBlock Instr]
-> [NatBasicBlock Instr]
invertCondBranches        = Maybe CFG
-> LabelMap CmmStatics
-> [NatBasicBlock Instr]
-> [NatBasicBlock Instr]
forall a.
Maybe CFG
-> LabelMap a -> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
X86.CodeGen.invertCondBranches
   }
    where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

ppcNcgImpl :: DynFlags -> NcgImpl CmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest
ppcNcgImpl :: DynFlags -> NcgImpl CmmStatics Instr JumpDest
ppcNcgImpl dflags :: DynFlags
dflags
 = NcgImpl :: forall statics instr jumpDest.
(RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> (instr -> Maybe (NatCmmDecl statics instr))
-> (jumpDest -> Maybe BlockId)
-> (instr -> Maybe jumpDest)
-> ((BlockId -> Maybe jumpDest) -> statics -> statics)
-> ((BlockId -> Maybe jumpDest) -> instr -> instr)
-> (NatCmmDecl statics instr -> SDoc)
-> Alignment
-> [RealReg]
-> ([NatCmmDecl statics instr] -> [NatCmmDecl statics instr])
-> ([NatCmmDecl statics instr] -> [NatCmmDecl statics instr])
-> (Alignment
    -> NatCmmDecl statics instr
    -> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)]))
-> (LabelMap CmmStatics
    -> [NatBasicBlock instr] -> [NatBasicBlock instr])
-> ([instr] -> [UnwindPoint])
-> (Maybe CFG
    -> LabelMap CmmStatics
    -> [NatBasicBlock instr]
    -> [NatBasicBlock instr])
-> NcgImpl statics instr jumpDest
NcgImpl {
        cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr]
cmmTopCodeGen             = RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr]
PPC.CodeGen.cmmTopCodeGen
       ,generateJumpTableForInstr :: Instr -> Maybe (NatCmmDecl CmmStatics Instr)
generateJumpTableForInstr = DynFlags -> Instr -> Maybe (NatCmmDecl CmmStatics Instr)
PPC.CodeGen.generateJumpTableForInstr DynFlags
dflags
       ,getJumpDestBlockId :: JumpDest -> Maybe BlockId
getJumpDestBlockId        = JumpDest -> Maybe BlockId
PPC.RegInfo.getJumpDestBlockId
       ,canShortcut :: Instr -> Maybe JumpDest
canShortcut               = Instr -> Maybe JumpDest
PPC.RegInfo.canShortcut
       ,shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics
shortcutStatics           = (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics
PPC.RegInfo.shortcutStatics
       ,shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
shortcutJump              = (BlockId -> Maybe JumpDest) -> Instr -> Instr
PPC.RegInfo.shortcutJump
       ,pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
pprNatCmmDecl             = NatCmmDecl CmmStatics Instr -> SDoc
PPC.Ppr.pprNatCmmDecl
       ,maxSpillSlots :: Alignment
maxSpillSlots             = DynFlags -> Alignment
PPC.Instr.maxSpillSlots DynFlags
dflags
       ,allocatableRegs :: [RealReg]
allocatableRegs           = Platform -> [RealReg]
PPC.Regs.allocatableRegs Platform
platform
       ,ncg_x86fp_kludge :: [NatCmmDecl CmmStatics Instr] -> [NatCmmDecl CmmStatics Instr]
ncg_x86fp_kludge          = [NatCmmDecl CmmStatics Instr] -> [NatCmmDecl CmmStatics Instr]
forall a. a -> a
id
       ,ncgAllocMoreStack :: Alignment
-> NatCmmDecl CmmStatics Instr
-> UniqSM (NatCmmDecl CmmStatics Instr, [(BlockId, BlockId)])
ncgAllocMoreStack         = Platform
-> Alignment
-> NatCmmDecl CmmStatics Instr
-> UniqSM (NatCmmDecl CmmStatics Instr, [(BlockId, BlockId)])
forall statics.
Platform
-> Alignment
-> NatCmmDecl statics Instr
-> UniqSM (NatCmmDecl statics Instr, [(BlockId, BlockId)])
PPC.Instr.allocMoreStack Platform
platform
       ,ncgExpandTop :: [NatCmmDecl CmmStatics Instr] -> [NatCmmDecl CmmStatics Instr]
ncgExpandTop              = [NatCmmDecl CmmStatics Instr] -> [NatCmmDecl CmmStatics Instr]
forall a. a -> a
id
       ,ncgMakeFarBranches :: LabelMap CmmStatics
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
ncgMakeFarBranches        = LabelMap CmmStatics
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
PPC.Instr.makeFarBranches
       ,extractUnwindPoints :: [Instr] -> [UnwindPoint]
extractUnwindPoints       = [UnwindPoint] -> [Instr] -> [UnwindPoint]
forall a b. a -> b -> a
const []
       ,invertCondBranches :: Maybe CFG
-> LabelMap CmmStatics
-> [NatBasicBlock Instr]
-> [NatBasicBlock Instr]
invertCondBranches        = \_ _ -> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> a
id
   }
    where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

sparcNcgImpl :: DynFlags -> NcgImpl CmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest
sparcNcgImpl :: DynFlags -> NcgImpl CmmStatics Instr JumpDest
sparcNcgImpl dflags :: DynFlags
dflags
 = NcgImpl :: forall statics instr jumpDest.
(RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> (instr -> Maybe (NatCmmDecl statics instr))
-> (jumpDest -> Maybe BlockId)
-> (instr -> Maybe jumpDest)
-> ((BlockId -> Maybe jumpDest) -> statics -> statics)
-> ((BlockId -> Maybe jumpDest) -> instr -> instr)
-> (NatCmmDecl statics instr -> SDoc)
-> Alignment
-> [RealReg]
-> ([NatCmmDecl statics instr] -> [NatCmmDecl statics instr])
-> ([NatCmmDecl statics instr] -> [NatCmmDecl statics instr])
-> (Alignment
    -> NatCmmDecl statics instr
    -> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)]))
-> (LabelMap CmmStatics
    -> [NatBasicBlock instr] -> [NatBasicBlock instr])
-> ([instr] -> [UnwindPoint])
-> (Maybe CFG
    -> LabelMap CmmStatics
    -> [NatBasicBlock instr]
    -> [NatBasicBlock instr])
-> NcgImpl statics instr jumpDest
NcgImpl {
        cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr]
cmmTopCodeGen             = RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr]
SPARC.CodeGen.cmmTopCodeGen
       ,generateJumpTableForInstr :: Instr -> Maybe (NatCmmDecl CmmStatics Instr)
generateJumpTableForInstr = DynFlags -> Instr -> Maybe (NatCmmDecl CmmStatics Instr)
SPARC.CodeGen.generateJumpTableForInstr DynFlags
dflags
       ,getJumpDestBlockId :: JumpDest -> Maybe BlockId
getJumpDestBlockId        = JumpDest -> Maybe BlockId
SPARC.ShortcutJump.getJumpDestBlockId
       ,canShortcut :: Instr -> Maybe JumpDest
canShortcut               = Instr -> Maybe JumpDest
SPARC.ShortcutJump.canShortcut
       ,shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics
shortcutStatics           = (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics
SPARC.ShortcutJump.shortcutStatics
       ,shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
shortcutJump              = (BlockId -> Maybe JumpDest) -> Instr -> Instr
SPARC.ShortcutJump.shortcutJump
       ,pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
pprNatCmmDecl             = NatCmmDecl CmmStatics Instr -> SDoc
SPARC.Ppr.pprNatCmmDecl
       ,maxSpillSlots :: Alignment
maxSpillSlots             = DynFlags -> Alignment
SPARC.Instr.maxSpillSlots DynFlags
dflags
       ,allocatableRegs :: [RealReg]
allocatableRegs           = [RealReg]
SPARC.Regs.allocatableRegs
       ,ncg_x86fp_kludge :: [NatCmmDecl CmmStatics Instr] -> [NatCmmDecl CmmStatics Instr]
ncg_x86fp_kludge          = [NatCmmDecl CmmStatics Instr] -> [NatCmmDecl CmmStatics Instr]
forall a. a -> a
id
       ,ncgAllocMoreStack :: Alignment
-> NatCmmDecl CmmStatics Instr
-> UniqSM (NatCmmDecl CmmStatics Instr, [(BlockId, BlockId)])
ncgAllocMoreStack         = Alignment
-> NatCmmDecl CmmStatics Instr
-> UniqSM (NatCmmDecl CmmStatics Instr, [(BlockId, BlockId)])
forall statics instr.
Alignment
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
noAllocMoreStack
       ,ncgExpandTop :: [NatCmmDecl CmmStatics Instr] -> [NatCmmDecl CmmStatics Instr]
ncgExpandTop              = (NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr)
-> [NatCmmDecl CmmStatics Instr] -> [NatCmmDecl CmmStatics Instr]
forall a b. (a -> b) -> [a] -> [b]
map NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr
SPARC.CodeGen.Expand.expandTop
       ,ncgMakeFarBranches :: LabelMap CmmStatics
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
ncgMakeFarBranches        = ([NatBasicBlock Instr] -> [NatBasicBlock Instr])
-> LabelMap CmmStatics
-> [NatBasicBlock Instr]
-> [NatBasicBlock Instr]
forall a b. a -> b -> a
const [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> a
id
       ,extractUnwindPoints :: [Instr] -> [UnwindPoint]
extractUnwindPoints       = [UnwindPoint] -> [Instr] -> [UnwindPoint]
forall a b. a -> b -> a
const []
       ,invertCondBranches :: Maybe CFG
-> LabelMap CmmStatics
-> [NatBasicBlock Instr]
-> [NatBasicBlock Instr]
invertCondBranches        = \_ _ -> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> a
id
   }

--
-- Allocating more stack space for spilling is currently only
-- supported for the linear register allocator on x86/x86_64, the rest
-- default to the panic below.  To support allocating extra stack on
-- more platforms provide a definition of ncgAllocMoreStack.
--
noAllocMoreStack :: Int -> NatCmmDecl statics instr
                 -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)])
noAllocMoreStack :: Alignment
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
noAllocMoreStack amount :: Alignment
amount _
  = String -> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
forall a. String -> a
panic (String -> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)]))
-> String
-> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
forall a b. (a -> b) -> a -> b
$   "Register allocator: out of stack slots (need " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Alignment -> String
forall a. Show a => a -> String
show Alignment
amount String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++  "   If you are trying to compile SHA1.hs from the crypto library then this\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++  "   is a known limitation in the linear allocator.\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++  "\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++  "   Try enabling the graph colouring allocator with -fregs-graph instead."
        String -> String -> String
forall a. [a] -> [a] -> [a]
++  "   You can still file a bug report if you like.\n"


-- | Data accumulated during code generation. Mostly about statistics,
-- but also collects debug data for DWARF generation.
data NativeGenAcc statics instr
  = NGS { NativeGenAcc statics instr -> [[CLabel]]
ngs_imports     :: ![[CLabel]]
        , NativeGenAcc statics instr -> [[NatCmmDecl statics instr]]
ngs_natives     :: ![[NatCmmDecl statics instr]]
             -- ^ Native code generated, for statistics. This might
             -- hold a lot of data, so it is important to clear this
             -- field as early as possible if it isn't actually
             -- required.
        , NativeGenAcc statics instr -> [[RegAllocStats statics instr]]
ngs_colorStats  :: ![[Color.RegAllocStats statics instr]]
        , NativeGenAcc statics instr -> [[RegAllocStats]]
ngs_linearStats :: ![[Linear.RegAllocStats]]
        , NativeGenAcc statics instr -> [BlockId]
ngs_labels      :: ![Label]
        , NativeGenAcc statics instr -> [DebugBlock]
ngs_debug       :: ![DebugBlock]
        , NativeGenAcc statics instr -> DwarfFiles
ngs_dwarfFiles  :: !DwarfFiles
        , NativeGenAcc statics instr -> LabelMap [UnwindPoint]
ngs_unwinds     :: !(LabelMap [UnwindPoint])
             -- ^ see Note [Unwinding information in the NCG]
             -- and Note [What is this unwinding business?] in Debug.
        }

{-
Note [Unwinding information in the NCG]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Unwind information is a type of metadata which allows a debugging tool
to reconstruct the values of machine registers at the time a procedure was
entered. For the most part, the production of unwind information is handled by
the Cmm stage, where it is represented by CmmUnwind nodes.

Unfortunately, the Cmm stage doesn't know everything necessary to produce
accurate unwinding information. For instance, the x86-64 calling convention
requires that the stack pointer be aligned to 16 bytes, which in turn means that
GHC must sometimes add padding to $sp prior to performing a foreign call. When
this happens unwind information must be updated accordingly.
For this reason, we make the NCG backends responsible for producing
unwinding tables (with the extractUnwindPoints function in NcgImpl).

We accumulate the produced unwind tables over CmmGroups in the ngs_unwinds
field of NativeGenAcc. This is a label map which contains an entry for each
procedure, containing a list of unwinding points (e.g. a label and an associated
unwinding table).

See also Note [What is this unwinding business?] in Debug.
-}

nativeCodeGen' :: (Outputable statics, Outputable instr,Outputable jumpDest,
                   Instruction instr)
               => DynFlags
               -> Module -> ModLocation
               -> NcgImpl statics instr jumpDest
               -> Handle
               -> UniqSupply
               -> Stream IO RawCmmGroup ()
               -> IO UniqSupply
nativeCodeGen' :: DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> IO UniqSupply
nativeCodeGen' dflags :: DynFlags
dflags this_mod :: Module
this_mod modLoc :: ModLocation
modLoc ncgImpl :: NcgImpl statics instr jumpDest
ncgImpl h :: Handle
h us :: UniqSupply
us cmms :: Stream IO RawCmmGroup ()
cmms
 = do
        -- BufHandle is a performance hack.  We could hide it inside
        -- Pretty if it weren't for the fact that we do lots of little
        -- printDocs here (in order to do codegen in constant space).
        BufHandle
bufh <- Handle -> IO BufHandle
newBufHandle Handle
h
        let ngs0 :: NativeGenAcc statics instr
ngs0 = [[CLabel]]
-> [[NatCmmDecl statics instr]]
-> [[RegAllocStats statics instr]]
-> [[RegAllocStats]]
-> [BlockId]
-> [DebugBlock]
-> DwarfFiles
-> LabelMap [UnwindPoint]
-> NativeGenAcc statics instr
forall statics instr.
[[CLabel]]
-> [[NatCmmDecl statics instr]]
-> [[RegAllocStats statics instr]]
-> [[RegAllocStats]]
-> [BlockId]
-> [DebugBlock]
-> DwarfFiles
-> LabelMap [UnwindPoint]
-> NativeGenAcc statics instr
NGS [] [] [] [] [] [] DwarfFiles
forall elt. UniqFM elt
emptyUFM LabelMap [UnwindPoint]
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
        (ngs :: NativeGenAcc statics instr
ngs, us' :: UniqSupply
us') <- DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply)
forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGenStream DynFlags
dflags Module
this_mod ModLocation
modLoc NcgImpl statics instr jumpDest
ncgImpl BufHandle
bufh UniqSupply
us
                                         Stream IO RawCmmGroup ()
cmms NativeGenAcc statics instr
forall statics instr. NativeGenAcc statics instr
ngs0
        DynFlags
-> ModLocation
-> BufHandle
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
forall instr statics.
Instruction instr =>
DynFlags
-> ModLocation
-> BufHandle
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
finishNativeGen DynFlags
dflags ModLocation
modLoc BufHandle
bufh UniqSupply
us' NativeGenAcc statics instr
ngs

finishNativeGen :: Instruction instr
                => DynFlags
                -> ModLocation
                -> BufHandle
                -> UniqSupply
                -> NativeGenAcc statics instr
                -> IO UniqSupply
finishNativeGen :: DynFlags
-> ModLocation
-> BufHandle
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
finishNativeGen dflags :: DynFlags
dflags modLoc :: ModLocation
modLoc bufh :: BufHandle
bufh@(BufHandle _ _ h :: Handle
h) us :: UniqSupply
us ngs :: NativeGenAcc statics instr
ngs
 = do
        -- Write debug data and finish
        let emitDw :: Bool
emitDw = DynFlags -> Alignment
debugLevel DynFlags
dflags Alignment -> Alignment -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SplitObjs DynFlags
dflags)
        UniqSupply
us' <- if Bool -> Bool
not Bool
emitDw then UniqSupply -> IO UniqSupply
forall (m :: * -> *) a. Monad m => a -> m a
return UniqSupply
us else do
          (dwarf :: SDoc
dwarf, us' :: UniqSupply
us') <- DynFlags
-> ModLocation
-> UniqSupply
-> [DebugBlock]
-> IO (SDoc, UniqSupply)
dwarfGen DynFlags
dflags ModLocation
modLoc UniqSupply
us (NativeGenAcc statics instr -> [DebugBlock]
forall statics instr. NativeGenAcc statics instr -> [DebugBlock]
ngs_debug NativeGenAcc statics instr
ngs)
          DynFlags -> BufHandle -> SDoc -> IO ()
emitNativeCode DynFlags
dflags BufHandle
bufh SDoc
dwarf
          UniqSupply -> IO UniqSupply
forall (m :: * -> *) a. Monad m => a -> m a
return UniqSupply
us'
        BufHandle -> IO ()
bFlush BufHandle
bufh

        -- dump global NCG stats for graph coloring allocator
        let stats :: [RegAllocStats statics instr]
stats = [[RegAllocStats statics instr]] -> [RegAllocStats statics instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (NativeGenAcc statics instr -> [[RegAllocStats statics instr]]
forall statics instr.
NativeGenAcc statics instr -> [[RegAllocStats statics instr]]
ngs_colorStats NativeGenAcc statics instr
ngs)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([RegAllocStats statics instr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RegAllocStats statics instr]
stats)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do

          -- build the global register conflict graph
          let graphGlobal :: Graph VirtualReg RegClass RealReg
graphGlobal
                  = (Graph VirtualReg RegClass RealReg
 -> Graph VirtualReg RegClass RealReg
 -> Graph VirtualReg RegClass RealReg)
-> Graph VirtualReg RegClass RealReg
-> [Graph VirtualReg RegClass RealReg]
-> Graph VirtualReg RegClass RealReg
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
forall k cls color.
Graph k cls color -> Graph k cls color -> Graph k cls color
Color.union Graph VirtualReg RegClass RealReg
forall k cls color. Graph k cls color
Color.initGraph
                  ([Graph VirtualReg RegClass RealReg]
 -> Graph VirtualReg RegClass RealReg)
-> [Graph VirtualReg RegClass RealReg]
-> Graph VirtualReg RegClass RealReg
forall a b. (a -> b) -> a -> b
$ [ RegAllocStats statics instr -> Graph VirtualReg RegClass RealReg
forall statics instr.
RegAllocStats statics instr -> Graph VirtualReg RegClass RealReg
Color.raGraph RegAllocStats statics instr
stat
                          | stat :: RegAllocStats statics instr
stat@Color.RegAllocStatsStart{} <- [RegAllocStats statics instr]
stats]

          SDoc -> IO ()
dump_stats ([RegAllocStats statics instr]
-> Graph VirtualReg RegClass RealReg -> SDoc
forall statics instr.
[RegAllocStats statics instr]
-> Graph VirtualReg RegClass RealReg -> SDoc
Color.pprStats [RegAllocStats statics instr]
stats Graph VirtualReg RegClass RealReg
graphGlobal)

          let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
          DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                  DumpFlag
Opt_D_dump_asm_conflicts "Register conflict graph"
                  (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ (RealReg -> SDoc)
-> Triv VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
-> SDoc
forall k cls color.
(Uniquable k, Outputable k, Outputable cls, Outputable color) =>
(color -> SDoc) -> Triv k cls color -> Graph k cls color -> SDoc
Color.dotGraph
                          (Platform -> RealReg -> SDoc
targetRegDotColor Platform
platform)
                          (Platform
-> (RegClass -> VirtualReg -> Alignment)
-> (RegClass -> RealReg -> Alignment)
-> Triv VirtualReg RegClass RealReg
Color.trivColorable Platform
platform
                                  (Platform -> RegClass -> VirtualReg -> Alignment
targetVirtualRegSqueeze Platform
platform)
                                  (Platform -> RegClass -> RealReg -> Alignment
targetRealRegSqueeze Platform
platform))
                  (Graph VirtualReg RegClass RealReg -> SDoc)
-> Graph VirtualReg RegClass RealReg -> SDoc
forall a b. (a -> b) -> a -> b
$ Graph VirtualReg RegClass RealReg
graphGlobal


        -- dump global NCG stats for linear allocator
        let linearStats :: [RegAllocStats]
linearStats = [[RegAllocStats]] -> [RegAllocStats]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (NativeGenAcc statics instr -> [[RegAllocStats]]
forall statics instr.
NativeGenAcc statics instr -> [[RegAllocStats]]
ngs_linearStats NativeGenAcc statics instr
ngs)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([RegAllocStats] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RegAllocStats]
linearStats)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          SDoc -> IO ()
dump_stats ([NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc
forall instr statics.
Instruction instr =>
[NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc
Linear.pprStats ([[NatCmmDecl statics instr]] -> [NatCmmDecl statics instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (NativeGenAcc statics instr -> [[NatCmmDecl statics instr]]
forall statics instr.
NativeGenAcc statics instr -> [[NatCmmDecl statics instr]]
ngs_natives NativeGenAcc statics instr
ngs)) [RegAllocStats]
linearStats)

        -- write out the imports
        Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO ()
printSDocLn Mode
Pretty.LeftMode DynFlags
dflags Handle
h (CodeStyle -> PprStyle
mkCodeStyle CodeStyle
AsmStyle)
                (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [CLabel] -> SDoc
makeImportsDoc DynFlags
dflags ([[CLabel]] -> [CLabel]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (NativeGenAcc statics instr -> [[CLabel]]
forall statics instr. NativeGenAcc statics instr -> [[CLabel]]
ngs_imports NativeGenAcc statics instr
ngs))
        UniqSupply -> IO UniqSupply
forall (m :: * -> *) a. Monad m => a -> m a
return UniqSupply
us'
  where
    dump_stats :: SDoc -> IO ()
dump_stats = DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
dumpSDoc DynFlags
dflags PrintUnqualified
alwaysQualify DumpFlag
Opt_D_dump_asm_stats "NCG stats"

cmmNativeGenStream :: (Outputable statics, Outputable instr
                      ,Outputable jumpDest, Instruction instr)
              => DynFlags
              -> Module -> ModLocation
              -> NcgImpl statics instr jumpDest
              -> BufHandle
              -> UniqSupply
              -> Stream IO RawCmmGroup ()
              -> NativeGenAcc statics instr
              -> IO (NativeGenAcc statics instr, UniqSupply)

cmmNativeGenStream :: DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGenStream dflags :: DynFlags
dflags this_mod :: Module
this_mod modLoc :: ModLocation
modLoc ncgImpl :: NcgImpl statics instr jumpDest
ncgImpl h :: BufHandle
h us :: UniqSupply
us cmm_stream :: Stream IO RawCmmGroup ()
cmm_stream ngs :: NativeGenAcc statics instr
ngs
 = do Either () (RawCmmGroup, Stream IO RawCmmGroup ())
r <- Stream IO RawCmmGroup ()
-> IO (Either () (RawCmmGroup, Stream IO RawCmmGroup ()))
forall (m :: * -> *) a b.
Stream m a b -> m (Either b (a, Stream m a b))
Stream.runStream Stream IO RawCmmGroup ()
cmm_stream
      case Either () (RawCmmGroup, Stream IO RawCmmGroup ())
r of
        Left () ->
          (NativeGenAcc statics instr, UniqSupply)
-> IO (NativeGenAcc statics instr, UniqSupply)
forall (m :: * -> *) a. Monad m => a -> m a
return (NativeGenAcc statics instr
ngs { ngs_imports :: [[CLabel]]
ngs_imports = [[CLabel]] -> [[CLabel]]
forall a. [a] -> [a]
reverse ([[CLabel]] -> [[CLabel]]) -> [[CLabel]] -> [[CLabel]]
forall a b. (a -> b) -> a -> b
$ NativeGenAcc statics instr -> [[CLabel]]
forall statics instr. NativeGenAcc statics instr -> [[CLabel]]
ngs_imports NativeGenAcc statics instr
ngs
                      , ngs_natives :: [[NatCmmDecl statics instr]]
ngs_natives = [[NatCmmDecl statics instr]] -> [[NatCmmDecl statics instr]]
forall a. [a] -> [a]
reverse ([[NatCmmDecl statics instr]] -> [[NatCmmDecl statics instr]])
-> [[NatCmmDecl statics instr]] -> [[NatCmmDecl statics instr]]
forall a b. (a -> b) -> a -> b
$ NativeGenAcc statics instr -> [[NatCmmDecl statics instr]]
forall statics instr.
NativeGenAcc statics instr -> [[NatCmmDecl statics instr]]
ngs_natives NativeGenAcc statics instr
ngs
                      , ngs_colorStats :: [[RegAllocStats statics instr]]
ngs_colorStats = [[RegAllocStats statics instr]] -> [[RegAllocStats statics instr]]
forall a. [a] -> [a]
reverse ([[RegAllocStats statics instr]]
 -> [[RegAllocStats statics instr]])
-> [[RegAllocStats statics instr]]
-> [[RegAllocStats statics instr]]
forall a b. (a -> b) -> a -> b
$ NativeGenAcc statics instr -> [[RegAllocStats statics instr]]
forall statics instr.
NativeGenAcc statics instr -> [[RegAllocStats statics instr]]
ngs_colorStats NativeGenAcc statics instr
ngs
                      , ngs_linearStats :: [[RegAllocStats]]
ngs_linearStats = [[RegAllocStats]] -> [[RegAllocStats]]
forall a. [a] -> [a]
reverse ([[RegAllocStats]] -> [[RegAllocStats]])
-> [[RegAllocStats]] -> [[RegAllocStats]]
forall a b. (a -> b) -> a -> b
$ NativeGenAcc statics instr -> [[RegAllocStats]]
forall statics instr.
NativeGenAcc statics instr -> [[RegAllocStats]]
ngs_linearStats NativeGenAcc statics instr
ngs
                      },
                  UniqSupply
us)
        Right (cmms :: RawCmmGroup
cmms, cmm_stream' :: Stream IO RawCmmGroup ()
cmm_stream') -> do

          -- Generate debug information
          let debugFlag :: Bool
debugFlag = DynFlags -> Alignment
debugLevel DynFlags
dflags Alignment -> Alignment -> Bool
forall a. Ord a => a -> a -> Bool
> 0
              !ndbgs :: [DebugBlock]
ndbgs | Bool
debugFlag = ModLocation -> RawCmmGroup -> [DebugBlock]
cmmDebugGen ModLocation
modLoc RawCmmGroup
cmms
                     | Bool
otherwise = []
              dbgMap :: LabelMap DebugBlock
dbgMap = [DebugBlock] -> LabelMap DebugBlock
debugToMap [DebugBlock]
ndbgs

          -- Insert split marker, generate native code
          let splitObjs :: Bool
splitObjs = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SplitObjs DynFlags
dflags
              split_marker :: GenCmmDecl d (LabelMap a) CmmGraph
split_marker = LabelMap a
-> CLabel
-> [GlobalReg]
-> CmmGraph
-> GenCmmDecl d (LabelMap a) CmmGraph
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap a
forall (map :: * -> *) a. IsMap map => map a
mapEmpty CLabel
mkSplitMarkerLabel [] (CmmGraph -> GenCmmDecl d (LabelMap a) CmmGraph)
-> CmmGraph -> GenCmmDecl d (LabelMap a) CmmGraph
forall a b. (a -> b) -> a -> b
$
                             BlockId -> [CmmBlock] -> CmmGraph
ofBlockList (String -> BlockId
forall a. String -> a
panic "split_marker_entry") []
              cmms' :: RawCmmGroup
cmms' | Bool
splitObjs  = RawCmmDecl
forall d a. GenCmmDecl d (LabelMap a) CmmGraph
split_marker RawCmmDecl -> RawCmmGroup -> RawCmmGroup
forall a. a -> [a] -> [a]
: RawCmmGroup
cmms
                    | Bool
otherwise  = RawCmmGroup
cmms
          (ngs' :: NativeGenAcc statics instr
ngs',us' :: UniqSupply
us') <- DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> LabelMap DebugBlock
-> UniqSupply
-> RawCmmGroup
-> NativeGenAcc statics instr
-> Alignment
-> IO (NativeGenAcc statics instr, UniqSupply)
forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> LabelMap DebugBlock
-> UniqSupply
-> RawCmmGroup
-> NativeGenAcc statics instr
-> Alignment
-> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGens DynFlags
dflags Module
this_mod ModLocation
modLoc NcgImpl statics instr jumpDest
ncgImpl BufHandle
h
                                             LabelMap DebugBlock
dbgMap UniqSupply
us RawCmmGroup
cmms' NativeGenAcc statics instr
ngs 0

          -- Link native code information into debug blocks
          -- See Note [What is this unwinding business?] in Debug.
          let !ldbgs :: [DebugBlock]
ldbgs = [BlockId] -> LabelMap [UnwindPoint] -> [DebugBlock] -> [DebugBlock]
cmmDebugLink (NativeGenAcc statics instr -> [BlockId]
forall statics instr. NativeGenAcc statics instr -> [BlockId]
ngs_labels NativeGenAcc statics instr
ngs') (NativeGenAcc statics instr -> LabelMap [UnwindPoint]
forall statics instr.
NativeGenAcc statics instr -> LabelMap [UnwindPoint]
ngs_unwinds NativeGenAcc statics instr
ngs') [DebugBlock]
ndbgs
          DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_debug "Debug Infos"
            ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (DebugBlock -> SDoc) -> [DebugBlock] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map DebugBlock -> SDoc
forall a. Outputable a => a -> SDoc
ppr [DebugBlock]
ldbgs)

          -- Emit & clear DWARF information when generating split
          -- object files, as we need it to land in the same object file
          -- When using split sections, note that we do not split the debug
          -- info but emit all the info at once in finishNativeGen.
          (ngs'' :: NativeGenAcc statics instr
ngs'', us'' :: UniqSupply
us'') <-
            if Bool
debugFlag Bool -> Bool -> Bool
&& Bool
splitObjs
            then do (dwarf :: SDoc
dwarf, us'' :: UniqSupply
us'') <- DynFlags
-> ModLocation
-> UniqSupply
-> [DebugBlock]
-> IO (SDoc, UniqSupply)
dwarfGen DynFlags
dflags ModLocation
modLoc UniqSupply
us [DebugBlock]
ldbgs
                    DynFlags -> BufHandle -> SDoc -> IO ()
emitNativeCode DynFlags
dflags BufHandle
h SDoc
dwarf
                    (NativeGenAcc statics instr, UniqSupply)
-> IO (NativeGenAcc statics instr, UniqSupply)
forall (m :: * -> *) a. Monad m => a -> m a
return (NativeGenAcc statics instr
ngs' { ngs_debug :: [DebugBlock]
ngs_debug = []
                                 , ngs_dwarfFiles :: DwarfFiles
ngs_dwarfFiles = DwarfFiles
forall elt. UniqFM elt
emptyUFM
                                 , ngs_labels :: [BlockId]
ngs_labels = [] },
                            UniqSupply
us'')
            else (NativeGenAcc statics instr, UniqSupply)
-> IO (NativeGenAcc statics instr, UniqSupply)
forall (m :: * -> *) a. Monad m => a -> m a
return (NativeGenAcc statics instr
ngs' { ngs_debug :: [DebugBlock]
ngs_debug  = NativeGenAcc statics instr -> [DebugBlock]
forall statics instr. NativeGenAcc statics instr -> [DebugBlock]
ngs_debug NativeGenAcc statics instr
ngs' [DebugBlock] -> [DebugBlock] -> [DebugBlock]
forall a. [a] -> [a] -> [a]
++ [DebugBlock]
ldbgs
                              , ngs_labels :: [BlockId]
ngs_labels = [] },
                         UniqSupply
us')

          DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply)
forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGenStream DynFlags
dflags Module
this_mod ModLocation
modLoc NcgImpl statics instr jumpDest
ncgImpl BufHandle
h UniqSupply
us''
              Stream IO RawCmmGroup ()
cmm_stream' NativeGenAcc statics instr
ngs''

-- | Do native code generation on all these cmms.
--
cmmNativeGens :: forall statics instr jumpDest.
                 (Outputable statics, Outputable instr
                 ,Outputable jumpDest, Instruction instr)
              => DynFlags
              -> Module -> ModLocation
              -> NcgImpl statics instr jumpDest
              -> BufHandle
              -> LabelMap DebugBlock
              -> UniqSupply
              -> [RawCmmDecl]
              -> NativeGenAcc statics instr
              -> Int
              -> IO (NativeGenAcc statics instr, UniqSupply)

cmmNativeGens :: DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> LabelMap DebugBlock
-> UniqSupply
-> RawCmmGroup
-> NativeGenAcc statics instr
-> Alignment
-> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGens dflags :: DynFlags
dflags this_mod :: Module
this_mod modLoc :: ModLocation
modLoc ncgImpl :: NcgImpl statics instr jumpDest
ncgImpl h :: BufHandle
h dbgMap :: LabelMap DebugBlock
dbgMap = UniqSupply
-> RawCmmGroup
-> NativeGenAcc statics instr
-> Alignment
-> IO (NativeGenAcc statics instr, UniqSupply)
go
  where
    go :: UniqSupply -> [RawCmmDecl]
       -> NativeGenAcc statics instr -> Int
       -> IO (NativeGenAcc statics instr, UniqSupply)

    go :: UniqSupply
-> RawCmmGroup
-> NativeGenAcc statics instr
-> Alignment
-> IO (NativeGenAcc statics instr, UniqSupply)
go us :: UniqSupply
us [] ngs :: NativeGenAcc statics instr
ngs !Alignment
_ =
        (NativeGenAcc statics instr, UniqSupply)
-> IO (NativeGenAcc statics instr, UniqSupply)
forall (m :: * -> *) a. Monad m => a -> m a
return (NativeGenAcc statics instr
ngs, UniqSupply
us)

    go us :: UniqSupply
us (cmm :: RawCmmDecl
cmm : cmms :: RawCmmGroup
cmms) ngs :: NativeGenAcc statics instr
ngs count :: Alignment
count = do
        let fileIds :: DwarfFiles
fileIds = NativeGenAcc statics instr -> DwarfFiles
forall statics instr. NativeGenAcc statics instr -> DwarfFiles
ngs_dwarfFiles NativeGenAcc statics instr
ngs
        (us' :: UniqSupply
us', fileIds' :: DwarfFiles
fileIds', native :: [NatCmmDecl statics instr]
native, imports :: [CLabel]
imports, colorStats :: Maybe [RegAllocStats statics instr]
colorStats, linearStats :: Maybe [RegAllocStats]
linearStats, unwinds :: LabelMap [UnwindPoint]
unwinds)
          <- {-# SCC "cmmNativeGen" #-}
             DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> UniqSupply
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> Alignment
-> IO
     (UniqSupply, DwarfFiles, [NatCmmDecl statics instr], [CLabel],
      Maybe [RegAllocStats statics instr], Maybe [RegAllocStats],
      LabelMap [UnwindPoint])
forall statics instr jumpDest.
(Instruction instr, Outputable statics, Outputable instr,
 Outputable jumpDest) =>
DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> UniqSupply
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> Alignment
-> IO
     (UniqSupply, DwarfFiles, [NatCmmDecl statics instr], [CLabel],
      Maybe [RegAllocStats statics instr], Maybe [RegAllocStats],
      LabelMap [UnwindPoint])
cmmNativeGen DynFlags
dflags Module
this_mod ModLocation
modLoc NcgImpl statics instr jumpDest
ncgImpl UniqSupply
us DwarfFiles
fileIds LabelMap DebugBlock
dbgMap
                          RawCmmDecl
cmm Alignment
count

        -- Generate .file directives for every new file that has been
        -- used. Note that it is important that we generate these in
        -- ascending order, as Clang's 3.6 assembler complains.
        let newFileIds :: [(FastString, Alignment)]
newFileIds = ((FastString, Alignment) -> (FastString, Alignment) -> Ordering)
-> [(FastString, Alignment)] -> [(FastString, Alignment)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((FastString, Alignment) -> Alignment)
-> (FastString, Alignment) -> (FastString, Alignment) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (FastString, Alignment) -> Alignment
forall a b. (a, b) -> b
snd) ([(FastString, Alignment)] -> [(FastString, Alignment)])
-> [(FastString, Alignment)] -> [(FastString, Alignment)]
forall a b. (a -> b) -> a -> b
$
                         DwarfFiles -> [(FastString, Alignment)]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM (DwarfFiles -> [(FastString, Alignment)])
-> DwarfFiles -> [(FastString, Alignment)]
forall a b. (a -> b) -> a -> b
$ DwarfFiles
fileIds' DwarfFiles -> DwarfFiles -> DwarfFiles
forall elt1 elt2. UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
`minusUFM` DwarfFiles
fileIds
            -- See Note [Unique Determinism and code generation]
            pprDecl :: (FastString, a) -> SDoc
pprDecl (f :: FastString
f,n :: a
n) = String -> SDoc
text "\t.file " SDoc -> SDoc -> SDoc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
n SDoc -> SDoc -> SDoc
<+>
                            SDoc -> SDoc
doubleQuotes (FastString -> SDoc
ftext FastString
f)

        DynFlags -> BufHandle -> SDoc -> IO ()
emitNativeCode DynFlags
dflags BufHandle
h (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
          ((FastString, Alignment) -> SDoc)
-> [(FastString, Alignment)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FastString, Alignment) -> SDoc
forall a. Outputable a => (FastString, a) -> SDoc
pprDecl [(FastString, Alignment)]
newFileIds [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
          (NatCmmDecl statics instr -> SDoc)
-> [NatCmmDecl statics instr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
pprNatCmmDecl NcgImpl statics instr jumpDest
ncgImpl) [NatCmmDecl statics instr]
native

        -- force evaluation all this stuff to avoid space leaks
        {-# SCC "seqString" #-} () -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ()
forall t. [t] -> ()
seqString (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (CLabel -> SDoc) -> [CLabel] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CLabel]
imports)

        let !labels' :: [BlockId]
labels' = if DynFlags -> Alignment
debugLevel DynFlags
dflags Alignment -> Alignment -> Bool
forall a. Ord a => a -> a -> Bool
> 0
                       then (instr -> Bool) -> [NatCmmDecl statics instr] -> [BlockId]
forall i d g.
(i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [BlockId]
cmmDebugLabels instr -> Bool
forall instr. Instruction instr => instr -> Bool
isMetaInstr [NatCmmDecl statics instr]
native else []
            !natives' :: [[NatCmmDecl statics instr]]
natives' = if DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_asm_stats DynFlags
dflags
                        then [NatCmmDecl statics instr]
native [NatCmmDecl statics instr]
-> [[NatCmmDecl statics instr]] -> [[NatCmmDecl statics instr]]
forall a. a -> [a] -> [a]
: NativeGenAcc statics instr -> [[NatCmmDecl statics instr]]
forall statics instr.
NativeGenAcc statics instr -> [[NatCmmDecl statics instr]]
ngs_natives NativeGenAcc statics instr
ngs else []

            mCon :: Maybe a -> [a] -> [a]
mCon = ([a] -> [a]) -> (a -> [a] -> [a]) -> Maybe a -> [a] -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a] -> [a]
forall a. a -> a
id (:)
            ngs' :: NativeGenAcc statics instr
ngs' = NativeGenAcc statics instr
ngs{ ngs_imports :: [[CLabel]]
ngs_imports     = [CLabel]
imports [CLabel] -> [[CLabel]] -> [[CLabel]]
forall a. a -> [a] -> [a]
: NativeGenAcc statics instr -> [[CLabel]]
forall statics instr. NativeGenAcc statics instr -> [[CLabel]]
ngs_imports NativeGenAcc statics instr
ngs
                      , ngs_natives :: [[NatCmmDecl statics instr]]
ngs_natives     = [[NatCmmDecl statics instr]]
natives'
                      , ngs_colorStats :: [[RegAllocStats statics instr]]
ngs_colorStats  = Maybe [RegAllocStats statics instr]
colorStats Maybe [RegAllocStats statics instr]
-> [[RegAllocStats statics instr]]
-> [[RegAllocStats statics instr]]
forall a. Maybe a -> [a] -> [a]
`mCon` NativeGenAcc statics instr -> [[RegAllocStats statics instr]]
forall statics instr.
NativeGenAcc statics instr -> [[RegAllocStats statics instr]]
ngs_colorStats NativeGenAcc statics instr
ngs
                      , ngs_linearStats :: [[RegAllocStats]]
ngs_linearStats = Maybe [RegAllocStats]
linearStats Maybe [RegAllocStats] -> [[RegAllocStats]] -> [[RegAllocStats]]
forall a. Maybe a -> [a] -> [a]
`mCon` NativeGenAcc statics instr -> [[RegAllocStats]]
forall statics instr.
NativeGenAcc statics instr -> [[RegAllocStats]]
ngs_linearStats NativeGenAcc statics instr
ngs
                      , ngs_labels :: [BlockId]
ngs_labels      = NativeGenAcc statics instr -> [BlockId]
forall statics instr. NativeGenAcc statics instr -> [BlockId]
ngs_labels NativeGenAcc statics instr
ngs [BlockId] -> [BlockId] -> [BlockId]
forall a. [a] -> [a] -> [a]
++ [BlockId]
labels'
                      , ngs_dwarfFiles :: DwarfFiles
ngs_dwarfFiles  = DwarfFiles
fileIds'
                      , ngs_unwinds :: LabelMap [UnwindPoint]
ngs_unwinds     = NativeGenAcc statics instr -> LabelMap [UnwindPoint]
forall statics instr.
NativeGenAcc statics instr -> LabelMap [UnwindPoint]
ngs_unwinds NativeGenAcc statics instr
ngs LabelMap [UnwindPoint]
-> LabelMap [UnwindPoint] -> LabelMap [UnwindPoint]
forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
`mapUnion` LabelMap [UnwindPoint]
unwinds
                      }
        UniqSupply
-> RawCmmGroup
-> NativeGenAcc statics instr
-> Alignment
-> IO (NativeGenAcc statics instr, UniqSupply)
go UniqSupply
us' RawCmmGroup
cmms NativeGenAcc statics instr
ngs' (Alignment
count Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
+ 1)

    seqString :: [t] -> ()
seqString []            = ()
    seqString (x :: t
x:xs :: [t]
xs)        = t
x t -> () -> ()
forall a b. a -> b -> b
`seq` [t] -> ()
seqString [t]
xs


emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()
emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()
emitNativeCode dflags :: DynFlags
dflags h :: BufHandle
h sdoc :: SDoc
sdoc = do

        {-# SCC "pprNativeCode" #-} DynFlags -> BufHandle -> PprStyle -> SDoc -> IO ()
bufLeftRenderSDoc DynFlags
dflags BufHandle
h
                                      (CodeStyle -> PprStyle
mkCodeStyle CodeStyle
AsmStyle) SDoc
sdoc

        -- dump native code
        DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                DumpFlag
Opt_D_dump_asm "Asm code"
                SDoc
sdoc

-- | Complete native code generation phase for a single top-level chunk of Cmm.
--      Dumping the output of each stage along the way.
--      Global conflict graph and NGC stats
cmmNativeGen
    :: forall statics instr jumpDest. (Instruction instr,
        Outputable statics, Outputable instr, Outputable jumpDest)
    => DynFlags
    -> Module -> ModLocation
    -> NcgImpl statics instr jumpDest
        -> UniqSupply
        -> DwarfFiles
        -> LabelMap DebugBlock
        -> RawCmmDecl                                   -- ^ the cmm to generate code for
        -> Int                                          -- ^ sequence number of this top thing
        -> IO   ( UniqSupply
                , DwarfFiles
                , [NatCmmDecl statics instr]                -- native code
                , [CLabel]                                  -- things imported by this cmm
                , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
                , Maybe [Linear.RegAllocStats]              -- stats for the linear register allocators
                , LabelMap [UnwindPoint]                    -- unwinding information for blocks
                )

cmmNativeGen :: DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> UniqSupply
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> Alignment
-> IO
     (UniqSupply, DwarfFiles, [NatCmmDecl statics instr], [CLabel],
      Maybe [RegAllocStats statics instr], Maybe [RegAllocStats],
      LabelMap [UnwindPoint])
cmmNativeGen dflags :: DynFlags
dflags this_mod :: Module
this_mod modLoc :: ModLocation
modLoc ncgImpl :: NcgImpl statics instr jumpDest
ncgImpl us :: UniqSupply
us fileIds :: DwarfFiles
fileIds dbgMap :: LabelMap DebugBlock
dbgMap cmm :: RawCmmDecl
cmm count :: Alignment
count
 = do
        let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

        let proc_name :: SDoc
proc_name = case RawCmmDecl
cmm of
                (CmmProc _ entry_label :: CLabel
entry_label _ _) -> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
entry_label
                _                           -> String -> SDoc
text "DataChunk"

        -- rewrite assignments to global regs
        let fixed_cmm :: RawCmmDecl
fixed_cmm =
                {-# SCC "fixStgRegisters" #-}
                DynFlags -> RawCmmDecl -> RawCmmDecl
fixStgRegisters DynFlags
dflags RawCmmDecl
cmm

        -- cmm to cmm optimisations
        let (opt_cmm :: RawCmmDecl
opt_cmm, imports :: [CLabel]
imports) =
                {-# SCC "cmmToCmm" #-}
                DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm DynFlags
dflags Module
this_mod RawCmmDecl
fixed_cmm

        DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                DumpFlag
Opt_D_dump_opt_cmm "Optimised Cmm"
                (RawCmmGroup -> SDoc
forall d info g.
(Outputable d, Outputable info, Outputable g) =>
GenCmmGroup d info g -> SDoc
pprCmmGroup [RawCmmDecl
opt_cmm])

        let cmmCfg :: CFG
cmmCfg = {-# SCC "getCFG" #-}
                     CfgWeights -> RawCmmDecl -> CFG
getCfgProc (DynFlags -> CfgWeights
cfgWeightInfo DynFlags
dflags) RawCmmDecl
opt_cmm

        -- generate native code from cmm
        let ((native :: [NatCmmDecl statics instr]
native, lastMinuteImports :: [CLabel]
lastMinuteImports, fileIds' :: DwarfFiles
fileIds', nativeCfgWeights :: CFG
nativeCfgWeights), usGen :: UniqSupply
usGen) =
                {-# SCC "genMachCode" #-}
                UniqSupply
-> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
-> (([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG),
    UniqSupply)
forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs UniqSupply
us (UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
 -> (([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG),
     UniqSupply))
-> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
-> (([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG),
    UniqSupply)
forall a b. (a -> b) -> a -> b
$ DynFlags
-> Module
-> ModLocation
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> CFG
-> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
forall statics instr.
DynFlags
-> Module
-> ModLocation
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> CFG
-> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
genMachCode DynFlags
dflags Module
this_mod ModLocation
modLoc
                                        (NcgImpl statics instr jumpDest
-> RawCmmDecl -> NatM [NatCmmDecl statics instr]
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> RawCmmDecl -> NatM [NatCmmDecl statics instr]
cmmTopCodeGen NcgImpl statics instr jumpDest
ncgImpl)
                                        DwarfFiles
fileIds LabelMap DebugBlock
dbgMap RawCmmDecl
opt_cmm CFG
cmmCfg


        DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                DumpFlag
Opt_D_dump_asm_native "Native code"
                ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (NatCmmDecl statics instr -> SDoc)
-> [NatCmmDecl statics instr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
pprNatCmmDecl NcgImpl statics instr jumpDest
ncgImpl) [NatCmmDecl statics instr]
native)

        DynFlags -> Maybe CFG -> String -> SDoc -> IO ()
maybeDumpCfg DynFlags
dflags (CFG -> Maybe CFG
forall a. a -> Maybe a
Just CFG
nativeCfgWeights) "CFG Weights - Native" SDoc
proc_name

        -- tag instructions with register liveness information
        -- also drops dead code. We don't keep the cfg in sync on
        -- some backends, so don't use it there.
        let livenessCfg :: Maybe CFG
livenessCfg = if (DynFlags -> Bool
backendMaintainsCfg DynFlags
dflags)
                                then CFG -> Maybe CFG
forall a. a -> Maybe a
Just CFG
nativeCfgWeights
                                else Maybe CFG
forall a. Maybe a
Nothing
        let (withLiveness :: [LiveCmmDecl statics instr]
withLiveness, usLive :: UniqSupply
usLive) =
                {-# SCC "regLiveness" #-}
                UniqSupply
-> UniqSM [LiveCmmDecl statics instr]
-> ([LiveCmmDecl statics instr], UniqSupply)
forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs UniqSupply
usGen
                        (UniqSM [LiveCmmDecl statics instr]
 -> ([LiveCmmDecl statics instr], UniqSupply))
-> UniqSM [LiveCmmDecl statics instr]
-> ([LiveCmmDecl statics instr], UniqSupply)
forall a b. (a -> b) -> a -> b
$ (LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr))
-> [LiveCmmDecl statics instr]
-> UniqSM [LiveCmmDecl statics instr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Platform
-> LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)
forall instr statics.
(Outputable instr, Instruction instr) =>
Platform
-> LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)
regLiveness Platform
platform)
                        -- TODO: Only use CFG for x86
                        ([LiveCmmDecl statics instr] -> UniqSM [LiveCmmDecl statics instr])
-> [LiveCmmDecl statics instr]
-> UniqSM [LiveCmmDecl statics instr]
forall a b. (a -> b) -> a -> b
$ (NatCmmDecl statics instr -> LiveCmmDecl statics instr)
-> [NatCmmDecl statics instr] -> [LiveCmmDecl statics instr]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe CFG -> NatCmmDecl statics instr -> LiveCmmDecl statics instr
forall instr statics.
(Instruction instr, Outputable instr) =>
Maybe CFG -> NatCmmDecl statics instr -> LiveCmmDecl statics instr
natCmmTopToLive Maybe CFG
livenessCfg) [NatCmmDecl statics instr]
native

        DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                DumpFlag
Opt_D_dump_asm_liveness "Liveness annotations added"
                ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (LiveCmmDecl statics instr -> SDoc)
-> [LiveCmmDecl statics instr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LiveCmmDecl statics instr -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LiveCmmDecl statics instr]
withLiveness)

        -- allocate registers
        (alloced :: [NatCmmDecl statics instr]
alloced, usAlloc :: UniqSupply
usAlloc, ppr_raStatsColor :: Maybe [RegAllocStats statics instr]
ppr_raStatsColor, ppr_raStatsLinear :: Maybe [RegAllocStats]
ppr_raStatsLinear, raStats :: [RegAllocStats]
raStats, stack_updt_blks :: [(BlockId, BlockId)]
stack_updt_blks) <-
         if ( GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RegsGraph DynFlags
dflags
           Bool -> Bool -> Bool
|| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RegsIterative DynFlags
dflags )
          then do
                -- the regs usable for allocation
                let (UniqFM (UniqSet RealReg)
alloc_regs :: UniqFM (UniqSet RealReg))
                        = (RealReg -> UniqFM (UniqSet RealReg) -> UniqFM (UniqSet RealReg))
-> UniqFM (UniqSet RealReg)
-> [RealReg]
-> UniqFM (UniqSet RealReg)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\r :: RealReg
r -> (UniqSet RealReg -> UniqSet RealReg -> UniqSet RealReg)
-> UniqFM (UniqSet RealReg)
-> UniqFM (UniqSet RealReg)
-> UniqFM (UniqSet RealReg)
forall elt.
(elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt
plusUFM_C UniqSet RealReg -> UniqSet RealReg -> UniqSet RealReg
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets
                                        (UniqFM (UniqSet RealReg)
 -> UniqFM (UniqSet RealReg) -> UniqFM (UniqSet RealReg))
-> UniqFM (UniqSet RealReg)
-> UniqFM (UniqSet RealReg)
-> UniqFM (UniqSet RealReg)
forall a b. (a -> b) -> a -> b
$ RegClass -> UniqSet RealReg -> UniqFM (UniqSet RealReg)
forall key elt. Uniquable key => key -> elt -> UniqFM elt
unitUFM (Platform -> RealReg -> RegClass
targetClassOfRealReg Platform
platform RealReg
r) (RealReg -> UniqSet RealReg
forall a. Uniquable a => a -> UniqSet a
unitUniqSet RealReg
r))
                                UniqFM (UniqSet RealReg)
forall elt. UniqFM elt
emptyUFM
                        ([RealReg] -> UniqFM (UniqSet RealReg))
-> [RealReg] -> UniqFM (UniqSet RealReg)
forall a b. (a -> b) -> a -> b
$ NcgImpl statics instr jumpDest -> [RealReg]
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> [RealReg]
allocatableRegs NcgImpl statics instr jumpDest
ncgImpl

                -- do the graph coloring register allocation
                let ((alloced :: [NatCmmDecl statics instr]
alloced, maybe_more_stack :: Maybe Alignment
maybe_more_stack, regAllocStats :: [RegAllocStats statics instr]
regAllocStats), usAlloc :: UniqSupply
usAlloc)
                        = {-# SCC "RegAlloc-color" #-}
                          UniqSupply
-> UniqSM
     ([NatCmmDecl statics instr], Maybe Alignment,
      [RegAllocStats statics instr])
-> (([NatCmmDecl statics instr], Maybe Alignment,
     [RegAllocStats statics instr]),
    UniqSupply)
forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs UniqSupply
usLive
                          (UniqSM
   ([NatCmmDecl statics instr], Maybe Alignment,
    [RegAllocStats statics instr])
 -> (([NatCmmDecl statics instr], Maybe Alignment,
      [RegAllocStats statics instr]),
     UniqSupply))
-> UniqSM
     ([NatCmmDecl statics instr], Maybe Alignment,
      [RegAllocStats statics instr])
-> (([NatCmmDecl statics instr], Maybe Alignment,
     [RegAllocStats statics instr]),
    UniqSupply)
forall a b. (a -> b) -> a -> b
$ DynFlags
-> UniqFM (UniqSet RealReg)
-> UniqSet Alignment
-> Alignment
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM
     ([NatCmmDecl statics instr], Maybe Alignment,
      [RegAllocStats statics instr])
forall statics instr.
(Outputable statics, Outputable instr, Instruction instr) =>
DynFlags
-> UniqFM (UniqSet RealReg)
-> UniqSet Alignment
-> Alignment
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM
     ([NatCmmDecl statics instr], Maybe Alignment,
      [RegAllocStats statics instr])
Color.regAlloc
                                DynFlags
dflags
                                UniqFM (UniqSet RealReg)
alloc_regs
                                ([Alignment] -> UniqSet Alignment
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [0 .. NcgImpl statics instr jumpDest -> Alignment
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> Alignment
maxSpillSlots NcgImpl statics instr jumpDest
ncgImpl])
                                (NcgImpl statics instr jumpDest -> Alignment
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> Alignment
maxSpillSlots NcgImpl statics instr jumpDest
ncgImpl)
                                [LiveCmmDecl statics instr]
withLiveness
                                Maybe CFG
livenessCfg

                let ((alloced' :: [NatCmmDecl statics instr]
alloced', stack_updt_blks :: [(BlockId, BlockId)]
stack_updt_blks), usAlloc' :: UniqSupply
usAlloc')
                        = UniqSupply
-> UniqSM ([NatCmmDecl statics instr], [(BlockId, BlockId)])
-> (([NatCmmDecl statics instr], [(BlockId, BlockId)]), UniqSupply)
forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs UniqSupply
usAlloc (UniqSM ([NatCmmDecl statics instr], [(BlockId, BlockId)])
 -> (([NatCmmDecl statics instr], [(BlockId, BlockId)]),
     UniqSupply))
-> UniqSM ([NatCmmDecl statics instr], [(BlockId, BlockId)])
-> (([NatCmmDecl statics instr], [(BlockId, BlockId)]), UniqSupply)
forall a b. (a -> b) -> a -> b
$
                                case Maybe Alignment
maybe_more_stack of
                                Nothing     -> ([NatCmmDecl statics instr], [(BlockId, BlockId)])
-> UniqSM ([NatCmmDecl statics instr], [(BlockId, BlockId)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([NatCmmDecl statics instr]
alloced, [])
                                Just amount :: Alignment
amount -> do
                                    (alloced' :: [NatCmmDecl statics instr]
alloced',stack_updt_blks :: [[(BlockId, BlockId)]]
stack_updt_blks) <- [(NatCmmDecl statics instr, [(BlockId, BlockId)])]
-> ([NatCmmDecl statics instr], [[(BlockId, BlockId)]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(NatCmmDecl statics instr, [(BlockId, BlockId)])]
 -> ([NatCmmDecl statics instr], [[(BlockId, BlockId)]]))
-> UniqSM [(NatCmmDecl statics instr, [(BlockId, BlockId)])]
-> UniqSM ([NatCmmDecl statics instr], [[(BlockId, BlockId)]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                                ((NatCmmDecl statics instr
 -> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)]))
-> [NatCmmDecl statics instr]
-> UniqSM [(NatCmmDecl statics instr, [(BlockId, BlockId)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((NcgImpl statics instr jumpDest
-> Alignment
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> Alignment
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
ncgAllocMoreStack NcgImpl statics instr jumpDest
ncgImpl) Alignment
amount) [NatCmmDecl statics instr]
alloced)
                                    ([NatCmmDecl statics instr], [(BlockId, BlockId)])
-> UniqSM ([NatCmmDecl statics instr], [(BlockId, BlockId)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([NatCmmDecl statics instr]
alloced', [[(BlockId, BlockId)]] -> [(BlockId, BlockId)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(BlockId, BlockId)]]
stack_updt_blks )


                -- dump out what happened during register allocation
                DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                        DumpFlag
Opt_D_dump_asm_regalloc "Registers allocated"
                        ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (NatCmmDecl statics instr -> SDoc)
-> [NatCmmDecl statics instr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
pprNatCmmDecl NcgImpl statics instr jumpDest
ncgImpl) [NatCmmDecl statics instr]
alloced)

                DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                        DumpFlag
Opt_D_dump_asm_regalloc_stages "Build/spill stages"
                        ([SDoc] -> SDoc
vcat   ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ ((Alignment, RegAllocStats statics instr) -> SDoc)
-> [(Alignment, RegAllocStats statics instr)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(stage :: Alignment
stage, stats :: RegAllocStats statics instr
stats)
                                        -> String -> SDoc
text "# --------------------------"
                                        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "#  cmm " SDoc -> SDoc -> SDoc
<> Alignment -> SDoc
int Alignment
count SDoc -> SDoc -> SDoc
<> String -> SDoc
text " Stage " SDoc -> SDoc -> SDoc
<> Alignment -> SDoc
int Alignment
stage
                                        SDoc -> SDoc -> SDoc
$$ RegAllocStats statics instr -> SDoc
forall a. Outputable a => a -> SDoc
ppr RegAllocStats statics instr
stats)
                                ([(Alignment, RegAllocStats statics instr)] -> [SDoc])
-> [(Alignment, RegAllocStats statics instr)] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ [Alignment]
-> [RegAllocStats statics instr]
-> [(Alignment, RegAllocStats statics instr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [RegAllocStats statics instr]
regAllocStats)

                let mPprStats :: Maybe [RegAllocStats statics instr]
mPprStats =
                        if DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_asm_stats DynFlags
dflags
                         then [RegAllocStats statics instr]
-> Maybe [RegAllocStats statics instr]
forall a. a -> Maybe a
Just [RegAllocStats statics instr]
regAllocStats else Maybe [RegAllocStats statics instr]
forall a. Maybe a
Nothing

                -- force evaluation of the Maybe to avoid space leak
                Maybe [RegAllocStats statics instr]
mPprStats Maybe [RegAllocStats statics instr] -> IO () -> IO ()
forall a b. a -> b -> b
`seq` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

                ([NatCmmDecl statics instr], UniqSupply,
 Maybe [RegAllocStats statics instr], Maybe [RegAllocStats],
 [RegAllocStats], [(BlockId, BlockId)])
-> IO
     ([NatCmmDecl statics instr], UniqSupply,
      Maybe [RegAllocStats statics instr], Maybe [RegAllocStats],
      [RegAllocStats], [(BlockId, BlockId)])
forall (m :: * -> *) a. Monad m => a -> m a
return  ( [NatCmmDecl statics instr]
alloced', UniqSupply
usAlloc'
                        , Maybe [RegAllocStats statics instr]
mPprStats
                        , Maybe [RegAllocStats]
forall a. Maybe a
Nothing
                        , [], [(BlockId, BlockId)]
stack_updt_blks)

          else do
                -- do linear register allocation
                let reg_alloc :: LiveCmmDecl statics instr
-> UniqSM
     (NatCmmDecl statics instr, Maybe RegAllocStats,
      [(BlockId, BlockId)])
reg_alloc proc :: LiveCmmDecl statics instr
proc = do
                       (alloced :: NatCmmDecl statics instr
alloced, maybe_more_stack :: Maybe Alignment
maybe_more_stack, ra_stats :: Maybe RegAllocStats
ra_stats) <-
                               DynFlags
-> LiveCmmDecl statics instr
-> UniqSM
     (NatCmmDecl statics instr, Maybe Alignment, Maybe RegAllocStats)
forall instr statics.
(Outputable instr, Instruction instr) =>
DynFlags
-> LiveCmmDecl statics instr
-> UniqSM
     (NatCmmDecl statics instr, Maybe Alignment, Maybe RegAllocStats)
Linear.regAlloc DynFlags
dflags LiveCmmDecl statics instr
proc
                       case Maybe Alignment
maybe_more_stack of
                         Nothing -> (NatCmmDecl statics instr, Maybe RegAllocStats,
 [(BlockId, BlockId)])
-> UniqSM
     (NatCmmDecl statics instr, Maybe RegAllocStats,
      [(BlockId, BlockId)])
forall (m :: * -> *) a. Monad m => a -> m a
return ( NatCmmDecl statics instr
alloced, Maybe RegAllocStats
ra_stats, [] )
                         Just amount :: Alignment
amount -> do
                           (alloced' :: NatCmmDecl statics instr
alloced',stack_updt_blks :: [(BlockId, BlockId)]
stack_updt_blks) <-
                               NcgImpl statics instr jumpDest
-> Alignment
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> Alignment
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
ncgAllocMoreStack NcgImpl statics instr jumpDest
ncgImpl Alignment
amount NatCmmDecl statics instr
alloced
                           (NatCmmDecl statics instr, Maybe RegAllocStats,
 [(BlockId, BlockId)])
-> UniqSM
     (NatCmmDecl statics instr, Maybe RegAllocStats,
      [(BlockId, BlockId)])
forall (m :: * -> *) a. Monad m => a -> m a
return (NatCmmDecl statics instr
alloced', Maybe RegAllocStats
ra_stats, [(BlockId, BlockId)]
stack_updt_blks )

                let ((alloced :: [NatCmmDecl statics instr]
alloced, regAllocStats :: [Maybe RegAllocStats]
regAllocStats, stack_updt_blks :: [[(BlockId, BlockId)]]
stack_updt_blks), usAlloc :: UniqSupply
usAlloc)
                        = {-# SCC "RegAlloc-linear" #-}
                          UniqSupply
-> UniqSM
     ([NatCmmDecl statics instr], [Maybe RegAllocStats],
      [[(BlockId, BlockId)]])
-> (([NatCmmDecl statics instr], [Maybe RegAllocStats],
     [[(BlockId, BlockId)]]),
    UniqSupply)
forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs UniqSupply
usLive
                          (UniqSM
   ([NatCmmDecl statics instr], [Maybe RegAllocStats],
    [[(BlockId, BlockId)]])
 -> (([NatCmmDecl statics instr], [Maybe RegAllocStats],
      [[(BlockId, BlockId)]]),
     UniqSupply))
-> UniqSM
     ([NatCmmDecl statics instr], [Maybe RegAllocStats],
      [[(BlockId, BlockId)]])
-> (([NatCmmDecl statics instr], [Maybe RegAllocStats],
     [[(BlockId, BlockId)]]),
    UniqSupply)
forall a b. (a -> b) -> a -> b
$ ([(NatCmmDecl statics instr, Maybe RegAllocStats,
   [(BlockId, BlockId)])]
 -> ([NatCmmDecl statics instr], [Maybe RegAllocStats],
     [[(BlockId, BlockId)]]))
-> UniqSM
     [(NatCmmDecl statics instr, Maybe RegAllocStats,
       [(BlockId, BlockId)])]
-> UniqSM
     ([NatCmmDecl statics instr], [Maybe RegAllocStats],
      [[(BlockId, BlockId)]])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(NatCmmDecl statics instr, Maybe RegAllocStats,
  [(BlockId, BlockId)])]
-> ([NatCmmDecl statics instr], [Maybe RegAllocStats],
    [[(BlockId, BlockId)]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3
                          (UniqSM
   [(NatCmmDecl statics instr, Maybe RegAllocStats,
     [(BlockId, BlockId)])]
 -> UniqSM
      ([NatCmmDecl statics instr], [Maybe RegAllocStats],
       [[(BlockId, BlockId)]]))
-> UniqSM
     [(NatCmmDecl statics instr, Maybe RegAllocStats,
       [(BlockId, BlockId)])]
-> UniqSM
     ([NatCmmDecl statics instr], [Maybe RegAllocStats],
      [[(BlockId, BlockId)]])
forall a b. (a -> b) -> a -> b
$ (LiveCmmDecl statics instr
 -> UniqSM
      (NatCmmDecl statics instr, Maybe RegAllocStats,
       [(BlockId, BlockId)]))
-> [LiveCmmDecl statics instr]
-> UniqSM
     [(NatCmmDecl statics instr, Maybe RegAllocStats,
       [(BlockId, BlockId)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LiveCmmDecl statics instr
-> UniqSM
     (NatCmmDecl statics instr, Maybe RegAllocStats,
      [(BlockId, BlockId)])
reg_alloc [LiveCmmDecl statics instr]
withLiveness

                DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                        DumpFlag
Opt_D_dump_asm_regalloc "Registers allocated"
                        ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (NatCmmDecl statics instr -> SDoc)
-> [NatCmmDecl statics instr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
pprNatCmmDecl NcgImpl statics instr jumpDest
ncgImpl) [NatCmmDecl statics instr]
alloced)

                let mPprStats :: Maybe [RegAllocStats]
mPprStats =
                        if DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_asm_stats DynFlags
dflags
                         then [RegAllocStats] -> Maybe [RegAllocStats]
forall a. a -> Maybe a
Just ([Maybe RegAllocStats] -> [RegAllocStats]
forall a. [Maybe a] -> [a]
catMaybes [Maybe RegAllocStats]
regAllocStats) else Maybe [RegAllocStats]
forall a. Maybe a
Nothing

                -- force evaluation of the Maybe to avoid space leak
                Maybe [RegAllocStats]
mPprStats Maybe [RegAllocStats] -> IO () -> IO ()
forall a b. a -> b -> b
`seq` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

                ([NatCmmDecl statics instr], UniqSupply,
 Maybe [RegAllocStats statics instr], Maybe [RegAllocStats],
 [RegAllocStats], [(BlockId, BlockId)])
-> IO
     ([NatCmmDecl statics instr], UniqSupply,
      Maybe [RegAllocStats statics instr], Maybe [RegAllocStats],
      [RegAllocStats], [(BlockId, BlockId)])
forall (m :: * -> *) a. Monad m => a -> m a
return  ( [NatCmmDecl statics instr]
alloced, UniqSupply
usAlloc
                        , Maybe [RegAllocStats statics instr]
forall a. Maybe a
Nothing
                        , Maybe [RegAllocStats]
mPprStats, ([Maybe RegAllocStats] -> [RegAllocStats]
forall a. [Maybe a] -> [a]
catMaybes [Maybe RegAllocStats]
regAllocStats)
                        , [[(BlockId, BlockId)]] -> [(BlockId, BlockId)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(BlockId, BlockId)]]
stack_updt_blks )

        -- Fixupblocks the register allocator inserted (from, regMoves, to)
        let cfgRegAllocUpdates :: [(BlockId,BlockId,BlockId)]
            cfgRegAllocUpdates :: [(BlockId, BlockId, BlockId)]
cfgRegAllocUpdates = ((RegAllocStats -> [(BlockId, BlockId, BlockId)])
-> [RegAllocStats] -> [(BlockId, BlockId, BlockId)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap RegAllocStats -> [(BlockId, BlockId, BlockId)]
Linear.ra_fixupList [RegAllocStats]
raStats)

        let cfgWithFixupBlks :: Maybe CFG
cfgWithFixupBlks =
                (CFG -> [(BlockId, BlockId, BlockId)] -> CFG)
-> Maybe (CFG -> [(BlockId, BlockId, BlockId)] -> CFG)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CFG -> [(BlockId, BlockId, BlockId)] -> CFG
addNodesBetween Maybe (CFG -> [(BlockId, BlockId, BlockId)] -> CFG)
-> Maybe CFG -> Maybe ([(BlockId, BlockId, BlockId)] -> CFG)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe CFG
livenessCfg Maybe ([(BlockId, BlockId, BlockId)] -> CFG)
-> Maybe [(BlockId, BlockId, BlockId)] -> Maybe CFG
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(BlockId, BlockId, BlockId)]
-> Maybe [(BlockId, BlockId, BlockId)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(BlockId, BlockId, BlockId)]
cfgRegAllocUpdates

        -- Insert stack update blocks
        let postRegCFG :: Maybe CFG
            postRegCFG :: Maybe CFG
postRegCFG =
                (CFG -> [(BlockId, BlockId)] -> CFG)
-> Maybe (CFG -> [(BlockId, BlockId)] -> CFG)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CFG -> (BlockId, BlockId) -> CFG)
-> CFG -> [(BlockId, BlockId)] -> CFG
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\m :: CFG
m (from :: BlockId
from,to :: BlockId
to) -> HasDebugCallStack => BlockId -> BlockId -> CFG -> CFG
BlockId -> BlockId -> CFG -> CFG
addImmediateSuccessor BlockId
from BlockId
to CFG
m )) Maybe (CFG -> [(BlockId, BlockId)] -> CFG)
-> Maybe CFG -> Maybe ([(BlockId, BlockId)] -> CFG)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                        Maybe CFG
cfgWithFixupBlks Maybe ([(BlockId, BlockId)] -> CFG)
-> Maybe [(BlockId, BlockId)] -> Maybe CFG
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(BlockId, BlockId)] -> Maybe [(BlockId, BlockId)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(BlockId, BlockId)]
stack_updt_blks

        ---- x86fp_kludge.  This pass inserts ffree instructions to clear
        ---- the FPU stack on x86.  The x86 ABI requires that the FPU stack
        ---- is clear, and library functions can return odd results if it
        ---- isn't.
        ----
        ---- NB. must happen before shortcutBranches, because that
        ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
        let kludged :: [NatCmmDecl statics instr]
kludged = {-# SCC "x86fp_kludge" #-} NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
ncg_x86fp_kludge NcgImpl statics instr jumpDest
ncgImpl [NatCmmDecl statics instr]
alloced

        ---- generate jump tables
        let tabled :: [NatCmmDecl statics instr]
tabled      =
                {-# SCC "generateJumpTables" #-}
                NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
generateJumpTables NcgImpl statics instr jumpDest
ncgImpl [NatCmmDecl statics instr]
kludged

        DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                DumpFlag
Opt_D_dump_cfg_weights "CFG Update information"
                ( String -> SDoc
text "stack:" SDoc -> SDoc -> SDoc
<+> [(BlockId, BlockId)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(BlockId, BlockId)]
stack_updt_blks SDoc -> SDoc -> SDoc
$$
                  String -> SDoc
text "linearAlloc:" SDoc -> SDoc -> SDoc
<+> [(BlockId, BlockId, BlockId)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(BlockId, BlockId, BlockId)]
cfgRegAllocUpdates )

        ---- shortcut branches
        let (shorted :: [NatCmmDecl statics instr]
shorted, postShortCFG :: Maybe CFG
postShortCFG)     =
                {-# SCC "shortcutBranches" #-}
                DynFlags
-> NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr]
-> Maybe CFG
-> ([NatCmmDecl statics instr], Maybe CFG)
forall statics instr jumpDest.
Outputable jumpDest =>
DynFlags
-> NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr]
-> Maybe CFG
-> ([NatCmmDecl statics instr], Maybe CFG)
shortcutBranches DynFlags
dflags NcgImpl statics instr jumpDest
ncgImpl [NatCmmDecl statics instr]
tabled Maybe CFG
postRegCFG

        let optimizedCFG :: Maybe CFG
optimizedCFG =
                HasDebugCallStack => CfgWeights -> RawCmmDecl -> CFG -> CFG
CfgWeights -> RawCmmDecl -> CFG -> CFG
optimizeCFG (DynFlags -> CfgWeights
cfgWeightInfo DynFlags
dflags) RawCmmDecl
cmm (CFG -> CFG) -> Maybe CFG -> Maybe CFG
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CFG
postShortCFG

        DynFlags -> Maybe CFG -> String -> SDoc -> IO ()
maybeDumpCfg DynFlags
dflags Maybe CFG
optimizedCFG "CFG Weights - Final" SDoc
proc_name

        --TODO: Partially check validity of the cfg.
        let getBlks :: GenCmmDecl d h (ListGraph i) -> [GenBasicBlock i]
getBlks (CmmProc _info :: h
_info _lbl :: CLabel
_lbl _live :: [GlobalReg]
_live (ListGraph blocks :: [GenBasicBlock i]
blocks)) = [GenBasicBlock i]
blocks
            getBlks _ = []

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ( DynFlags -> Bool
backendMaintainsCfg DynFlags
dflags Bool -> Bool -> Bool
&&
                (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoAsmLinting DynFlags
dflags Bool -> Bool -> Bool
|| Bool
debugIsOn )) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                let blocks :: [GenBasicBlock instr]
blocks = (NatCmmDecl statics instr -> [GenBasicBlock instr])
-> [NatCmmDecl statics instr] -> [GenBasicBlock instr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NatCmmDecl statics instr -> [GenBasicBlock instr]
forall d h i. GenCmmDecl d h (ListGraph i) -> [GenBasicBlock i]
getBlks [NatCmmDecl statics instr]
shorted
                let labels :: LabelSet
labels = [ElemOf LabelSet] -> LabelSet
forall set. IsSet set => [ElemOf set] -> set
setFromList ([ElemOf LabelSet] -> LabelSet) -> [ElemOf LabelSet] -> LabelSet
forall a b. (a -> b) -> a -> b
$ (GenBasicBlock instr -> BlockId)
-> [GenBasicBlock instr] -> [BlockId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenBasicBlock instr -> BlockId
forall i. GenBasicBlock i -> BlockId
blockId [GenBasicBlock instr]
blocks :: LabelSet
                () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! Maybe Bool -> () -> ()
forall a b. a -> b -> b
seq ((CFG -> LabelSet -> SDoc -> Bool)
-> Maybe (CFG -> LabelSet -> SDoc -> Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CFG -> LabelSet -> SDoc -> Bool
sanityCheckCfg Maybe (CFG -> LabelSet -> SDoc -> Bool)
-> Maybe CFG -> Maybe (LabelSet -> SDoc -> Bool)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe CFG
optimizedCFG Maybe (LabelSet -> SDoc -> Bool)
-> Maybe LabelSet -> Maybe (SDoc -> Bool)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LabelSet -> Maybe LabelSet
forall (f :: * -> *) a. Applicative f => a -> f a
pure LabelSet
labels Maybe (SDoc -> Bool) -> Maybe SDoc -> Maybe Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                                        SDoc -> Maybe SDoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> SDoc
text "cfg not in lockstep")) ()

        ---- sequence blocks
        let sequenced :: [NatCmmDecl statics instr]
            sequenced :: [NatCmmDecl statics instr]
sequenced =
                [NatCmmDecl statics instr]
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
forall statics instr.
[NatCmmDecl statics instr]
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
checkLayout [NatCmmDecl statics instr]
shorted ([NatCmmDecl statics instr] -> [NatCmmDecl statics instr])
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
forall a b. (a -> b) -> a -> b
$
                {-# SCC "sequenceBlocks" #-}
                (NatCmmDecl statics instr -> NatCmmDecl statics instr)
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags
-> NcgImpl statics instr jumpDest
-> Maybe CFG
-> NatCmmDecl statics instr
-> NatCmmDecl statics instr
forall instr statics jumpDest.
(Instruction instr, Outputable instr) =>
DynFlags
-> NcgImpl statics instr jumpDest
-> Maybe CFG
-> NatCmmDecl statics instr
-> NatCmmDecl statics instr
BlockLayout.sequenceTop
                        DynFlags
dflags
                        NcgImpl statics instr jumpDest
ncgImpl Maybe CFG
optimizedCFG)
                    [NatCmmDecl statics instr]
shorted

        let branchOpt :: [NatCmmDecl statics instr]
            branchOpt :: [NatCmmDecl statics instr]
branchOpt =
                {-# SCC "invertCondBranches" #-}
                (NatCmmDecl statics instr -> NatCmmDecl statics instr)
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
forall a b. (a -> b) -> [a] -> [b]
map NatCmmDecl statics instr -> NatCmmDecl statics instr
invert [NatCmmDecl statics instr]
sequenced
              where
                invertConds :: LabelMap CmmStatics -> [NatBasicBlock instr]
                            -> [NatBasicBlock instr]
                invertConds :: LabelMap CmmStatics
-> [GenBasicBlock instr] -> [GenBasicBlock instr]
invertConds = (NcgImpl statics instr jumpDest
-> Maybe CFG
-> LabelMap CmmStatics
-> [GenBasicBlock instr]
-> [GenBasicBlock instr]
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> Maybe CFG
-> LabelMap CmmStatics
-> [NatBasicBlock instr]
-> [NatBasicBlock instr]
invertCondBranches NcgImpl statics instr jumpDest
ncgImpl) Maybe CFG
optimizedCFG
                invert :: NatCmmDecl statics instr -> NatCmmDecl statics instr
invert top :: NatCmmDecl statics instr
top@CmmData {} = NatCmmDecl statics instr
top
                invert (CmmProc info :: LabelMap CmmStatics
info lbl :: CLabel
lbl live :: [GlobalReg]
live (ListGraph blocks :: [GenBasicBlock instr]
blocks)) =
                    LabelMap CmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph instr
-> NatCmmDecl statics instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap CmmStatics
info CLabel
lbl [GlobalReg]
live ([GenBasicBlock instr] -> ListGraph instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph ([GenBasicBlock instr] -> ListGraph instr)
-> [GenBasicBlock instr] -> ListGraph instr
forall a b. (a -> b) -> a -> b
$ LabelMap CmmStatics
-> [GenBasicBlock instr] -> [GenBasicBlock instr]
invertConds LabelMap CmmStatics
info [GenBasicBlock instr]
blocks)

        ---- expansion of SPARC synthetic instrs
        let expanded :: [NatCmmDecl statics instr]
expanded =
                {-# SCC "sparc_expand" #-}
                NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
ncgExpandTop NcgImpl statics instr jumpDest
ncgImpl [NatCmmDecl statics instr]
branchOpt
                --ncgExpandTop ncgImpl sequenced

        DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                DumpFlag
Opt_D_dump_asm_expanded "Synthetic instructions expanded"
                ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (NatCmmDecl statics instr -> SDoc)
-> [NatCmmDecl statics instr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
pprNatCmmDecl NcgImpl statics instr jumpDest
ncgImpl) [NatCmmDecl statics instr]
expanded)

        -- generate unwinding information from cmm
        let unwinds :: BlockMap [UnwindPoint]
            unwinds :: LabelMap [UnwindPoint]
unwinds =
                {-# SCC "unwindingInfo" #-}
                (LabelMap [UnwindPoint]
 -> NatCmmDecl statics instr -> LabelMap [UnwindPoint])
-> LabelMap [UnwindPoint]
-> [NatCmmDecl statics instr]
-> LabelMap [UnwindPoint]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LabelMap [UnwindPoint]
-> NatCmmDecl statics instr -> LabelMap [UnwindPoint]
addUnwind LabelMap [UnwindPoint]
forall (map :: * -> *) a. IsMap map => map a
mapEmpty [NatCmmDecl statics instr]
expanded
              where
                addUnwind :: LabelMap [UnwindPoint]
-> NatCmmDecl statics instr -> LabelMap [UnwindPoint]
addUnwind acc :: LabelMap [UnwindPoint]
acc proc :: NatCmmDecl statics instr
proc =
                    LabelMap [UnwindPoint]
acc LabelMap [UnwindPoint]
-> LabelMap [UnwindPoint] -> LabelMap [UnwindPoint]
forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
`mapUnion` DynFlags
-> NcgImpl statics instr jumpDest
-> NatCmmDecl statics instr
-> LabelMap [UnwindPoint]
forall instr statics jumpDest.
Instruction instr =>
DynFlags
-> NcgImpl statics instr jumpDest
-> NatCmmDecl statics instr
-> LabelMap [UnwindPoint]
computeUnwinding DynFlags
dflags NcgImpl statics instr jumpDest
ncgImpl NatCmmDecl statics instr
proc

        (UniqSupply, DwarfFiles, [NatCmmDecl statics instr], [CLabel],
 Maybe [RegAllocStats statics instr], Maybe [RegAllocStats],
 LabelMap [UnwindPoint])
-> IO
     (UniqSupply, DwarfFiles, [NatCmmDecl statics instr], [CLabel],
      Maybe [RegAllocStats statics instr], Maybe [RegAllocStats],
      LabelMap [UnwindPoint])
forall (m :: * -> *) a. Monad m => a -> m a
return  ( UniqSupply
usAlloc
                , DwarfFiles
fileIds'
                , [NatCmmDecl statics instr]
expanded
                , [CLabel]
lastMinuteImports [CLabel] -> [CLabel] -> [CLabel]
forall a. [a] -> [a] -> [a]
++ [CLabel]
imports
                , Maybe [RegAllocStats statics instr]
ppr_raStatsColor
                , Maybe [RegAllocStats]
ppr_raStatsLinear
                , LabelMap [UnwindPoint]
unwinds )

maybeDumpCfg :: DynFlags -> Maybe CFG -> String -> SDoc -> IO ()
maybeDumpCfg :: DynFlags -> Maybe CFG -> String -> SDoc -> IO ()
maybeDumpCfg _dflags :: DynFlags
_dflags Nothing _ _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeDumpCfg dflags :: DynFlags
dflags (Just cfg :: CFG
cfg) msg :: String
msg proc_name :: SDoc
proc_name
        | CFG -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CFG
cfg = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise
        = DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn
                DynFlags
dflags DumpFlag
Opt_D_dump_cfg_weights String
msg
                (SDoc
proc_name SDoc -> SDoc -> SDoc
<> Char -> SDoc
char ':' SDoc -> SDoc -> SDoc
$$ CFG -> SDoc
pprEdgeWeights CFG
cfg)

-- | Make sure all blocks we want the layout algorithm to place have been placed.
checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
            -> [NatCmmDecl statics instr]
checkLayout :: [NatCmmDecl statics instr]
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
checkLayout procsUnsequenced :: [NatCmmDecl statics instr]
procsUnsequenced procsSequenced :: [NatCmmDecl statics instr]
procsSequenced =
        ASSERT2(setNull diff,
                ppr "Block sequencing dropped blocks:" <> ppr diff)
        [NatCmmDecl statics instr]
procsSequenced
  where
        blocks1 :: LabelSet
blocks1 = (LabelSet -> LabelSet -> LabelSet)
-> LabelSet -> [LabelSet] -> LabelSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => set -> set -> set
setUnion) LabelSet
forall set. IsSet set => set
setEmpty ([LabelSet] -> LabelSet) -> [LabelSet] -> LabelSet
forall a b. (a -> b) -> a -> b
$
                        (NatCmmDecl statics instr -> LabelSet)
-> [NatCmmDecl statics instr] -> [LabelSet]
forall a b. (a -> b) -> [a] -> [b]
map NatCmmDecl statics instr -> LabelSet
forall p d h i.
(IsSet p, ElemOf p ~ BlockId) =>
GenCmmDecl d h (ListGraph i) -> p
getBlockIds [NatCmmDecl statics instr]
procsUnsequenced :: LabelSet
        blocks2 :: LabelSet
blocks2 = (LabelSet -> LabelSet -> LabelSet)
-> LabelSet -> [LabelSet] -> LabelSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => set -> set -> set
setUnion) LabelSet
forall set. IsSet set => set
setEmpty ([LabelSet] -> LabelSet) -> [LabelSet] -> LabelSet
forall a b. (a -> b) -> a -> b
$
                        (NatCmmDecl statics instr -> LabelSet)
-> [NatCmmDecl statics instr] -> [LabelSet]
forall a b. (a -> b) -> [a] -> [b]
map NatCmmDecl statics instr -> LabelSet
forall p d h i.
(IsSet p, ElemOf p ~ BlockId) =>
GenCmmDecl d h (ListGraph i) -> p
getBlockIds [NatCmmDecl statics instr]
procsSequenced
        diff :: LabelSet
diff = LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => set -> set -> set
setDifference LabelSet
blocks1 LabelSet
blocks2

        getBlockIds :: GenCmmDecl d h (ListGraph i) -> p
getBlockIds (CmmData _ _) = p
forall set. IsSet set => set
setEmpty
        getBlockIds (CmmProc _ _ _ (ListGraph blocks :: [GenBasicBlock i]
blocks)) =
                [ElemOf p] -> p
forall set. IsSet set => [ElemOf set] -> set
setFromList ([ElemOf p] -> p) -> [ElemOf p] -> p
forall a b. (a -> b) -> a -> b
$ (GenBasicBlock i -> BlockId) -> [GenBasicBlock i] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map GenBasicBlock i -> BlockId
forall i. GenBasicBlock i -> BlockId
blockId [GenBasicBlock i]
blocks


x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr
x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) Instr
-> NatCmmDecl (Alignment, CmmStatics) Instr
x86fp_kludge top :: NatCmmDecl (Alignment, CmmStatics) Instr
top@(CmmData _ _) = NatCmmDecl (Alignment, CmmStatics) Instr
top
x86fp_kludge (CmmProc info :: LabelMap CmmStatics
info lbl :: CLabel
lbl live :: [GlobalReg]
live (ListGraph code :: [NatBasicBlock Instr]
code)) =
        LabelMap CmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph Instr
-> NatCmmDecl (Alignment, CmmStatics) Instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap CmmStatics
info CLabel
lbl [GlobalReg]
live ([NatBasicBlock Instr] -> ListGraph Instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph ([NatBasicBlock Instr] -> ListGraph Instr)
-> [NatBasicBlock Instr] -> ListGraph Instr
forall a b. (a -> b) -> a -> b
$ [NatBasicBlock Instr] -> [NatBasicBlock Instr]
X86.Instr.i386_insert_ffrees [NatBasicBlock Instr]
code)

-- | Compute unwinding tables for the blocks of a procedure
computeUnwinding :: Instruction instr
                 => DynFlags -> NcgImpl statics instr jumpDest
                 -> NatCmmDecl statics instr
                    -- ^ the native code generated for the procedure
                 -> LabelMap [UnwindPoint]
                    -- ^ unwinding tables for all points of all blocks of the
                    -- procedure
computeUnwinding :: DynFlags
-> NcgImpl statics instr jumpDest
-> NatCmmDecl statics instr
-> LabelMap [UnwindPoint]
computeUnwinding dflags :: DynFlags
dflags _ _
  | DynFlags -> Alignment
debugLevel DynFlags
dflags Alignment -> Alignment -> Bool
forall a. Eq a => a -> a -> Bool
== 0         = LabelMap [UnwindPoint]
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
computeUnwinding _ _ (CmmData _ _) = LabelMap [UnwindPoint]
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
computeUnwinding _ ncgImpl :: NcgImpl statics instr jumpDest
ncgImpl (CmmProc _ _ _ (ListGraph blks :: [GenBasicBlock instr]
blks)) =
    -- In general we would need to push unwinding information down the
    -- block-level call-graph to ensure that we fully account for all
    -- relevant register writes within a procedure.
    --
    -- However, the only unwinding information that we care about in GHC is for
    -- Sp. The fact that CmmLayoutStack already ensures that we have unwind
    -- information at the beginning of every block means that there is no need
    -- to perform this sort of push-down.
    [(KeyOf LabelMap, [UnwindPoint])] -> LabelMap [UnwindPoint]
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (KeyOf LabelMap
BlockId
blk_lbl, NcgImpl statics instr jumpDest -> [instr] -> [UnwindPoint]
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> [instr] -> [UnwindPoint]
extractUnwindPoints NcgImpl statics instr jumpDest
ncgImpl [instr]
instrs)
                | BasicBlock blk_lbl :: BlockId
blk_lbl instrs :: [instr]
instrs <- [GenBasicBlock instr]
blks ]

-- | Build a doc for all the imports.
--
makeImportsDoc :: DynFlags -> [CLabel] -> SDoc
makeImportsDoc :: DynFlags -> [CLabel] -> SDoc
makeImportsDoc dflags :: DynFlags
dflags imports :: [CLabel]
imports
 = [CLabel] -> SDoc
dyld_stubs [CLabel]
imports
            SDoc -> SDoc -> SDoc
$$
            -- On recent versions of Darwin, the linker supports
            -- dead-stripping of code and data on a per-symbol basis.
            -- There's a hack to make this work in PprMach.pprNatCmmDecl.
            (if Platform -> Bool
platformHasSubsectionsViaSymbols Platform
platform
             then String -> SDoc
text ".subsections_via_symbols"
             else SDoc
Outputable.empty)
            SDoc -> SDoc -> SDoc
$$
                -- On recent GNU ELF systems one can mark an object file
                -- as not requiring an executable stack. If all objects
                -- linked into a program have this note then the program
                -- will not use an executable stack, which is good for
                -- security. GHC generated code does not need an executable
                -- stack so add the note in:
            (if Platform -> Bool
platformHasGnuNonexecStack Platform
platform
             then String -> SDoc
text ".section .note.GNU-stack,\"\"," SDoc -> SDoc -> SDoc
<> String -> SDoc
sectionType "progbits"
             else SDoc
Outputable.empty)
            SDoc -> SDoc -> SDoc
$$
                -- And just because every other compiler does, let's stick in
                -- an identifier directive: .ident "GHC x.y.z"
            (if Platform -> Bool
platformHasIdentDirective Platform
platform
             then let compilerIdent :: SDoc
compilerIdent = String -> SDoc
text "GHC" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
cProjectVersion
                   in String -> SDoc
text ".ident" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
doubleQuotes SDoc
compilerIdent
             else SDoc
Outputable.empty)

 where
        platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        arch :: Arch
arch = Platform -> Arch
platformArch Platform
platform
        os :: OS
os   = Platform -> OS
platformOS   Platform
platform

        -- Generate "symbol stubs" for all external symbols that might
        -- come from a dynamic library.
        dyld_stubs :: [CLabel] -> SDoc
{-      dyld_stubs imps = vcat $ map pprDyldSymbolStub $
                                    map head $ group $ sort imps-}
        -- (Hack) sometimes two Labels pretty-print the same, but have
        -- different uniques; so we compare their text versions...
        dyld_stubs :: [CLabel] -> SDoc
dyld_stubs imps :: [CLabel]
imps
                | DynFlags -> Arch -> OS -> Bool
needImportedSymbols DynFlags
dflags Arch
arch OS
os
                = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
                        (DynFlags -> Arch -> OS -> SDoc
pprGotDeclaration DynFlags
dflags Arch
arch OS
os SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
:) ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
                        ([(CLabel, String)] -> SDoc) -> [[(CLabel, String)]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ( DynFlags -> Platform -> CLabel -> SDoc
pprImportedSymbol DynFlags
dflags Platform
platform (CLabel -> SDoc)
-> ([(CLabel, String)] -> CLabel) -> [(CLabel, String)] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CLabel, String) -> CLabel
forall a b. (a, b) -> a
fst ((CLabel, String) -> CLabel)
-> ([(CLabel, String)] -> (CLabel, String))
-> [(CLabel, String)]
-> CLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CLabel, String)] -> (CLabel, String)
forall a. [a] -> a
head) ([[(CLabel, String)]] -> [SDoc]) -> [[(CLabel, String)]] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
                        ((CLabel, String) -> (CLabel, String) -> Bool)
-> [(CLabel, String)] -> [[(CLabel, String)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(_,a :: String
a) (_,b :: String
b) -> String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
b) ([(CLabel, String)] -> [[(CLabel, String)]])
-> [(CLabel, String)] -> [[(CLabel, String)]]
forall a b. (a -> b) -> a -> b
$
                        ((CLabel, String) -> (CLabel, String) -> Ordering)
-> [(CLabel, String)] -> [(CLabel, String)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(_,a :: String
a) (_,b :: String
b) -> String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare String
a String
b) ([(CLabel, String)] -> [(CLabel, String)])
-> [(CLabel, String)] -> [(CLabel, String)]
forall a b. (a -> b) -> a -> b
$
                        (CLabel -> (CLabel, String)) -> [CLabel] -> [(CLabel, String)]
forall a b. (a -> b) -> [a] -> [b]
map CLabel -> (CLabel, String)
doPpr ([CLabel] -> [(CLabel, String)]) -> [CLabel] -> [(CLabel, String)]
forall a b. (a -> b) -> a -> b
$
                        [CLabel]
imps
                | Bool
otherwise
                = SDoc
Outputable.empty

        doPpr :: CLabel -> (CLabel, String)
doPpr lbl :: CLabel
lbl = (CLabel
lbl, DynFlags -> SDoc -> PprStyle -> String
renderWithStyle DynFlags
dflags (Platform -> CLabel -> SDoc
pprCLabel Platform
platform CLabel
lbl) PprStyle
astyle)
        astyle :: PprStyle
astyle = CodeStyle -> PprStyle
mkCodeStyle CodeStyle
AsmStyle

-- -----------------------------------------------------------------------------
-- Generate jump tables

-- Analyzes all native code and generates data sections for all jump
-- table instructions.
generateJumpTables
        :: NcgImpl statics instr jumpDest
        -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
generateJumpTables :: NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
generateJumpTables ncgImpl :: NcgImpl statics instr jumpDest
ncgImpl xs :: [NatCmmDecl statics instr]
xs = (NatCmmDecl statics instr -> [NatCmmDecl statics instr])
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NatCmmDecl statics instr -> [NatCmmDecl statics instr]
f [NatCmmDecl statics instr]
xs
    where f :: NatCmmDecl statics instr -> [NatCmmDecl statics instr]
f p :: NatCmmDecl statics instr
p@(CmmProc _ _ _ (ListGraph xs :: [GenBasicBlock instr]
xs)) = NatCmmDecl statics instr
p NatCmmDecl statics instr
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
forall a. a -> [a] -> [a]
: (GenBasicBlock instr -> [NatCmmDecl statics instr])
-> [GenBasicBlock instr] -> [NatCmmDecl statics instr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenBasicBlock instr -> [NatCmmDecl statics instr]
g [GenBasicBlock instr]
xs
          f p :: NatCmmDecl statics instr
p = [NatCmmDecl statics instr
p]
          g :: GenBasicBlock instr -> [NatCmmDecl statics instr]
g (BasicBlock _ xs :: [instr]
xs) = [Maybe (NatCmmDecl statics instr)] -> [NatCmmDecl statics instr]
forall a. [Maybe a] -> [a]
catMaybes ((instr -> Maybe (NatCmmDecl statics instr))
-> [instr] -> [Maybe (NatCmmDecl statics instr)]
forall a b. (a -> b) -> [a] -> [b]
map (NcgImpl statics instr jumpDest
-> instr -> Maybe (NatCmmDecl statics instr)
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> instr -> Maybe (NatCmmDecl statics instr)
generateJumpTableForInstr NcgImpl statics instr jumpDest
ncgImpl) [instr]
xs)

-- -----------------------------------------------------------------------------
-- Shortcut branches

shortcutBranches
        :: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags
        -> NcgImpl statics instr jumpDest
        -> [NatCmmDecl statics instr]
        -> Maybe CFG
        -> ([NatCmmDecl statics instr],Maybe CFG)

shortcutBranches :: DynFlags
-> NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr]
-> Maybe CFG
-> ([NatCmmDecl statics instr], Maybe CFG)
shortcutBranches dflags :: DynFlags
dflags ncgImpl :: NcgImpl statics instr jumpDest
ncgImpl tops :: [NatCmmDecl statics instr]
tops weights :: Maybe CFG
weights
  | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AsmShortcutting DynFlags
dflags
  = ( (NatCmmDecl statics instr -> NatCmmDecl statics instr)
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
forall a b. (a -> b) -> [a] -> [b]
map (NcgImpl statics instr jumpDest
-> LabelMap jumpDest
-> NatCmmDecl statics instr
-> NatCmmDecl statics instr
forall statics instr jumpDest h.
NcgImpl statics instr jumpDest
-> LabelMap jumpDest
-> GenCmmDecl statics h (ListGraph instr)
-> GenCmmDecl statics h (ListGraph instr)
apply_mapping NcgImpl statics instr jumpDest
ncgImpl LabelMap jumpDest
mapping) [NatCmmDecl statics instr]
tops'
    , LabelMap (Maybe BlockId) -> CFG -> CFG
shortcutWeightMap LabelMap (Maybe BlockId)
mappingBid (CFG -> CFG) -> Maybe CFG -> Maybe CFG
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
<$!> Maybe CFG
weights )
  | Bool
otherwise
  = ([NatCmmDecl statics instr]
tops, Maybe CFG
weights)
  where
    (tops' :: [NatCmmDecl statics instr]
tops', mappings :: [LabelMap jumpDest]
mappings) = (NatCmmDecl statics instr
 -> (NatCmmDecl statics instr, LabelMap jumpDest))
-> [NatCmmDecl statics instr]
-> ([NatCmmDecl statics instr], [LabelMap jumpDest])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip (NcgImpl statics instr jumpDest
-> NatCmmDecl statics instr
-> (NatCmmDecl statics instr, LabelMap jumpDest)
forall instr t d statics jumpDest.
NcgImpl statics instr jumpDest
-> GenCmmDecl d (LabelMap t) (ListGraph instr)
-> (GenCmmDecl d (LabelMap t) (ListGraph instr), LabelMap jumpDest)
build_mapping NcgImpl statics instr jumpDest
ncgImpl) [NatCmmDecl statics instr]
tops
    mapping :: LabelMap jumpDest
mapping = [LabelMap jumpDest] -> LabelMap jumpDest
forall (map :: * -> *) a. IsMap map => [map a] -> map a
mapUnions [LabelMap jumpDest]
mappings :: LabelMap jumpDest
    mappingBid :: LabelMap (Maybe BlockId)
mappingBid = (jumpDest -> Maybe BlockId)
-> LabelMap jumpDest -> LabelMap (Maybe BlockId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NcgImpl statics instr jumpDest -> jumpDest -> Maybe BlockId
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> jumpDest -> Maybe BlockId
getJumpDestBlockId NcgImpl statics instr jumpDest
ncgImpl) LabelMap jumpDest
mapping

build_mapping :: forall instr t d statics jumpDest.
                 NcgImpl statics instr jumpDest
              -> GenCmmDecl d (LabelMap t) (ListGraph instr)
              -> (GenCmmDecl d (LabelMap t) (ListGraph instr)
                 ,LabelMap jumpDest)
build_mapping :: NcgImpl statics instr jumpDest
-> GenCmmDecl d (LabelMap t) (ListGraph instr)
-> (GenCmmDecl d (LabelMap t) (ListGraph instr), LabelMap jumpDest)
build_mapping _ top :: GenCmmDecl d (LabelMap t) (ListGraph instr)
top@(CmmData _ _) = (GenCmmDecl d (LabelMap t) (ListGraph instr)
top, LabelMap jumpDest
forall (map :: * -> *) a. IsMap map => map a
mapEmpty)
build_mapping _ (CmmProc info :: LabelMap t
info lbl :: CLabel
lbl live :: [GlobalReg]
live (ListGraph []))
  = (LabelMap t
-> CLabel
-> [GlobalReg]
-> ListGraph instr
-> GenCmmDecl d (LabelMap t) (ListGraph instr)
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap t
info CLabel
lbl [GlobalReg]
live ([GenBasicBlock instr] -> ListGraph instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph []), LabelMap jumpDest
forall (map :: * -> *) a. IsMap map => map a
mapEmpty)
build_mapping ncgImpl :: NcgImpl statics instr jumpDest
ncgImpl (CmmProc info :: LabelMap t
info lbl :: CLabel
lbl live :: [GlobalReg]
live (ListGraph (head :: GenBasicBlock instr
head:blocks :: [GenBasicBlock instr]
blocks)))
  = (LabelMap t
-> CLabel
-> [GlobalReg]
-> ListGraph instr
-> GenCmmDecl d (LabelMap t) (ListGraph instr)
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap t
info CLabel
lbl [GlobalReg]
live ([GenBasicBlock instr] -> ListGraph instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph (GenBasicBlock instr
headGenBasicBlock instr
-> [GenBasicBlock instr] -> [GenBasicBlock instr]
forall a. a -> [a] -> [a]
:[GenBasicBlock instr]
others)), LabelMap jumpDest
mapping)
        -- drop the shorted blocks, but don't ever drop the first one,
        -- because it is pointed to by a global label.
  where
    -- find all the blocks that just consist of a jump that can be
    -- shorted.
    -- Don't completely eliminate loops here -- that can leave a dangling jump!
    shortcut_blocks :: [(BlockId, jumpDest)]
    (_, shortcut_blocks :: [(BlockId, jumpDest)]
shortcut_blocks, others :: [GenBasicBlock instr]
others) =
        ((LabelSet, [(BlockId, jumpDest)], [GenBasicBlock instr])
 -> GenBasicBlock instr
 -> (LabelSet, [(BlockId, jumpDest)], [GenBasicBlock instr]))
-> (LabelSet, [(BlockId, jumpDest)], [GenBasicBlock instr])
-> [GenBasicBlock instr]
-> (LabelSet, [(BlockId, jumpDest)], [GenBasicBlock instr])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (LabelSet, [(BlockId, jumpDest)], [GenBasicBlock instr])
-> GenBasicBlock instr
-> (LabelSet, [(BlockId, jumpDest)], [GenBasicBlock instr])
split (LabelSet
forall set. IsSet set => set
setEmpty :: LabelSet, [], []) [GenBasicBlock instr]
blocks
    split :: (LabelSet, [(BlockId, jumpDest)], [GenBasicBlock instr])
-> GenBasicBlock instr
-> (LabelSet, [(BlockId, jumpDest)], [GenBasicBlock instr])
split (s :: LabelSet
s, shortcut_blocks :: [(BlockId, jumpDest)]
shortcut_blocks, others :: [GenBasicBlock instr]
others) b :: GenBasicBlock instr
b@(BasicBlock id :: BlockId
id [insn :: instr
insn])
        | Just jd :: jumpDest
jd <- NcgImpl statics instr jumpDest -> instr -> Maybe jumpDest
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> instr -> Maybe jumpDest
canShortcut NcgImpl statics instr jumpDest
ncgImpl instr
insn
        , Just dest :: BlockId
dest <- NcgImpl statics instr jumpDest -> jumpDest -> Maybe BlockId
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> jumpDest -> Maybe BlockId
getJumpDestBlockId NcgImpl statics instr jumpDest
ncgImpl jumpDest
jd
        , Bool -> Bool
not (BlockId -> Bool
has_info BlockId
id)
        , (ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf LabelSet
BlockId
dest LabelSet
s) Bool -> Bool -> Bool
|| BlockId
dest BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
id -- loop checks
        = (LabelSet
s, [(BlockId, jumpDest)]
shortcut_blocks, GenBasicBlock instr
b GenBasicBlock instr
-> [GenBasicBlock instr] -> [GenBasicBlock instr]
forall a. a -> [a] -> [a]
: [GenBasicBlock instr]
others)
    split (s :: LabelSet
s, shortcut_blocks :: [(BlockId, jumpDest)]
shortcut_blocks, others :: [GenBasicBlock instr]
others) (BasicBlock id :: BlockId
id [insn :: instr
insn])
        | Just dest :: jumpDest
dest <- NcgImpl statics instr jumpDest -> instr -> Maybe jumpDest
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> instr -> Maybe jumpDest
canShortcut NcgImpl statics instr jumpDest
ncgImpl instr
insn
        , Bool -> Bool
not (BlockId -> Bool
has_info BlockId
id)
        = (ElemOf LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert ElemOf LabelSet
BlockId
id LabelSet
s, (BlockId
id,jumpDest
dest) (BlockId, jumpDest)
-> [(BlockId, jumpDest)] -> [(BlockId, jumpDest)]
forall a. a -> [a] -> [a]
: [(BlockId, jumpDest)]
shortcut_blocks, [GenBasicBlock instr]
others)
    split (s :: LabelSet
s, shortcut_blocks :: [(BlockId, jumpDest)]
shortcut_blocks, others :: [GenBasicBlock instr]
others) other :: GenBasicBlock instr
other = (LabelSet
s, [(BlockId, jumpDest)]
shortcut_blocks, GenBasicBlock instr
other GenBasicBlock instr
-> [GenBasicBlock instr] -> [GenBasicBlock instr]
forall a. a -> [a] -> [a]
: [GenBasicBlock instr]
others)

    -- do not eliminate blocks that have an info table
    has_info :: BlockId -> Bool
has_info l :: BlockId
l = KeyOf LabelMap -> LabelMap t -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember KeyOf LabelMap
BlockId
l LabelMap t
info

    -- build a mapping from BlockId to JumpDest for shorting branches
    mapping :: LabelMap jumpDest
mapping = [(KeyOf LabelMap, jumpDest)] -> LabelMap jumpDest
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [(KeyOf LabelMap, jumpDest)]
[(BlockId, jumpDest)]
shortcut_blocks

apply_mapping :: NcgImpl statics instr jumpDest
              -> LabelMap jumpDest
              -> GenCmmDecl statics h (ListGraph instr)
              -> GenCmmDecl statics h (ListGraph instr)
apply_mapping :: NcgImpl statics instr jumpDest
-> LabelMap jumpDest
-> GenCmmDecl statics h (ListGraph instr)
-> GenCmmDecl statics h (ListGraph instr)
apply_mapping ncgImpl :: NcgImpl statics instr jumpDest
ncgImpl ufm :: LabelMap jumpDest
ufm (CmmData sec :: Section
sec statics :: statics
statics)
  = Section -> statics -> GenCmmDecl statics h (ListGraph instr)
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec (NcgImpl statics instr jumpDest
-> (BlockId -> Maybe jumpDest) -> statics -> statics
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> (BlockId -> Maybe jumpDest) -> statics -> statics
shortcutStatics NcgImpl statics instr jumpDest
ncgImpl (\bid :: BlockId
bid -> KeyOf LabelMap -> LabelMap jumpDest -> Maybe jumpDest
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
bid LabelMap jumpDest
ufm) statics
statics)
apply_mapping ncgImpl :: NcgImpl statics instr jumpDest
ncgImpl ufm :: LabelMap jumpDest
ufm (CmmProc info :: h
info lbl :: CLabel
lbl live :: [GlobalReg]
live (ListGraph blocks :: [GenBasicBlock instr]
blocks))
  = h
-> CLabel
-> [GlobalReg]
-> ListGraph instr
-> GenCmmDecl statics h (ListGraph instr)
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc h
info CLabel
lbl [GlobalReg]
live ([GenBasicBlock instr] -> ListGraph instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph ([GenBasicBlock instr] -> ListGraph instr)
-> [GenBasicBlock instr] -> ListGraph instr
forall a b. (a -> b) -> a -> b
$ (GenBasicBlock instr -> GenBasicBlock instr)
-> [GenBasicBlock instr] -> [GenBasicBlock instr]
forall a b. (a -> b) -> [a] -> [b]
map GenBasicBlock instr -> GenBasicBlock instr
short_bb [GenBasicBlock instr]
blocks)
  where
    short_bb :: GenBasicBlock instr -> GenBasicBlock instr
short_bb (BasicBlock id :: BlockId
id insns :: [instr]
insns) = BlockId -> [instr] -> GenBasicBlock instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id ([instr] -> GenBasicBlock instr) -> [instr] -> GenBasicBlock instr
forall a b. (a -> b) -> a -> b
$! (instr -> instr) -> [instr] -> [instr]
forall a b. (a -> b) -> [a] -> [b]
map instr -> instr
short_insn [instr]
insns
    short_insn :: instr -> instr
short_insn i :: instr
i = NcgImpl statics instr jumpDest
-> (BlockId -> Maybe jumpDest) -> instr -> instr
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> (BlockId -> Maybe jumpDest) -> instr -> instr
shortcutJump NcgImpl statics instr jumpDest
ncgImpl (\bid :: BlockId
bid -> KeyOf LabelMap -> LabelMap jumpDest -> Maybe jumpDest
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
bid LabelMap jumpDest
ufm) instr
i
                 -- shortcutJump should apply the mapping repeatedly,
                 -- just in case we can short multiple branches.

-- -----------------------------------------------------------------------------
-- Instruction selection

-- Native code instruction selection for a chunk of stix code.  For
-- this part of the computation, we switch from the UniqSM monad to
-- the NatM monad.  The latter carries not only a Unique, but also an
-- Int denoting the current C stack pointer offset in the generated
-- code; this is needed for creating correct spill offsets on
-- architectures which don't offer, or for which it would be
-- prohibitively expensive to employ, a frame pointer register.  Viz,
-- x86.

-- The offset is measured in bytes, and indicates the difference
-- between the current (simulated) C stack-ptr and the value it was at
-- the beginning of the block.  For stacks which grow down, this value
-- should be either zero or negative.

-- Along with the stack pointer offset, we also carry along a LabelMap of
-- DebugBlocks, which we read to generate .location directives.
--
-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction.  Is that bad?

genMachCode
        :: DynFlags
        -> Module -> ModLocation
        -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
        -> DwarfFiles
        -> LabelMap DebugBlock
        -> RawCmmDecl
        -> CFG
        -> UniqSM
                ( [NatCmmDecl statics instr]
                , [CLabel]
                , DwarfFiles
                , CFG
                )

genMachCode :: DynFlags
-> Module
-> ModLocation
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> CFG
-> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
genMachCode dflags :: DynFlags
dflags this_mod :: Module
this_mod modLoc :: ModLocation
modLoc cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr]
cmmTopCodeGen fileIds :: DwarfFiles
fileIds dbgMap :: LabelMap DebugBlock
dbgMap cmm_top :: RawCmmDecl
cmm_top cmm_cfg :: CFG
cmm_cfg
  = do  { UniqSupply
initial_us <- UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
        ; let initial_st :: NatM_State
initial_st           = UniqSupply
-> Alignment
-> DynFlags
-> Module
-> ModLocation
-> DwarfFiles
-> LabelMap DebugBlock
-> CFG
-> NatM_State
mkNatM_State UniqSupply
initial_us 0 DynFlags
dflags Module
this_mod
                                                  ModLocation
modLoc DwarfFiles
fileIds LabelMap DebugBlock
dbgMap CFG
cmm_cfg
              (new_tops :: [NatCmmDecl statics instr]
new_tops, final_st :: NatM_State
final_st) = NatM_State
-> NatM [NatCmmDecl statics instr]
-> ([NatCmmDecl statics instr], NatM_State)
forall a. NatM_State -> NatM a -> (a, NatM_State)
initNat NatM_State
initial_st (RawCmmDecl -> NatM [NatCmmDecl statics instr]
cmmTopCodeGen RawCmmDecl
cmm_top)
              final_delta :: Alignment
final_delta          = NatM_State -> Alignment
natm_delta NatM_State
final_st
              final_imports :: [CLabel]
final_imports        = NatM_State -> [CLabel]
natm_imports NatM_State
final_st
              final_cfg :: CFG
final_cfg            = NatM_State -> CFG
natm_cfg NatM_State
final_st
        ; if   Alignment
final_delta Alignment -> Alignment -> Bool
forall a. Eq a => a -> a -> Bool
== 0
          then ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
-> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
forall (m :: * -> *) a. Monad m => a -> m a
return ([NatCmmDecl statics instr]
new_tops, [CLabel]
final_imports
                      , NatM_State -> DwarfFiles
natm_fileid NatM_State
final_st, CFG
final_cfg)
          else String
-> SDoc
-> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "genMachCode: nonzero final delta" (Alignment -> SDoc
int Alignment
final_delta)
    }

-- -----------------------------------------------------------------------------
-- Generic Cmm optimiser

{-
Here we do:

  (a) Constant folding
  (c) Position independent code and dynamic linking
        (i)  introduce the appropriate indirections
             and position independent refs
        (ii) compile a list of imported symbols
  (d) Some arch-specific optimizations

(a) will be moving to the new Hoopl pipeline, however, (c) and
(d) are only needed by the native backend and will continue to live
here.

Ideas for other things we could do (put these in Hoopl please!):

  - shortcut jumps-to-jumps
  - simple CSE: if an expr is assigned to a temp, then replace later occs of
    that expr with the temp, until the expr is no longer valid (can push through
    temp assignments, and certain assigns to mem...)
-}

cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm _ _ top :: RawCmmDecl
top@(CmmData _ _) = (RawCmmDecl
top, [])
cmmToCmm dflags :: DynFlags
dflags this_mod :: Module
this_mod (CmmProc info :: LabelMap CmmStatics
info lbl :: CLabel
lbl live :: [GlobalReg]
live graph :: CmmGraph
graph)
    = DynFlags -> Module -> CmmOptM RawCmmDecl -> (RawCmmDecl, [CLabel])
forall a. DynFlags -> Module -> CmmOptM a -> (a, [CLabel])
runCmmOpt DynFlags
dflags Module
this_mod (CmmOptM RawCmmDecl -> (RawCmmDecl, [CLabel]))
-> CmmOptM RawCmmDecl -> (RawCmmDecl, [CLabel])
forall a b. (a -> b) -> a -> b
$
      do [CmmBlock]
blocks' <- (CmmBlock -> CmmOptM CmmBlock) -> [CmmBlock] -> CmmOptM [CmmBlock]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CmmBlock -> CmmOptM CmmBlock
cmmBlockConFold (CmmGraph -> [CmmBlock]
toBlockList CmmGraph
graph)
         RawCmmDecl -> CmmOptM RawCmmDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (RawCmmDecl -> CmmOptM RawCmmDecl)
-> RawCmmDecl -> CmmOptM RawCmmDecl
forall a b. (a -> b) -> a -> b
$ LabelMap CmmStatics
-> CLabel -> [GlobalReg] -> CmmGraph -> RawCmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap CmmStatics
info CLabel
lbl [GlobalReg]
live (BlockId -> [CmmBlock] -> CmmGraph
ofBlockList (CmmGraph -> BlockId
forall (n :: * -> * -> *). GenCmmGraph n -> BlockId
g_entry CmmGraph
graph) [CmmBlock]
blocks')

-- Avoids using unboxed tuples when loading into GHCi
#if !defined(GHC_LOADED_INTO_GHCI)

type OptMResult a = (# a, [CLabel] #)

pattern OptMResult :: a -> b -> (# a, b #)
pattern $bOptMResult :: a -> b -> (# a, b #)
$mOptMResult :: forall r a b. (# a, b #) -> (a -> b -> r) -> (Void# -> r) -> r
OptMResult x y = (# x, y #)
{-# COMPLETE OptMResult #-}
#else

data OptMResult a = OptMResult !a ![CLabel]
#endif

newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> OptMResult a)

instance Functor CmmOptM where
    fmap :: (a -> b) -> CmmOptM a -> CmmOptM b
fmap = (a -> b) -> CmmOptM a -> CmmOptM b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative CmmOptM where
    pure :: a -> CmmOptM a
pure x :: a
x = (DynFlags -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a
forall a.
(DynFlags -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((DynFlags -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a)
-> (DynFlags -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a
forall a b. (a -> b) -> a -> b
$ \_ _ imports :: [CLabel]
imports -> a -> [CLabel] -> OptMResult a
forall a b. a -> b -> (# a, b #)
OptMResult a
x [CLabel]
imports
    <*> :: CmmOptM (a -> b) -> CmmOptM a -> CmmOptM b
(<*>) = CmmOptM (a -> b) -> CmmOptM a -> CmmOptM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad CmmOptM where
  (CmmOptM f :: DynFlags -> Module -> [CLabel] -> OptMResult a
f) >>= :: CmmOptM a -> (a -> CmmOptM b) -> CmmOptM b
>>= g :: a -> CmmOptM b
g =
    (DynFlags -> Module -> [CLabel] -> OptMResult b) -> CmmOptM b
forall a.
(DynFlags -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((DynFlags -> Module -> [CLabel] -> OptMResult b) -> CmmOptM b)
-> (DynFlags -> Module -> [CLabel] -> OptMResult b) -> CmmOptM b
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags this_mod :: Module
this_mod imports0 :: [CLabel]
imports0 ->
                case DynFlags -> Module -> [CLabel] -> OptMResult a
f DynFlags
dflags Module
this_mod [CLabel]
imports0 of
                  OptMResult x :: a
x imports1 :: [CLabel]
imports1 ->
                    case a -> CmmOptM b
g a
x of
                      CmmOptM g' :: DynFlags -> Module -> [CLabel] -> OptMResult b
g' -> DynFlags -> Module -> [CLabel] -> OptMResult b
g' DynFlags
dflags Module
this_mod [CLabel]
imports1

instance CmmMakeDynamicReferenceM CmmOptM where
    addImport :: CLabel -> CmmOptM ()
addImport = CLabel -> CmmOptM ()
addImportCmmOpt
    getThisModule :: CmmOptM Module
getThisModule = (DynFlags -> Module -> [CLabel] -> OptMResult Module)
-> CmmOptM Module
forall a.
(DynFlags -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((DynFlags -> Module -> [CLabel] -> OptMResult Module)
 -> CmmOptM Module)
-> (DynFlags -> Module -> [CLabel] -> OptMResult Module)
-> CmmOptM Module
forall a b. (a -> b) -> a -> b
$ \_ this_mod :: Module
this_mod imports :: [CLabel]
imports -> Module -> [CLabel] -> OptMResult Module
forall a b. a -> b -> (# a, b #)
OptMResult Module
this_mod [CLabel]
imports

addImportCmmOpt :: CLabel -> CmmOptM ()
addImportCmmOpt :: CLabel -> CmmOptM ()
addImportCmmOpt lbl :: CLabel
lbl = (DynFlags -> Module -> [CLabel] -> OptMResult ()) -> CmmOptM ()
forall a.
(DynFlags -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((DynFlags -> Module -> [CLabel] -> OptMResult ()) -> CmmOptM ())
-> (DynFlags -> Module -> [CLabel] -> OptMResult ()) -> CmmOptM ()
forall a b. (a -> b) -> a -> b
$ \_ _ imports :: [CLabel]
imports -> () -> [CLabel] -> OptMResult ()
forall a b. a -> b -> (# a, b #)
OptMResult () (CLabel
lblCLabel -> [CLabel] -> [CLabel]
forall a. a -> [a] -> [a]
:[CLabel]
imports)

instance HasDynFlags CmmOptM where
    getDynFlags :: CmmOptM DynFlags
getDynFlags = (DynFlags -> Module -> [CLabel] -> OptMResult DynFlags)
-> CmmOptM DynFlags
forall a.
(DynFlags -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((DynFlags -> Module -> [CLabel] -> OptMResult DynFlags)
 -> CmmOptM DynFlags)
-> (DynFlags -> Module -> [CLabel] -> OptMResult DynFlags)
-> CmmOptM DynFlags
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags _ imports :: [CLabel]
imports -> DynFlags -> [CLabel] -> OptMResult DynFlags
forall a b. a -> b -> (# a, b #)
OptMResult DynFlags
dflags [CLabel]
imports

runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel])
runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel])
runCmmOpt dflags :: DynFlags
dflags this_mod :: Module
this_mod (CmmOptM f :: DynFlags -> Module -> [CLabel] -> OptMResult a
f) =
  case DynFlags -> Module -> [CLabel] -> OptMResult a
f DynFlags
dflags Module
this_mod [] of
    OptMResult result :: a
result imports :: [CLabel]
imports -> (a
result, [CLabel]
imports)

cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
cmmBlockConFold block :: CmmBlock
block = do
  let (entry :: CmmNode C O
entry, middle :: Block CmmNode O O
middle, last :: CmmNode O C
last) = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: * -> * -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
      stmts :: [CmmNode O O]
stmts = Block CmmNode O O -> [CmmNode O O]
forall (n :: * -> * -> *). Block n O O -> [n O O]
blockToList Block CmmNode O O
middle
  [CmmNode O O]
stmts' <- (CmmNode O O -> CmmOptM (CmmNode O O))
-> [CmmNode O O] -> CmmOptM [CmmNode O O]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CmmNode O O -> CmmOptM (CmmNode O O)
forall e x. CmmNode e x -> CmmOptM (CmmNode e x)
cmmStmtConFold [CmmNode O O]
stmts
  CmmNode O C
last' <- CmmNode O C -> CmmOptM (CmmNode O C)
forall e x. CmmNode e x -> CmmOptM (CmmNode e x)
cmmStmtConFold CmmNode O C
last
  CmmBlock -> CmmOptM CmmBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmBlock -> CmmOptM CmmBlock) -> CmmBlock -> CmmOptM CmmBlock
forall a b. (a -> b) -> a -> b
$ CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
forall (n :: * -> * -> *).
n C O -> Block n O O -> n O C -> Block n C C
blockJoin CmmNode C O
entry ([CmmNode O O] -> Block CmmNode O O
forall (n :: * -> * -> *). [n O O] -> Block n O O
blockFromList [CmmNode O O]
stmts') CmmNode O C
last'

-- This does three optimizations, but they're very quick to check, so we don't
-- bother turning them off even when the Hoopl code is active.  Since
-- this is on the old Cmm representation, we can't reuse the code either:
--  * reg = reg      --> nop
--  * if 0 then jump --> nop
--  * if 1 then jump --> jump
-- We might be tempted to skip this step entirely of not Opt_PIC, but
-- there is some PowerPC code for the non-PIC case, which would also
-- have to be separated.
cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)
cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)
cmmStmtConFold stmt :: CmmNode e x
stmt
   = case CmmNode e x
stmt of
        CmmAssign reg :: CmmReg
reg src :: CmmExpr
src
           -> do CmmExpr
src' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
src
                 CmmNode O O -> CmmOptM (CmmNode e x)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode O O -> CmmOptM (CmmNode e x))
-> CmmNode O O -> CmmOptM (CmmNode e x)
forall a b. (a -> b) -> a -> b
$ case CmmExpr
src' of
                   CmmReg reg' :: CmmReg
reg' | CmmReg
reg CmmReg -> CmmReg -> Bool
forall a. Eq a => a -> a -> Bool
== CmmReg
reg' -> FastString -> CmmNode O O
CmmComment (String -> FastString
fsLit "nop")
                   new_src :: CmmExpr
new_src -> CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
reg CmmExpr
new_src

        CmmStore addr :: CmmExpr
addr src :: CmmExpr
src
           -> do CmmExpr
addr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
addr
                 CmmExpr
src'  <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
src
                 CmmNode O O -> CmmOptM (CmmNode e x)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode O O -> CmmOptM (CmmNode e x))
-> CmmNode O O -> CmmOptM (CmmNode e x)
forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmExpr -> CmmNode O O
CmmStore CmmExpr
addr' CmmExpr
src'

        CmmCall { cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
addr }
           -> do CmmExpr
addr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
JumpReference CmmExpr
addr
                 CmmNode e x -> CmmOptM (CmmNode e x)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode e x -> CmmOptM (CmmNode e x))
-> CmmNode e x -> CmmOptM (CmmNode e x)
forall a b. (a -> b) -> a -> b
$ CmmNode e x
stmt { cml_target :: CmmExpr
cml_target = CmmExpr
addr' }

        CmmUnsafeForeignCall target :: ForeignTarget
target regs :: [CmmFormal]
regs args :: [CmmExpr]
args
           -> do ForeignTarget
target' <- case ForeignTarget
target of
                              ForeignTarget e :: CmmExpr
e conv :: ForeignConvention
conv -> do
                                CmmExpr
e' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
CallReference CmmExpr
e
                                ForeignTarget -> CmmOptM ForeignTarget
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignTarget -> CmmOptM ForeignTarget)
-> ForeignTarget -> CmmOptM ForeignTarget
forall a b. (a -> b) -> a -> b
$ CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget CmmExpr
e' ForeignConvention
conv
                              PrimTarget _ ->
                                ForeignTarget -> CmmOptM ForeignTarget
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignTarget
target
                 [CmmExpr]
args' <- (CmmExpr -> CmmOptM CmmExpr) -> [CmmExpr] -> CmmOptM [CmmExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference) [CmmExpr]
args
                 CmmNode O O -> CmmOptM (CmmNode e x)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode O O -> CmmOptM (CmmNode e x))
-> CmmNode O O -> CmmOptM (CmmNode e x)
forall a b. (a -> b) -> a -> b
$ ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmNode O O
CmmUnsafeForeignCall ForeignTarget
target' [CmmFormal]
regs [CmmExpr]
args'

        CmmCondBranch test :: CmmExpr
test true :: BlockId
true false :: BlockId
false likely :: Maybe Bool
likely
           -> do CmmExpr
test' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
test
                 CmmNode O C -> CmmOptM (CmmNode e x)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode O C -> CmmOptM (CmmNode e x))
-> CmmNode O C -> CmmOptM (CmmNode e x)
forall a b. (a -> b) -> a -> b
$ case CmmExpr
test' of
                   CmmLit (CmmInt 0 _) -> BlockId -> CmmNode O C
CmmBranch BlockId
false
                   CmmLit (CmmInt _ _) -> BlockId -> CmmNode O C
CmmBranch BlockId
true
                   _other :: CmmExpr
_other -> CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmNode O C
CmmCondBranch CmmExpr
test' BlockId
true BlockId
false Maybe Bool
likely

        CmmSwitch expr :: CmmExpr
expr ids :: SwitchTargets
ids
           -> do CmmExpr
expr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
expr
                 CmmNode O C -> CmmOptM (CmmNode e x)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode O C -> CmmOptM (CmmNode e x))
-> CmmNode O C -> CmmOptM (CmmNode e x)
forall a b. (a -> b) -> a -> b
$ CmmExpr -> SwitchTargets -> CmmNode O C
CmmSwitch CmmExpr
expr' SwitchTargets
ids

        other :: CmmNode e x
other
           -> CmmNode e x -> CmmOptM (CmmNode e x)
forall (m :: * -> *) a. Monad m => a -> m a
return CmmNode e x
other

cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold referenceKind :: ReferenceKind
referenceKind expr :: CmmExpr
expr = do
    DynFlags
dflags <- CmmOptM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

    -- With -O1 and greater, the cmmSink pass does constant-folding, so
    -- we don't need to do it again here.
    let expr' :: CmmExpr
expr' = if DynFlags -> Alignment
optLevel DynFlags
dflags Alignment -> Alignment -> Bool
forall a. Ord a => a -> a -> Bool
>= 1
                    then CmmExpr
expr
                    else DynFlags -> CmmExpr -> CmmExpr
cmmExprCon DynFlags
dflags CmmExpr
expr

    ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
referenceKind CmmExpr
expr'

cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr
cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr
cmmExprCon dflags :: DynFlags
dflags (CmmLoad addr :: CmmExpr
addr rep :: CmmType
rep) = CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> CmmExpr
cmmExprCon DynFlags
dflags CmmExpr
addr) CmmType
rep
cmmExprCon dflags :: DynFlags
dflags (CmmMachOp mop :: MachOp
mop args :: [CmmExpr]
args)
    = DynFlags -> MachOp -> [CmmExpr] -> CmmExpr
cmmMachOpFold DynFlags
dflags MachOp
mop ((CmmExpr -> CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> CmmExpr -> CmmExpr
cmmExprCon DynFlags
dflags) [CmmExpr]
args)
cmmExprCon _ other :: CmmExpr
other = CmmExpr
other

-- handles both PIC and non-PIC cases... a very strange mixture
-- of things to do.
cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative referenceKind :: ReferenceKind
referenceKind expr :: CmmExpr
expr = do
     DynFlags
dflags <- CmmOptM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
     let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
         arch :: Arch
arch = Platform -> Arch
platformArch Platform
platform
     case CmmExpr
expr of
        CmmLoad addr :: CmmExpr
addr rep :: CmmType
rep
           -> do CmmExpr
addr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
DataReference CmmExpr
addr
                 CmmExpr -> CmmOptM CmmExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmExpr -> CmmOptM CmmExpr) -> CmmExpr -> CmmOptM CmmExpr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmType -> CmmExpr
CmmLoad CmmExpr
addr' CmmType
rep

        CmmMachOp mop :: MachOp
mop args :: [CmmExpr]
args
           -> do [CmmExpr]
args' <- (CmmExpr -> CmmOptM CmmExpr) -> [CmmExpr] -> CmmOptM [CmmExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
DataReference) [CmmExpr]
args
                 CmmExpr -> CmmOptM CmmExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmExpr -> CmmOptM CmmExpr) -> CmmExpr -> CmmOptM CmmExpr
forall a b. (a -> b) -> a -> b
$ MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
mop [CmmExpr]
args'

        CmmLit (CmmBlock id :: BlockId
id)
           -> ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
referenceKind (CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (BlockId -> CLabel
infoTblLbl BlockId
id)))
           -- we must convert block Ids to CLabels here, because we
           -- might have to do the PIC transformation.  Hence we must
           -- not modify BlockIds beyond this point.

        CmmLit (CmmLabel lbl :: CLabel
lbl)
           -> do
                DynFlags -> ReferenceKind -> CLabel -> CmmOptM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
referenceKind CLabel
lbl
        CmmLit (CmmLabelOff lbl :: CLabel
lbl off :: Alignment
off)
           -> do
                 CmmExpr
dynRef <- DynFlags -> ReferenceKind -> CLabel -> CmmOptM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
referenceKind CLabel
lbl
                 -- need to optimize here, since it's late
                 CmmExpr -> CmmOptM CmmExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmExpr -> CmmOptM CmmExpr) -> CmmExpr -> CmmOptM CmmExpr
forall a b. (a -> b) -> a -> b
$ DynFlags -> MachOp -> [CmmExpr] -> CmmExpr
cmmMachOpFold DynFlags
dflags (Width -> MachOp
MO_Add (DynFlags -> Width
wordWidth DynFlags
dflags)) [
                     CmmExpr
dynRef,
                     (CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt (Alignment -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Alignment
off) (DynFlags -> Width
wordWidth DynFlags
dflags))
                   ]

        -- On powerpc (non-PIC), it's easier to jump directly to a label than
        -- to use the register table, so we replace these registers
        -- with the corresponding labels:
        CmmReg (CmmGlobal EagerBlackholeInfo)
          | Arch
arch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchPPC Bool -> Bool -> Bool
&& Bool -> Bool
not (DynFlags -> Bool
positionIndependent DynFlags
dflags)
          -> ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
referenceKind (CmmExpr -> CmmOptM CmmExpr) -> CmmExpr -> CmmOptM CmmExpr
forall a b. (a -> b) -> a -> b
$
             CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
rtsUnitId (String -> FastString
fsLit "__stg_EAGER_BLACKHOLE_info")))
        CmmReg (CmmGlobal GCEnter1)
          | Arch
arch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchPPC Bool -> Bool -> Bool
&& Bool -> Bool
not (DynFlags -> Bool
positionIndependent DynFlags
dflags)
          -> ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
referenceKind (CmmExpr -> CmmOptM CmmExpr) -> CmmExpr -> CmmOptM CmmExpr
forall a b. (a -> b) -> a -> b
$
             CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
rtsUnitId (String -> FastString
fsLit "__stg_gc_enter_1")))
        CmmReg (CmmGlobal GCFun)
          | Arch
arch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchPPC Bool -> Bool -> Bool
&& Bool -> Bool
not (DynFlags -> Bool
positionIndependent DynFlags
dflags)
          -> ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
referenceKind (CmmExpr -> CmmOptM CmmExpr) -> CmmExpr -> CmmOptM CmmExpr
forall a b. (a -> b) -> a -> b
$
             CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
rtsUnitId (String -> FastString
fsLit "__stg_gc_fun")))

        other :: CmmExpr
other
           -> CmmExpr -> CmmOptM CmmExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CmmExpr
other