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

-- | Note [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. (Which ideally would be folded into CmmOpt ...)
--
-- We convert to the machine-specific 'Instr' datatype with
-- 'cmmCodeGen', assuming an infinite supply of registers.  We then use
-- a (mostly) machine-independent register allocator to rejoin
-- reality.  Obviously, 'regAlloc' has machine-specific helper
-- functions (see the used register allocator for details).
--
-- 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 are generally contained under
--  GHC/CmmToAsm/<Arch>/* and generally breaks down as follows:
--
--   * "Regs": Everything about the target platform's machine
--     registers (and immediate operands, and addresses, which tend to
--     intermingle/interact with registers).
--
--   * "Instr":  Includes the 'Instr' datatype plus a miscellany of other things
--     (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
--
--   * "CodeGen":  is where 'Cmm' stuff turns into
--     machine instructions.
--
--   * "Ppr": 'pprInstr' turns an 'Instr' into text (well, really
--     a 'SDoc').
--
-- The register allocators lives under GHC.CmmToAsm.Reg.*, there is both a Linear and a Graph
-- based register allocator. Both of which have their own notes describing them. They
-- are mostly platform independent but there are some platform specific files
-- encoding architecture details under Reg/<Allocator>/<Arch.hs>
--
-- -}
--
module GHC.CmmToAsm
   ( nativeCodeGen

   -- * Test-only exports: see #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.Dataflow.Label
import GHC.Cmm.GenericOpt
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    -> NCGConfig
-> Logger
-> Platform
-> ToolSettings
-> UniqSupply
-> ModLocation
-> Handle
-> Stream IO RawCmmGroup a
-> IO a
forall a.
NCGConfig
-> Logger
-> Platform
-> ToolSettings
-> UniqSupply
-> ModLocation
-> Handle
-> Stream IO RawCmmGroup a
-> IO a
Wasm32.ncgWasm NCGConfig
config Logger
logger 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).
        bufh <- Handle -> IO BufHandle
newBufHandle Handle
h
        let 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 {k} (key :: k) elt. UniqFM key elt
emptyUFM LabelMap [UnwindPoint]
forall v. LabelMap v
mapEmpty
        (ngs, us', a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh us
                                         cmms ngs0
        _ <- finishNativeGen logger config modLoc bufh us' ngs
        return 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
        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
                     compPath <- IO String
getCurrentDirectory
                     let (dwarf_h, us') = dwarfGen compPath config modLoc us (ngs_debug ngs)
                         (dwarf_s, _)   = dwarfGen compPath config modLoc us (ngs_debug ngs)
                     emitNativeCode logger config bufh dwarf_h dwarf_s
                     return us'

        -- dump global NCG stats for graph coloring allocator
        let 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)
        unless (null stats) $ do

          -- build the global register conflict graph
          let 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]

          dump_stats (Color.pprStats stats graphGlobal)

          let platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
          putDumpFileMaybe logger
                  Opt_D_dump_asm_conflicts "Register conflict graph"
                  FormatText
                  $ Color.dotGraph
                          (targetRegDotColor platform)
                          (Color.trivColorable platform
                                  (targetVirtualRegSqueeze platform)
                                  (targetRealRegSqueeze platform))
                  $ graphGlobal


        -- dump global NCG stats for linear allocator
        let 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)
        unless (null linearStats) $
          dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)

        -- write out the imports
        let ctx = NCGConfig -> SDocContext
ncgAsmContext NCGConfig
config
        bPutHDoc bufh ctx $ makeImportsDoc config (concat (ngs_imports ngs))
        bFlush bufh

        return 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
          (us', 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
              (ngs',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 = [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 = NCGConfig -> Platform
ncgPlatform NCGConfig
config
              unless (null ldbgs) $
                putDumpFileMaybe logger Opt_D_dump_debug "Debug Infos" FormatText
                  (vcat $ map (pdoc platform) ldbgs)

              -- Accumulate debug information for emission in finishNativeGen.
              let ngs'' = NativeGenAcc statics instr
ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
              return (us', ngs'')

          loop us' cmm_stream' 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
        (us', fileIds', native, imports, colorStats, linearStats, 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) -> (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 {k} (key :: k) 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 {k} (key :: k) elt1 elt2.
UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1
`minusUFM` DwarfFiles
fileIds
            -- See Note [Unique Determinism and code generation]
            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
        emitNativeCode logger config h
          (vcat $
           map pprDecl newFileIds ++
           map (pprNatCmmDeclH ncgImpl) native)
          (vcat $
           map pprDecl newFileIds ++
           map (pprNatCmmDeclS ncgImpl) native)

        -- force evaluation all this stuff to avoid space leaks
        let platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
        {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pprAsmLabel platform) imports) ()

        let !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' = 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 = ([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{ 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
                      }
        go us' cmms ngs' (count + 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
        (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, 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 {k} elt (key :: k).
(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 {k} (key :: k) 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
                                    (alloced',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)
                                    return (alloced', concat 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
                       (alloced, maybe_more_stack, 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_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
                           (alloced',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
                           return (alloced', ra_stats, 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 = ((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 =
                (\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 =
                (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      =
                {-# 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

        when (not $ null nativeCfgWeights) $ putDumpFileMaybe logger
                Opt_D_dump_cfg_weights "CFG Update information"
                FormatText
                ( text "stack:" <+> ppr stack_updt_blks $$
                  text "linearAlloc:" <+> ppr cfgRegAllocUpdates )

        ---- shortcut branches
        let (shorted, postShortCFG)     =
                {-# SCC "shortcutBranches" #-}
                shortcutBranches config ncgImpl tabled postRegCFG

        let 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

        maybeDumpCfg logger optimizedCFG "CFG Weights - Final" proc_name

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

        when ( ncgEnableDeadCodeElimination config &&
                (ncgAsmLinting config || debugIsOn )) $ do
                let 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 = [Label] -> LabelSet
setFromList ([Label] -> LabelSet) -> [Label] -> 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 = Maybe CFG -> CFG
forall a. HasCallStack => Maybe a -> a
fromJust Maybe CFG
optimizedCFG
                return $! seq (sanityCheckCfg cfg labels $
                                text "cfg not in lockstep") ()

        ---- sequence blocks
        -- sequenced :: [NatCmmDecl statics instr]
        let (sequenced, us_seq) =
                        {-# SCC "sequenceBlocks" #-}
                        initUs usAlloc $ mapM (BlockLayout.sequenceTop
                                ncgImpl optimizedCFG)
                            shorted

        massert (checkLayout shorted sequenced)

        let 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 =
                {-# 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 v. LabelMap v
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 v. LabelMap v -> LabelMap v -> LabelMap v
`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

        return  ( us_seq
                , fileIds'
                , branchOpt
                , lastMinuteImports ++ imports
                , ppr_raStatsColor
                , ppr_raStatsLinear
                , 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]
            -> Bool
checkLayout :: forall statics instr.
[NatCmmDecl statics instr] -> [NatCmmDecl statics instr] -> Bool
checkLayout [NatCmmDecl statics instr]
procsUnsequenced [NatCmmDecl statics instr]
procsSequenced =
        Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (LabelSet -> 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)
        Bool
True
  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
setUnion) LabelSet
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 {d} {h} {i}. GenCmmDecl d h (ListGraph i) -> LabelSet
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
setUnion) LabelSet
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 {d} {h} {i}. GenCmmDecl d h (ListGraph i) -> LabelSet
getBlockIds [NatCmmDecl statics instr]
procsSequenced
        diff :: LabelSet
diff = LabelSet -> LabelSet -> LabelSet
setDifference LabelSet
blocks1 LabelSet
blocks2

        getBlockIds :: GenCmmDecl d h (ListGraph i) -> LabelSet
getBlockIds (CmmData Section
_ d
_) = LabelSet
setEmpty
        getBlockIds (CmmProc h
_ CLabel
_ [GlobalReg]
_ (ListGraph [GenBasicBlock i]
blocks)) =
                [Label] -> LabelSet
setFromList ([Label] -> LabelSet) -> [Label] -> LabelSet
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 v. LabelMap v
mapEmpty
computeUnwinding NCGConfig
_ NcgImpl statics instr jumpDest
_ (CmmData Section
_ statics
_)   = LabelMap [UnwindPoint]
forall v. LabelMap v
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.
    [(Label, [UnwindPoint])] -> LabelMap [UnwindPoint]
forall v. [(Label, v)] -> LabelMap v
mapFromList [ (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 a. [LabelMap a] -> LabelMap 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 v. LabelMap v
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 v. LabelMap v
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
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)
        , (Label -> LabelSet -> Bool
setMember 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)
        = (Label -> LabelSet -> LabelSet
setInsert 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 = Label -> LabelMap t -> Bool
forall a. Label -> LabelMap a -> Bool
mapMember Label
l LabelMap t
info

    -- build a mapping from BlockId to JumpDest for shorting branches
    mapping :: LabelMap jumpDest
mapping = [(Label, jumpDest)] -> LabelMap jumpDest
forall v. [(Label, v)] -> LabelMap v
mapFromList [(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 -> Label -> LabelMap jumpDest -> Maybe jumpDest
forall a. Label -> LabelMap a -> Maybe a
mapLookup 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 -> Label -> LabelMap jumpDest -> Maybe jumpDest
forall a. Label -> LabelMap a -> Maybe a
mapLookup 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  { initial_us <- UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
        ; let 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
              (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
              final_delta          = NatM_State -> Int
natm_delta NatM_State
final_st
              final_imports        = NatM_State -> [CLabel]
natm_imports NatM_State
final_st
              final_cfg            = NatM_State -> CFG
natm_cfg NatM_State
final_st
        ; if   final_delta == 0
          then return (new_tops, final_imports
                      , natm_fileid final_st, final_cfg)
          else pprPanic "genMachCode: nonzero final delta" (int final_delta)
    }