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

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

-- | 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(..)
   )
where

import GHC.Prelude hiding (head)

import qualified GHC.CmmToAsm.X86   as X86
import qualified GHC.CmmToAsm.PPC   as PPC
import qualified GHC.CmmToAsm.AArch64 as AArch64
import qualified GHC.CmmToAsm.Wasm as Wasm32

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.CLabel

import GHC.Types.Unique.FM
import GHC.Types.Unique.Supply
import GHC.Driver.DynFlags
import GHC.Driver.Ppr
import GHC.Utils.Misc
import GHC.Utils.Logger

import GHC.Utils.BufHandle
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Error
import GHC.Utils.Exception (evaluate)
import GHC.Utils.Constants (debugIsOn)

import GHC.Data.FastString
import GHC.Types.Unique.Set
import GHC.Unit
import GHC.Data.Stream (Stream)
import qualified GHC.Data.Stream as Stream
import GHC.Settings

import Data.List (sortBy)
import Data.List.NonEmpty (groupAllWith, head)
import Data.Maybe
import Data.Ord         ( comparing )
import Control.Monad
import System.IO
import System.Directory ( getCurrentDirectory )

--------------------
nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle -> UniqSupply
              -> Stream IO RawCmmGroup a
              -> IO a
nativeCodeGen :: forall a.
Logger
-> ToolSettings
-> NCGConfig
-> ModLocation
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen Logger
logger ToolSettings
ts NCGConfig
config ModLocation
modLoc Handle
h UniqSupply
us Stream IO RawCmmGroup a
cmms
 = let 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
-> 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
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen' Logger
logger 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
ArchS390X     -> String -> IO a
forall a. HasCallStack => String -> a
panic String
"nativeCodeGen: No NCG for S390X"
      ArchARM {}    -> String -> IO a
forall a. HasCallStack => 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. HasCallStack => String -> a
panic String
"nativeCodeGen: No NCG for Alpha"
      Arch
ArchMipseb    -> String -> IO a
forall a. HasCallStack => String -> a
panic String
"nativeCodeGen: No NCG for mipseb"
      Arch
ArchMipsel    -> String -> IO a
forall a. HasCallStack => String -> a
panic String
"nativeCodeGen: No NCG for mipsel"
      Arch
ArchRISCV64   -> String -> IO a
forall a. HasCallStack => String -> a
panic String
"nativeCodeGen: No NCG for RISCV64"
      Arch
ArchLoongArch64->String -> IO a
forall a. HasCallStack => String -> a
panic String
"nativeCodeGen: No NCG for LoongArch64"
      Arch
ArchUnknown   -> String -> IO a
forall a. HasCallStack => String -> a
panic String
"nativeCodeGen: No NCG for unknown arch"
      Arch
ArchJavaScript-> String -> IO a
forall a. HasCallStack => String -> a
panic String
"nativeCodeGen: No NCG for JavaScript"
      Arch
ArchWasm32    -> Platform
-> ToolSettings
-> UniqSupply
-> ModLocation
-> Handle
-> Stream IO RawCmmGroup a
-> IO a
forall a.
Platform
-> ToolSettings
-> UniqSupply
-> ModLocation
-> Handle
-> Stream IO RawCmmGroup a
-> IO a
Wasm32.ncgWasm Platform
platform ToolSettings
ts UniqSupply
us ModLocation
modLoc Handle
h Stream IO RawCmmGroup a
cmms

-- | 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
               -> 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
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen' Logger
logger 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 a. LabelMap a
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
        (NativeGenAcc statics instr
ngs, UniqSupply
us', a
a) <- Logger
-> 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
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
cmmNativeGenStream Logger
logger 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
-> NCGConfig
-> ModLocation
-> BufHandle
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
forall instr statics.
Instruction instr =>
Logger
-> NCGConfig
-> ModLocation
-> BufHandle
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
finishNativeGen Logger
logger NCGConfig
config ModLocation
modLoc BufHandle
bufh UniqSupply
us' NativeGenAcc statics instr
ngs
        a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

finishNativeGen :: Instruction instr
                => Logger
                -> NCGConfig
                -> ModLocation
                -> BufHandle
                -> UniqSupply
                -> NativeGenAcc statics instr
                -> IO UniqSupply
finishNativeGen :: forall instr statics.
Instruction instr =>
Logger
-> NCGConfig
-> ModLocation
-> BufHandle
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
finishNativeGen Logger
logger NCGConfig
config ModLocation
modLoc BufHandle
bufh UniqSupply
us NativeGenAcc statics instr
ngs
 = Logger
-> SDoc -> (UniqSupply -> ()) -> IO UniqSupply -> IO UniqSupply
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NCG") (UniqSupply -> () -> ()
forall a b. a -> b -> b
`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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return UniqSupply
us
                  else do
                     String
compPath <- IO String
getCurrentDirectory
                     let (HDoc
dwarf_h, UniqSupply
us') = String
-> NCGConfig
-> ModLocation
-> UniqSupply
-> [DebugBlock]
-> (HDoc, UniqSupply)
forall doc.
IsDoc doc =>
String
-> NCGConfig
-> ModLocation
-> UniqSupply
-> [DebugBlock]
-> (doc, UniqSupply)
dwarfGen String
compPath NCGConfig
config ModLocation
modLoc UniqSupply
us (NativeGenAcc statics instr -> [DebugBlock]
forall statics instr. NativeGenAcc statics instr -> [DebugBlock]
ngs_debug NativeGenAcc statics instr
ngs)
                         (SDoc
dwarf_s, UniqSupply
_)   = String
-> NCGConfig
-> ModLocation
-> UniqSupply
-> [DebugBlock]
-> (SDoc, UniqSupply)
forall doc.
IsDoc doc =>
String
-> NCGConfig
-> ModLocation
-> UniqSupply
-> [DebugBlock]
-> (doc, UniqSupply)
dwarfGen String
compPath NCGConfig
config ModLocation
modLoc UniqSupply
us (NativeGenAcc statics instr -> [DebugBlock]
forall statics instr. NativeGenAcc statics instr -> [DebugBlock]
ngs_debug NativeGenAcc statics instr
ngs)
                     Logger -> NCGConfig -> BufHandle -> HDoc -> SDoc -> IO ()
emitNativeCode Logger
logger NCGConfig
config BufHandle
bufh HDoc
dwarf_h SDoc
dwarf_s
                     UniqSupply -> IO UniqSupply
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return UniqSupply
us'

        -- 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 a. [a] -> 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 b a. (b -> a -> b) -> b -> [a] -> b
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 -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger
                  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 a. [a] -> 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
        BufHandle -> SDocContext -> HDoc -> IO ()
bPutHDoc BufHandle
bufh SDocContext
ctx (HDoc -> IO ()) -> HDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ NCGConfig -> [CLabel] -> HDoc
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))
        BufHandle -> IO ()
bFlush BufHandle
bufh

        UniqSupply -> IO UniqSupply
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return UniqSupply
us'
  where
    dump_stats :: SDoc -> IO ()
dump_stats = Logger
-> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
logDumpFile Logger
logger (NamePprCtx -> PprStyle
mkDumpStyle NamePprCtx
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
              -> 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
-> NCGConfig
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
cmmNativeGenStream Logger
logger 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
forall doc. IsLine doc => String -> doc
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NativeGenAcc statics instr
ngs { ngs_imports = reverse $ ngs_imports ngs
                      , ngs_natives = reverse $ ngs_natives ngs
                      , ngs_colorStats = reverse $ ngs_colorStats ngs
                      , ngs_linearStats = reverse $ ngs_linearStats 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 a b. IO a -> (a -> IO b) -> IO b
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
-> SDoc
-> ((UniqSupply, NativeGenAcc statics instr) -> ())
-> IO (UniqSupply, NativeGenAcc statics instr)
-> IO (UniqSupply, NativeGenAcc statics instr)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent Logger
logger
                SDoc
ncglabel (\(UniqSupply
a, NativeGenAcc statics instr
b) -> UniqSupply
a UniqSupply -> () -> ()
forall a b. a -> b -> b
`seq` NativeGenAcc statics instr
b NativeGenAcc statics instr -> () -> ()
forall a b. a -> b -> b
`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
-> NCGConfig
-> 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
-> NCGConfig
-> NcgImpl statics instr jumpDest
-> BufHandle
-> LabelMap DebugBlock
-> UniqSupply
-> RawCmmGroup
-> NativeGenAcc statics instr
-> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGens Logger
logger NCGConfig
config 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 = NCGConfig -> Platform
ncgPlatform NCGConfig
config
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([DebugBlock] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DebugBlock]
ldbgs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_debug String
"Debug Infos" DumpFormat
FormatText
                  ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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 = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
              (UniqSupply, NativeGenAcc statics instr)
-> IO (UniqSupply, NativeGenAcc statics instr)
forall a. a -> IO a
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
              -> NCGConfig
              -> 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
-> NCGConfig
-> NcgImpl statics instr jumpDest
-> BufHandle
-> LabelMap DebugBlock
-> UniqSupply
-> RawCmmGroup
-> NativeGenAcc statics instr
-> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
cmmNativeGens Logger
logger NCGConfig
config 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 a. a -> IO a
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
-> 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
-> 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 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, Int) -> doc
pprDecl (FastString
f,Int
n) = Line doc -> doc
forall doc. IsDoc doc => Line doc -> doc
line (Line doc -> doc) -> Line doc -> doc
forall a b. (a -> b) -> a -> b
$ String -> Line doc
forall doc. IsLine doc => String -> doc
text String
"\t.file " Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> Line doc
forall doc. IsLine doc => Int -> doc
int Int
n Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                                   String -> Line doc
forall doc. IsLine doc => String -> doc
pprFilePathString (FastString -> String
unpackFS FastString
f)

        -- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad
        Logger -> NCGConfig -> BufHandle -> HDoc -> SDoc -> IO ()
emitNativeCode Logger
logger NCGConfig
config BufHandle
h
          ([HDoc] -> HDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([HDoc] -> HDoc) -> [HDoc] -> HDoc
forall a b. (a -> b) -> a -> b
$
           ((FastString, Int) -> HDoc) -> [(FastString, Int)] -> [HDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FastString, Int) -> HDoc
forall {doc}. IsDoc doc => (FastString, Int) -> doc
pprDecl [(FastString, Int)]
newFileIds [HDoc] -> [HDoc] -> [HDoc]
forall a. [a] -> [a] -> [a]
++
           (NatCmmDecl statics instr -> HDoc)
-> [NatCmmDecl statics instr] -> [HDoc]
forall a b. (a -> b) -> [a] -> [b]
map (NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> HDoc
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> HDoc
pprNatCmmDeclH NcgImpl statics instr jumpDest
ncgImpl) [NatCmmDecl statics instr]
native)
          ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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 {doc}. IsDoc doc => (FastString, Int) -> doc
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
pprNatCmmDeclS NcgImpl statics instr jumpDest
ncgImpl) [NatCmmDecl statics instr]
native)

        -- force evaluation all this stuff to avoid space leaks
        let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
        {-# 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 (SDoc -> String
showSDocUnsafe (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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 doc. IsLine doc => Platform -> CLabel -> doc
pprAsmLabel 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 Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_asm_stats
                        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     = imports : ngs_imports ngs
                      , ngs_natives     = natives'
                      , ngs_colorStats  = colorStats `mCon` ngs_colorStats ngs
                      , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs
                      , ngs_labels      = ngs_labels ngs ++ labels'
                      , ngs_dwarfFiles  = fileIds'
                      , ngs_unwinds     = ngs_unwinds ngs `mapUnion` 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)


-- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad
emitNativeCode :: Logger -> NCGConfig -> BufHandle -> HDoc -> SDoc -> IO ()
emitNativeCode :: Logger -> NCGConfig -> BufHandle -> HDoc -> SDoc -> IO ()
emitNativeCode Logger
logger NCGConfig
config BufHandle
h HDoc
hdoc SDoc
sdoc = do
        let ctx :: SDocContext
ctx = NCGConfig -> SDocContext
ncgAsmContext NCGConfig
config
        {-# SCC "pprNativeCode" #-} BufHandle -> SDocContext -> HDoc -> IO ()
bPutHDoc BufHandle
h SDocContext
ctx HDoc
hdoc

        -- dump native code
        Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger
                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
    -> 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
-> 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 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 doc. IsLine doc => Platform -> CLabel -> doc
pprAsmLabel Platform
platform CLabel
entry_label
                RawCmmDecl
_                           -> String -> SDoc
forall doc. IsLine doc => String -> doc
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 -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger
                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
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> CFG
-> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
forall statics instr.
NCGConfig
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> CFG
-> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
genMachCode NCGConfig
config
                                        (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 -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger
                DumpFlag
Opt_D_dump_asm_native String
"Native code" DumpFormat
FormatASM
                ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
pprNatCmmDeclS NcgImpl statics instr jumpDest
ncgImpl) [NatCmmDecl statics instr]
native)

        Logger -> Maybe CFG -> String -> SDoc -> IO ()
maybeDumpCfg Logger
logger (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 NCGConfig -> Bool
ncgEnableDeadCodeElimination NCGConfig
config
                                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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger
                DumpFlag
Opt_D_dump_asm_liveness String
"Liveness annotations added"
                DumpFormat
FormatCMM
                ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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 ( NCGConfig -> Bool
ncgRegsGraph NCGConfig
config Bool -> Bool -> Bool
|| NCGConfig -> Bool
ncgRegsIterative NCGConfig
config )
          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 a b. (a -> b -> b) -> b -> [a] -> b
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 a. a -> UniqSM a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> UniqSM a
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 -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger
                        DumpFlag
Opt_D_dump_asm_regalloc String
"Registers allocated"
                        DumpFormat
FormatCMM
                        ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
pprNatCmmDeclS NcgImpl statics instr jumpDest
ncgImpl) [NatCmmDecl statics instr]
alloced)

                Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger
                        DumpFlag
Opt_D_dump_asm_regalloc_stages String
"Build/spill stages"
                        DumpFormat
FormatText
                        ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsLine doc => String -> doc
text String
"# --------------------------"
                                        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"#  cmm " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
count SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" Stage " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
stage
                                        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ RegAllocStats statics SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((instr -> SDoc)
-> RegAllocStats statics instr -> RegAllocStats statics SDoc
forall a b.
(a -> b) -> RegAllocStats statics a -> RegAllocStats statics b
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 Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_asm_stats
                         then [RegAllocStats statics instr]
-> Maybe [RegAllocStats statics instr]
forall a. a -> Maybe a
Just [RegAllocStats statics instr]
regAllocStats else Maybe [RegAllocStats statics instr]
forall a. Maybe a
Nothing

                -- force evaluation of the Maybe to avoid space leak
                Maybe [RegAllocStats statics instr]
mPprStats Maybe [RegAllocStats statics instr] -> IO () -> IO ()
forall a b. a -> b -> b
`seq` () -> IO ()
forall a. a -> IO a
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 a. a -> IO a
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 a. a -> UniqSM a
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 a. a -> UniqSM a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LiveCmmDecl statics instr
-> UniqSM
     (NatCmmDecl statics instr, Maybe RegAllocStats, [(Label, Label)])
reg_alloc [LiveCmmDecl statics instr]
withLiveness

                Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger
                        DumpFlag
Opt_D_dump_asm_regalloc String
"Registers allocated"
                        DumpFormat
FormatCMM
                        ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
pprNatCmmDeclS NcgImpl statics instr jumpDest
ncgImpl) [NatCmmDecl statics instr]
alloced)

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

                -- force evaluation of the Maybe to avoid space leak
                Maybe [RegAllocStats]
mPprStats Maybe [RegAllocStats] -> IO () -> IO ()
forall a b. a -> b -> b
`seq` () -> IO ()
forall a. a -> IO a
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 a. a -> IO a
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 a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CFG -> (Label, Label) -> CFG) -> CFG -> [(Label, Label)] -> CFG
forall b a. (b -> a -> b) -> b -> [a] -> b
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 a b. Maybe (a -> b) -> Maybe a -> Maybe b
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 a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(Label, Label)] -> Maybe [(Label, Label)]
forall a. a -> Maybe a
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 a. LabelMap a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CFG
nativeCfgWeights) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger
                DumpFlag
Opt_D_dump_cfg_weights String
"CFG Update information"
                DumpFormat
FormatText
                ( String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stack:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [(Label, Label)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Label, Label)]
stack_updt_blks SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"linearAlloc:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [(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" #-}
                NCGConfig
-> NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr]
-> Maybe CFG
-> ([NatCmmDecl statics instr], Maybe CFG)
forall statics instr jumpDest.
Outputable jumpDest =>
NCGConfig
-> NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr]
-> Maybe CFG
-> ([NatCmmDecl statics instr], Maybe CFG)
shortcutBranches NCGConfig
config 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 (NCGConfig -> Bool
ncgCmmStaticPred NCGConfig
config) 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 -> Maybe CFG -> String -> SDoc -> IO ()
maybeDumpCfg Logger
logger 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 ( NCGConfig -> Bool
ncgEnableDeadCodeElimination NCGConfig
config Bool -> Bool -> Bool
&&
                (NCGConfig -> Bool
ncgAsmLinting NCGConfig
config 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 a b. (a -> b) -> [a] -> [b]
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! Bool -> () -> ()
forall a b. a -> b -> b
seq (CFG -> LabelSet -> SDoc -> Bool
sanityCheckCfg CFG
cfg LabelSet
labels (SDoc -> Bool) -> SDoc -> Bool
forall a b. (a -> b) -> a -> b
$
                                String -> SDoc
forall doc. IsLine doc => String -> doc
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)

        -- 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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. LabelMap a
forall (map :: * -> *) a. IsMap map => map a
mapEmpty [NatCmmDecl statics instr]
branchOpt
              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 a. LabelMap a -> LabelMap a -> LabelMap a
forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
`mapUnion` NCGConfig
-> NcgImpl statics instr jumpDest
-> NatCmmDecl statics instr
-> LabelMap [UnwindPoint]
forall instr statics jumpDest.
Instruction instr =>
NCGConfig
-> NcgImpl statics instr jumpDest
-> NatCmmDecl statics instr
-> LabelMap [UnwindPoint]
computeUnwinding NCGConfig
config 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return  ( UniqSupply
usAlloc
                , DwarfFiles
fileIds'
                , [NatCmmDecl statics instr]
branchOpt
                , [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 -> Maybe CFG -> String -> SDoc -> IO ()
maybeDumpCfg :: Logger -> Maybe CFG -> String -> SDoc -> IO ()
maybeDumpCfg Logger
_logger Maybe CFG
Nothing String
_ SDoc
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeDumpCfg Logger
logger (Just CFG
cfg) String
msg SDoc
proc_name
        | CFG -> Bool
forall a. LabelMap a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CFG
cfg = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise
        = Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger
                DumpFlag
Opt_D_dump_cfg_weights String
msg
                DumpFormat
FormatText
                (SDoc
proc_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ 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 =
        Bool
-> SDoc -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (LabelSet -> Bool
forall set. IsSet set => set -> Bool
setNull LabelSet
diff) (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Block sequencing dropped blocks:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> LabelSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr LabelSet
diff)
        [NatCmmDecl statics instr]
procsSequenced
  where
        blocks1 :: LabelSet
blocks1 = (LabelSet -> LabelSet -> LabelSet)
-> LabelSet -> [LabelSet] -> LabelSet
forall b a. (b -> a -> b) -> b -> [a] -> b
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 b a. (b -> a -> b) -> b -> [a] -> b
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
                 => NCGConfig
                 -> 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 =>
NCGConfig
-> NcgImpl statics instr jumpDest
-> NatCmmDecl statics instr
-> LabelMap [UnwindPoint]
computeUnwinding NCGConfig
config NcgImpl statics instr jumpDest
_ NatCmmDecl statics instr
_
  | Bool -> Bool
not (NCGConfig -> Bool
ncgComputeUnwinding NCGConfig
config) = LabelMap [UnwindPoint]
forall a. LabelMap a
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
computeUnwinding NCGConfig
_ NcgImpl statics instr jumpDest
_ (CmmData Section
_ statics
_)   = LabelMap [UnwindPoint]
forall a. LabelMap a
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
computeUnwinding NCGConfig
_ 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 a. [(KeyOf LabelMap, a)] -> LabelMap a
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] -> HDoc
makeImportsDoc :: NCGConfig -> [CLabel] -> HDoc
makeImportsDoc NCGConfig
config [CLabel]
imports
 = [CLabel] -> HDoc
dyld_stubs [CLabel]
imports
            HDoc -> HDoc -> HDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
            -- 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 Line HDoc -> HDoc
forall doc. IsDoc doc => Line doc -> doc
line (Line HDoc -> HDoc) -> Line HDoc -> HDoc
forall a b. (a -> b) -> a -> b
$ String -> HLine
forall doc. IsLine doc => String -> doc
text String
".subsections_via_symbols"
             else HDoc
forall doc. IsOutput doc => doc
Outputable.empty)
            HDoc -> HDoc -> HDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                -- 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 Line HDoc -> HDoc
forall doc. IsDoc doc => Line doc -> doc
line (Line HDoc -> HDoc) -> Line HDoc -> HDoc
forall a b. (a -> b) -> a -> b
$ String -> HLine
forall doc. IsLine doc => String -> doc
text String
".section .note.GNU-stack,\"\"," HLine -> HLine -> HLine
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> String -> HLine
forall doc. IsLine doc => Platform -> String -> doc
sectionType Platform
platform String
"progbits"
             else HDoc
forall doc. IsOutput doc => doc
Outputable.empty)
            HDoc -> HDoc -> HDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                -- 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 :: HLine
compilerIdent = String -> HLine
forall doc. IsLine doc => String -> doc
text String
"GHC" HLine -> HLine -> HLine
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> HLine
forall doc. IsLine doc => String -> doc
text String
cProjectVersion
                   in Line HDoc -> HDoc
forall doc. IsDoc doc => Line doc -> doc
line (Line HDoc -> HDoc) -> Line HDoc -> HDoc
forall a b. (a -> b) -> a -> b
$ String -> HLine
forall doc. IsLine doc => String -> doc
text String
".ident" HLine -> HLine -> HLine
forall doc. IsLine doc => doc -> doc -> doc
<+> HLine -> HLine
forall doc. IsLine doc => doc -> doc
doubleQuotes HLine
compilerIdent
             else HDoc
forall doc. IsOutput doc => doc
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] -> HDoc
        -- (Hack) sometimes two Labels pretty-print the same, but have
        -- different uniques; so we compare their text versions...
        dyld_stubs :: [CLabel] -> HDoc
dyld_stubs [CLabel]
imps
                | NCGConfig -> Bool
needImportedSymbols NCGConfig
config
                = [HDoc] -> HDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([HDoc] -> HDoc) -> [HDoc] -> HDoc
forall a b. (a -> b) -> a -> b
$
                        (NCGConfig -> HDoc
pprGotDeclaration NCGConfig
config HDoc -> [HDoc] -> [HDoc]
forall a. a -> [a] -> [a]
:) ([HDoc] -> [HDoc]) -> [HDoc] -> [HDoc]
forall a b. (a -> b) -> a -> b
$
                        (NonEmpty (CLabel, String) -> HDoc)
-> [NonEmpty (CLabel, String)] -> [HDoc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NCGConfig -> CLabel -> HDoc
pprImportedSymbol NCGConfig
config (CLabel -> HDoc)
-> (NonEmpty (CLabel, String) -> CLabel)
-> NonEmpty (CLabel, String)
-> HDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CLabel, String) -> CLabel
forall a b. (a, b) -> a
fst ((CLabel, String) -> CLabel)
-> (NonEmpty (CLabel, String) -> (CLabel, String))
-> NonEmpty (CLabel, String)
-> CLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (CLabel, String) -> (CLabel, String)
forall a. NonEmpty a -> a
head) ([NonEmpty (CLabel, String)] -> [HDoc])
-> [NonEmpty (CLabel, String)] -> [HDoc]
forall a b. (a -> b) -> a -> b
$
                        ((CLabel, String) -> String)
-> [(CLabel, String)] -> [NonEmpty (CLabel, String)]
forall b a. Ord b => (a -> b) -> [a] -> [NonEmpty a]
groupAllWith (CLabel, String) -> String
forall a b. (a, b) -> b
snd ([(CLabel, String)] -> [NonEmpty (CLabel, String)])
-> [(CLabel, String)] -> [NonEmpty (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
                = HDoc
forall doc. IsOutput doc => doc
Outputable.empty

        doPpr :: CLabel -> (CLabel, String)
doPpr CLabel
lbl = (CLabel
lbl, SDocContext -> SDoc -> String
showSDocOneLine
                              (NCGConfig -> SDocContext
ncgAsmContext NCGConfig
config)
                              (Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprAsmLabel Platform
platform 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) = (instr -> Maybe (NatCmmDecl statics instr))
-> [instr] -> [NatCmmDecl statics instr]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (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

-- Note [No asm-shortcutting on Darwin]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Asm-shortcutting may produce relative references to symbols defined in
-- other compilation units. This is not something that MachO relocations
-- support (see #21972). For this reason we disable the optimisation on Darwin.
-- We do so in the backend without a warning since this flag is enabled by
-- `-O2`.
--
-- Another way to address this issue would be to rather implement a
-- PLT-relocatable jump-table strategy. However, this would only benefit Darwin
-- and does not seem worth the effort as this optimisation generally doesn't
-- offer terribly great benefits.

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

shortcutBranches :: forall statics instr jumpDest.
Outputable jumpDest =>
NCGConfig
-> NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr]
-> Maybe CFG
-> ([NatCmmDecl statics instr], Maybe CFG)
shortcutBranches NCGConfig
config NcgImpl statics instr jumpDest
ncgImpl [NatCmmDecl statics instr]
tops Maybe CFG
weights
  | NCGConfig -> Bool
ncgEnableShortcutting NCGConfig
config
    -- See Note [No asm-shortcutting on Darwin]
  , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ OS -> Bool
osMachOTarget (OS -> Bool) -> OS -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> OS
platformOS (Platform -> OS) -> Platform -> OS
forall a b. (a -> b) -> a -> b
$ NCGConfig -> Platform
ncgPlatform NCGConfig
config
  = ( (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 a b. (a -> b) -> LabelMap a -> LabelMap b
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 a. LabelMap a
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 a. LabelMap a
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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. KeyOf LabelMap -> LabelMap a -> 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 a. [(KeyOf LabelMap, a)] -> LabelMap a
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 a. KeyOf LabelMap -> LabelMap a -> Maybe a
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 a. KeyOf LabelMap -> LabelMap a -> Maybe a
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
        -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
        -> DwarfFiles
        -> LabelMap DebugBlock
        -> RawCmmDecl
        -> CFG
        -> UniqSM
                ( [NatCmmDecl statics instr]
                , [CLabel]
                , DwarfFiles
                , CFG
                )

genMachCode :: forall statics instr.
NCGConfig
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> DwarfFiles
-> LabelMap DebugBlock
-> RawCmmDecl
-> CFG
-> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
genMachCode NCGConfig
config 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
-> DwarfFiles
-> LabelMap DebugBlock
-> CFG
-> NatM_State
mkNatM_State UniqSupply
initial_us Int
0 NCGConfig
config
                                                  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 a. a -> UniqSM a
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
forall doc. IsLine doc => Int -> doc
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CmmBlock -> CmmOptM CmmBlock
cmmBlockConFold (CmmGraph -> [CmmBlock]
toBlockList CmmGraph
graph)
         RawCmmDecl -> CmmOptM RawCmmDecl
forall a. a -> CmmOptM a
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
$cfmap :: forall a b. (a -> b) -> CmmOptM a -> CmmOptM b
fmap :: forall a b. (a -> b) -> CmmOptM a -> CmmOptM b
$c<$ :: forall a b. a -> CmmOptM b -> CmmOptM a
<$ :: forall a b. a -> CmmOptM b -> CmmOptM a
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 'Closed 'Open
entry, Block CmmNode 'Open 'Open
middle, CmmNode 'Open 'Closed
last) = CmmBlock
-> (CmmNode 'Closed 'Open, Block CmmNode 'Open 'Open,
    CmmNode 'Open 'Closed)
forall (n :: Extensibility -> Extensibility -> *).
Block n 'Closed 'Closed
-> (n 'Closed 'Open, Block n 'Open 'Open, n 'Open 'Closed)
blockSplit CmmBlock
block
      stmts :: [CmmNode 'Open 'Open]
stmts = Block CmmNode 'Open 'Open -> [CmmNode 'Open 'Open]
forall (n :: Extensibility -> Extensibility -> *).
Block n 'Open 'Open -> [n 'Open 'Open]
blockToList Block CmmNode 'Open 'Open
middle
  [CmmNode 'Open 'Open]
stmts' <- (CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open))
-> [CmmNode 'Open 'Open] -> CmmOptM [CmmNode 'Open 'Open]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open)
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmOptM (CmmNode e x)
cmmStmtConFold [CmmNode 'Open 'Open]
stmts
  CmmNode 'Open 'Closed
last' <- CmmNode 'Open 'Closed -> CmmOptM (CmmNode 'Open 'Closed)
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmOptM (CmmNode e x)
cmmStmtConFold CmmNode 'Open 'Closed
last
  CmmBlock -> CmmOptM CmmBlock
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmBlock -> CmmOptM CmmBlock) -> CmmBlock -> CmmOptM CmmBlock
forall a b. (a -> b) -> a -> b
$ CmmNode 'Closed 'Open
-> Block CmmNode 'Open 'Open -> CmmNode 'Open 'Closed -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *).
n 'Closed 'Open
-> Block n 'Open 'Open
-> n 'Open 'Closed
-> Block n 'Closed 'Closed
blockJoin CmmNode 'Closed 'Open
entry ([CmmNode 'Open 'Open] -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
[n 'Open 'Open] -> Block n 'Open 'Open
blockFromList [CmmNode 'Open 'Open]
stmts') CmmNode 'Open 'Closed
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 a. a -> CmmOptM a
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 'Open 'Open
CmmComment (String -> FastString
fsLit String
"nop")
                   CmmExpr
new_src -> CmmReg -> CmmExpr -> CmmNode 'Open 'Open
CmmAssign CmmReg
reg CmmExpr
new_src

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

        CmmCall { cml_target :: CmmNode 'Open 'Closed -> 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 a. a -> CmmOptM a
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 = 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 a. a -> CmmOptM a
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 a. a -> CmmOptM a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold ReferenceKind
DataReference) [CmmExpr]
args
                 CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open)
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open))
-> CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open)
forall a b. (a -> b) -> a -> b
$ ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmNode 'Open 'Open
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 a. a -> CmmOptM a
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 'Open 'Closed
CmmBranch Label
false
                   CmmLit (CmmInt Integer
_ Width
_) -> Label -> CmmNode 'Open 'Closed
CmmBranch Label
true
                   CmmExpr
_other -> CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
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 'Open 'Closed -> CmmOptM (CmmNode 'Open 'Closed)
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode 'Open 'Closed -> CmmOptM (CmmNode 'Open 'Closed))
-> CmmNode 'Open 'Closed -> CmmOptM (CmmNode 'Open 'Closed)
forall a b. (a -> b) -> a -> b
$ CmmExpr -> SwitchTargets -> CmmNode 'Open 'Closed
CmmSwitch CmmExpr
expr' SwitchTargets
ids

        CmmNode e x
other
           -> CmmNode e x -> CmmOptM (CmmNode e x)
forall a. a -> CmmOptM a
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 AlignmentSpec
align) = CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (NCGConfig -> CmmExpr -> CmmExpr
cmmExprCon NCGConfig
config CmmExpr
addr) CmmType
rep AlignmentSpec
align
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 AlignmentSpec
align
          -> do CmmExpr
addr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
DataReference CmmExpr
addr
                CmmExpr -> CmmOptM CmmExpr
forall a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmExpr -> CmmOptM CmmExpr) -> CmmExpr -> CmmOptM CmmExpr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
addr' CmmType
rep AlignmentSpec
align

        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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative ReferenceKind
DataReference) [CmmExpr]
args
                CmmExpr -> CmmOptM CmmExpr
forall a. a -> CmmOptM a
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 a. a -> CmmOptM a
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 (GlobalRegUse GlobalReg
EagerBlackholeInfo CmmType
_))
          | 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 (GlobalRegUse GlobalReg
GCEnter1 CmmType
_))
          | 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 (GlobalRegUse GlobalReg
GCFun CmmType
_))
          | 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 a. a -> CmmOptM a
forall (m :: * -> *) a. Monad m => a -> m a
return CmmExpr
other