    -- -----------------------------------------------------------------------------
    --
    -- (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)
        }