-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 1993-2004
--
--
-- -----------------------------------------------------------------------------

{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms,
    DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ScopedTypeVariables #-}

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

-- | Native code generator
--
-- The native-code generator has machine-independent and
-- machine-dependent modules.
--
-- This module ("GHC.CmmToAsm") 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.
-- -}
--
module GHC.CmmToAsm
   ( nativeCodeGen

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

#include "HsVersions.h"

import GHC.Prelude

import qualified GHC.CmmToAsm.X86   as X86
import qualified GHC.CmmToAsm.PPC   as PPC
import qualified GHC.CmmToAsm.SPARC as SPARC
import qualified GHC.CmmToAsm.AArch64 as AArch64

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.CmmToAsm.Types
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.Driver.Ppr
import GHC.Utils.Misc
import GHC.Utils.Logger

import qualified GHC.Utils.Ppr as Pretty
import GHC.Utils.BufHandle
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
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

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

--------------------
nativeCodeGen :: forall a . Logger -> DynFlags -> Module -> ModLocation -> Handle -> UniqSupply
              -> Stream IO RawCmmGroup a
              -> IO a
nativeCodeGen :: forall a.
Logger
-> DynFlags
-> Module
-> ModLocation
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen Logger
logger DynFlags
dflags Module
this_mod ModLocation
modLoc Handle
h UniqSupply
us Stream IO RawCmmGroup a
cmms
 = let config :: NCGConfig
config   = DynFlags -> Module -> NCGConfig
initNCGConfig DynFlags
dflags Module
this_mod
       platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
       nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)
            => NcgImpl statics instr jumpDest -> IO a
       nCG' :: forall statics jumpDest instr.
(OutputableP Platform statics, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO a
nCG' NcgImpl statics instr jumpDest
ncgImpl = Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
forall statics jumpDest instr a.
(OutputableP Platform statics, Outputable jumpDest,
 Instruction instr) =>
Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen' Logger
logger DynFlags
dflags NCGConfig
config 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 jumpDest instr.
(OutputableP Platform statics, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO a
nCG' (NCGConfig -> NcgImpl (Alignment, RawCmmStatics) Instr JumpDest
X86.ncgX86     NCGConfig
config)
      Arch
ArchX86_64    -> NcgImpl (Alignment, RawCmmStatics) Instr JumpDest -> IO a
forall statics jumpDest instr.
(OutputableP Platform statics, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO a
nCG' (NCGConfig -> NcgImpl (Alignment, RawCmmStatics) Instr JumpDest
X86.ncgX86_64  NCGConfig
config)
      Arch
ArchPPC       -> NcgImpl RawCmmStatics Instr JumpDest -> IO a
forall statics jumpDest instr.
(OutputableP Platform statics, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO a
nCG' (NCGConfig -> NcgImpl RawCmmStatics Instr JumpDest
PPC.ncgPPC     NCGConfig
config)
      ArchPPC_64 PPC_64ABI
_  -> NcgImpl RawCmmStatics Instr JumpDest -> IO a
forall statics jumpDest instr.
(OutputableP Platform statics, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO a
nCG' (NCGConfig -> NcgImpl RawCmmStatics Instr JumpDest
PPC.ncgPPC     NCGConfig
config)
      Arch
ArchSPARC     -> NcgImpl RawCmmStatics Instr JumpDest -> IO a
forall statics jumpDest instr.
(OutputableP Platform statics, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO a
nCG' (NCGConfig -> NcgImpl RawCmmStatics Instr JumpDest
SPARC.ncgSPARC NCGConfig
config)
      Arch
ArchSPARC64   -> String -> IO a
forall a. String -> a
panic String
"nativeCodeGen: No NCG for SPARC64"
      Arch
ArchS390X     -> String -> IO a
forall a. String -> a
panic String
"nativeCodeGen: No NCG for S390X"
      ArchARM {}    -> String -> IO a
forall a. String -> a
panic String
"nativeCodeGen: No NCG for ARM"
      Arch
ArchAArch64   -> NcgImpl RawCmmStatics Instr JumpDest -> IO a
forall statics jumpDest instr.
(OutputableP Platform statics, Outputable jumpDest,
 Instruction instr) =>
NcgImpl statics instr jumpDest -> IO a
nCG' (NCGConfig -> NcgImpl RawCmmStatics Instr JumpDest
AArch64.ncgAArch64 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
ArchRISCV64   -> String -> IO a
forall a. String -> a
panic String
"nativeCodeGen: No NCG for RISCV64"
      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"

-- | 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 -> [Label]
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' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr)
               => Logger
               -> DynFlags
               -> NCGConfig
               -> ModLocation
               -> NcgImpl statics instr jumpDest
               -> Handle
               -> UniqSupply
               -> Stream IO RawCmmGroup a
               -> IO a
nativeCodeGen' :: forall statics jumpDest instr a.
(OutputableP Platform statics, Outputable jumpDest,
 Instruction instr) =>
Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen' Logger
logger DynFlags
dflags NCGConfig
config 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]]
-> [Label]
-> [DebugBlock]
-> DwarfFiles
-> LabelMap [UnwindPoint]
-> NativeGenAcc statics instr
forall statics instr.
[[CLabel]]
-> [[NatCmmDecl statics instr]]
-> [[RegAllocStats statics instr]]
-> [[RegAllocStats]]
-> [Label]
-> [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) <- Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
forall statics jumpDest instr a.
(OutputableP Platform statics, Outputable jumpDest,
 Instruction instr) =>
Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
cmmNativeGenStream Logger
logger DynFlags
dflags NCGConfig
config 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
_ <- Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> BufHandle
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
forall instr statics.
Instruction instr =>
Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> BufHandle
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
finishNativeGen Logger
logger DynFlags
dflags NCGConfig
config 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
                => Logger
                -> DynFlags
                -> NCGConfig
                -> ModLocation
                -> BufHandle
                -> UniqSupply
                -> NativeGenAcc statics instr
                -> IO UniqSupply
finishNativeGen :: forall instr statics.
Instruction instr =>
Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> BufHandle
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
finishNativeGen Logger
logger DynFlags
dflags NCGConfig
config ModLocation
modLoc bufh :: BufHandle
bufh@(BufHandle Ptr Word8
_ FastMutInt
_ Handle
h) UniqSupply
us NativeGenAcc statics instr
ngs
 = Logger
-> DynFlags
-> SDoc
-> (UniqSupply -> ())
-> IO UniqSupply
-> IO UniqSupply
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent Logger
logger 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
        UniqSupply
us' <- if Bool -> Bool
not (NCGConfig -> Bool
ncgDwarfEnabled NCGConfig
config)
                  then UniqSupply -> IO UniqSupply
forall (m :: * -> *) a. Monad m => a -> m a
return UniqSupply
us
                  else do
                     (SDoc
dwarf, UniqSupply
us') <- NCGConfig
-> ModLocation
-> UniqSupply
-> [DebugBlock]
-> IO (SDoc, UniqSupply)
dwarfGen NCGConfig
config ModLocation
modLoc UniqSupply
us (NativeGenAcc statics instr -> [DebugBlock]
forall statics instr. NativeGenAcc statics instr -> [DebugBlock]
ngs_debug NativeGenAcc statics instr
ngs)
                     Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()
emitNativeCode Logger
logger DynFlags
dflags NCGConfig
config 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 = NCGConfig -> Platform
ncgPlatform NCGConfig
config
          Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger 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 = NCGConfig -> SDocContext
ncgAsmContext NCGConfig
config
        SDocContext -> Mode -> Handle -> SDoc -> IO ()
printSDocLn SDocContext
ctx Mode
Pretty.LeftMode Handle
h
                (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ NCGConfig -> [CLabel] -> SDoc
makeImportsDoc NCGConfig
config ([[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 = Logger -> DumpAction
putDumpMsg Logger
logger DynFlags
dflags (PrintUnqualified -> PprStyle
mkDumpStyle PrintUnqualified
alwaysQualify)
                   DumpFlag
Opt_D_dump_asm_stats String
"NCG stats"
                   DumpFormat
FormatText

cmmNativeGenStream :: forall statics jumpDest instr a . (OutputableP Platform statics, Outputable jumpDest, Instruction instr)
              => Logger
              -> DynFlags
              -> NCGConfig
              -> ModLocation
              -> NcgImpl statics instr jumpDest
              -> BufHandle
              -> UniqSupply
              -> Stream.Stream IO RawCmmGroup a
              -> NativeGenAcc statics instr
              -> IO (NativeGenAcc statics instr, UniqSupply, a)

cmmNativeGenStream :: forall statics jumpDest instr a.
(OutputableP Platform statics, Outputable jumpDest,
 Instruction instr) =>
Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
cmmNativeGenStream Logger
logger DynFlags
dflags NCGConfig
config ModLocation
modLoc NcgImpl statics instr jumpDest
ncgImpl BufHandle
h UniqSupply
us Stream IO RawCmmGroup a
cmm_stream NativeGenAcc statics instr
ngs
 = UniqSupply
-> StreamS IO RawCmmGroup a
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
loop UniqSupply
us (Stream IO RawCmmGroup a -> StreamS IO RawCmmGroup a
forall (m :: * -> *) r' r.
Applicative m =>
Stream m r' r -> StreamS m r' r
Stream.runStream Stream IO RawCmmGroup a
cmm_stream) NativeGenAcc statics instr
ngs
  where
    ncglabel :: SDoc
ncglabel = String -> SDoc
text String
"NCG"
    loop :: UniqSupply
              -> Stream.StreamS IO RawCmmGroup a
              -> NativeGenAcc statics instr
              -> IO (NativeGenAcc statics instr, UniqSupply, a)
    loop :: UniqSupply
-> StreamS IO RawCmmGroup a
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
loop UniqSupply
us StreamS IO RawCmmGroup a
s NativeGenAcc statics instr
ngs =
      case StreamS IO RawCmmGroup a
s of
        Stream.Done 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)
        Stream.Effect IO (StreamS IO RawCmmGroup a)
m -> IO (StreamS IO RawCmmGroup a)
m IO (StreamS IO RawCmmGroup a)
-> (StreamS IO RawCmmGroup a
    -> IO (NativeGenAcc statics instr, UniqSupply, a))
-> IO (NativeGenAcc statics instr, UniqSupply, a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \StreamS IO RawCmmGroup a
cmm_stream' -> UniqSupply
-> StreamS IO RawCmmGroup a
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
loop UniqSupply
us StreamS IO RawCmmGroup a
cmm_stream' NativeGenAcc statics instr
ngs
        Stream.Yield RawCmmGroup
cmms StreamS IO RawCmmGroup a
cmm_stream' -> do
          (UniqSupply
us', NativeGenAcc statics instr
ngs'') <-
            Logger
-> DynFlags
-> SDoc
-> ((UniqSupply, NativeGenAcc statics instr) -> ())
-> IO (UniqSupply, NativeGenAcc statics instr)
-> IO (UniqSupply, NativeGenAcc statics instr)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent Logger
logger
                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 !ndbgs :: [DebugBlock]
ndbgs | NCGConfig -> Bool
ncgDwarfEnabled NCGConfig
config = 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') <- Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> LabelMap DebugBlock
-> UniqSupply
-> RawCmmGroup
-> NativeGenAcc statics instr
-> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
forall statics instr jumpDest.
(OutputableP Platform statics, Outputable jumpDest,
 Instruction instr) =>
Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> LabelMap DebugBlock
-> UniqSupply
-> RawCmmGroup
-> NativeGenAcc statics instr
-> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGens Logger
logger DynFlags
dflags NCGConfig
config 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 = [Label] -> LabelMap [UnwindPoint] -> [DebugBlock] -> [DebugBlock]
cmmDebugLink (NativeGenAcc statics instr -> [Label]
forall statics instr. NativeGenAcc statics instr -> [Label]
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
                  platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
              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
$
                Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger 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 (Platform -> DebugBlock -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform) [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 :: [Label]
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'')

          UniqSupply
-> StreamS IO RawCmmGroup a
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
loop UniqSupply
us' StreamS IO RawCmmGroup a
cmm_stream' NativeGenAcc statics instr
ngs''


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

cmmNativeGens :: forall statics instr jumpDest.
(OutputableP Platform statics, Outputable jumpDest,
 Instruction instr) =>
Logger
-> DynFlags
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> LabelMap DebugBlock
-> UniqSupply
-> RawCmmGroup
-> NativeGenAcc statics instr
-> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGens Logger
logger DynFlags
dflags NCGConfig
config 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" #-}
             Logger
-> DynFlags
-> 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, OutputableP Platform statics,
 Outputable jumpDest) =>
Logger
-> DynFlags
-> 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 Logger
logger DynFlags
dflags 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)

        Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()
emitNativeCode Logger
logger DynFlags
dflags NCGConfig
config 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
        let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        {-# 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 (Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform) [CLabel]
imports) ()

        let !labels' :: [Label]
labels' = if NCGConfig -> Bool
ncgDwarfEnabled NCGConfig
config
                       then (instr -> Bool) -> [NatCmmDecl statics instr] -> [Label]
forall i d g.
(i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
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 :: [Label]
ngs_labels      = NativeGenAcc statics instr -> [Label]
forall statics instr. NativeGenAcc statics instr -> [Label]
ngs_labels NativeGenAcc statics instr
ngs [Label] -> [Label] -> [Label]
forall a. [a] -> [a] -> [a]
++ [Label]
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 :: Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()
emitNativeCode :: Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()
emitNativeCode Logger
logger DynFlags
dflags NCGConfig
config BufHandle
h SDoc
sdoc = do

        let ctx :: SDocContext
ctx = NCGConfig -> SDocContext
ncgAsmContext NCGConfig
config
        {-# SCC "pprNativeCode" #-} SDocContext -> BufHandle -> SDoc -> IO ()
bufLeftRenderSDoc SDocContext
ctx BufHandle
h SDoc
sdoc

        -- dump native code
        Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger 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, OutputableP Platform statics, Outputable jumpDest)
    => Logger
    -> DynFlags
    -> 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, OutputableP Platform statics,
 Outputable jumpDest) =>
Logger
-> DynFlags
-> 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 Logger
logger DynFlags
dflags 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 weights :: Weights
weights  = NCGConfig -> Weights
ncgCfgWeights NCGConfig
config

        let proc_name :: SDoc
proc_name = case RawCmmDecl
cmm of
                (CmmProc LabelMap RawCmmStatics
_ CLabel
entry_label [GlobalReg]
_ CmmGraph
_) -> Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CLabel
entry_label
                RawCmmDecl
_                           -> String -> SDoc
text String
"DataChunk"

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

        -- cmm to cmm optimisations
        let (RawCmmDecl
opt_cmm, [CLabel]
imports) =
                {-# SCC "cmmToCmm" #-}
                NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm NCGConfig
config RawCmmDecl
fixed_cmm

        Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags
                DumpFlag
Opt_D_dump_opt_cmm String
"Optimised Cmm" DumpFormat
FormatCMM
                (Platform -> RawCmmGroup -> SDoc
forall d info g.
(OutputableP Platform d, OutputableP Platform info,
 OutputableP Platform g) =>
Platform -> GenCmmGroup d info g -> SDoc
pprCmmGroup Platform
platform [RawCmmDecl
opt_cmm])

        let cmmCfg :: CFG
cmmCfg = {-# SCC "getCFG" #-}
                     Platform -> Weights -> RawCmmDecl -> CFG
getCfgProc Platform
platform Weights
weights 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
$ NCGConfig
-> ModLocation
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> CFG
-> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
forall statics instr.
NCGConfig
-> ModLocation
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> CFG
-> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
genMachCode NCGConfig
config 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

        Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger 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)

        Logger -> DynFlags -> Maybe CFG -> String -> SDoc -> IO ()
maybeDumpCfg Logger
logger 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.
Instruction instr =>
Maybe CFG
-> Platform
-> NatCmmDecl statics instr
-> UniqSM (LiveCmmDecl statics instr)
cmmTopLiveness Maybe CFG
livenessCfg Platform
platform) [NatCmmDecl statics instr]
native

        Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger 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 (Platform -> LiveCmmDecl statics instr -> SDoc
forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
Platform -> LiveCmmDecl statics instr -> SDoc
pprLiveCmmDecl Platform
platform) [LiveCmmDecl statics instr]
withLiveness)

        -- allocate registers
        ([NatCmmDecl statics instr]
alloced, UniqSupply
usAlloc, Maybe [RegAllocStats statics instr]
ppr_raStatsColor, Maybe [RegAllocStats]
ppr_raStatsLinear, [RegAllocStats]
raStats, [(Label, Label)]
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.
(OutputableP Platform statics, 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', [(Label, Label)]
stack_updt_blks), UniqSupply
usAlloc')
                        = UniqSupply
-> UniqSM ([NatCmmDecl statics instr], [(Label, Label)])
-> (([NatCmmDecl statics instr], [(Label, Label)]), UniqSupply)
forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs UniqSupply
usAlloc (UniqSM ([NatCmmDecl statics instr], [(Label, Label)])
 -> (([NatCmmDecl statics instr], [(Label, Label)]), UniqSupply))
-> UniqSM ([NatCmmDecl statics instr], [(Label, Label)])
-> (([NatCmmDecl statics instr], [(Label, Label)]), UniqSupply)
forall a b. (a -> b) -> a -> b
$
                                case Maybe Int
maybe_more_stack of
                                Maybe Int
Nothing     -> ([NatCmmDecl statics instr], [(Label, Label)])
-> UniqSM ([NatCmmDecl statics instr], [(Label, Label)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([NatCmmDecl statics instr]
alloced, [])
                                Just Int
amount -> do
                                    ([NatCmmDecl statics instr]
alloced',[[(Label, Label)]]
stack_updt_blks) <- [(NatCmmDecl statics instr, [(Label, Label)])]
-> ([NatCmmDecl statics instr], [[(Label, Label)]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(NatCmmDecl statics instr, [(Label, Label)])]
 -> ([NatCmmDecl statics instr], [[(Label, Label)]]))
-> UniqSM [(NatCmmDecl statics instr, [(Label, Label)])]
-> UniqSM ([NatCmmDecl statics instr], [[(Label, Label)]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                                ((NatCmmDecl statics instr
 -> UniqSM (NatCmmDecl statics instr, [(Label, Label)]))
-> [NatCmmDecl statics instr]
-> UniqSM [(NatCmmDecl statics instr, [(Label, Label)])]
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, [(Label, Label)])
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> Int
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(Label, Label)])
ncgAllocMoreStack NcgImpl statics instr jumpDest
ncgImpl) Int
amount) [NatCmmDecl statics instr]
alloced)
                                    ([NatCmmDecl statics instr], [(Label, Label)])
-> UniqSM ([NatCmmDecl statics instr], [(Label, Label)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([NatCmmDecl statics instr]
alloced', [[(Label, Label)]] -> [(Label, Label)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Label, Label)]]
stack_updt_blks )


                -- dump out what happened during register allocation
                Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger 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)

                Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger 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 SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((instr -> SDoc)
-> RegAllocStats statics instr -> RegAllocStats statics SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Platform -> instr -> SDoc
forall instr. Instruction instr => Platform -> instr -> SDoc
pprInstr Platform
platform) 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], [(Label, Label)])
-> IO
     ([NatCmmDecl statics instr], UniqSupply,
      Maybe [RegAllocStats statics instr], Maybe [RegAllocStats],
      [RegAllocStats], [(Label, Label)])
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
                        , [], [(Label, Label)]
stack_updt_blks)

          else do
                -- do linear register allocation
                let reg_alloc :: LiveCmmDecl statics instr
-> UniqSM
     (NatCmmDecl statics instr, Maybe RegAllocStats, [(Label, Label)])
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.
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, [(Label, Label)])
-> UniqSM
     (NatCmmDecl statics instr, Maybe RegAllocStats, [(Label, Label)])
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',[(Label, Label)]
stack_updt_blks) <-
                               NcgImpl statics instr jumpDest
-> Int
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(Label, Label)])
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> Int
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(Label, Label)])
ncgAllocMoreStack NcgImpl statics instr jumpDest
ncgImpl Int
amount NatCmmDecl statics instr
alloced
                           (NatCmmDecl statics instr, Maybe RegAllocStats, [(Label, Label)])
-> UniqSM
     (NatCmmDecl statics instr, Maybe RegAllocStats, [(Label, Label)])
forall (m :: * -> *) a. Monad m => a -> m a
return (NatCmmDecl statics instr
alloced', Maybe RegAllocStats
ra_stats, [(Label, Label)]
stack_updt_blks )

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

                Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger 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], [(Label, Label)])
-> IO
     ([NatCmmDecl statics instr], UniqSupply,
      Maybe [RegAllocStats statics instr], Maybe [RegAllocStats],
      [RegAllocStats], [(Label, Label)])
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)
                        , [[(Label, Label)]] -> [(Label, Label)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Label, Label)]]
stack_updt_blks )

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

        let cfgWithFixupBlks :: Maybe CFG
cfgWithFixupBlks =
                (\CFG
cfg -> Weights -> CFG -> [(Label, Label, Label)] -> CFG
addNodesBetween Weights
weights CFG
cfg [(Label, Label, Label)]
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 -> [(Label, Label)] -> CFG)
-> Maybe (CFG -> [(Label, Label)] -> CFG)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CFG -> (Label, Label) -> CFG) -> CFG -> [(Label, Label)] -> CFG
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\CFG
m (Label
from,Label
to) -> Weights -> Label -> Label -> CFG -> CFG
addImmediateSuccessor Weights
weights Label
from Label
to CFG
m ))
                     Maybe (CFG -> [(Label, Label)] -> CFG)
-> Maybe CFG -> Maybe ([(Label, Label)] -> CFG)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe CFG
cfgWithFixupBlks
                     Maybe ([(Label, Label)] -> CFG)
-> Maybe [(Label, Label)] -> Maybe CFG
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(Label, Label)] -> Maybe [(Label, Label)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Label, Label)]
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
$ Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags
                DumpFlag
Opt_D_dump_cfg_weights String
"CFG Update information"
                DumpFormat
FormatText
                ( String -> SDoc
text String
"stack:" SDoc -> SDoc -> SDoc
<+> [(Label, Label)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Label, Label)]
stack_updt_blks SDoc -> SDoc -> SDoc
$$
                  String -> SDoc
text String
"linearAlloc:" SDoc -> SDoc -> SDoc
<+> [(Label, Label, Label)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Label, Label, Label)]
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 -> Weights -> RawCmmDecl -> CFG -> CFG
optimizeCFG (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CmmStaticPred DynFlags
dflags) Weights
weights RawCmmDecl
cmm (CFG -> CFG) -> Maybe CFG -> Maybe CFG
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
<$!> Maybe CFG
postShortCFG

        Logger -> DynFlags -> Maybe CFG -> String -> SDoc -> IO ()
maybeDumpCfg Logger
logger 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 -> Label) -> [GenBasicBlock instr] -> [Label]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenBasicBlock instr -> Label
forall i. GenBasicBlock i -> Label
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 (NcgImpl statics instr jumpDest
-> Maybe CFG
-> NatCmmDecl statics instr
-> NatCmmDecl statics instr
forall instr statics jumpDest.
Instruction instr =>
NcgImpl statics instr jumpDest
-> Maybe CFG
-> NatCmmDecl statics instr
-> NatCmmDecl statics instr
BlockLayout.sequenceTop
                        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

        Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger 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 :: Logger -> DynFlags -> Maybe CFG -> String -> SDoc -> IO ()
maybeDumpCfg :: Logger -> DynFlags -> Maybe CFG -> String -> SDoc -> IO ()
maybeDumpCfg Logger
_logger DynFlags
_dflags Maybe CFG
Nothing String
_ SDoc
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeDumpCfg Logger
logger 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
        = Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger
                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}.
(ElemOf set ~ Label, IsSet set) =>
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}.
(ElemOf set ~ Label, IsSet set) =>
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 -> Label) -> [GenBasicBlock i] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map GenBasicBlock i -> Label
forall i. GenBasicBlock i -> Label
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
Label
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 Label
blk_lbl [instr]
instrs <- [GenBasicBlock instr]
blks ]

-- | Build a doc for all the imports.
--
makeImportsDoc :: NCGConfig -> [CLabel] -> SDoc
makeImportsDoc :: NCGConfig -> [CLabel] -> SDoc
makeImportsDoc NCGConfig
config [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
        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 ( NCGConfig -> CLabel -> SDoc
pprImportedSymbol 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
renderWithContext
                              (NCGConfig -> SDocContext
ncgAsmContext NCGConfig
config)
                              (Platform -> LabelStyle -> CLabel -> SDoc
pprCLabel Platform
platform LabelStyle
AsmStyle CLabel
lbl))

-- -----------------------------------------------------------------------------
-- 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 Label
_ [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 Label) -> CFG -> CFG
shortcutWeightMap LabelMap (Maybe Label)
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 Label)
mappingBid = (jumpDest -> Maybe Label)
-> LabelMap jumpDest -> LabelMap (Maybe Label)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NcgImpl statics instr jumpDest -> jumpDest -> Maybe Label
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> jumpDest -> Maybe Label
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
_, [(Label, jumpDest)]
shortcut_blocks, [GenBasicBlock instr]
others) =
        ((LabelSet, [(Label, jumpDest)], [GenBasicBlock instr])
 -> GenBasicBlock instr
 -> (LabelSet, [(Label, jumpDest)], [GenBasicBlock instr]))
-> (LabelSet, [(Label, jumpDest)], [GenBasicBlock instr])
-> [GenBasicBlock instr]
-> (LabelSet, [(Label, jumpDest)], [GenBasicBlock instr])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (LabelSet, [(Label, jumpDest)], [GenBasicBlock instr])
-> GenBasicBlock instr
-> (LabelSet, [(Label, jumpDest)], [GenBasicBlock instr])
split (LabelSet
forall set. IsSet set => set
setEmpty :: LabelSet, [], []) [GenBasicBlock instr]
blocks
    split :: (LabelSet, [(Label, jumpDest)], [GenBasicBlock instr])
-> GenBasicBlock instr
-> (LabelSet, [(Label, jumpDest)], [GenBasicBlock instr])
split (LabelSet
s, [(Label, jumpDest)]
shortcut_blocks, [GenBasicBlock instr]
others) b :: GenBasicBlock instr
b@(BasicBlock Label
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 Label
dest <- NcgImpl statics instr jumpDest -> jumpDest -> Maybe Label
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> jumpDest -> Maybe Label
getJumpDestBlockId NcgImpl statics instr jumpDest
ncgImpl jumpDest
jd
        , Bool -> Bool
not (Label -> Bool
has_info Label
id)
        , (ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf LabelSet
Label
dest LabelSet
s) Bool -> Bool -> Bool
|| Label
dest Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
id -- loop checks
        = (LabelSet
s, [(Label, jumpDest)]
shortcut_blocks, GenBasicBlock instr
b GenBasicBlock instr
-> [GenBasicBlock instr] -> [GenBasicBlock instr]
forall a. a -> [a] -> [a]
: [GenBasicBlock instr]
others)
    split (LabelSet
s, [(Label, jumpDest)]
shortcut_blocks, [GenBasicBlock instr]
others) (BasicBlock Label
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 (Label -> Bool
has_info Label
id)
        = (ElemOf LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert ElemOf LabelSet
Label
id LabelSet
s, (Label
id,jumpDest
dest) (Label, jumpDest) -> [(Label, jumpDest)] -> [(Label, jumpDest)]
forall a. a -> [a] -> [a]
: [(Label, jumpDest)]
shortcut_blocks, [GenBasicBlock instr]
others)
    split (LabelSet
s, [(Label, jumpDest)]
shortcut_blocks, [GenBasicBlock instr]
others) GenBasicBlock instr
other = (LabelSet
s, [(Label, 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 :: Label -> Bool
has_info Label
l = KeyOf LabelMap -> LabelMap t -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember KeyOf LabelMap
Label
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)]
[(Label, 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
-> (Label -> Maybe jumpDest) -> statics -> statics
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> (Label -> Maybe jumpDest) -> statics -> statics
shortcutStatics NcgImpl statics instr jumpDest
ncgImpl (\Label
bid -> KeyOf LabelMap -> LabelMap jumpDest -> Maybe jumpDest
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
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 Label
id [instr]
insns) = Label -> [instr] -> GenBasicBlock instr
forall i. Label -> [i] -> GenBasicBlock i
BasicBlock Label
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
-> (Label -> Maybe jumpDest) -> instr -> instr
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> (Label -> Maybe jumpDest) -> instr -> instr
shortcutJump NcgImpl statics instr jumpDest
ncgImpl (\Label
bid -> KeyOf LabelMap -> LabelMap jumpDest -> Maybe jumpDest
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
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
        :: NCGConfig
        -> ModLocation
        -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
        -> DwarfFiles
        -> LabelMap DebugBlock
        -> RawCmmDecl
        -> CFG
        -> UniqSM
                ( [NatCmmDecl statics instr]
                , [CLabel]
                , DwarfFiles
                , CFG
                )

genMachCode :: forall statics instr.
NCGConfig
-> ModLocation
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> CFG
-> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
genMachCode NCGConfig
config 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
-> NCGConfig
-> ModLocation
-> DwarfFiles
-> LabelMap DebugBlock
-> CFG
-> NatM_State
mkNatM_State UniqSupply
initial_us Int
0 NCGConfig
config
                                                  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 -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm NCGConfig
_ top :: RawCmmDecl
top@(CmmData Section
_ RawCmmStatics
_) = (RawCmmDecl
top, [])
cmmToCmm NCGConfig
config (CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalReg]
live CmmGraph
graph)
    = NCGConfig -> CmmOptM RawCmmDecl -> (RawCmmDecl, [CLabel])
forall a. NCGConfig -> CmmOptM a -> (a, [CLabel])
runCmmOpt NCGConfig
config (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 (Label -> [CmmBlock] -> CmmGraph
ofBlockList (CmmGraph -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
graph) [CmmBlock]
blocks')

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

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

newtype CmmOptM a = CmmOptM (NCGConfig -> [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 -> [CLabel] -> OptMResult a) -> CmmOptM a
forall a. (NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a)
-> (NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a
forall a b. (a -> b) -> a -> b
$ \NCGConfig
_ [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 -> [CLabel] -> OptMResult a
f) >>= :: forall a b. CmmOptM a -> (a -> CmmOptM b) -> CmmOptM b
>>= a -> CmmOptM b
g =
    (NCGConfig -> [CLabel] -> OptMResult b) -> CmmOptM b
forall a. (NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((NCGConfig -> [CLabel] -> OptMResult b) -> CmmOptM b)
-> (NCGConfig -> [CLabel] -> OptMResult b) -> CmmOptM b
forall a b. (a -> b) -> a -> b
$ \NCGConfig
config [CLabel]
imports0 ->
                case NCGConfig -> [CLabel] -> OptMResult a
f NCGConfig
config [CLabel]
imports0 of
                  OptMResult a
x [CLabel]
imports1 ->
                    case a -> CmmOptM b
g a
x of
                      CmmOptM NCGConfig -> [CLabel] -> OptMResult b
g' -> NCGConfig -> [CLabel] -> OptMResult b
g' NCGConfig
config [CLabel]
imports1

instance CmmMakeDynamicReferenceM CmmOptM where
    addImport :: CLabel -> CmmOptM ()
addImport = CLabel -> CmmOptM ()
addImportCmmOpt

addImportCmmOpt :: CLabel -> CmmOptM ()
addImportCmmOpt :: CLabel -> CmmOptM ()
addImportCmmOpt CLabel
lbl = (NCGConfig -> [CLabel] -> OptMResult ()) -> CmmOptM ()
forall a. (NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((NCGConfig -> [CLabel] -> OptMResult ()) -> CmmOptM ())
-> (NCGConfig -> [CLabel] -> OptMResult ()) -> CmmOptM ()
forall a b. (a -> b) -> a -> b
$ \NCGConfig
_ [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 -> [CLabel] -> OptMResult NCGConfig)
-> CmmOptM NCGConfig
forall a. (NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a
CmmOptM ((NCGConfig -> [CLabel] -> OptMResult NCGConfig)
 -> CmmOptM NCGConfig)
-> (NCGConfig -> [CLabel] -> OptMResult NCGConfig)
-> CmmOptM NCGConfig
forall a b. (a -> b) -> a -> b
$ \NCGConfig
config [CLabel]
imports -> NCGConfig -> [CLabel] -> OptMResult NCGConfig
forall a b. a -> b -> (# a, b #)
OptMResult NCGConfig
config [CLabel]
imports

runCmmOpt :: NCGConfig -> CmmOptM a -> (a, [CLabel])
runCmmOpt :: forall a. NCGConfig -> CmmOptM a -> (a, [CLabel])
runCmmOpt NCGConfig
config (CmmOptM NCGConfig -> [CLabel] -> OptMResult a
f) =
  case NCGConfig -> [CLabel] -> OptMResult a
f NCGConfig
config [] 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 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
$ 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 Label
true Label
false Maybe Bool
likely
           -> do CmmExpr
test' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference CmmExpr
test
                 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
$ case CmmExpr
test' of
                   CmmLit (CmmInt Integer
0 Width
_) -> Label -> CmmNode O C
CmmBranch Label
false
                   CmmLit (CmmInt Integer
_ Width
_) -> Label -> CmmNode O C
CmmBranch Label
true
                   CmmExpr
_other -> CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C
CmmCondBranch CmmExpr
test' Label
true Label
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 Label
id)
          -> ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
referenceKind (CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (Label -> CLabel
infoTblLbl Label
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)
          -> 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

-- | Initialize the native code generator configuration from the DynFlags
initNCGConfig :: DynFlags -> Module -> NCGConfig
initNCGConfig :: DynFlags -> Module -> NCGConfig
initNCGConfig DynFlags
dflags Module
this_mod = NCGConfig
   { ncgPlatform :: Platform
ncgPlatform              = DynFlags -> Platform
targetPlatform DynFlags
dflags
   , ncgThisModule :: Module
ncgThisModule            = Module
this_mod
   , ncgAsmContext :: SDocContext
ncgAsmContext            = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags (LabelStyle -> PprStyle
PprCode LabelStyle
AsmStyle)
   , ncgProcAlignment :: Maybe Int
ncgProcAlignment         = DynFlags -> Maybe Int
cmmProcAlignment DynFlags
dflags
   , ncgExternalDynamicRefs :: Bool
ncgExternalDynamicRefs   = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalDynamicRefs DynFlags
dflags
   , ncgPIC :: Bool
ncgPIC                   = DynFlags -> Bool
positionIndependent DynFlags
dflags
   , ncgInlineThresholdMemcpy :: Word
ncgInlineThresholdMemcpy = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int
maxInlineMemcpyInsns DynFlags
dflags
   , ncgInlineThresholdMemset :: Word
ncgInlineThresholdMemset = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int
maxInlineMemsetInsns DynFlags
dflags
   , ncgSplitSections :: Bool
ncgSplitSections         = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SplitSections DynFlags
dflags
   , ncgRegsIterative :: Bool
ncgRegsIterative         = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RegsIterative DynFlags
dflags
   , ncgAsmLinting :: Bool
ncgAsmLinting            = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoAsmLinting DynFlags
dflags
   , ncgCfgWeights :: Weights
ncgCfgWeights            = DynFlags -> Weights
cfgWeights DynFlags
dflags
   , ncgCfgBlockLayout :: Bool
ncgCfgBlockLayout        = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CfgBlocklayout DynFlags
dflags
   , ncgCfgWeightlessLayout :: Bool
ncgCfgWeightlessLayout   = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WeightlessBlocklayout DynFlags
dflags

     -- With -O1 and greater, the cmmSink pass does constant-folding, so
     -- we don't need to do it again in the native code generator.
   , ncgDoConstantFolding :: Bool
ncgDoConstantFolding     = DynFlags -> Int
optLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1

   , ncgDumpRegAllocStages :: Bool
ncgDumpRegAllocStages    = DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_asm_regalloc_stages DynFlags
dflags
   , ncgDumpAsmStats :: Bool
ncgDumpAsmStats          = DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_asm_stats DynFlags
dflags
   , ncgDumpAsmConflicts :: Bool
ncgDumpAsmConflicts      = DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_asm_conflicts DynFlags
dflags
   , ncgBmiVersion :: Maybe BmiVersion
ncgBmiVersion            = case Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) of
                                 Arch
ArchX86_64 -> DynFlags -> Maybe BmiVersion
bmiVersion DynFlags
dflags
                                 Arch
ArchX86    -> DynFlags -> Maybe BmiVersion
bmiVersion DynFlags
dflags
                                 Arch
_          -> Maybe BmiVersion
forall a. Maybe a
Nothing

     -- We assume  SSE1 and SSE2 operations are available on both
     -- x86 and x86_64. Historically we didn't default to SSE2 and
     -- SSE1 on x86, which results in defacto nondeterminism for how
     -- rounding behaves in the associated x87 floating point instructions
     -- because variations in the spill/fpu stack placement of arguments for
     -- operations would change the precision and final result of what
     -- would otherwise be the same expressions with respect to single or
     -- double precision IEEE floating point computations.
   , ncgSseVersion :: Maybe SseVersion
ncgSseVersion =
      let v :: Maybe SseVersion
v | DynFlags -> Maybe SseVersion
sseVersion DynFlags
dflags Maybe SseVersion -> Maybe SseVersion -> Bool
forall a. Ord a => a -> a -> Bool
< SseVersion -> Maybe SseVersion
forall a. a -> Maybe a
Just SseVersion
SSE2 = SseVersion -> Maybe SseVersion
forall a. a -> Maybe a
Just SseVersion
SSE2
            | Bool
otherwise                     = DynFlags -> Maybe SseVersion
sseVersion DynFlags
dflags
      in case Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) of
            Arch
ArchX86_64 -> Maybe SseVersion
v
            Arch
ArchX86    -> Maybe SseVersion
v
            Arch
_          -> Maybe SseVersion
forall a. Maybe a
Nothing

   , ncgDwarfEnabled :: Bool
ncgDwarfEnabled        = OS -> Bool
osElfTarget (Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)) Bool -> Bool -> Bool
&& DynFlags -> Int
debugLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
/= Arch
ArchAArch64
   , ncgDwarfUnwindings :: Bool
ncgDwarfUnwindings     = OS -> Bool
osElfTarget (Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)) Bool -> Bool -> Bool
&& DynFlags -> Int
debugLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
   , ncgDwarfStripBlockInfo :: Bool
ncgDwarfStripBlockInfo = OS -> Bool
osElfTarget (Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)) Bool -> Bool -> Bool
&& DynFlags -> Int
debugLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 -- We strip out block information when running with -g0 or -g1.
   , ncgDwarfSourceNotes :: Bool
ncgDwarfSourceNotes    = OS -> Bool
osElfTarget (Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)) Bool -> Bool -> Bool
&& DynFlags -> Int
debugLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 -- We produce GHC-specific source-note DIEs only with -g3
   , ncgExposeInternalSymbols :: Bool
ncgExposeInternalSymbols = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExposeInternalSymbols DynFlags
dflags
   }