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

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

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

{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

module GHC.CmmToAsm (
                    -- * 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"

import GHC.Prelude

import qualified GHC.CmmToAsm.X86.CodeGen as X86.CodeGen
import qualified GHC.CmmToAsm.X86.Regs    as X86.Regs
import qualified GHC.CmmToAsm.X86.Instr   as X86.Instr
import qualified GHC.CmmToAsm.X86.Ppr     as X86.Ppr

import qualified GHC.CmmToAsm.SPARC.CodeGen as SPARC.CodeGen
import qualified GHC.CmmToAsm.SPARC.Regs    as SPARC.Regs
import qualified GHC.CmmToAsm.SPARC.Instr   as SPARC.Instr
import qualified GHC.CmmToAsm.SPARC.Ppr     as SPARC.Ppr
import qualified GHC.CmmToAsm.SPARC.ShortcutJump   as SPARC.ShortcutJump
import qualified GHC.CmmToAsm.SPARC.CodeGen.Expand as SPARC.CodeGen.Expand

import qualified GHC.CmmToAsm.PPC.CodeGen as PPC.CodeGen
import qualified GHC.CmmToAsm.PPC.Regs    as PPC.Regs
import qualified GHC.CmmToAsm.PPC.RegInfo as PPC.RegInfo
import qualified GHC.CmmToAsm.PPC.Instr   as PPC.Instr
import qualified GHC.CmmToAsm.PPC.Ppr     as PPC.Ppr

import GHC.CmmToAsm.Reg.Liveness
import qualified GHC.CmmToAsm.Reg.Linear                as Linear

import qualified GHC.Data.Graph.Color                   as Color
import qualified GHC.CmmToAsm.Reg.Graph                 as Color
import qualified GHC.CmmToAsm.Reg.Graph.Stats           as Color
import qualified GHC.CmmToAsm.Reg.Graph.TrivColorable   as Color

import GHC.Utils.Asm
import GHC.CmmToAsm.Reg.Target
import GHC.Platform
import GHC.CmmToAsm.BlockLayout as BlockLayout
import GHC.Settings.Config
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.PIC
import GHC.Platform.Reg
import GHC.Platform.Reg.Class (RegClass)
import GHC.CmmToAsm.Monad
import GHC.CmmToAsm.CFG
import GHC.CmmToAsm.Dwarf
import GHC.CmmToAsm.Config
import GHC.Cmm.DebugBlock

import GHC.Cmm.BlockId
import GHC.StgToCmm.CgUtils ( fixStgRegisters )
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Opt           ( cmmMachOpFold )
import GHC.Cmm.Ppr
import GHC.Cmm.CLabel

import GHC.Types.Unique.FM
import GHC.Types.Unique.Supply
import GHC.Driver.Session
import GHC.Utils.Misc

import GHC.Types.Basic       ( Alignment )
import qualified GHC.Utils.Ppr as Pretty
import GHC.Utils.BufHandle
import GHC.Utils.Outputable as Outputable
import GHC.Data.FastString
import GHC.Types.Unique.Set
import GHC.Utils.Error
import GHC.Unit
import GHC.Data.Stream (Stream)
import qualified GHC.Data.Stream as Stream

-- DEBUGGING ONLY
--import GHC.Data.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 :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqSupply
              -> Stream IO RawCmmGroup a
              -> IO a
nativeCodeGen :: forall a.
DynFlags
-> Module
-> ModLocation
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen DynFlags
dflags Module
this_mod ModLocation
modLoc Handle
h UniqSupply
us Stream IO RawCmmGroup a
cmms
 = let config :: NCGConfig
config   = DynFlags -> NCGConfig
initConfig DynFlags
dflags
       platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
       nCG' :: ( Outputable statics, Outputable instr
               , Outputable jumpDest, Instruction instr)
            => NcgImpl statics instr jumpDest -> IO a
       nCG' :: forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO a
nCG' NcgImpl statics instr jumpDest
ncgImpl = DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
forall statics instr jumpDest a.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen' DynFlags
dflags Module
this_mod ModLocation
modLoc NcgImpl statics instr jumpDest
ncgImpl Handle
h UniqSupply
us Stream IO RawCmmGroup a
cmms
   in case Platform -> Arch
platformArch Platform
platform of
      Arch
ArchX86       -> NcgImpl (Alignment, RawCmmStatics) Instr JumpDest -> IO a
forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO a
nCG' (NCGConfig -> NcgImpl (Alignment, RawCmmStatics) Instr JumpDest
x86NcgImpl    NCGConfig
config)
      Arch
ArchX86_64    -> NcgImpl (Alignment, RawCmmStatics) Instr JumpDest -> IO a
forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO a
nCG' (NCGConfig -> NcgImpl (Alignment, RawCmmStatics) Instr JumpDest
x86_64NcgImpl NCGConfig
config)
      Arch
ArchPPC       -> NcgImpl RawCmmStatics Instr JumpDest -> IO a
forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO a
nCG' (NCGConfig -> NcgImpl RawCmmStatics Instr JumpDest
ppcNcgImpl    NCGConfig
config)
      Arch
ArchS390X     -> String -> IO a
forall a. String -> a
panic String
"nativeCodeGen: No NCG for S390X"
      Arch
ArchSPARC     -> NcgImpl RawCmmStatics Instr JumpDest -> IO a
forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO a
nCG' (NCGConfig -> NcgImpl RawCmmStatics Instr JumpDest
sparcNcgImpl  NCGConfig
config)
      Arch
ArchSPARC64   -> String -> IO a
forall a. String -> a
panic String
"nativeCodeGen: No NCG for SPARC64"
      ArchARM {}    -> String -> IO a
forall a. String -> a
panic String
"nativeCodeGen: No NCG for ARM"
      Arch
ArchAArch64   -> String -> IO a
forall a. String -> a
panic String
"nativeCodeGen: No NCG for AArch64"
      ArchPPC_64 PPC_64ABI
_  -> NcgImpl RawCmmStatics Instr JumpDest -> IO a
forall statics instr jumpDest.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO a
nCG' (NCGConfig -> NcgImpl RawCmmStatics Instr JumpDest
ppcNcgImpl    NCGConfig
config)
      Arch
ArchAlpha     -> String -> IO a
forall a. String -> a
panic String
"nativeCodeGen: No NCG for Alpha"
      Arch
ArchMipseb    -> String -> IO a
forall a. String -> a
panic String
"nativeCodeGen: No NCG for mipseb"
      Arch
ArchMipsel    -> String -> IO a
forall a. String -> a
panic String
"nativeCodeGen: No NCG for mipsel"
      Arch
ArchUnknown   -> String -> IO a
forall a. String -> a
panic String
"nativeCodeGen: No NCG for unknown arch"
      Arch
ArchJavaScript-> String -> IO a
forall a. String -> a
panic String
"nativeCodeGen: No NCG for JavaScript"

x86NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics)
                                  X86.Instr.Instr X86.Instr.JumpDest
x86NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) Instr JumpDest
x86NcgImpl NCGConfig
config
 = (NCGConfig -> NcgImpl (Alignment, RawCmmStatics) Instr JumpDest
x86_64NcgImpl NCGConfig
config)

x86_64NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics)
                                  X86.Instr.Instr X86.Instr.JumpDest
x86_64NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) Instr JumpDest
x86_64NcgImpl NCGConfig
config
 = NcgImpl :: forall statics instr jumpDest.
NCGConfig
-> (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)
-> Int
-> [RealReg]
-> ([NatCmmDecl statics instr] -> [NatCmmDecl statics instr])
-> (Int
    -> NatCmmDecl statics instr
    -> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)]))
-> (LabelMap RawCmmStatics
    -> [NatBasicBlock instr] -> [NatBasicBlock instr])
-> ([instr] -> [UnwindPoint])
-> (Maybe CFG
    -> LabelMap RawCmmStatics
    -> [NatBasicBlock instr]
    -> [NatBasicBlock instr])
-> NcgImpl statics instr jumpDest
NcgImpl {
        ncgConfig :: NCGConfig
ncgConfig                 = NCGConfig
config
       ,cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]
cmmTopCodeGen             = RawCmmDecl -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]
X86.CodeGen.cmmTopCodeGen
       ,generateJumpTableForInstr :: Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)
generateJumpTableForInstr = NCGConfig
-> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)
X86.CodeGen.generateJumpTableForInstr NCGConfig
config
       ,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, RawCmmStatics) -> (Alignment, RawCmmStatics)
shortcutStatics           = (BlockId -> Maybe JumpDest)
-> (Alignment, RawCmmStatics) -> (Alignment, RawCmmStatics)
X86.Instr.shortcutStatics
       ,shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
shortcutJump              = (BlockId -> Maybe JumpDest) -> Instr -> Instr
X86.Instr.shortcutJump
       ,pprNatCmmDecl :: NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc
pprNatCmmDecl             = NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc
X86.Ppr.pprNatCmmDecl NCGConfig
config
       ,maxSpillSlots :: Int
maxSpillSlots             = NCGConfig -> Int
X86.Instr.maxSpillSlots NCGConfig
config
       ,allocatableRegs :: [RealReg]
allocatableRegs           = Platform -> [RealReg]
X86.Regs.allocatableRegs Platform
platform
       ,ncgAllocMoreStack :: Int
-> NatCmmDecl (Alignment, RawCmmStatics) Instr
-> UniqSM
     (NatCmmDecl (Alignment, RawCmmStatics) Instr, [(BlockId, BlockId)])
ncgAllocMoreStack         = Platform
-> Int
-> NatCmmDecl (Alignment, RawCmmStatics) Instr
-> UniqSM
     (NatCmmDecl (Alignment, RawCmmStatics) Instr, [(BlockId, BlockId)])
forall statics.
Platform
-> Int
-> NatCmmDecl statics Instr
-> UniqSM (NatCmmDecl statics Instr, [(BlockId, BlockId)])
X86.Instr.allocMoreStack Platform
platform
       ,ncgExpandTop :: [NatCmmDecl (Alignment, RawCmmStatics) Instr]
-> [NatCmmDecl (Alignment, RawCmmStatics) Instr]
ncgExpandTop              = [NatCmmDecl (Alignment, RawCmmStatics) Instr]
-> [NatCmmDecl (Alignment, RawCmmStatics) Instr]
forall a. a -> a
id
       ,ncgMakeFarBranches :: LabelMap RawCmmStatics
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
ncgMakeFarBranches        = ([NatBasicBlock Instr] -> [NatBasicBlock Instr])
-> LabelMap RawCmmStatics
-> [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 RawCmmStatics
-> [NatBasicBlock Instr]
-> [NatBasicBlock Instr]
invertCondBranches        = Maybe CFG
-> LabelMap RawCmmStatics
-> [NatBasicBlock Instr]
-> [NatBasicBlock Instr]
forall a.
Maybe CFG
-> LabelMap a -> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
X86.CodeGen.invertCondBranches
   }
    where
      platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config

ppcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest
ppcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics Instr JumpDest
ppcNcgImpl NCGConfig
config
 = NcgImpl :: forall statics instr jumpDest.
NCGConfig
-> (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)
-> Int
-> [RealReg]
-> ([NatCmmDecl statics instr] -> [NatCmmDecl statics instr])
-> (Int
    -> NatCmmDecl statics instr
    -> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)]))
-> (LabelMap RawCmmStatics
    -> [NatBasicBlock instr] -> [NatBasicBlock instr])
-> ([instr] -> [UnwindPoint])
-> (Maybe CFG
    -> LabelMap RawCmmStatics
    -> [NatBasicBlock instr]
    -> [NatBasicBlock instr])
-> NcgImpl statics instr jumpDest
NcgImpl {
        ncgConfig :: NCGConfig
ncgConfig                 = NCGConfig
config
       ,cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl RawCmmStatics Instr]
cmmTopCodeGen             = RawCmmDecl -> NatM [NatCmmDecl RawCmmStatics Instr]
PPC.CodeGen.cmmTopCodeGen
       ,generateJumpTableForInstr :: Instr -> Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr = NCGConfig -> Instr -> Maybe (NatCmmDecl RawCmmStatics Instr)
PPC.CodeGen.generateJumpTableForInstr NCGConfig
config
       ,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) -> RawCmmStatics -> RawCmmStatics
shortcutStatics           = (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics
PPC.RegInfo.shortcutStatics
       ,shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
shortcutJump              = (BlockId -> Maybe JumpDest) -> Instr -> Instr
PPC.RegInfo.shortcutJump
       ,pprNatCmmDecl :: NatCmmDecl RawCmmStatics Instr -> SDoc
pprNatCmmDecl             = NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc
PPC.Ppr.pprNatCmmDecl NCGConfig
config
       ,maxSpillSlots :: Int
maxSpillSlots             = NCGConfig -> Int
PPC.Instr.maxSpillSlots NCGConfig
config
       ,allocatableRegs :: [RealReg]
allocatableRegs           = Platform -> [RealReg]
PPC.Regs.allocatableRegs Platform
platform
       ,ncgAllocMoreStack :: Int
-> NatCmmDecl RawCmmStatics Instr
-> UniqSM (NatCmmDecl RawCmmStatics Instr, [(BlockId, BlockId)])
ncgAllocMoreStack         = Platform
-> Int
-> NatCmmDecl RawCmmStatics Instr
-> UniqSM (NatCmmDecl RawCmmStatics Instr, [(BlockId, BlockId)])
forall statics.
Platform
-> Int
-> NatCmmDecl statics Instr
-> UniqSM (NatCmmDecl statics Instr, [(BlockId, BlockId)])
PPC.Instr.allocMoreStack Platform
platform
       ,ncgExpandTop :: [NatCmmDecl RawCmmStatics Instr]
-> [NatCmmDecl RawCmmStatics Instr]
ncgExpandTop              = [NatCmmDecl RawCmmStatics Instr]
-> [NatCmmDecl RawCmmStatics Instr]
forall a. a -> a
id
       ,ncgMakeFarBranches :: LabelMap RawCmmStatics
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
ncgMakeFarBranches        = LabelMap RawCmmStatics
-> [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 RawCmmStatics
-> [NatBasicBlock Instr]
-> [NatBasicBlock Instr]
invertCondBranches        = \Maybe CFG
_ LabelMap RawCmmStatics
_ -> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> a
id
   }
    where
      platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config

sparcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest
sparcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics Instr JumpDest
sparcNcgImpl NCGConfig
config
 = NcgImpl :: forall statics instr jumpDest.
NCGConfig
-> (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)
-> Int
-> [RealReg]
-> ([NatCmmDecl statics instr] -> [NatCmmDecl statics instr])
-> (Int
    -> NatCmmDecl statics instr
    -> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)]))
-> (LabelMap RawCmmStatics
    -> [NatBasicBlock instr] -> [NatBasicBlock instr])
-> ([instr] -> [UnwindPoint])
-> (Maybe CFG
    -> LabelMap RawCmmStatics
    -> [NatBasicBlock instr]
    -> [NatBasicBlock instr])
-> NcgImpl statics instr jumpDest
NcgImpl {
        ncgConfig :: NCGConfig
ncgConfig                 = NCGConfig
config
       ,cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl RawCmmStatics Instr]
cmmTopCodeGen             = RawCmmDecl -> NatM [NatCmmDecl RawCmmStatics Instr]
SPARC.CodeGen.cmmTopCodeGen
       ,generateJumpTableForInstr :: Instr -> Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr = Platform -> Instr -> Maybe (NatCmmDecl RawCmmStatics Instr)
SPARC.CodeGen.generateJumpTableForInstr Platform
platform
       ,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) -> RawCmmStatics -> RawCmmStatics
shortcutStatics           = (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics
SPARC.ShortcutJump.shortcutStatics
       ,shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
shortcutJump              = (BlockId -> Maybe JumpDest) -> Instr -> Instr
SPARC.ShortcutJump.shortcutJump
       ,pprNatCmmDecl :: NatCmmDecl RawCmmStatics Instr -> SDoc
pprNatCmmDecl             = NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc
SPARC.Ppr.pprNatCmmDecl NCGConfig
config
       ,maxSpillSlots :: Int
maxSpillSlots             = NCGConfig -> Int
SPARC.Instr.maxSpillSlots NCGConfig
config
       ,allocatableRegs :: [RealReg]
allocatableRegs           = [RealReg]
SPARC.Regs.allocatableRegs
       ,ncgAllocMoreStack :: Int
-> NatCmmDecl RawCmmStatics Instr
-> UniqSM (NatCmmDecl RawCmmStatics Instr, [(BlockId, BlockId)])
ncgAllocMoreStack         = Int
-> NatCmmDecl RawCmmStatics Instr
-> UniqSM (NatCmmDecl RawCmmStatics Instr, [(BlockId, BlockId)])
forall statics instr.
Int
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
noAllocMoreStack
       ,ncgExpandTop :: [NatCmmDecl RawCmmStatics Instr]
-> [NatCmmDecl RawCmmStatics Instr]
ncgExpandTop              = (NatCmmDecl RawCmmStatics Instr -> NatCmmDecl RawCmmStatics Instr)
-> [NatCmmDecl RawCmmStatics Instr]
-> [NatCmmDecl RawCmmStatics Instr]
forall a b. (a -> b) -> [a] -> [b]
map NatCmmDecl RawCmmStatics Instr -> NatCmmDecl RawCmmStatics Instr
SPARC.CodeGen.Expand.expandTop
       ,ncgMakeFarBranches :: LabelMap RawCmmStatics
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
ncgMakeFarBranches        = ([NatBasicBlock Instr] -> [NatBasicBlock Instr])
-> LabelMap RawCmmStatics
-> [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 RawCmmStatics
-> [NatBasicBlock Instr]
-> [NatBasicBlock Instr]
invertCondBranches        = \Maybe CFG
_ LabelMap RawCmmStatics
_ -> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> a
id
   }
    where
      platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config

--
-- 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 :: forall statics instr.
Int
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
noAllocMoreStack Int
amount NatCmmDecl statics instr
_
  = 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
$   String
"Register allocator: out of stack slots (need " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
amount String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
"   If you are trying to compile SHA1.hs from the crypto library then this\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
"   is a known limitation in the linear allocator.\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
"\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
"   Try enabling the graph colouring allocator with -fregs-graph instead."
        String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
"   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 { forall statics instr. NativeGenAcc statics instr -> [[CLabel]]
ngs_imports     :: ![[CLabel]]
        , forall statics instr.
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.
        , forall statics instr.
NativeGenAcc statics instr -> [[RegAllocStats statics instr]]
ngs_colorStats  :: ![[Color.RegAllocStats statics instr]]
        , forall statics instr.
NativeGenAcc statics instr -> [[RegAllocStats]]
ngs_linearStats :: ![[Linear.RegAllocStats]]
        , forall statics instr. NativeGenAcc statics instr -> [BlockId]
ngs_labels      :: ![Label]
        , forall statics instr. NativeGenAcc statics instr -> [DebugBlock]
ngs_debug       :: ![DebugBlock]
        , forall statics instr. NativeGenAcc statics instr -> DwarfFiles
ngs_dwarfFiles  :: !DwarfFiles
        , forall statics instr.
NativeGenAcc statics instr -> LabelMap [UnwindPoint]
ngs_unwinds     :: !(LabelMap [UnwindPoint])
             -- ^ see Note [Unwinding information in the NCG]
             -- and Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
        }

{-
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 "GHC.Cmm.DebugBlock".
-}

nativeCodeGen' :: (Outputable statics, Outputable instr,Outputable jumpDest,
                   Instruction instr)
               => DynFlags
               -> Module -> ModLocation
               -> NcgImpl statics instr jumpDest
               -> Handle
               -> UniqSupply
               -> Stream IO RawCmmGroup a
               -> IO a
nativeCodeGen' :: forall statics instr jumpDest a.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen' DynFlags
dflags Module
this_mod ModLocation
modLoc NcgImpl statics instr jumpDest
ncgImpl Handle
h UniqSupply
us Stream IO RawCmmGroup a
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 key elt. UniqFM key elt
emptyUFM LabelMap [UnwindPoint]
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
        (NativeGenAcc statics instr
ngs, UniqSupply
us', a
a) <- DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
forall statics instr jumpDest a.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
cmmNativeGenStream DynFlags
dflags Module
this_mod ModLocation
modLoc NcgImpl statics instr jumpDest
ncgImpl BufHandle
bufh UniqSupply
us
                                         Stream IO RawCmmGroup a
cmms NativeGenAcc statics instr
forall {statics} {instr}. NativeGenAcc statics instr
ngs0
        UniqSupply
_ <- 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
        a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

finishNativeGen :: Instruction instr
                => DynFlags
                -> ModLocation
                -> BufHandle
                -> UniqSupply
                -> NativeGenAcc statics instr
                -> IO UniqSupply
finishNativeGen :: forall instr statics.
Instruction instr =>
DynFlags
-> ModLocation
-> BufHandle
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
finishNativeGen DynFlags
dflags ModLocation
modLoc bufh :: BufHandle
bufh@(BufHandle Ptr Word8
_ FastMutInt
_ Handle
h) UniqSupply
us NativeGenAcc statics instr
ngs
 = DynFlags
-> SDoc -> (UniqSupply -> ()) -> IO UniqSupply -> IO UniqSupply
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent DynFlags
dflags (String -> SDoc
text String
"NCG") (UniqSupply -> () -> ()
`seq` ()) (IO UniqSupply -> IO UniqSupply) -> IO UniqSupply -> IO UniqSupply
forall a b. (a -> b) -> a -> b
$ do
        -- Write debug data and finish
        let emitDw :: Bool
emitDw = DynFlags -> Int
debugLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        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
          (SDoc
dwarf, 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 ()
unless ([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 -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                  DumpFlag
Opt_D_dump_asm_conflicts String
"Register conflict graph"
                  DumpFormat
FormatText
                  (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 -> Int)
-> (RegClass -> RealReg -> Int)
-> Triv VirtualReg RegClass RealReg
Color.trivColorable Platform
platform
                                  (Platform -> RegClass -> VirtualReg -> Int
targetVirtualRegSqueeze Platform
platform)
                                  (Platform -> RegClass -> RealReg -> Int
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 ()
unless ([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
        let ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags (CodeStyle -> PprStyle
mkCodeStyle CodeStyle
AsmStyle)
        SDocContext -> Mode -> Handle -> SDoc -> IO ()
printSDocLn SDocContext
ctx Mode
Pretty.LeftMode Handle
h
                (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 = DumpAction
dumpAction DynFlags
dflags (PrintUnqualified -> PprStyle
mkDumpStyle PrintUnqualified
alwaysQualify)
                   (DumpFlag -> DumpOptions
dumpOptionsFromFlag DumpFlag
Opt_D_dump_asm_stats) String
"NCG stats"
                   DumpFormat
FormatText

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

cmmNativeGenStream :: forall statics instr jumpDest a.
(Outputable statics, Outputable instr, Outputable jumpDest,
 Instruction instr) =>
DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
cmmNativeGenStream DynFlags
dflags Module
this_mod ModLocation
modLoc NcgImpl statics instr jumpDest
ncgImpl BufHandle
h UniqSupply
us Stream IO RawCmmGroup a
cmm_stream NativeGenAcc statics instr
ngs
 = do Either a (RawCmmGroup, Stream IO RawCmmGroup a)
r <- Stream IO RawCmmGroup a
-> IO (Either a (RawCmmGroup, Stream IO RawCmmGroup a))
forall (m :: * -> *) a b.
Stream m a b -> m (Either b (a, Stream m a b))
Stream.runStream Stream IO RawCmmGroup a
cmm_stream
      case Either a (RawCmmGroup, Stream IO RawCmmGroup a)
r of
        Left a
a ->
          (NativeGenAcc statics instr, UniqSupply, a)
-> IO (NativeGenAcc statics instr, UniqSupply, a)
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,
                  a
a)
        Right (RawCmmGroup
cmms, Stream IO RawCmmGroup a
cmm_stream') -> do
          (UniqSupply
us', NativeGenAcc statics instr
ngs'') <-
            DynFlags
-> SDoc
-> ((UniqSupply, NativeGenAcc statics instr) -> ())
-> IO (UniqSupply, NativeGenAcc statics instr)
-> IO (UniqSupply, NativeGenAcc statics instr)
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent
                DynFlags
dflags
                SDoc
ncglabel (\(UniqSupply
a, NativeGenAcc statics instr
b) -> UniqSupply
a UniqSupply -> () -> ()
`seq` NativeGenAcc statics instr
b NativeGenAcc statics instr -> () -> ()
`seq` ()) (IO (UniqSupply, NativeGenAcc statics instr)
 -> IO (UniqSupply, NativeGenAcc statics instr))
-> IO (UniqSupply, NativeGenAcc statics instr)
-> IO (UniqSupply, NativeGenAcc statics instr)
forall a b. (a -> b) -> a -> b
$ do
              -- Generate debug information
              let debugFlag :: Bool
debugFlag = DynFlags -> Int
debugLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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

              -- Generate native code
              (NativeGenAcc statics instr
ngs',UniqSupply
us') <- DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> LabelMap DebugBlock
-> UniqSupply
-> RawCmmGroup
-> NativeGenAcc statics instr
-> Int
-> 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
-> Int
-> 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 Int
0

              -- Link native code information into debug blocks
              -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
              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
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([DebugBlock] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DebugBlock]
ldbgs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_debug String
"Debug Infos" DumpFormat
FormatText
                  ([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)

              -- Accumulate debug information for emission in finishNativeGen.
              let ngs'' :: NativeGenAcc statics instr
ngs'' = 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, NativeGenAcc statics instr)
-> IO (UniqSupply, NativeGenAcc statics instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqSupply
us', NativeGenAcc statics instr
ngs'')

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

    where ncglabel :: SDoc
ncglabel = String -> SDoc
text String
"NCG"

-- | 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 :: 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
-> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGens DynFlags
dflags Module
this_mod ModLocation
modLoc NcgImpl statics instr jumpDest
ncgImpl BufHandle
h LabelMap DebugBlock
dbgMap = UniqSupply
-> RawCmmGroup
-> NativeGenAcc statics instr
-> Int
-> 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
-> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
go UniqSupply
us [] NativeGenAcc statics instr
ngs !Int
_ =
        (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 UniqSupply
us (RawCmmDecl
cmm : RawCmmGroup
cmms) NativeGenAcc statics instr
ngs Int
count = do
        let fileIds :: DwarfFiles
fileIds = NativeGenAcc statics instr -> DwarfFiles
forall statics instr. NativeGenAcc statics instr -> DwarfFiles
ngs_dwarfFiles NativeGenAcc statics instr
ngs
        (UniqSupply
us', DwarfFiles
fileIds', [NatCmmDecl statics instr]
native, [CLabel]
imports, Maybe [RegAllocStats statics instr]
colorStats, Maybe [RegAllocStats]
linearStats, LabelMap [UnwindPoint]
unwinds)
          <- {-# SCC "cmmNativeGen" #-}
             DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> UniqSupply
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> Int
-> 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
-> Int
-> 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 Int
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, Int)]
newFileIds = ((FastString, Int) -> (FastString, Int) -> Ordering)
-> [(FastString, Int)] -> [(FastString, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((FastString, Int) -> Int)
-> (FastString, Int) -> (FastString, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (FastString, Int) -> Int
forall a b. (a, b) -> b
snd) ([(FastString, Int)] -> [(FastString, Int)])
-> [(FastString, Int)] -> [(FastString, Int)]
forall a b. (a -> b) -> a -> b
$
                         DwarfFiles -> [(FastString, Int)]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM (DwarfFiles -> [(FastString, Int)])
-> DwarfFiles -> [(FastString, Int)]
forall a b. (a -> b) -> a -> b
$ DwarfFiles
fileIds' DwarfFiles -> DwarfFiles -> DwarfFiles
forall key elt1 elt2.
UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1
`minusUFM` DwarfFiles
fileIds
            -- See Note [Unique Determinism and code generation]
            pprDecl :: (FastString, a) -> SDoc
pprDecl (FastString
f,a
n) = String -> SDoc
text String
"\t.file " SDoc -> SDoc -> SDoc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
n SDoc -> SDoc -> SDoc
<+>
                            String -> SDoc
pprFilePathString (FastString -> String
unpackFS 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, Int) -> SDoc) -> [(FastString, Int)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FastString, Int) -> SDoc
forall {a}. Outputable a => (FastString, a) -> SDoc
pprDecl [(FastString, Int)]
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 a b. [a] -> b -> b
seqList (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 -> Int
debugLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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
-> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
go UniqSupply
us' RawCmmGroup
cmms NativeGenAcc statics instr
ngs' (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)


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

        let ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags (CodeStyle -> PprStyle
mkCodeStyle CodeStyle
AsmStyle)
        {-# SCC "pprNativeCode" #-} SDocContext -> BufHandle -> SDoc -> IO ()
bufLeftRenderSDoc SDocContext
ctx BufHandle
h SDoc
sdoc

        -- dump native code
        DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                DumpFlag
Opt_D_dump_asm String
"Asm code" DumpFormat
FormatASM
                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 :: forall statics instr jumpDest.
(Instruction instr, Outputable statics, Outputable instr,
 Outputable jumpDest) =>
DynFlags
-> Module
-> ModLocation
-> NcgImpl statics instr jumpDest
-> UniqSupply
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> Int
-> 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 Int
count
 = do
        let config :: NCGConfig
config   = NcgImpl statics instr jumpDest -> NCGConfig
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> NCGConfig
ncgConfig NcgImpl statics instr jumpDest
ncgImpl
        let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config

        let proc_name :: SDoc
proc_name = case RawCmmDecl
cmm of
                (CmmProc LabelMap RawCmmStatics
_ CLabel
entry_label [GlobalReg]
_ CmmGraph
_) -> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
entry_label
                RawCmmDecl
_                           -> String -> SDoc
text String
"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 (RawCmmDecl
opt_cmm, [CLabel]
imports) =
                {-# SCC "cmmToCmm" #-}
                NCGConfig -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm NCGConfig
config Module
this_mod RawCmmDecl
fixed_cmm

        DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                DumpFlag
Opt_D_dump_opt_cmm String
"Optimised Cmm" DumpFormat
FormatCMM
                (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 (([NatCmmDecl statics instr]
native, [CLabel]
lastMinuteImports, DwarfFiles
fileIds', CFG
nativeCfgWeights), 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 -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                DumpFlag
Opt_D_dump_asm_native String
"Native code" DumpFormat
FormatASM
                ([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) String
"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 Platform -> Bool
backendMaintainsCfg Platform
platform
                                then CFG -> Maybe CFG
forall a. a -> Maybe a
Just CFG
nativeCfgWeights
                                else Maybe CFG
forall a. Maybe a
Nothing
        let ([LiveCmmDecl statics instr]
withLiveness, 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
$ (NatCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr))
-> [NatCmmDecl statics instr] -> UniqSM [LiveCmmDecl statics instr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe CFG
-> Platform
-> NatCmmDecl statics instr
-> UniqSM (LiveCmmDecl statics instr)
forall instr statics.
(Outputable instr, Instruction instr) =>
Maybe CFG
-> Platform
-> NatCmmDecl statics instr
-> UniqSM (LiveCmmDecl statics instr)
cmmTopLiveness Maybe CFG
livenessCfg Platform
platform) [NatCmmDecl statics instr]
native

        DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                DumpFlag
Opt_D_dump_asm_liveness String
"Liveness annotations added"
                DumpFormat
FormatCMM
                ([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
        ([NatCmmDecl statics instr]
alloced, UniqSupply
usAlloc, Maybe [RegAllocStats statics instr]
ppr_raStatsColor, Maybe [RegAllocStats]
ppr_raStatsLinear, [RegAllocStats]
raStats, [(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 RegClass (UniqSet RealReg)
alloc_regs :: UniqFM RegClass (UniqSet RealReg))
                        = (RealReg
 -> UniqFM RegClass (UniqSet RealReg)
 -> UniqFM RegClass (UniqSet RealReg))
-> UniqFM RegClass (UniqSet RealReg)
-> [RealReg]
-> UniqFM RegClass (UniqSet RealReg)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\RealReg
r -> (UniqSet RealReg -> UniqSet RealReg -> UniqSet RealReg)
-> UniqFM RegClass (UniqSet RealReg)
-> UniqFM RegClass (UniqSet RealReg)
-> UniqFM RegClass (UniqSet RealReg)
forall elt key.
(elt -> elt -> elt)
-> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
plusUFM_C UniqSet RealReg -> UniqSet RealReg -> UniqSet RealReg
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets
                                        (UniqFM RegClass (UniqSet RealReg)
 -> UniqFM RegClass (UniqSet RealReg)
 -> UniqFM RegClass (UniqSet RealReg))
-> UniqFM RegClass (UniqSet RealReg)
-> UniqFM RegClass (UniqSet RealReg)
-> UniqFM RegClass (UniqSet RealReg)
forall a b. (a -> b) -> a -> b
$ RegClass -> UniqSet RealReg -> UniqFM RegClass (UniqSet RealReg)
forall key elt. Uniquable key => key -> elt -> UniqFM key elt
unitUFM (Platform -> RealReg -> RegClass
targetClassOfRealReg Platform
platform RealReg
r) (RealReg -> UniqSet RealReg
forall a. Uniquable a => a -> UniqSet a
unitUniqSet RealReg
r))
                                UniqFM RegClass (UniqSet RealReg)
forall key elt. UniqFM key elt
emptyUFM
                        ([RealReg] -> UniqFM RegClass (UniqSet RealReg))
-> [RealReg] -> UniqFM RegClass (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 (([NatCmmDecl statics instr]
alloced, Maybe Int
maybe_more_stack, [RegAllocStats statics instr]
regAllocStats), UniqSupply
usAlloc)
                        = {-# SCC "RegAlloc-color" #-}
                          UniqSupply
-> UniqSM
     ([NatCmmDecl statics instr], Maybe Int,
      [RegAllocStats statics instr])
-> (([NatCmmDecl statics instr], Maybe Int,
     [RegAllocStats statics instr]),
    UniqSupply)
forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs UniqSupply
usLive
                          (UniqSM
   ([NatCmmDecl statics instr], Maybe Int,
    [RegAllocStats statics instr])
 -> (([NatCmmDecl statics instr], Maybe Int,
      [RegAllocStats statics instr]),
     UniqSupply))
-> UniqSM
     ([NatCmmDecl statics instr], Maybe Int,
      [RegAllocStats statics instr])
-> (([NatCmmDecl statics instr], Maybe Int,
     [RegAllocStats statics instr]),
    UniqSupply)
forall a b. (a -> b) -> a -> b
$ NCGConfig
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM
     ([NatCmmDecl statics instr], Maybe Int,
      [RegAllocStats statics instr])
forall statics instr.
(Outputable statics, Outputable instr, Instruction instr) =>
NCGConfig
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM
     ([NatCmmDecl statics instr], Maybe Int,
      [RegAllocStats statics instr])
Color.regAlloc
                                NCGConfig
config
                                UniqFM RegClass (UniqSet RealReg)
alloc_regs
                                ([Int] -> UniqSet Int
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [Int
0 .. NcgImpl statics instr jumpDest -> Int
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> Int
maxSpillSlots NcgImpl statics instr jumpDest
ncgImpl])
                                (NcgImpl statics instr jumpDest -> Int
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> Int
maxSpillSlots NcgImpl statics instr jumpDest
ncgImpl)
                                [LiveCmmDecl statics instr]
withLiveness
                                Maybe CFG
livenessCfg

                let (([NatCmmDecl statics instr]
alloced', [(BlockId, BlockId)]
stack_updt_blks), 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 Int
maybe_more_stack of
                                Maybe Int
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 Int
amount -> do
                                    ([NatCmmDecl statics instr]
alloced',[[(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
-> Int
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> Int
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
ncgAllocMoreStack NcgImpl statics instr jumpDest
ncgImpl) Int
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 -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                        DumpFlag
Opt_D_dump_asm_regalloc String
"Registers allocated"
                        DumpFormat
FormatCMM
                        ([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 -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                        DumpFlag
Opt_D_dump_asm_regalloc_stages String
"Build/spill stages"
                        DumpFormat
FormatText
                        ([SDoc] -> SDoc
vcat   ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ ((Int, RegAllocStats statics instr) -> SDoc)
-> [(Int, RegAllocStats statics instr)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
stage, RegAllocStats statics instr
stats)
                                        -> String -> SDoc
text String
"# --------------------------"
                                        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"#  cmm " SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
count SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" Stage " SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
stage
                                        SDoc -> SDoc -> SDoc
$$ RegAllocStats statics instr -> SDoc
forall a. Outputable a => a -> SDoc
ppr RegAllocStats statics instr
stats)
                                ([(Int, RegAllocStats statics instr)] -> [SDoc])
-> [(Int, RegAllocStats statics instr)] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ [Int]
-> [RegAllocStats statics instr]
-> [(Int, RegAllocStats statics instr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
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 ()
`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 LiveCmmDecl statics instr
proc = do
                       (NatCmmDecl statics instr
alloced, Maybe Int
maybe_more_stack, Maybe RegAllocStats
ra_stats) <-
                               NCGConfig
-> LiveCmmDecl statics instr
-> UniqSM
     (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
forall instr statics.
(Outputable instr, Instruction instr) =>
NCGConfig
-> LiveCmmDecl statics instr
-> UniqSM
     (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
Linear.regAlloc NCGConfig
config LiveCmmDecl statics instr
proc
                       case Maybe Int
maybe_more_stack of
                         Maybe Int
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 Int
amount -> do
                           (NatCmmDecl statics instr
alloced',[(BlockId, BlockId)]
stack_updt_blks) <-
                               NcgImpl statics instr jumpDest
-> Int
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> Int
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId, BlockId)])
ncgAllocMoreStack NcgImpl statics instr jumpDest
ncgImpl Int
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 (([NatCmmDecl statics instr]
alloced, [Maybe RegAllocStats]
regAllocStats, [[(BlockId, BlockId)]]
stack_updt_blks), 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 -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                        DumpFlag
Opt_D_dump_asm_regalloc String
"Registers allocated"
                        DumpFormat
FormatCMM
                        ([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 ()
`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
cfg -> DynFlags -> CFG -> [(BlockId, BlockId, BlockId)] -> CFG
addNodesBetween DynFlags
dflags CFG
cfg [(BlockId, BlockId, BlockId)]
cfgRegAllocUpdates) (CFG -> CFG) -> Maybe CFG -> Maybe CFG
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CFG
livenessCfg

        -- Insert stack update blocks
        let 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' (\CFG
m (BlockId
from,BlockId
to) -> DynFlags -> BlockId -> BlockId -> CFG -> CFG
addImmediateSuccessor DynFlags
dflags 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

        ---- 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]
alloced

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CFG -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CFG
nativeCfgWeights) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                DumpFlag
Opt_D_dump_cfg_weights String
"CFG Update information"
                DumpFormat
FormatText
                ( String -> SDoc
text String
"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 String
"linearAlloc:" SDoc -> SDoc -> SDoc
<+> [(BlockId, BlockId, BlockId)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(BlockId, BlockId, BlockId)]
cfgRegAllocUpdates )

        ---- shortcut branches
        let ([NatCmmDecl statics instr]
shorted, 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 :: Maybe CFG
optimizedCFG =
                Bool -> CfgWeights -> RawCmmDecl -> CFG -> CFG
optimizeCFG (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CmmStaticPred DynFlags
dflags) (DynFlags -> CfgWeights
cfgWeightInfo DynFlags
dflags) RawCmmDecl
cmm (CFG -> CFG) -> Maybe CFG -> Maybe CFG
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
<$!> Maybe CFG
postShortCFG

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

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

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ( Platform -> Bool
backendMaintainsCfg Platform
platform 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
                let cfg :: CFG
cfg = Maybe CFG -> CFG
forall a. HasCallStack => Maybe a -> a
fromJust Maybe CFG
optimizedCFG
                () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! Bool -> () -> ()
seq (CFG -> LabelSet -> SDoc -> Bool
sanityCheckCfg CFG
cfg LabelSet
labels (SDoc -> Bool) -> SDoc -> Bool
forall a b. (a -> b) -> a -> b
$
                                String -> SDoc
text String
"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 RawCmmStatics -> [NatBasicBlock instr]
                            -> [NatBasicBlock instr]
                invertConds :: LabelMap RawCmmStatics
-> [GenBasicBlock instr] -> [GenBasicBlock instr]
invertConds = NcgImpl statics instr jumpDest
-> Maybe CFG
-> LabelMap RawCmmStatics
-> [GenBasicBlock instr]
-> [GenBasicBlock instr]
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> Maybe CFG
-> LabelMap RawCmmStatics
-> [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 LabelMap RawCmmStatics
info CLabel
lbl [GlobalReg]
live (ListGraph [GenBasicBlock instr]
blocks)) =
                    LabelMap RawCmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph instr
-> NatCmmDecl statics instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
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 RawCmmStatics
-> [GenBasicBlock instr] -> [GenBasicBlock instr]
invertConds LabelMap RawCmmStatics
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 -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags
                DumpFlag
Opt_D_dump_asm_expanded String
"Synthetic instructions expanded"
                DumpFormat
FormatCMM
                ([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 LabelMap [UnwindPoint]
acc 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 DynFlags
_dflags Maybe CFG
Nothing String
_ SDoc
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeDumpCfg DynFlags
dflags (Just CFG
cfg) String
msg 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 -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn
                DynFlags
dflags DumpFlag
Opt_D_dump_cfg_weights String
msg
                DumpFormat
FormatText
                (SDoc
proc_name SDoc -> SDoc -> SDoc
<> Char -> SDoc
char 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 :: forall statics instr.
[NatCmmDecl statics instr]
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
checkLayout [NatCmmDecl statics instr]
procsUnsequenced [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 {set} {d} {h} {i}.
(IsSet set, ElemOf set ~ BlockId) =>
GenCmmDecl d h (ListGraph i) -> set
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 {set} {d} {h} {i}.
(IsSet set, ElemOf set ~ BlockId) =>
GenCmmDecl d h (ListGraph i) -> set
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) -> set
getBlockIds (CmmData Section
_ d
_) = set
forall set. IsSet set => set
setEmpty
        getBlockIds (CmmProc h
_ CLabel
_ [GlobalReg]
_ (ListGraph [GenBasicBlock i]
blocks)) =
                [ElemOf set] -> set
forall set. IsSet set => [ElemOf set] -> set
setFromList ([ElemOf set] -> set) -> [ElemOf set] -> set
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

-- | 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 :: forall instr statics jumpDest.
Instruction instr =>
DynFlags
-> NcgImpl statics instr jumpDest
-> NatCmmDecl statics instr
-> LabelMap [UnwindPoint]
computeUnwinding DynFlags
dflags NcgImpl statics instr jumpDest
_ NatCmmDecl statics instr
_
  | DynFlags -> Int
debugLevel DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0         = LabelMap [UnwindPoint]
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
computeUnwinding DynFlags
_ NcgImpl statics instr jumpDest
_ (CmmData Section
_ statics
_) = LabelMap [UnwindPoint]
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
computeUnwinding DynFlags
_ NcgImpl statics instr jumpDest
ncgImpl (CmmProc LabelMap RawCmmStatics
_ CLabel
_ [GlobalReg]
_ (ListGraph [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 GHC.Cmm.LayoutStack 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 BlockId
blk_lbl [instr]
instrs <- [GenBasicBlock instr]
blks ]

-- | Build a doc for all the imports.
--
makeImportsDoc :: DynFlags -> [CLabel] -> SDoc
makeImportsDoc :: DynFlags -> [CLabel] -> SDoc
makeImportsDoc DynFlags
dflags [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 String
".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 String
".section .note.GNU-stack,\"\"," SDoc -> SDoc -> SDoc
<> Platform -> String -> SDoc
sectionType Platform
platform String
"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 String
"GHC" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
cProjectVersion
                   in String -> SDoc
text String
".ident" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
doubleQuotes SDoc
compilerIdent
             else SDoc
Outputable.empty)

 where
        config :: NCGConfig
config   = DynFlags -> NCGConfig
initConfig DynFlags
dflags
        platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config

        -- 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 [CLabel]
imps
                | NCGConfig -> Bool
needImportedSymbols NCGConfig
config
                = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
                        (NCGConfig -> SDoc
pprGotDeclaration NCGConfig
config 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 -> NCGConfig -> CLabel -> SDoc
pprImportedSymbol DynFlags
dflags NCGConfig
config (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 (\(CLabel
_,String
a) (CLabel
_,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 (\(CLabel
_,String
a) (CLabel
_,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 CLabel
lbl = (CLabel
lbl, SDocContext -> SDoc -> String
renderWithStyle
                              (DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
astyle)
                              (DynFlags -> CLabel -> SDoc
pprCLabel DynFlags
dflags CLabel
lbl))
        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 :: forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
generateJumpTables NcgImpl statics instr jumpDest
ncgImpl [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 LabelMap RawCmmStatics
_ CLabel
_ [GlobalReg]
_ (ListGraph [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 NatCmmDecl statics instr
p = [NatCmmDecl statics instr
p]
          g :: GenBasicBlock instr -> [NatCmmDecl statics instr]
g (BasicBlock BlockId
_ [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 :: 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]
tops 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
    ([NatCmmDecl statics instr]
tops', [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 :: 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
_ top :: GenCmmDecl d (LabelMap t) (ListGraph instr)
top@(CmmData Section
_ d
_) = (GenCmmDecl d (LabelMap t) (ListGraph instr)
top, LabelMap jumpDest
forall (map :: * -> *) a. IsMap map => map a
mapEmpty)
build_mapping NcgImpl statics instr jumpDest
_ (CmmProc LabelMap t
info CLabel
lbl [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 statics instr jumpDest
ncgImpl (CmmProc LabelMap t
info CLabel
lbl [GlobalReg]
live (ListGraph (GenBasicBlock instr
head:[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)]
    (LabelSet
_, [(BlockId, jumpDest)]
shortcut_blocks, [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 (LabelSet
s, [(BlockId, jumpDest)]
shortcut_blocks, [GenBasicBlock instr]
others) b :: GenBasicBlock instr
b@(BasicBlock BlockId
id [instr
insn])
        | Just 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 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 (LabelSet
s, [(BlockId, jumpDest)]
shortcut_blocks, [GenBasicBlock instr]
others) (BasicBlock BlockId
id [instr
insn])
        | Just 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 (LabelSet
s, [(BlockId, jumpDest)]
shortcut_blocks, [GenBasicBlock instr]
others) 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 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 :: 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
ufm (CmmData Section
sec 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 (\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 statics instr jumpDest
ncgImpl LabelMap jumpDest
ufm (CmmProc h
info CLabel
lbl [GlobalReg]
live (ListGraph [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 BlockId
id [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 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 (\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 :: 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 RawCmmDecl -> NatM [NatCmmDecl statics instr]
cmmTopCodeGen DwarfFiles
fileIds LabelMap DebugBlock
dbgMap RawCmmDecl
cmm_top CFG
cmm_cfg
  = do  { UniqSupply
initial_us <- UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
        ; let initial_st :: NatM_State
initial_st           = UniqSupply
-> Int
-> DynFlags
-> Module
-> ModLocation
-> DwarfFiles
-> LabelMap DebugBlock
-> CFG
-> NatM_State
mkNatM_State UniqSupply
initial_us Int
0 DynFlags
dflags Module
this_mod
                                                  ModLocation
modLoc DwarfFiles
fileIds LabelMap DebugBlock
dbgMap CFG
cmm_cfg
              ([NatCmmDecl statics instr]
new_tops, 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 :: Int
final_delta          = NatM_State -> Int
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   Int
final_delta Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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 String
"genMachCode: nonzero final delta" (Int -> SDoc
int Int
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 :: NCGConfig -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm :: NCGConfig -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm NCGConfig
_ Module
_ top :: RawCmmDecl
top@(CmmData Section
_ RawCmmStatics
_) = (RawCmmDecl
top, [])
cmmToCmm NCGConfig
config Module
this_mod (CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalReg]
live CmmGraph
graph)
    = NCGConfig -> Module -> CmmOptM RawCmmDecl -> (RawCmmDecl, [CLabel])
forall a. NCGConfig -> Module -> CmmOptM a -> (a, [CLabel])
runCmmOpt NCGConfig
config 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 RawCmmStatics
-> CLabel -> [GlobalReg] -> CmmGraph -> RawCmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalReg]
live (BlockId -> [CmmBlock] -> CmmGraph
ofBlockList (CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
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 $mOptMResult :: forall {r} {a} {b}.
(# a, b #) -> (a -> b -> r) -> (Void# -> r) -> r
$bOptMResult :: forall a b. a -> b -> (# a, b #)
OptMResult x y = (# x, y #)
{-# COMPLETE OptMResult #-}
#else

data OptMResult a = OptMResult !a ![CLabel] deriving (Functor)
#endif

newtype CmmOptM a = CmmOptM (NCGConfig -> Module -> [CLabel] -> OptMResult a)
    deriving ((forall a b. (a -> b) -> CmmOptM a -> CmmOptM b)
-> (forall a b. a -> CmmOptM b -> CmmOptM a) -> Functor CmmOptM
forall a b. a -> CmmOptM b -> CmmOptM a
forall a b. (a -> b) -> CmmOptM a -> CmmOptM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CmmOptM b -> CmmOptM a
$c<$ :: forall a b. a -> CmmOptM b -> CmmOptM a
fmap :: forall a b. (a -> b) -> CmmOptM a -> CmmOptM b
$cfmap :: forall a b. (a -> b) -> CmmOptM a -> CmmOptM b
Functor)

instance Applicative CmmOptM where
    pure :: forall a. a -> CmmOptM a
pure a
x = (NCGConfig -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a
forall a.
(NCGConfig -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((NCGConfig -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a)
-> (NCGConfig -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a
forall a b. (a -> b) -> a -> b
$ \NCGConfig
_ Module
_ [CLabel]
imports -> a -> [CLabel] -> OptMResult a
forall a b. a -> b -> (# a, b #)
OptMResult a
x [CLabel]
imports
    <*> :: forall a b. 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 NCGConfig -> Module -> [CLabel] -> OptMResult a
f) >>= :: forall a b. CmmOptM a -> (a -> CmmOptM b) -> CmmOptM b
>>= a -> CmmOptM b
g =
    (NCGConfig -> Module -> [CLabel] -> OptMResult b) -> CmmOptM b
forall a.
(NCGConfig -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((NCGConfig -> Module -> [CLabel] -> OptMResult b) -> CmmOptM b)
-> (NCGConfig -> Module -> [CLabel] -> OptMResult b) -> CmmOptM b
forall a b. (a -> b) -> a -> b
$ \NCGConfig
config Module
this_mod [CLabel]
imports0 ->
                case NCGConfig -> Module -> [CLabel] -> OptMResult a
f NCGConfig
config Module
this_mod [CLabel]
imports0 of
                  OptMResult a
x [CLabel]
imports1 ->
                    case a -> CmmOptM b
g a
x of
                      CmmOptM NCGConfig -> Module -> [CLabel] -> OptMResult b
g' -> NCGConfig -> Module -> [CLabel] -> OptMResult b
g' NCGConfig
config Module
this_mod [CLabel]
imports1

instance CmmMakeDynamicReferenceM CmmOptM where
    addImport :: CLabel -> CmmOptM ()
addImport = CLabel -> CmmOptM ()
addImportCmmOpt
    getThisModule :: CmmOptM Module
getThisModule = (NCGConfig -> Module -> [CLabel] -> OptMResult Module)
-> CmmOptM Module
forall a.
(NCGConfig -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((NCGConfig -> Module -> [CLabel] -> OptMResult Module)
 -> CmmOptM Module)
-> (NCGConfig -> Module -> [CLabel] -> OptMResult Module)
-> CmmOptM Module
forall a b. (a -> b) -> a -> b
$ \NCGConfig
_ Module
this_mod [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 CLabel
lbl = (NCGConfig -> Module -> [CLabel] -> OptMResult ()) -> CmmOptM ()
forall a.
(NCGConfig -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((NCGConfig -> Module -> [CLabel] -> OptMResult ()) -> CmmOptM ())
-> (NCGConfig -> Module -> [CLabel] -> OptMResult ()) -> CmmOptM ()
forall a b. (a -> b) -> a -> b
$ \NCGConfig
_ Module
_ [CLabel]
imports -> () -> [CLabel] -> OptMResult ()
forall a b. a -> b -> (# a, b #)
OptMResult () (CLabel
lblCLabel -> [CLabel] -> [CLabel]
forall a. a -> [a] -> [a]
:[CLabel]
imports)

getCmmOptConfig :: CmmOptM NCGConfig
getCmmOptConfig :: CmmOptM NCGConfig
getCmmOptConfig = (NCGConfig -> Module -> [CLabel] -> OptMResult NCGConfig)
-> CmmOptM NCGConfig
forall a.
(NCGConfig -> Module -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((NCGConfig -> Module -> [CLabel] -> OptMResult NCGConfig)
 -> CmmOptM NCGConfig)
-> (NCGConfig -> Module -> [CLabel] -> OptMResult NCGConfig)
-> CmmOptM NCGConfig
forall a b. (a -> b) -> a -> b
$ \NCGConfig
config Module
_ [CLabel]
imports -> NCGConfig -> [CLabel] -> OptMResult NCGConfig
forall a b. a -> b -> (# a, b #)
OptMResult NCGConfig
config [CLabel]
imports

runCmmOpt :: NCGConfig -> Module -> CmmOptM a -> (a, [CLabel])
runCmmOpt :: forall a. NCGConfig -> Module -> CmmOptM a -> (a, [CLabel])
runCmmOpt NCGConfig
config Module
this_mod (CmmOptM NCGConfig -> Module -> [CLabel] -> OptMResult a
f) =
  case NCGConfig -> Module -> [CLabel] -> OptMResult a
f NCGConfig
config Module
this_mod [] of
    OptMResult a
result [CLabel]
imports -> (a
result, [CLabel]
imports)

cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
cmmBlockConFold CmmBlock
block = do
  let (CmmNode C O
entry, Block CmmNode O O
middle, CmmNode O C
last) = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
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 :: Extensibility -> Extensibility -> *).
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 :: Extensibility) (x :: Extensibility).
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 :: Extensibility) (x :: Extensibility).
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 :: Extensibility -> Extensibility -> *).
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 :: Extensibility -> Extensibility -> *).
[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 :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmOptM (CmmNode e x)
cmmStmtConFold CmmNode e x
stmt
   = case CmmNode e x
stmt of
        CmmAssign CmmReg
reg CmmExpr
src
           -> do CmmExpr
src' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
src
                 CmmNode O O -> CmmOptM (CmmNode O O)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode O O -> CmmOptM (CmmNode O O))
-> CmmNode O O -> CmmOptM (CmmNode O O)
forall a b. (a -> b) -> a -> b
$ case CmmExpr
src' of
                   CmmReg CmmReg
reg' | CmmReg
reg CmmReg -> CmmReg -> Bool
forall a. Eq a => a -> a -> Bool
== CmmReg
reg' -> FastString -> CmmNode O O
CmmComment (String -> FastString
fsLit String
"nop")
                   CmmExpr
new_src -> CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
reg CmmExpr
new_src

        CmmStore CmmExpr
addr 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 O O)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode O O -> CmmOptM (CmmNode O O))
-> CmmNode O O -> CmmOptM (CmmNode O O)
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 ForeignTarget
target [CmmFormal]
regs [CmmExpr]
args
           -> do ForeignTarget
target' <- case ForeignTarget
target of
                              ForeignTarget CmmExpr
e 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 CallishMachOp
_ ->
                                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 O O)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode O O -> CmmOptM (CmmNode O O))
-> CmmNode O O -> CmmOptM (CmmNode O O)
forall a b. (a -> b) -> a -> b
$ ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmNode O O
CmmUnsafeForeignCall ForeignTarget
target' [CmmFormal]
regs [CmmExpr]
args'

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

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

        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 CmmExpr
expr = do
    NCGConfig
config <- CmmOptM NCGConfig
getCmmOptConfig

    let expr' :: CmmExpr
expr' = if Bool -> Bool
not (NCGConfig -> Bool
ncgDoConstantFolding NCGConfig
config)
                    then CmmExpr
expr
                    else NCGConfig -> CmmExpr -> CmmExpr
cmmExprCon NCGConfig
config CmmExpr
expr

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

cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr
cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr
cmmExprCon NCGConfig
config (CmmLoad CmmExpr
addr CmmType
rep) = CmmExpr -> CmmType -> CmmExpr
CmmLoad (NCGConfig -> CmmExpr -> CmmExpr
cmmExprCon NCGConfig
config CmmExpr
addr) CmmType
rep
cmmExprCon NCGConfig
config (CmmMachOp MachOp
mop [CmmExpr]
args)
    = Platform -> MachOp -> [CmmExpr] -> CmmExpr
cmmMachOpFold (NCGConfig -> Platform
ncgPlatform NCGConfig
config) MachOp
mop ((CmmExpr -> CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (NCGConfig -> CmmExpr -> CmmExpr
cmmExprCon NCGConfig
config) [CmmExpr]
args)
cmmExprCon NCGConfig
_ 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 CmmExpr
expr = do
     NCGConfig
config <- CmmOptM NCGConfig
getCmmOptConfig
     let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
         arch :: Arch
arch = Platform -> Arch
platformArch Platform
platform
     case CmmExpr
expr of
        CmmLoad CmmExpr
addr 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 MachOp
mop [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 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 CLabel
lbl)
           -> do
                NCGConfig -> ReferenceKind -> CLabel -> CmmOptM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference NCGConfig
config ReferenceKind
referenceKind CLabel
lbl
        CmmLit (CmmLabelOff CLabel
lbl Int
off)
           -> do
                 CmmExpr
dynRef <- NCGConfig -> ReferenceKind -> CLabel -> CmmOptM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference NCGConfig
config 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
$ Platform -> MachOp -> [CmmExpr] -> CmmExpr
cmmMachOpFold Platform
platform (Width -> MachOp
MO_Add (Platform -> Width
wordWidth Platform
platform)) [
                     CmmExpr
dynRef,
                     (CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) (Platform -> Width
wordWidth Platform
platform))
                   ]

        -- 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 GlobalReg
EagerBlackholeInfo)
          | Arch
arch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchPPC Bool -> Bool -> Bool
&& Bool -> Bool
not (NCGConfig -> Bool
ncgPIC NCGConfig
config)
          -> 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 String
"__stg_EAGER_BLACKHOLE_info")))
        CmmReg (CmmGlobal GlobalReg
GCEnter1)
          | Arch
arch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchPPC Bool -> Bool -> Bool
&& Bool -> Bool
not (NCGConfig -> Bool
ncgPIC NCGConfig
config)
          -> 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 String
"__stg_gc_enter_1")))
        CmmReg (CmmGlobal GlobalReg
GCFun)
          | Arch
arch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchPPC Bool -> Bool -> Bool
&& Bool -> Bool
not (NCGConfig -> Bool
ncgPIC NCGConfig
config)
          -> 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 String
"__stg_gc_fun")))

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