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

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

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

    -- | Native code generator
    --
    -- The native-code generator has machine-independent and
    -- machine-dependent modules.
    --
    -- This module ("GHC.CmmToAsm") is the top-level machine-independent
    -- module.  Before entering machine-dependent land, we do some
    -- machine-independent optimisations (defined below) on the
    -- 'CmmStmts's.
    --
    -- We convert to the machine-specific 'Instr' datatype with
    -- 'cmmCodeGen', assuming an infinite supply of registers.  We then use
    -- a machine-independent register allocator ('regAlloc') to rejoin
    -- reality.  Obviously, 'regAlloc' has machine-specific helper
    -- functions (see about "RegAllocInfo" below).
    --
    -- Finally, we order the basic blocks of the function so as to minimise
    -- the number of jumps between blocks, by utilising fallthrough wherever
    -- possible.
    --
    -- The machine-dependent bits break down as follows:
    --
    --   * ["MachRegs"]  Everything about the target platform's machine
    --     registers (and immediate operands, and addresses, which tend to
    --     intermingle/interact with registers).
    --
    --   * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should
    --     have a module of its own), plus a miscellany of other things
    --     (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
    --
    --   * ["MachCodeGen"]  is where 'Cmm' stuff turns into
    --     machine instructions.
    --
    --   * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
    --     a 'SDoc').
    --
    --   * ["RegAllocInfo"] In the register allocator, we manipulate
    --     'MRegsState's, which are 'BitSet's, one bit per machine register.
    --     When we want to say something about a specific machine register
    --     (e.g., ``it gets clobbered by this instruction''), we set/unset
    --     its bit.  Obviously, we do this 'BitSet' thing for efficiency
    --     reasons.
    --
    --     The 'RegAllocInfo' module collects together the machine-specific
    --     info needed to do register allocation.
    --
    --    * ["RegisterAlloc"] The (machine-independent) register allocator.
    -- -}
    --
    module GHC.CmmToAsm
       ( nativeCodeGen

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

    #include "HsVersions.h"

    import GHC.Prelude

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

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

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

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

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

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

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

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

    --------------------
    nativeCodeGen :: forall a . Logger -> DynFlags -> Module -> ModLocation -> Handle -> UniqSupply
                  -> Stream IO RawCmmGroup a
                  -> IO a
    nativeCodeGen :: forall a.
    Logger
    -> DynFlags
    -> Module
    -> ModLocation
    -> Handle
    -> UniqSupply
    -> Stream IO RawCmmGroup a
    -> IO a
    nativeCodeGen Logger
    logger DynFlags
    dflags Module
    this_mod ModLocation
    modLoc Handle
    h UniqSupply
    us Stream IO RawCmmGroup a
    cmms
     = let config :: NCGConfig
    config   = DynFlags -> Module -> NCGConfig
    initNCGConfig DynFlags
    dflags Module
    this_mod
           platform :: Platform
    platform = NCGConfig -> Platform
    ncgPlatform NCGConfig
    config
           nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)
                => NcgImpl statics instr jumpDest -> IO a
           nCG' :: forall statics jumpDest instr.
    (OutputableP Platform statics, Outputable jumpDest,
     Instruction instr) =>
    NcgImpl statics instr jumpDest -> IO a
    nCG' NcgImpl statics instr jumpDest
    ncgImpl = forall statics jumpDest instr a.
    (OutputableP Platform statics, Outputable jumpDest,
     Instruction instr) =>
    Logger
    -> DynFlags
    -> NCGConfig
    -> ModLocation
    -> NcgImpl statics instr jumpDest
    -> Handle
    -> UniqSupply
    -> Stream IO RawCmmGroup a
    -> IO a
    nativeCodeGen' Logger
    logger DynFlags
    dflags NCGConfig
    config ModLocation
    modLoc NcgImpl statics instr jumpDest
    ncgImpl Handle
    h UniqSupply
    us Stream IO RawCmmGroup a
    cmms
       in case Platform -> Arch
    platformArch Platform
    platform of
          Arch
    ArchX86       -> 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    -> 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       -> 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
    _  -> forall statics jumpDest instr.
    (OutputableP Platform statics, Outputable jumpDest,
     Instruction instr) =>
    NcgImpl statics instr jumpDest -> IO a
    nCG' (NCGConfig -> NcgImpl RawCmmStatics Instr JumpDest
    PPC.ncgPPC     NCGConfig
    config)
          Arch
    ArchSPARC     -> forall statics jumpDest instr.
    (OutputableP Platform statics, Outputable jumpDest,
     Instruction instr) =>
    NcgImpl statics instr jumpDest -> IO a
    nCG' (NCGConfig -> NcgImpl RawCmmStatics Instr JumpDest
    SPARC.ncgSPARC NCGConfig
    config)
          Arch
    ArchSPARC64   -> forall a. String -> a
    panic String
    "nativeCodeGen: No NCG for SPARC64"
          Arch
    ArchS390X     -> forall a. String -> a
    panic String
    "nativeCodeGen: No NCG for S390X"
          ArchARM {}    -> forall a. String -> a
    panic String
    "nativeCodeGen: No NCG for ARM"
          Arch
    ArchAArch64   -> 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     -> forall a. String -> a
    panic String
    "nativeCodeGen: No NCG for Alpha"
          Arch
    ArchMipseb    -> forall a. String -> a
    panic String
    "nativeCodeGen: No NCG for mipseb"
          Arch
    ArchMipsel    -> forall a. String -> a
    panic String
    "nativeCodeGen: No NCG for mipsel"
          Arch
    ArchRISCV64   -> forall a. String -> a
    panic String
    "nativeCodeGen: No NCG for RISCV64"
          Arch
    ArchUnknown   -> forall a. String -> a
    panic String
    "nativeCodeGen: No NCG for unknown arch"
          Arch
    ArchJavaScript-> forall a. String -> a
    panic String
    "nativeCodeGen: No NCG for JavaScript"

    -- | Data accumulated during code generation. Mostly about statistics,
    -- but also collects debug data for DWARF generation.
    data NativeGenAcc statics instr
      = NGS { forall statics instr. NativeGenAcc statics instr -> [[CLabel]]
    ngs_imports     :: ![[CLabel]]
            , forall statics instr.
    NativeGenAcc statics instr -> [[NatCmmDecl statics instr]]
    ngs_natives     :: ![[NatCmmDecl statics instr]]
                 -- ^ Native code generated, for statistics. This might
                 -- hold a lot of data, so it is important to clear this
                 -- field as early as possible if it isn't actually
                 -- required.
            , forall statics instr.
    NativeGenAcc statics instr -> [[RegAllocStats statics instr]]
    ngs_colorStats  :: ![[Color.RegAllocStats statics instr]]
            , forall statics instr.
    NativeGenAcc statics instr -> [[RegAllocStats]]
    ngs_linearStats :: ![[Linear.RegAllocStats]]
            , forall statics instr. NativeGenAcc statics instr -> [Label]
    ngs_labels      :: ![Label]
            , forall statics instr. NativeGenAcc statics instr -> [DebugBlock]
    ngs_debug       :: ![DebugBlock]
            , forall statics instr. NativeGenAcc statics instr -> DwarfFiles
    ngs_dwarfFiles  :: !DwarfFiles
            , forall statics instr.
    NativeGenAcc statics instr -> LabelMap [UnwindPoint]
    ngs_unwinds     :: !(LabelMap [UnwindPoint])
                 -- ^ see Note [Unwinding information in the NCG]
                 -- and Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
            }

    {-
    Note [Unwinding information in the NCG]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Unwind information is a type of metadata which allows a debugging tool
    to reconstruct the values of machine registers at the time a procedure was
    entered. For the most part, the production of unwind information is handled by
    the Cmm stage, where it is represented by CmmUnwind nodes.

    Unfortunately, the Cmm stage doesn't know everything necessary to produce
    accurate unwinding information. For instance, the x86-64 calling convention
    requires that the stack pointer be aligned to 16 bytes, which in turn means that
    GHC must sometimes add padding to $sp prior to performing a foreign call. When
    this happens unwind information must be updated accordingly.
    For this reason, we make the NCG backends responsible for producing
    unwinding tables (with the extractUnwindPoints function in NcgImpl).

    We accumulate the produced unwind tables over CmmGroups in the ngs_unwinds
    field of NativeGenAcc. This is a label map which contains an entry for each
    procedure, containing a list of unwinding points (e.g. a label and an associated
    unwinding table).

    See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
    -}

    nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr)
                   => Logger
                   -> DynFlags
                   -> NCGConfig
                   -> ModLocation
                   -> NcgImpl statics instr jumpDest
                   -> Handle
                   -> UniqSupply
                   -> Stream IO RawCmmGroup a
                   -> IO a
    nativeCodeGen' :: forall statics jumpDest instr a.
    (OutputableP Platform statics, Outputable jumpDest,
     Instruction instr) =>
    Logger
    -> DynFlags
    -> NCGConfig
    -> ModLocation
    -> NcgImpl statics instr jumpDest
    -> Handle
    -> UniqSupply
    -> Stream IO RawCmmGroup a
    -> IO a
    nativeCodeGen' Logger
    logger DynFlags
    dflags NCGConfig
    config ModLocation
    modLoc NcgImpl statics instr jumpDest
    ncgImpl Handle
    h UniqSupply
    us Stream IO RawCmmGroup a
    cmms
     = do
            -- BufHandle is a performance hack.  We could hide it inside
            -- Pretty if it weren't for the fact that we do lots of little
            -- printDocs here (in order to do codegen in constant space).
            BufHandle
    bufh <- Handle -> IO BufHandle
    newBufHandle Handle
    h
            let ngs0 :: NativeGenAcc statics instr
    ngs0 = forall statics instr.
    [[CLabel]]
    -> [[NatCmmDecl statics instr]]
    -> [[RegAllocStats statics instr]]
    -> [[RegAllocStats]]
    -> [Label]
    -> [DebugBlock]
    -> DwarfFiles
    -> LabelMap [UnwindPoint]
    -> NativeGenAcc statics instr
    NGS [] [] [] [] [] [] forall key elt. UniqFM key elt
    emptyUFM forall (map :: * -> *) a. IsMap map => map a
    mapEmpty
            (NativeGenAcc statics instr
    ngs, UniqSupply
    us', a
    a) <- forall statics jumpDest instr a.
    (OutputableP Platform statics, Outputable jumpDest,
     Instruction instr) =>
    Logger
    -> DynFlags
    -> NCGConfig
    -> ModLocation
    -> NcgImpl statics instr jumpDest
    -> BufHandle
    -> UniqSupply
    -> Stream IO RawCmmGroup a
    -> NativeGenAcc statics instr
    -> IO (NativeGenAcc statics instr, UniqSupply, a)
    cmmNativeGenStream Logger
    logger DynFlags
    dflags NCGConfig
    config ModLocation
    modLoc NcgImpl statics instr jumpDest
    ncgImpl BufHandle
    bufh UniqSupply
    us
                                             Stream IO RawCmmGroup a
    cmms forall {statics} {instr}. NativeGenAcc statics instr
    ngs0
            UniqSupply
    _ <- forall instr statics.
    Instruction instr =>
    Logger
    -> DynFlags
    -> NCGConfig
    -> ModLocation
    -> BufHandle
    -> UniqSupply
    -> NativeGenAcc statics instr
    -> IO UniqSupply
    finishNativeGen Logger
    logger DynFlags
    dflags NCGConfig
    config ModLocation
    modLoc BufHandle
    bufh UniqSupply
    us' NativeGenAcc statics instr
    ngs
            forall (m :: * -> *) a. Monad m => a -> m a
    return a
    a

    finishNativeGen :: Instruction instr
                    => Logger
                    -> DynFlags
                    -> NCGConfig
                    -> ModLocation
                    -> BufHandle
                    -> UniqSupply
                    -> NativeGenAcc statics instr
                    -> IO UniqSupply
    finishNativeGen :: forall instr statics.
    Instruction instr =>
    Logger
    -> DynFlags
    -> NCGConfig
    -> ModLocation
    -> BufHandle
    -> UniqSupply
    -> NativeGenAcc statics instr
    -> IO UniqSupply
    finishNativeGen Logger
    logger DynFlags
    dflags NCGConfig
    config ModLocation
    modLoc bufh :: BufHandle
    bufh@(BufHandle Ptr Word8
    _ FastMutInt
    _ Handle
    h) UniqSupply
    us NativeGenAcc statics instr
    ngs
     = forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
    withTimingSilent Logger
    logger DynFlags
    dflags (String -> SDoc
    text String
    "NCG") (seq :: forall a b. a -> b -> b
    `seq` ()) forall a b. (a -> b) -> a -> b
    $ do
            -- Write debug data and finish
            UniqSupply
    us' <- if Bool -> Bool
    not (NCGConfig -> Bool
    ncgDwarfEnabled NCGConfig
    config)
                      then forall (m :: * -> *) a. Monad m => a -> m a
    return UniqSupply
    us
                      else do
                         (SDoc
    dwarf, UniqSupply
    us') <- NCGConfig
    -> ModLocation
    -> UniqSupply
    -> [DebugBlock]
    -> IO (SDoc, UniqSupply)
    dwarfGen NCGConfig
    config ModLocation
    modLoc UniqSupply
    us (forall statics instr. NativeGenAcc statics instr -> [DebugBlock]
    ngs_debug NativeGenAcc statics instr
    ngs)
                         Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()
    emitNativeCode Logger
    logger DynFlags
    dflags NCGConfig
    config BufHandle
    bufh SDoc
    dwarf
                         forall (m :: * -> *) a. Monad m => a -> m a
    return UniqSupply
    us'
            BufHandle -> IO ()
    bFlush BufHandle
    bufh

            -- dump global NCG stats for graph coloring allocator
            let stats :: [RegAllocStats statics instr]
    stats = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat (forall statics instr.
    NativeGenAcc statics instr -> [[RegAllocStats statics instr]]
    ngs_colorStats NativeGenAcc statics instr
    ngs)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [RegAllocStats statics instr]
    stats) forall a b. (a -> b) -> a -> b
    $ do

              -- build the global register conflict graph
              let graphGlobal :: Graph VirtualReg RegClass RealReg
    graphGlobal
                      = forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' forall k cls color.
    Graph k cls color -> Graph k cls color -> Graph k cls color
    Color.union forall k cls color. Graph k cls color
    Color.initGraph
                      forall a b. (a -> b) -> a -> b
    $ [ forall statics instr.
    RegAllocStats statics instr -> Graph VirtualReg RegClass RealReg
    Color.raGraph RegAllocStats statics instr
    stat
                              | stat :: RegAllocStats statics instr
    stat@Color.RegAllocStatsStart{} <- [RegAllocStats statics instr]
    stats]

              SDoc -> IO ()
    dump_stats (forall statics instr.
    [RegAllocStats statics instr]
    -> Graph VirtualReg RegClass RealReg -> SDoc
    Color.pprStats [RegAllocStats statics instr]
    stats Graph VirtualReg RegClass RealReg
    graphGlobal)

              let platform :: Platform
    platform = NCGConfig -> Platform
    ncgPlatform NCGConfig
    config
              Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn Logger
    logger DynFlags
    dflags
                      DumpFlag
    Opt_D_dump_asm_conflicts String
    "Register conflict graph"
                      DumpFormat
    FormatText
                      forall a b. (a -> b) -> a -> b
    $ forall k cls color.
    (Uniquable k, Outputable k, Outputable cls, Outputable color) =>
    (color -> SDoc) -> Triv k cls color -> Graph k cls color -> SDoc
    Color.dotGraph
                              (Platform -> RealReg -> SDoc
    targetRegDotColor Platform
    platform)
                              (Platform
    -> (RegClass -> VirtualReg -> Int)
    -> (RegClass -> RealReg -> Int)
    -> Triv VirtualReg RegClass RealReg
    Color.trivColorable Platform
    platform
                                      (Platform -> RegClass -> VirtualReg -> Int
    targetVirtualRegSqueeze Platform
    platform)
                                      (Platform -> RegClass -> RealReg -> Int
    targetRealRegSqueeze Platform
    platform))
                      forall a b. (a -> b) -> a -> b
    $ Graph VirtualReg RegClass RealReg
    graphGlobal

            -- dump global NCG stats for linear allocator
            let linearStats :: [RegAllocStats]
    linearStats = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat (forall statics instr.
    NativeGenAcc statics instr -> [[RegAllocStats]]
    ngs_linearStats NativeGenAcc statics instr
    ngs)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [RegAllocStats]
    linearStats) forall a b. (a -> b) -> a -> b
    $
              SDoc -> IO ()
    dump_stats (forall instr statics.
    Instruction instr =>
    [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc
    Linear.pprStats (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat (forall statics instr.
    NativeGenAcc statics instr -> [[NatCmmDecl statics instr]]
    ngs_natives NativeGenAcc statics instr
    ngs)) [RegAllocStats]
    linearStats)

            -- write out the imports
            let ctx :: SDocContext
    ctx = NCGConfig -> SDocContext
    ncgAsmContext NCGConfig
    config
            SDocContext -> Mode -> Handle -> SDoc -> IO ()
    printSDocLn SDocContext
    ctx Mode
    Pretty.LeftMode Handle
    h
                    forall a b. (a -> b) -> a -> b
    $ NCGConfig -> [CLabel] -> SDoc
    makeImportsDoc NCGConfig
    config (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat (forall statics instr. NativeGenAcc statics instr -> [[CLabel]]
    ngs_imports NativeGenAcc statics instr
    ngs))
            forall (m :: * -> *) a. Monad m => a -> m a
    return UniqSupply
    us'
      where
        dump_stats :: SDoc -> IO ()
    dump_stats = Logger -> DumpAction
    putDumpMsg Logger
    logger DynFlags
    dflags (PrintUnqualified -> PprStyle
    mkDumpStyle PrintUnqualified
    alwaysQualify)
                       DumpFlag
    Opt_D_dump_asm_stats String
    "NCG stats"
                       DumpFormat
    FormatText

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

    cmmNativeGenStream :: forall statics jumpDest instr a.
    (OutputableP Platform statics, Outputable jumpDest,
     Instruction instr) =>
    Logger
    -> DynFlags
    -> NCGConfig
    -> ModLocation
    -> NcgImpl statics instr jumpDest
    -> BufHandle
    -> UniqSupply
    -> Stream IO RawCmmGroup a
    -> NativeGenAcc statics instr
    -> IO (NativeGenAcc statics instr, UniqSupply, a)
    cmmNativeGenStream Logger
    logger DynFlags
    dflags NCGConfig
    config ModLocation
    modLoc NcgImpl statics instr jumpDest
    ncgImpl BufHandle
    h UniqSupply
    us Stream IO RawCmmGroup a
    cmm_stream NativeGenAcc statics instr
    ngs
     = UniqSupply
    -> StreamS IO RawCmmGroup a
    -> NativeGenAcc statics instr
    -> IO (NativeGenAcc statics instr, UniqSupply, a)
    loop UniqSupply
    us (forall (m :: * -> *) r' r.
    Applicative m =>
    Stream m r' r -> StreamS m r' r
    Stream.runStream Stream IO RawCmmGroup a
    cmm_stream) NativeGenAcc statics instr
    ngs
      where
        ncglabel :: SDoc
    ncglabel = String -> SDoc
    text String
    "NCG"
        loop :: UniqSupply
                  -> Stream.StreamS IO RawCmmGroup a
                  -> NativeGenAcc statics instr
                  -> IO (NativeGenAcc statics instr, UniqSupply, a)
        loop :: UniqSupply
    -> StreamS IO RawCmmGroup a
    -> NativeGenAcc statics instr
    -> IO (NativeGenAcc statics instr, UniqSupply, a)
    loop UniqSupply
    us StreamS IO RawCmmGroup a
    s NativeGenAcc statics instr
    ngs =
          case StreamS IO RawCmmGroup a
    s of
            Stream.Done a
    a ->
              forall (m :: * -> *) a. Monad m => a -> m a
    return (NativeGenAcc statics instr
    ngs { ngs_imports :: [[CLabel]]
    ngs_imports = forall a. [a] -> [a]
    reverse forall a b. (a -> b) -> a -> b
    $ forall statics instr. NativeGenAcc statics instr -> [[CLabel]]
    ngs_imports NativeGenAcc statics instr
    ngs
                          , ngs_natives :: [[NatCmmDecl statics instr]]
    ngs_natives = forall a. [a] -> [a]
    reverse forall a b. (a -> b) -> a -> b
    $ forall statics instr.
    NativeGenAcc statics instr -> [[NatCmmDecl statics instr]]
    ngs_natives NativeGenAcc statics instr
    ngs
                          , ngs_colorStats :: [[RegAllocStats statics instr]]
    ngs_colorStats = forall a. [a] -> [a]
    reverse forall a b. (a -> b) -> a -> b
    $ forall statics instr.
    NativeGenAcc statics instr -> [[RegAllocStats statics instr]]
    ngs_colorStats NativeGenAcc statics instr
    ngs
                          , ngs_linearStats :: [[RegAllocStats]]
    ngs_linearStats = forall a. [a] -> [a]
    reverse forall a b. (a -> b) -> a -> b
    $ forall statics instr.
    NativeGenAcc statics instr -> [[RegAllocStats]]
    ngs_linearStats NativeGenAcc statics instr
    ngs
                          },
                      UniqSupply
    us,
                      a
    a)
            Stream.Effect IO (StreamS IO RawCmmGroup a)
    m -> IO (StreamS IO RawCmmGroup a)
    m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \StreamS IO RawCmmGroup a
    cmm_stream' -> UniqSupply
    -> StreamS IO RawCmmGroup a
    -> NativeGenAcc statics instr
    -> IO (NativeGenAcc statics instr, UniqSupply, a)
    loop UniqSupply
    us StreamS IO RawCmmGroup a
    cmm_stream' NativeGenAcc statics instr
    ngs
            Stream.Yield RawCmmGroup
    cmms StreamS IO RawCmmGroup a
    cmm_stream' -> do
              (UniqSupply
    us', NativeGenAcc statics instr
    ngs'') <-
                forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
    withTimingSilent Logger
    logger
                    DynFlags
    dflags
                    SDoc
    ncglabel (\(UniqSupply
    a, NativeGenAcc statics instr
    b) -> UniqSupply
    a seq :: forall a b. a -> b -> b
    `seq` NativeGenAcc statics instr
    b seq :: forall a b. a -> b -> b
    `seq` ()) forall a b. (a -> b) -> a -> b
    $ do
                  -- Generate debug information
                  let !ndbgs :: [DebugBlock]
    ndbgs | NCGConfig -> Bool
    ncgDwarfEnabled NCGConfig
    config = ModLocation -> RawCmmGroup -> [DebugBlock]
    cmmDebugGen ModLocation
    modLoc RawCmmGroup
    cmms
                             | Bool
    otherwise              = []
                      dbgMap :: LabelMap DebugBlock
    dbgMap = [DebugBlock] -> LabelMap DebugBlock
    debugToMap [DebugBlock]
    ndbgs

                  -- Generate native code
                  (NativeGenAcc statics instr
    ngs',UniqSupply
    us') <- forall statics instr jumpDest.
    (OutputableP Platform statics, Outputable jumpDest,
     Instruction instr) =>
    Logger
    -> DynFlags
    -> NCGConfig
    -> ModLocation
    -> NcgImpl statics instr jumpDest
    -> BufHandle
    -> LabelMap DebugBlock
    -> UniqSupply
    -> RawCmmGroup
    -> NativeGenAcc statics instr
    -> Int
    -> IO (NativeGenAcc statics instr, UniqSupply)
    cmmNativeGens Logger
    logger DynFlags
    dflags NCGConfig
    config ModLocation
    modLoc NcgImpl statics instr jumpDest
    ncgImpl BufHandle
    h
                                              LabelMap DebugBlock
    dbgMap UniqSupply
    us RawCmmGroup
    cmms NativeGenAcc statics instr
    ngs Int
    0

                  -- Link native code information into debug blocks
                  -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
                  let !ldbgs :: [DebugBlock]
    ldbgs = [Label] -> LabelMap [UnwindPoint] -> [DebugBlock] -> [DebugBlock]
    cmmDebugLink (forall statics instr. NativeGenAcc statics instr -> [Label]
    ngs_labels NativeGenAcc statics instr
    ngs') (forall statics instr.
    NativeGenAcc statics instr -> LabelMap [UnwindPoint]
    ngs_unwinds NativeGenAcc statics instr
    ngs') [DebugBlock]
    ndbgs
                      platform :: Platform
    platform = DynFlags -> Platform
    targetPlatform DynFlags
    dflags
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [DebugBlock]
    ldbgs) forall a b. (a -> b) -> a -> b
    $
                    Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn Logger
    logger DynFlags
    dflags DumpFlag
    Opt_D_dump_debug String
    "Debug Infos" DumpFormat
    FormatText
                      ([SDoc] -> SDoc
    vcat forall a b. (a -> b) -> a -> b
    $ forall a b. (a -> b) -> [a] -> [b]
    map (forall env a. OutputableP env a => env -> a -> SDoc
    pdoc Platform
    platform) [DebugBlock]
    ldbgs)

                  -- Accumulate debug information for emission in finishNativeGen.
                  let ngs'' :: NativeGenAcc statics instr
    ngs'' = NativeGenAcc statics instr
    ngs' { ngs_debug :: [DebugBlock]
    ngs_debug = forall statics instr. NativeGenAcc statics instr -> [DebugBlock]
    ngs_debug NativeGenAcc statics instr
    ngs' forall a. [a] -> [a] -> [a]
    ++ [DebugBlock]
    ldbgs, ngs_labels :: [Label]
    ngs_labels = [] }
                  forall (m :: * -> *) a. Monad m => a -> m a
    return (UniqSupply
    us', NativeGenAcc statics instr
    ngs'')

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

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

    cmmNativeGens :: forall statics instr jumpDest.
    (OutputableP Platform statics, Outputable jumpDest,
     Instruction instr) =>
    Logger
    -> DynFlags
    -> NCGConfig
    -> ModLocation
    -> NcgImpl statics instr jumpDest
    -> BufHandle
    -> LabelMap DebugBlock
    -> UniqSupply
    -> RawCmmGroup
    -> NativeGenAcc statics instr
    -> Int
    -> IO (NativeGenAcc statics instr, UniqSupply)
    cmmNativeGens Logger
    logger DynFlags
    dflags NCGConfig
    config ModLocation
    modLoc NcgImpl statics instr jumpDest
    ncgImpl BufHandle
    h LabelMap DebugBlock
    dbgMap = UniqSupply
    -> RawCmmGroup
    -> NativeGenAcc statics instr
    -> Int
    -> IO (NativeGenAcc statics instr, UniqSupply)
    go
      where
        go :: UniqSupply -> [RawCmmDecl]
           -> NativeGenAcc statics instr -> Int
           -> IO (NativeGenAcc statics instr, UniqSupply)

        go :: UniqSupply
    -> RawCmmGroup
    -> NativeGenAcc statics instr
    -> Int
    -> IO (NativeGenAcc statics instr, UniqSupply)
    go UniqSupply
    us [] NativeGenAcc statics instr
    ngs !Int
    _ =
            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 = forall statics instr. NativeGenAcc statics instr -> DwarfFiles
    ngs_dwarfFiles NativeGenAcc statics instr
    ngs
            (UniqSupply
    us', DwarfFiles
    fileIds', [NatCmmDecl statics instr]
    native, [CLabel]
    imports, Maybe [RegAllocStats statics instr]
    colorStats, Maybe [RegAllocStats]
    linearStats, LabelMap [UnwindPoint]
    unwinds)
              <- {-# SCC "cmmNativeGen" #-}
                 forall statics instr jumpDest.
    (Instruction instr, OutputableP Platform statics,
     Outputable jumpDest) =>
    Logger
    -> DynFlags
    -> ModLocation
    -> NcgImpl statics instr jumpDest
    -> UniqSupply
    -> DwarfFiles
    -> LabelMap DebugBlock
    -> RawCmmDecl
    -> Int
    -> IO
         (UniqSupply, DwarfFiles, [NatCmmDecl statics instr], [CLabel],
          Maybe [RegAllocStats statics instr], Maybe [RegAllocStats],
          LabelMap [UnwindPoint])
    cmmNativeGen Logger
    logger DynFlags
    dflags ModLocation
    modLoc NcgImpl statics instr jumpDest
    ncgImpl UniqSupply
    us DwarfFiles
    fileIds LabelMap DebugBlock
    dbgMap
                              RawCmmDecl
    cmm Int
    count

            -- Generate .file directives for every new file that has been
            -- used. Note that it is important that we generate these in
            -- ascending order, as Clang's 3.6 assembler complains.
            let newFileIds :: [(FastString, Int)]
    newFileIds = forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
    comparing forall a b. (a, b) -> b
    snd) forall a b. (a -> b) -> a -> b
    $
                             forall key elt. UniqFM key elt -> [elt]
    nonDetEltsUFM forall a b. (a -> b) -> a -> b
    $ DwarfFiles
    fileIds' forall key elt1 elt2.
    UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt1
    `minusUFM` DwarfFiles
    fileIds
                -- See Note [Unique Determinism and code generation]
                pprDecl :: (FastString, a) -> SDoc
    pprDecl (FastString
    f,a
    n) = String -> SDoc
    text String
    "\t.file " SDoc -> SDoc -> SDoc
    <> forall a. Outputable a => a -> SDoc
    ppr a
    n SDoc -> SDoc -> SDoc
    <+>
                                String -> SDoc
    pprFilePathString (FastString -> String
    unpackFS FastString
    f)

            Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()
    emitNativeCode Logger
    logger DynFlags
    dflags NCGConfig
    config BufHandle
    h forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    vcat forall a b. (a -> b) -> a -> b
    $
              forall a b. (a -> b) -> [a] -> [b]
    map forall {a}. Outputable a => (FastString, a) -> SDoc
    pprDecl [(FastString, Int)]
    newFileIds forall a. [a] -> [a] -> [a]
    ++
              forall a b. (a -> b) -> [a] -> [b]
    map (forall statics instr jumpDest.
    NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
    pprNatCmmDecl NcgImpl statics instr jumpDest
    ncgImpl) [NatCmmDecl statics instr]
    native

            -- force evaluation all this stuff to avoid space leaks
            let platform :: Platform
    platform = DynFlags -> Platform
    targetPlatform DynFlags
    dflags
            {-# SCC "seqString" #-} forall a. a -> IO a
    evaluate forall a b. (a -> b) -> a -> b
    $ forall a b. [a] -> b -> b
    seqList (DynFlags -> SDoc -> String
    showSDoc DynFlags
    dflags forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    vcat forall a b. (a -> b) -> a -> b
    $ forall a b. (a -> b) -> [a] -> [b]
    map (forall env a. OutputableP env a => env -> a -> SDoc
    pdoc Platform
    platform) [CLabel]
    imports) ()

            let !labels' :: [Label]
    labels' = if NCGConfig -> Bool
    ncgDwarfEnabled NCGConfig
    config
                           then forall i d g.
    (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
    cmmDebugLabels forall instr. Instruction instr => instr -> Bool
    isMetaInstr [NatCmmDecl statics instr]
    native else []
                !natives' :: [[NatCmmDecl statics instr]]
    natives' = if DumpFlag -> DynFlags -> Bool
    dopt DumpFlag
    Opt_D_dump_asm_stats DynFlags
    dflags
                            then [NatCmmDecl statics instr]
    native forall a. a -> [a] -> [a]
    : forall statics instr.
    NativeGenAcc statics instr -> [[NatCmmDecl statics instr]]
    ngs_natives NativeGenAcc statics instr
    ngs else []

                mCon :: Maybe a -> [a] -> [a]
    mCon = forall b a. b -> (a -> b) -> Maybe a -> b
    maybe forall a. a -> a
    id (:)
                ngs' :: NativeGenAcc statics instr
    ngs' = NativeGenAcc statics instr
    ngs{ ngs_imports :: [[CLabel]]
    ngs_imports     = [CLabel]
    imports forall a. a -> [a] -> [a]
    : forall statics instr. NativeGenAcc statics instr -> [[CLabel]]
    ngs_imports NativeGenAcc statics instr
    ngs
                          , ngs_natives :: [[NatCmmDecl statics instr]]
    ngs_natives     = [[NatCmmDecl statics instr]]
    natives'
                          , ngs_colorStats :: [[RegAllocStats statics instr]]
    ngs_colorStats  = Maybe [RegAllocStats statics instr]
    colorStats forall {a}. Maybe a -> [a] -> [a]
    `mCon` forall statics instr.
    NativeGenAcc statics instr -> [[RegAllocStats statics instr]]
    ngs_colorStats NativeGenAcc statics instr
    ngs
                          , ngs_linearStats :: [[RegAllocStats]]
    ngs_linearStats = Maybe [RegAllocStats]
    linearStats forall {a}. Maybe a -> [a] -> [a]
    `mCon` forall statics instr.
    NativeGenAcc statics instr -> [[RegAllocStats]]
    ngs_linearStats NativeGenAcc statics instr
    ngs
                          , ngs_labels :: [Label]
    ngs_labels      = forall statics instr. NativeGenAcc statics instr -> [Label]
    ngs_labels NativeGenAcc statics instr
    ngs forall a. [a] -> [a] -> [a]
    ++ [Label]
    labels'
                          , ngs_dwarfFiles :: DwarfFiles
    ngs_dwarfFiles  = DwarfFiles
    fileIds'
                          , ngs_unwinds :: LabelMap [UnwindPoint]
    ngs_unwinds     = forall statics instr.
    NativeGenAcc statics instr -> LabelMap [UnwindPoint]
    ngs_unwinds NativeGenAcc statics instr
    ngs forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
    `mapUnion` LabelMap [UnwindPoint]
    unwinds
                          }
            UniqSupply
    -> RawCmmGroup
    -> NativeGenAcc statics instr
    -> Int
    -> IO (NativeGenAcc statics instr, UniqSupply)
    go UniqSupply
    us' RawCmmGroup
    cmms NativeGenAcc statics instr
    ngs' (Int
    count forall a. Num a => a -> a -> a
    + Int
    1)

    emitNativeCode :: Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()
    emitNativeCode :: Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()
    emitNativeCode Logger
    logger DynFlags
    dflags NCGConfig
    config BufHandle
    h SDoc
    sdoc = do

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

            -- dump native code
            Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn Logger
    logger DynFlags
    dflags
                    DumpFlag
    Opt_D_dump_asm String
    "Asm code" DumpFormat
    FormatASM
                    SDoc
    sdoc

    -- | Complete native code generation phase for a single top-level chunk of Cmm.
    --      Dumping the output of each stage along the way.
    --      Global conflict graph and NGC stats
    cmmNativeGen
        :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest)
        => Logger
        -> DynFlags
        -> ModLocation
        -> NcgImpl statics instr jumpDest
            -> UniqSupply
            -> DwarfFiles
            -> LabelMap DebugBlock
            -> RawCmmDecl                                   -- ^ the cmm to generate code for
            -> Int                                          -- ^ sequence number of this top thing
            -> IO   ( UniqSupply
                    , DwarfFiles
                    , [NatCmmDecl statics instr]                -- native code
                    , [CLabel]                                  -- things imported by this cmm
                    , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
                    , Maybe [Linear.RegAllocStats]              -- stats for the linear register allocators
                    , LabelMap [UnwindPoint]                    -- unwinding information for blocks
                    )

    cmmNativeGen :: forall statics instr jumpDest.
    (Instruction instr, OutputableP Platform statics,
     Outputable jumpDest) =>
    Logger
    -> DynFlags
    -> ModLocation
    -> NcgImpl statics instr jumpDest
    -> UniqSupply
    -> DwarfFiles
    -> LabelMap DebugBlock
    -> RawCmmDecl
    -> Int
    -> IO
         (UniqSupply, DwarfFiles, [NatCmmDecl statics instr], [CLabel],
          Maybe [RegAllocStats statics instr], Maybe [RegAllocStats],
          LabelMap [UnwindPoint])
    cmmNativeGen Logger
    logger DynFlags
    dflags ModLocation
    modLoc NcgImpl statics instr jumpDest
    ncgImpl UniqSupply
    us DwarfFiles
    fileIds LabelMap DebugBlock
    dbgMap RawCmmDecl
    cmm Int
    count
     = do
            let config :: NCGConfig
    config   = 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
    _) -> forall env a. OutputableP env a => env -> a -> SDoc
    pdoc Platform
    platform CLabel
    entry_label
                    RawCmmDecl
    _                           -> String -> SDoc
    text String
    "DataChunk"

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

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

            Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn Logger
    logger DynFlags
    dflags
                    DumpFlag
    Opt_D_dump_opt_cmm String
    "Optimised Cmm" DumpFormat
    FormatCMM
                    (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" #-}
                    forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
    initUs UniqSupply
    us forall a b. (a -> b) -> a -> b
    $ forall statics instr.
    NCGConfig
    -> ModLocation
    -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
    -> DwarfFiles
    -> LabelMap DebugBlock
    -> RawCmmDecl
    -> CFG
    -> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
    genMachCode NCGConfig
    config ModLocation
    modLoc
                                            (forall statics instr jumpDest.
    NcgImpl statics instr jumpDest
    -> RawCmmDecl -> NatM [NatCmmDecl statics instr]
    cmmTopCodeGen NcgImpl statics instr jumpDest
    ncgImpl)
                                            DwarfFiles
    fileIds LabelMap DebugBlock
    dbgMap RawCmmDecl
    opt_cmm CFG
    cmmCfg

            Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn Logger
    logger DynFlags
    dflags
                    DumpFlag
    Opt_D_dump_asm_native String
    "Native code" DumpFormat
    FormatASM
                    ([SDoc] -> SDoc
    vcat forall a b. (a -> b) -> a -> b
    $ forall a b. (a -> b) -> [a] -> [b]
    map (forall statics instr jumpDest.
    NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
    pprNatCmmDecl NcgImpl statics instr jumpDest
    ncgImpl) [NatCmmDecl statics instr]
    native)

            Logger -> DynFlags -> Maybe CFG -> String -> SDoc -> IO ()
    maybeDumpCfg Logger
    logger DynFlags
    dflags (forall a. a -> Maybe a
    Just CFG
    nativeCfgWeights) String
    "CFG Weights - Native" SDoc
    proc_name

            -- tag instructions with register liveness information
            -- also drops dead code. We don't keep the cfg in sync on
            -- some backends, so don't use it there.
            let livenessCfg :: Maybe CFG
    livenessCfg = if Platform -> Bool
    backendMaintainsCfg Platform
    platform
                                    then forall a. a -> Maybe a
    Just CFG
    nativeCfgWeights
                                    else forall a. Maybe a
    Nothing
            let ([LiveCmmDecl statics instr]
    withLiveness, UniqSupply
    usLive) =
                    {-# SCC "regLiveness" #-}
                    forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
    initUs UniqSupply
    usGen
                            forall a b. (a -> b) -> a -> b
    $ forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (forall instr statics.
    Instruction instr =>
    Maybe CFG
    -> Platform
    -> NatCmmDecl statics instr
    -> UniqSM (LiveCmmDecl statics instr)
    cmmTopLiveness Maybe CFG
    livenessCfg Platform
    platform) [NatCmmDecl statics instr]
    native

            Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn Logger
    logger DynFlags
    dflags
                    DumpFlag
    Opt_D_dump_asm_liveness String
    "Liveness annotations added"
                    DumpFormat
    FormatCMM
                    ([SDoc] -> SDoc
    vcat forall a b. (a -> b) -> a -> b
    $ forall a b. (a -> b) -> [a] -> [b]
    map (forall statics instr.
    (OutputableP Platform statics, Instruction instr) =>
    Platform -> LiveCmmDecl statics instr -> SDoc
    pprLiveCmmDecl Platform
    platform) [LiveCmmDecl statics instr]
    withLiveness)

            -- allocate registers
            ([NatCmmDecl statics instr]
    alloced, UniqSupply
    usAlloc, Maybe [RegAllocStats statics instr]
    ppr_raStatsColor, Maybe [RegAllocStats]
    ppr_raStatsLinear, [RegAllocStats]
    raStats, [(Label, Label)]
    stack_updt_blks) <-
             if ( GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_RegsGraph DynFlags
    dflags
               Bool -> Bool -> Bool
    || GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_RegsIterative DynFlags
    dflags )
              then do
                    -- the regs usable for allocation
                    let (UniqFM RegClass (UniqSet RealReg)
    alloc_regs :: UniqFM RegClass (UniqSet RealReg))
                            = forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\RealReg
    r -> forall elt key.
    (elt -> elt -> elt)
    -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
    plusUFM_C forall a. UniqSet a -> UniqSet a -> UniqSet a
    unionUniqSets
                                            forall a b. (a -> b) -> a -> b
    $ forall key elt. Uniquable key => key -> elt -> UniqFM key elt
    unitUFM (Platform -> RealReg -> RegClass
    targetClassOfRealReg Platform
    platform RealReg
    r) (forall a. Uniquable a => a -> UniqSet a
    unitUniqSet RealReg
    r))
                                    forall key elt. UniqFM key elt
    emptyUFM
                            forall a b. (a -> b) -> a -> b
    $ 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" #-}
                              forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
    initUs UniqSupply
    usLive
                              forall a b. (a -> b) -> a -> b
    $ 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
                                    (forall a. Uniquable a => [a] -> UniqSet a
    mkUniqSet [Int
    0 .. forall statics instr jumpDest.
    NcgImpl statics instr jumpDest -> Int
    maxSpillSlots NcgImpl statics instr jumpDest
    ncgImpl])
                                    (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')
                            = forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
    initUs UniqSupply
    usAlloc forall a b. (a -> b) -> a -> b
    $
                                    case Maybe Int
    maybe_more_stack of
                                    Maybe Int
    Nothing     -> forall (m :: * -> *) a. Monad m => a -> m a
    return ([NatCmmDecl statics instr]
    alloced, [])
                                    Just Int
    amount -> do
                                        ([NatCmmDecl statics instr]
    alloced',[[(Label, Label)]]
    stack_updt_blks) <- forall a b. [(a, b)] -> ([a], [b])
    unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$>
                                                    (forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM ((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)
                                        forall (m :: * -> *) a. Monad m => a -> m a
    return ([NatCmmDecl statics instr]
    alloced', forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[(Label, Label)]]
    stack_updt_blks )

                    -- dump out what happened during register allocation
                    Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn Logger
    logger DynFlags
    dflags
                            DumpFlag
    Opt_D_dump_asm_regalloc String
    "Registers allocated"
                            DumpFormat
    FormatCMM
                            ([SDoc] -> SDoc
    vcat forall a b. (a -> b) -> a -> b
    $ forall a b. (a -> b) -> [a] -> [b]
    map (forall statics instr jumpDest.
    NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
    pprNatCmmDecl NcgImpl statics instr jumpDest
    ncgImpl) [NatCmmDecl statics instr]
    alloced)

                    Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn Logger
    logger DynFlags
    dflags
                            DumpFlag
    Opt_D_dump_asm_regalloc_stages String
    "Build/spill stages"
                            DumpFormat
    FormatText
                            ([SDoc] -> SDoc
    vcat   forall a b. (a -> b) -> a -> b
    $ forall a b. (a -> b) -> [a] -> [b]
    map (\(Int
    stage, RegAllocStats statics instr
    stats)
                                            -> String -> SDoc
    text String
    "# --------------------------"
                                            SDoc -> SDoc -> SDoc
    $$ String -> SDoc
    text String
    "#  cmm " SDoc -> SDoc -> SDoc
    <> Int -> SDoc
    int Int
    count SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    " Stage " SDoc -> SDoc -> SDoc
    <> Int -> SDoc
    int Int
    stage
                                            SDoc -> SDoc -> SDoc
    $$ forall a. Outputable a => a -> SDoc
    ppr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (forall instr. Instruction instr => Platform -> instr -> SDoc
    pprInstr Platform
    platform) RegAllocStats statics instr
    stats))
                                    forall a b. (a -> b) -> a -> b
    $ forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    0..] [RegAllocStats statics instr]
    regAllocStats)

                    let mPprStats :: Maybe [RegAllocStats statics instr]
    mPprStats =
                            if DumpFlag -> DynFlags -> Bool
    dopt DumpFlag
    Opt_D_dump_asm_stats DynFlags
    dflags
                             then forall a. a -> Maybe a
    Just [RegAllocStats statics instr]
    regAllocStats else forall a. Maybe a
    Nothing

                    -- force evaluation of the Maybe to avoid space leak
                    Maybe [RegAllocStats statics instr]
    mPprStats seq :: forall a b. a -> b -> b
    `seq` forall (m :: * -> *) a. Monad m => a -> m a
    return ()

                    forall (m :: * -> *) a. Monad m => a -> m a
    return  ( [NatCmmDecl statics instr]
    alloced', UniqSupply
    usAlloc'
                            , Maybe [RegAllocStats statics instr]
    mPprStats
                            , forall a. Maybe a
    Nothing
                            , [], [(Label, Label)]
    stack_updt_blks)

              else do
                    -- do linear register allocation
                    let reg_alloc :: LiveCmmDecl statics instr
    -> UniqSM
         (NatCmmDecl statics instr, Maybe RegAllocStats, [(Label, Label)])
    reg_alloc LiveCmmDecl statics instr
    proc = do
                           (NatCmmDecl statics instr
    alloced, Maybe Int
    maybe_more_stack, Maybe RegAllocStats
    ra_stats) <-
                                   forall instr statics.
    Instruction instr =>
    NCGConfig
    -> LiveCmmDecl statics instr
    -> UniqSM
         (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
    Linear.regAlloc NCGConfig
    config LiveCmmDecl statics instr
    proc
                           case Maybe Int
    maybe_more_stack of
                             Maybe Int
    Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
    return ( NatCmmDecl statics instr
    alloced, Maybe RegAllocStats
    ra_stats, [] )
                             Just Int
    amount -> do
                               (NatCmmDecl statics instr
    alloced',[(Label, Label)]
    stack_updt_blks) <-
                                   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
                               forall (m :: * -> *) a. Monad m => a -> m a
    return (NatCmmDecl statics instr
    alloced', Maybe RegAllocStats
    ra_stats, [(Label, Label)]
    stack_updt_blks )

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

                    Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn Logger
    logger DynFlags
    dflags
                            DumpFlag
    Opt_D_dump_asm_regalloc String
    "Registers allocated"
                            DumpFormat
    FormatCMM
                            ([SDoc] -> SDoc
    vcat forall a b. (a -> b) -> a -> b
    $ forall a b. (a -> b) -> [a] -> [b]
    map (forall statics instr jumpDest.
    NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
    pprNatCmmDecl NcgImpl statics instr jumpDest
    ncgImpl) [NatCmmDecl statics instr]
    alloced)

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

                    -- force evaluation of the Maybe to avoid space leak
                    Maybe [RegAllocStats]
    mPprStats seq :: forall a b. a -> b -> b
    `seq` forall (m :: * -> *) a. Monad m => a -> m a
    return ()

                    forall (m :: * -> *) a. Monad m => a -> m a
    return  ( [NatCmmDecl statics instr]
    alloced, UniqSupply
    usAlloc
                            , forall a. Maybe a
    Nothing
                            , Maybe [RegAllocStats]
    mPprStats, (forall a. [Maybe a] -> [a]
    catMaybes [Maybe RegAllocStats]
    regAllocStats)
                            , forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[(Label, Label)]]
    stack_updt_blks )

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

            let cfgWithFixupBlks :: Maybe CFG
    cfgWithFixupBlks =
                    (\CFG
    cfg -> Weights -> CFG -> [(Label, Label, Label)] -> CFG
    addNodesBetween Weights
    weights CFG
    cfg [(Label, Label, Label)]
    cfgRegAllocUpdates) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Maybe CFG
    livenessCfg

            -- Insert stack update blocks
            let postRegCFG :: Maybe CFG
    postRegCFG =
                    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (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 ))
                         forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Maybe CFG
    cfgWithFixupBlks
                         forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> forall (f :: * -> *) a. Applicative f => a -> f a
    pure [(Label, Label)]
    stack_updt_blks

            ---- generate jump tables
            let tabled :: [NatCmmDecl statics instr]
    tabled      =
                    {-# SCC "generateJumpTables" #-}
                    forall statics instr jumpDest.
    NcgImpl statics instr jumpDest
    -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
    generateJumpTables NcgImpl statics instr jumpDest
    ncgImpl [NatCmmDecl statics instr]
    alloced

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

            ---- shortcut branches
            let ([NatCmmDecl statics instr]
    shorted, Maybe CFG
    postShortCFG)     =
                    {-# SCC "shortcutBranches" #-}
                    forall statics instr jumpDest.
    Outputable jumpDest =>
    DynFlags
    -> NcgImpl statics instr jumpDest
    -> [NatCmmDecl statics instr]
    -> Maybe CFG
    -> ([NatCmmDecl statics instr], Maybe CFG)
    shortcutBranches DynFlags
    dflags NcgImpl statics instr jumpDest
    ncgImpl [NatCmmDecl statics instr]
    tabled Maybe CFG
    postRegCFG

            let optimizedCFG :: Maybe CFG
                optimizedCFG :: Maybe CFG
    optimizedCFG =
                    Bool -> Weights -> RawCmmDecl -> CFG -> CFG
    optimizeCFG (GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_CmmStaticPred DynFlags
    dflags) Weights
    weights RawCmmDecl
    cmm forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    <$!> Maybe CFG
    postShortCFG

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

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

            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ( Platform -> Bool
    backendMaintainsCfg Platform
    platform Bool -> Bool -> Bool
    &&
                    (GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_DoAsmLinting DynFlags
    dflags Bool -> Bool -> Bool
    || Bool
    debugIsOn )) forall a b. (a -> b) -> a -> b
    $ do
                    let blocks :: [GenBasicBlock instr]
    blocks = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap forall {d} {h} {i}.
    GenCmmDecl d h (ListGraph i) -> [GenBasicBlock i]
    getBlks [NatCmmDecl statics instr]
    shorted
                    let labels :: LabelSet
    labels = forall set. IsSet set => [ElemOf set] -> set
    setFromList forall a b. (a -> b) -> a -> b
    $ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap forall i. GenBasicBlock i -> Label
    blockId [GenBasicBlock instr]
    blocks :: LabelSet
                    let cfg :: CFG
    cfg = forall a. HasCallStack => Maybe a -> a
    fromJust Maybe CFG
    optimizedCFG
                    forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $! seq :: forall a b. a -> b -> b
    seq (CFG -> LabelSet -> SDoc -> Bool
    sanityCheckCfg CFG
    cfg LabelSet
    labels forall a b. (a -> b) -> a -> b
    $
                                    String -> SDoc
    text String
    "cfg not in lockstep") ()

            ---- sequence blocks
            let sequenced :: [NatCmmDecl statics instr]
                sequenced :: [NatCmmDecl statics instr]
    sequenced =
                    forall statics instr.
    [NatCmmDecl statics instr]
    -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
    checkLayout [NatCmmDecl statics instr]
    shorted forall a b. (a -> b) -> a -> b
    $
                    {-# SCC "sequenceBlocks" #-}
                    forall a b. (a -> b) -> [a] -> [b]
    map (forall instr statics jumpDest.
    Instruction instr =>
    NcgImpl statics instr jumpDest
    -> Maybe CFG
    -> NatCmmDecl statics instr
    -> NatCmmDecl statics instr
    BlockLayout.sequenceTop
                            NcgImpl statics instr jumpDest
    ncgImpl Maybe CFG
    optimizedCFG)
                        [NatCmmDecl statics instr]
    shorted

            let branchOpt :: [NatCmmDecl statics instr]
                branchOpt :: [NatCmmDecl statics instr]
    branchOpt =
                    {-# SCC "invertCondBranches" #-}
                    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 = 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)) =
                        forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc LabelMap RawCmmStatics
    info CLabel
    lbl [GlobalReg]
    live (forall i. [GenBasicBlock i] -> ListGraph i
    ListGraph forall a b. (a -> b) -> a -> b
    $ LabelMap RawCmmStatics
    -> [GenBasicBlock instr] -> [GenBasicBlock instr]
    invertConds LabelMap RawCmmStatics
    info [GenBasicBlock instr]
    blocks)

            ---- expansion of SPARC synthetic instrs
            let expanded :: [NatCmmDecl statics instr]
    expanded =
                    {-# SCC "sparc_expand" #-}
                    forall statics instr jumpDest.
    NcgImpl statics instr jumpDest
    -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
    ncgExpandTop NcgImpl statics instr jumpDest
    ncgImpl [NatCmmDecl statics instr]
    branchOpt
                    --ncgExpandTop ncgImpl sequenced

            Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn Logger
    logger DynFlags
    dflags
                    DumpFlag
    Opt_D_dump_asm_expanded String
    "Synthetic instructions expanded"
                    DumpFormat
    FormatCMM
                    ([SDoc] -> SDoc
    vcat forall a b. (a -> b) -> a -> b
    $ forall a b. (a -> b) -> [a] -> [b]
    map (forall statics instr jumpDest.
    NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> SDoc
    pprNatCmmDecl NcgImpl statics instr jumpDest
    ncgImpl) [NatCmmDecl statics instr]
    expanded)

            -- generate unwinding information from cmm
            let unwinds :: BlockMap [UnwindPoint]
                unwinds :: LabelMap [UnwindPoint]
    unwinds =
                    {-# SCC "unwindingInfo" #-}
                    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' LabelMap [UnwindPoint]
    -> NatCmmDecl statics instr -> LabelMap [UnwindPoint]
    addUnwind forall (map :: * -> *) a. IsMap map => map a
    mapEmpty [NatCmmDecl statics instr]
    expanded
                  where
                    addUnwind :: LabelMap [UnwindPoint]
    -> NatCmmDecl statics instr -> LabelMap [UnwindPoint]
    addUnwind LabelMap [UnwindPoint]
    acc NatCmmDecl statics instr
    proc =
                        LabelMap [UnwindPoint]
    acc forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
    `mapUnion` forall instr statics jumpDest.
    Instruction instr =>
    DynFlags
    -> NcgImpl statics instr jumpDest
    -> NatCmmDecl statics instr
    -> LabelMap [UnwindPoint]
    computeUnwinding DynFlags
    dflags NcgImpl statics instr jumpDest
    ncgImpl NatCmmDecl statics instr
    proc

            forall (m :: * -> *) a. Monad m => a -> m a
    return  ( UniqSupply
    usAlloc
                    , DwarfFiles
    fileIds'
                    , [NatCmmDecl statics instr]
    expanded
                    , [CLabel]
    lastMinuteImports forall a. [a] -> [a] -> [a]
    ++ [CLabel]
    imports
                    , Maybe [RegAllocStats statics instr]
    ppr_raStatsColor
                    , Maybe [RegAllocStats]
    ppr_raStatsLinear
                    , LabelMap [UnwindPoint]
    unwinds )

    maybeDumpCfg :: Logger -> DynFlags -> Maybe CFG -> String -> SDoc -> IO ()
    maybeDumpCfg :: Logger -> DynFlags -> Maybe CFG -> String -> SDoc -> IO ()
    maybeDumpCfg Logger
    _logger DynFlags
    _dflags Maybe CFG
    Nothing String
    _ SDoc
    _ = forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    maybeDumpCfg Logger
    logger DynFlags
    dflags (Just CFG
    cfg) String
    msg SDoc
    proc_name
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
    null CFG
    cfg = forall (m :: * -> *) a. Monad m => a -> m a
    return ()
            | Bool
    otherwise
            = Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn Logger
    logger
                    DynFlags
    dflags DumpFlag
    Opt_D_dump_cfg_weights String
    msg
                    DumpFormat
    FormatText
                    (SDoc
    proc_name SDoc -> SDoc -> SDoc
    <> Char -> SDoc
    char Char
    ':' SDoc -> SDoc -> SDoc
    $$ CFG -> SDoc
    pprEdgeWeights CFG
    cfg)

    -- | Make sure all blocks we want the layout algorithm to place have been placed.
    checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
                -> [NatCmmDecl statics instr]
    checkLayout :: forall statics instr.
    [NatCmmDecl statics instr]
    -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
    checkLayout [NatCmmDecl statics instr]
    procsUnsequenced [NatCmmDecl statics instr]
    procsSequenced =
            ASSERT2(setNull diff,
                    ppr "Block sequencing dropped blocks:" <> ppr diff)
            [NatCmmDecl statics instr]
    procsSequenced
      where
            blocks1 :: LabelSet
    blocks1 = forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (forall set. IsSet set => set -> set -> set
    setUnion) forall set. IsSet set => set
    setEmpty forall a b. (a -> b) -> a -> b
    $
                            forall a b. (a -> b) -> [a] -> [b]
    map forall {set} {d} {h} {i}.
    (ElemOf set ~ Label, IsSet set) =>
    GenCmmDecl d h (ListGraph i) -> set
    getBlockIds [NatCmmDecl statics instr]
    procsUnsequenced :: LabelSet
            blocks2 :: LabelSet
    blocks2 = forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (forall set. IsSet set => set -> set -> set
    setUnion) forall set. IsSet set => set
    setEmpty forall a b. (a -> b) -> a -> b
    $
                            forall a b. (a -> b) -> [a] -> [b]
    map forall {set} {d} {h} {i}.
    (ElemOf set ~ Label, IsSet set) =>
    GenCmmDecl d h (ListGraph i) -> set
    getBlockIds [NatCmmDecl statics instr]
    procsSequenced
            diff :: LabelSet
    diff = forall set. IsSet set => set -> set -> set
    setDifference LabelSet
    blocks1 LabelSet
    blocks2

            getBlockIds :: GenCmmDecl d h (ListGraph i) -> set
    getBlockIds (CmmData Section
    _ d
    _) = forall set. IsSet set => set
    setEmpty
            getBlockIds (CmmProc h
    _ CLabel
    _ [GlobalReg]
    _ (ListGraph [GenBasicBlock i]
    blocks)) =
                    forall set. IsSet set => [ElemOf set] -> set
    setFromList forall a b. (a -> b) -> a -> b
    $ forall a b. (a -> b) -> [a] -> [b]
    map forall i. GenBasicBlock i -> Label
    blockId [GenBasicBlock i]
    blocks

    -- | Compute unwinding tables for the blocks of a procedure
    computeUnwinding :: Instruction instr
                     => DynFlags -> NcgImpl statics instr jumpDest
                     -> NatCmmDecl statics instr
                        -- ^ the native code generated for the procedure
                     -> LabelMap [UnwindPoint]
                        -- ^ unwinding tables for all points of all blocks of the
                        -- procedure
    computeUnwinding :: forall instr statics jumpDest.
    Instruction instr =>
    DynFlags
    -> NcgImpl statics instr jumpDest
    -> NatCmmDecl statics instr
    -> LabelMap [UnwindPoint]
    computeUnwinding DynFlags
    dflags NcgImpl statics instr jumpDest
    _ NatCmmDecl statics instr
    _
      | DynFlags -> Int
    debugLevel DynFlags
    dflags forall a. Eq a => a -> a -> Bool
    == Int
    0         = forall (map :: * -> *) a. IsMap map => map a
    mapEmpty
    computeUnwinding DynFlags
    _ NcgImpl statics instr jumpDest
    _ (CmmData Section
    _ statics
    _) = forall (map :: * -> *) a. IsMap map => map a
    mapEmpty
    computeUnwinding DynFlags
    _ NcgImpl statics instr jumpDest
    ncgImpl (CmmProc LabelMap RawCmmStatics
    _ CLabel
    _ [GlobalReg]
    _ (ListGraph [GenBasicBlock instr]
    blks)) =
        -- In general we would need to push unwinding information down the
        -- block-level call-graph to ensure that we fully account for all
        -- relevant register writes within a procedure.
        --
        -- However, the only unwinding information that we care about in GHC is for
        -- Sp. The fact that GHC.Cmm.LayoutStack already ensures that we have unwind
        -- information at the beginning of every block means that there is no need
        -- to perform this sort of push-down.
        forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
    mapFromList [ (Label
    blk_lbl, forall statics instr jumpDest.
    NcgImpl statics instr jumpDest -> [instr] -> [UnwindPoint]
    extractUnwindPoints NcgImpl statics instr jumpDest
    ncgImpl [instr]
    instrs)
                    | BasicBlock Label
    blk_lbl [instr]
    instrs <- [GenBasicBlock instr]
    blks ]

    -- | Build a doc for all the imports.
    --
    makeImportsDoc :: NCGConfig -> [CLabel] -> SDoc
    makeImportsDoc :: NCGConfig -> [CLabel] -> SDoc
    makeImportsDoc NCGConfig
    config [CLabel]
    imports
     = [CLabel] -> SDoc
    dyld_stubs [CLabel]
    imports
                SDoc -> SDoc -> SDoc
    $$
                -- On recent versions of Darwin, the linker supports
                -- dead-stripping of code and data on a per-symbol basis.
                -- There's a hack to make this work in PprMach.pprNatCmmDecl.
                (if Platform -> Bool
    platformHasSubsectionsViaSymbols Platform
    platform
                 then String -> SDoc
    text String
    ".subsections_via_symbols"
                 else SDoc
    Outputable.empty)
                SDoc -> SDoc -> SDoc
    $$
                    -- On recent GNU ELF systems one can mark an object file
                    -- as not requiring an executable stack. If all objects
                    -- linked into a program have this note then the program
                    -- will not use an executable stack, which is good for
                    -- security. GHC generated code does not need an executable
                    -- stack so add the note in:
                (if Platform -> Bool
    platformHasGnuNonexecStack Platform
    platform
                 then String -> SDoc
    text String
    ".section .note.GNU-stack,\"\"," SDoc -> SDoc -> SDoc
    <> Platform -> String -> SDoc
    sectionType Platform
    platform String
    "progbits"
                 else SDoc
    Outputable.empty)
                SDoc -> SDoc -> SDoc
    $$
                    -- And just because every other compiler does, let's stick in
                    -- an identifier directive: .ident "GHC x.y.z"
                (if Platform -> Bool
    platformHasIdentDirective Platform
    platform
                 then let compilerIdent :: SDoc
    compilerIdent = String -> SDoc
    text String
    "GHC" SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    cProjectVersion
                       in String -> SDoc
    text String
    ".ident" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    doubleQuotes SDoc
    compilerIdent
                 else SDoc
    Outputable.empty)

     where
            platform :: Platform
    platform = NCGConfig -> Platform
    ncgPlatform NCGConfig
    config

            -- Generate "symbol stubs" for all external symbols that might
            -- come from a dynamic library.
            dyld_stubs :: [CLabel] -> SDoc
    {-      dyld_stubs imps = vcat $ map pprDyldSymbolStub $
                                        map head $ group $ sort imps-}
            -- (Hack) sometimes two Labels pretty-print the same, but have
            -- different uniques; so we compare their text versions...
            dyld_stubs :: [CLabel] -> SDoc
    dyld_stubs [CLabel]
    imps
                    | NCGConfig -> Bool
    needImportedSymbols NCGConfig
    config
                    = [SDoc] -> SDoc
    vcat forall a b. (a -> b) -> a -> b
    $
                            (NCGConfig -> SDoc
    pprGotDeclaration NCGConfig
    config forall a. a -> [a] -> [a]
    :) forall a b. (a -> b) -> a -> b
    $
                            forall a b. (a -> b) -> [a] -> [b]
    map ( NCGConfig -> CLabel -> SDoc
    pprImportedSymbol NCGConfig
    config forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b. (a, b) -> a
    fst forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a. [a] -> a
    head) forall a b. (a -> b) -> a -> b
    $
                            forall a. (a -> a -> Bool) -> [a] -> [[a]]
    groupBy (\(CLabel
    _,String
    a) (CLabel
    _,String
    b) -> String
    a forall a. Eq a => a -> a -> Bool
    == String
    b) forall a b. (a -> b) -> a -> b
    $
                            forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy (\(CLabel
    _,String
    a) (CLabel
    _,String
    b) -> forall a. Ord a => a -> a -> Ordering
    compare String
    a String
    b) forall a b. (a -> b) -> a -> b
    $
                            forall a b. (a -> b) -> [a] -> [b]
    map CLabel -> (CLabel, String)
    doPpr forall a b. (a -> b) -> a -> b
    $
                            [CLabel]
    imps
                    | Bool
    otherwise
                    = SDoc
    Outputable.empty

            doPpr :: CLabel -> (CLabel, String)
    doPpr CLabel
    lbl = (CLabel
    lbl, SDocContext -> SDoc -> String
    renderWithContext
                                  (NCGConfig -> SDocContext
    ncgAsmContext NCGConfig
    config)
                                  (Platform -> LabelStyle -> CLabel -> SDoc
    pprCLabel Platform
    platform LabelStyle
    AsmStyle CLabel
    lbl))

    -- -----------------------------------------------------------------------------
    -- Generate jump tables

    -- Analyzes all native code and generates data sections for all jump
    -- table instructions.
    generateJumpTables
            :: NcgImpl statics instr jumpDest
            -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
    generateJumpTables :: forall statics instr jumpDest.
    NcgImpl statics instr jumpDest
    -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
    generateJumpTables NcgImpl statics instr jumpDest
    ncgImpl [NatCmmDecl statics instr]
    xs = 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 forall a. a -> [a] -> [a]
    : 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) = forall a. [Maybe a] -> [a]
    catMaybes (forall a b. (a -> b) -> [a] -> [b]
    map (forall statics instr jumpDest.
    NcgImpl statics instr jumpDest
    -> instr -> Maybe (NatCmmDecl statics instr)
    generateJumpTableForInstr NcgImpl statics instr jumpDest
    ncgImpl) [instr]
    xs)

    -- -----------------------------------------------------------------------------
    -- Shortcut branches

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

    shortcutBranches :: forall statics instr jumpDest.
    Outputable jumpDest =>
    DynFlags
    -> NcgImpl statics instr jumpDest
    -> [NatCmmDecl statics instr]
    -> Maybe CFG
    -> ([NatCmmDecl statics instr], Maybe CFG)
    shortcutBranches DynFlags
    dflags NcgImpl statics instr jumpDest
    ncgImpl [NatCmmDecl statics instr]
    tops Maybe CFG
    weights
      | GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_AsmShortcutting DynFlags
    dflags
      = ( forall a b. (a -> b) -> [a] -> [b]
    map (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 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) = forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
    mapAndUnzip (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 = forall (map :: * -> *) a. IsMap map => [map a] -> map a
    mapUnions [LabelMap jumpDest]
    mappings :: LabelMap jumpDest
        mappingBid :: LabelMap (Maybe Label)
    mappingBid = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (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, forall (map :: * -> *) a. IsMap map => map a
    mapEmpty)
    build_mapping NcgImpl statics instr jumpDest
    _ (CmmProc LabelMap t
    info CLabel
    lbl [GlobalReg]
    live (ListGraph []))
      = (forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc LabelMap t
    info CLabel
    lbl [GlobalReg]
    live (forall i. [GenBasicBlock i] -> ListGraph i
    ListGraph []), forall (map :: * -> *) a. IsMap map => map a
    mapEmpty)
    build_mapping NcgImpl statics instr jumpDest
    ncgImpl (CmmProc LabelMap t
    info CLabel
    lbl [GlobalReg]
    live (ListGraph (GenBasicBlock instr
    head:[GenBasicBlock instr]
    blocks)))
      = (forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc LabelMap t
    info CLabel
    lbl [GlobalReg]
    live (forall i. [GenBasicBlock i] -> ListGraph i
    ListGraph (GenBasicBlock instr
    headforall 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) =
            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 (forall set. IsSet set => set
    setEmpty :: LabelSet, [], []) [GenBasicBlock instr]
    blocks
        split :: (LabelSet, [(Label, jumpDest)], [GenBasicBlock instr])
    -> GenBasicBlock instr
    -> (LabelSet, [(Label, jumpDest)], [GenBasicBlock instr])
    split (LabelSet
    s, [(Label, jumpDest)]
    shortcut_blocks, [GenBasicBlock instr]
    others) b :: GenBasicBlock instr
    b@(BasicBlock Label
    id [instr
    insn])
            | Just jumpDest
    jd <- forall statics instr jumpDest.
    NcgImpl statics instr jumpDest -> instr -> Maybe jumpDest
    canShortcut NcgImpl statics instr jumpDest
    ncgImpl instr
    insn
            , Just Label
    dest <- 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)
            , (forall set. IsSet set => ElemOf set -> set -> Bool
    setMember Label
    dest LabelSet
    s) Bool -> Bool -> Bool
    || Label
    dest forall a. Eq a => a -> a -> Bool
    == Label
    id -- loop checks
            = (LabelSet
    s, [(Label, jumpDest)]
    shortcut_blocks, GenBasicBlock instr
    b 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 <- 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)
            = (forall set. IsSet set => ElemOf set -> set -> set
    setInsert Label
    id LabelSet
    s, (Label
    id,jumpDest
    dest) 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 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 = forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
    mapMember Label
    l LabelMap t
    info

        -- build a mapping from BlockId to JumpDest for shorting branches
        mapping :: LabelMap jumpDest
    mapping = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
    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)
      = forall d h g. Section -> d -> GenCmmDecl d h g
    CmmData Section
    sec (forall statics instr jumpDest.
    NcgImpl statics instr jumpDest
    -> (Label -> Maybe jumpDest) -> statics -> statics
    shortcutStatics NcgImpl statics instr jumpDest
    ncgImpl (\Label
    bid -> forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map 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))
      = forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc h
    info CLabel
    lbl [GlobalReg]
    live (forall i. [GenBasicBlock i] -> ListGraph i
    ListGraph forall a b. (a -> b) -> a -> b
    $ 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) = forall i. Label -> [i] -> GenBasicBlock i
    BasicBlock Label
    id forall a b. (a -> b) -> a -> b
    $! forall a b. (a -> b) -> [a] -> [b]
    map instr -> instr
    short_insn [instr]
    insns
        short_insn :: instr -> instr
    short_insn instr
    i = forall statics instr jumpDest.
    NcgImpl statics instr jumpDest
    -> (Label -> Maybe jumpDest) -> instr -> instr
    shortcutJump NcgImpl statics instr jumpDest
    ncgImpl (\Label
    bid -> forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map 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
            -> ModLocation
            -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
            -> DwarfFiles
            -> LabelMap DebugBlock
            -> RawCmmDecl
            -> CFG
            -> UniqSM
                    ( [NatCmmDecl statics instr]
                    , [CLabel]
                    , DwarfFiles
                    , CFG
                    )

    genMachCode :: forall statics instr.
    NCGConfig
    -> ModLocation
    -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
    -> DwarfFiles
    -> LabelMap DebugBlock
    -> RawCmmDecl
    -> CFG
    -> UniqSM ([NatCmmDecl statics instr], [CLabel], DwarfFiles, CFG)
    genMachCode NCGConfig
    config ModLocation
    modLoc RawCmmDecl -> NatM [NatCmmDecl statics instr]
    cmmTopCodeGen DwarfFiles
    fileIds LabelMap DebugBlock
    dbgMap RawCmmDecl
    cmm_top CFG
    cmm_cfg
      = do  { UniqSupply
    initial_us <- forall (m :: * -> *). MonadUnique m => m UniqSupply
    getUniqueSupplyM
            ; let initial_st :: NatM_State
    initial_st           = UniqSupply
    -> Int
    -> NCGConfig
    -> ModLocation
    -> DwarfFiles
    -> LabelMap DebugBlock
    -> CFG
    -> NatM_State
    mkNatM_State UniqSupply
    initial_us Int
    0 NCGConfig
    config
                                                      ModLocation
    modLoc DwarfFiles
    fileIds LabelMap DebugBlock
    dbgMap CFG
    cmm_cfg
                  ([NatCmmDecl statics instr]
    new_tops, NatM_State
    final_st) = forall a. NatM_State -> NatM a -> (a, NatM_State)
    initNat NatM_State
    initial_st (RawCmmDecl -> NatM [NatCmmDecl statics instr]
    cmmTopCodeGen RawCmmDecl
    cmm_top)
                  final_delta :: Int
    final_delta          = NatM_State -> Int
    natm_delta NatM_State
    final_st
                  final_imports :: [CLabel]
    final_imports        = NatM_State -> [CLabel]
    natm_imports NatM_State
    final_st
                  final_cfg :: CFG
    final_cfg            = NatM_State -> CFG
    natm_cfg NatM_State
    final_st
            ; if   Int
    final_delta forall a. Eq a => a -> a -> Bool
    == Int
    0
              then forall (m :: * -> *) a. Monad m => a -> m a
    return ([NatCmmDecl statics instr]
    new_tops, [CLabel]
    final_imports
                          , NatM_State -> DwarfFiles
    natm_fileid NatM_State
    final_st, CFG
    final_cfg)
              else forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "genMachCode: nonzero final delta" (Int -> SDoc
    int Int
    final_delta)
        }

    -- -----------------------------------------------------------------------------
    -- Generic Cmm optimiser

    {-
    Here we do:

      (a) Constant folding
      (c) Position independent code and dynamic linking
            (i)  introduce the appropriate indirections
                 and position independent refs
            (ii) compile a list of imported symbols
      (d) Some arch-specific optimizations

    (a) will be moving to the new Hoopl pipeline, however, (c) and
    (d) are only needed by the native backend and will continue to live
    here.

    Ideas for other things we could do (put these in Hoopl please!):

      - shortcut jumps-to-jumps
      - simple CSE: if an expr is assigned to a temp, then replace later occs of
        that expr with the temp, until the expr is no longer valid (can push through
        temp assignments, and certain assigns to mem...)
    -}

    cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel])
    cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel])
    cmmToCmm NCGConfig
    _ top :: RawCmmDecl
    top@(CmmData Section
    _ RawCmmStatics
    _) = (RawCmmDecl
    top, [])
    cmmToCmm NCGConfig
    config (CmmProc LabelMap RawCmmStatics
    info CLabel
    lbl [GlobalReg]
    live CmmGraph
    graph)
        = forall a. NCGConfig -> CmmOptM a -> (a, [CLabel])
    runCmmOpt NCGConfig
    config forall a b. (a -> b) -> a -> b
    $
          do [CmmBlock]
    blocks' <- forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM CmmBlock -> CmmOptM CmmBlock
    cmmBlockConFold (CmmGraph -> [CmmBlock]
    toBlockList CmmGraph
    graph)
             forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc LabelMap RawCmmStatics
    info CLabel
    lbl [GlobalReg]
    live (Label -> [CmmBlock] -> CmmGraph
    ofBlockList (forall (n :: Extensibility -> Extensibility -> *).
    GenCmmGraph n -> Label
    g_entry CmmGraph
    graph) [CmmBlock]
    blocks')

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

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

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

    instance Applicative CmmOptM where
        pure :: forall a. a -> CmmOptM a
    pure a
    x = forall a. (NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a
    CmmOptM forall a b. (a -> b) -> a -> b
    $ \NCGConfig
    _ [CLabel]
    imports -> forall a b. a -> b -> (# a, b #)
    OptMResult a
    x [CLabel]
    imports
        <*> :: forall a b. CmmOptM (a -> b) -> CmmOptM a -> CmmOptM b
    (<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    ap

    instance Monad CmmOptM where
      (CmmOptM NCGConfig -> [CLabel] -> OptMResult a
    f) >>= :: forall a b. CmmOptM a -> (a -> CmmOptM b) -> CmmOptM b
    >>= a -> CmmOptM b
    g =
        forall a. (NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a
    CmmOptM forall a b. (a -> b) -> a -> b
    $ \NCGConfig
    config [CLabel]
    imports0 ->
                    case NCGConfig -> [CLabel] -> OptMResult a
    f NCGConfig
    config [CLabel]
    imports0 of
                      OptMResult a
    x [CLabel]
    imports1 ->
                        case a -> CmmOptM b
    g a
    x of
                          CmmOptM NCGConfig -> [CLabel] -> OptMResult b
    g' -> NCGConfig -> [CLabel] -> OptMResult b
    g' NCGConfig
    config [CLabel]
    imports1

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

    addImportCmmOpt :: CLabel -> CmmOptM ()
    addImportCmmOpt :: CLabel -> CmmOptM ()
    addImportCmmOpt CLabel
    lbl = forall a. (NCGConfig -> [CLabel] -> OptMResult a) -> CmmOptM a
    CmmOptM forall a b. (a -> b) -> a -> b
    $ \NCGConfig
    _ [CLabel]
    imports -> forall a b. a -> b -> (# a, b #)
    OptMResult () (CLabel
    lblforall a. a -> [a] -> [a]
    :[CLabel]
    imports)

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

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

    cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
    cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
    cmmBlockConFold CmmBlock
    block = do
      let (CmmNode C O
    entry, Block CmmNode O O
    middle, CmmNode O C
    last) = forall (n :: Extensibility -> Extensibility -> *).
    Block n C C -> (n C O, Block n O O, n O C)
    blockSplit CmmBlock
    block
          stmts :: [CmmNode O O]
    stmts = forall (n :: Extensibility -> Extensibility -> *).
    Block n O O -> [n O O]
    blockToList Block CmmNode O O
    middle
      [CmmNode O O]
    stmts' <- forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM forall (e :: Extensibility) (x :: Extensibility).
    CmmNode e x -> CmmOptM (CmmNode e x)
    cmmStmtConFold [CmmNode O O]
    stmts
      CmmNode O C
    last' <- forall (e :: Extensibility) (x :: Extensibility).
    CmmNode e x -> CmmOptM (CmmNode e x)
    cmmStmtConFold CmmNode O C
    last
      forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ forall (n :: Extensibility -> Extensibility -> *).
    n C O -> Block n O O -> n O C -> Block n C C
    blockJoin CmmNode C O
    entry (forall (n :: Extensibility -> Extensibility -> *).
    [n O O] -> Block n O O
    blockFromList [CmmNode O O]
    stmts') CmmNode O C
    last'

    -- This does three optimizations, but they're very quick to check, so we don't
    -- bother turning them off even when the Hoopl code is active.  Since
    -- this is on the old Cmm representation, we can't reuse the code either:
    --  * reg = reg      --> nop
    --  * if 0 then jump --> nop
    --  * if 1 then jump --> jump
    -- We might be tempted to skip this step entirely of not Opt_PIC, but
    -- there is some PowerPC code for the non-PIC case, which would also
    -- have to be separated.
    cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)
    cmmStmtConFold :: forall (e :: Extensibility) (x :: Extensibility).
    CmmNode e x -> CmmOptM (CmmNode e x)
    cmmStmtConFold CmmNode e x
    stmt
       = case CmmNode e x
    stmt of
            CmmAssign CmmReg
    reg CmmExpr
    src
               -> do CmmExpr
    src' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprConFold ReferenceKind
    DataReference CmmExpr
    src
                     forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ case CmmExpr
    src' of
                       CmmReg CmmReg
    reg' | CmmReg
    reg forall a. Eq a => a -> a -> Bool
    == CmmReg
    reg' -> FastString -> CmmNode O O
    CmmComment (String -> FastString
    fsLit String
    "nop")
                       CmmExpr
    new_src -> CmmReg -> CmmExpr -> CmmNode O O
    CmmAssign CmmReg
    reg CmmExpr
    new_src

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

            CmmCall { cml_target :: CmmNode O C -> CmmExpr
    cml_target = CmmExpr
    addr }
               -> do CmmExpr
    addr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprConFold ReferenceKind
    JumpReference CmmExpr
    addr
                     forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ CmmNode e x
    stmt { cml_target :: CmmExpr
    cml_target = CmmExpr
    addr' }

            CmmUnsafeForeignCall ForeignTarget
    target [CmmFormal]
    regs [CmmExpr]
    args
               -> do ForeignTarget
    target' <- case ForeignTarget
    target of
                                  ForeignTarget CmmExpr
    e ForeignConvention
    conv -> do
                                    CmmExpr
    e' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprConFold ReferenceKind
    CallReference CmmExpr
    e
                                    forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ CmmExpr -> ForeignConvention -> ForeignTarget
    ForeignTarget CmmExpr
    e' ForeignConvention
    conv
                                  PrimTarget CallishMachOp
    _ ->
                                    forall (m :: * -> *) a. Monad m => a -> m a
    return ForeignTarget
    target
                     [CmmExpr]
    args' <- forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprConFold ReferenceKind
    DataReference) [CmmExpr]
    args
                     forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmNode O O
    CmmUnsafeForeignCall ForeignTarget
    target' [CmmFormal]
    regs [CmmExpr]
    args'

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

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

            CmmNode e x
    other
               -> forall (m :: * -> *) a. Monad m => a -> m a
    return CmmNode e x
    other

    cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprConFold ReferenceKind
    referenceKind CmmExpr
    expr = do
        NCGConfig
    config <- CmmOptM NCGConfig
    getCmmOptConfig

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

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

    cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr
    cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr
    cmmExprCon NCGConfig
    config (CmmLoad CmmExpr
    addr CmmType
    rep AlignmentSpec
    align) = CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
    CmmLoad (NCGConfig -> CmmExpr -> CmmExpr
    cmmExprCon NCGConfig
    config CmmExpr
    addr) CmmType
    rep AlignmentSpec
    align
    cmmExprCon NCGConfig
    config (CmmMachOp MachOp
    mop [CmmExpr]
    args)
        = Platform -> MachOp -> [CmmExpr] -> CmmExpr
    cmmMachOpFold (NCGConfig -> Platform
    ncgPlatform NCGConfig
    config) MachOp
    mop (forall a b. (a -> b) -> [a] -> [b]
    map (NCGConfig -> CmmExpr -> CmmExpr
    cmmExprCon NCGConfig
    config) [CmmExpr]
    args)
    cmmExprCon NCGConfig
    _ CmmExpr
    other = CmmExpr
    other

    -- handles both PIC and non-PIC cases... a very strange mixture
    -- of things to do.
    cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprNative ReferenceKind
    referenceKind CmmExpr
    expr = do
         NCGConfig
    config <- CmmOptM NCGConfig
    getCmmOptConfig
         let platform :: Platform
    platform = NCGConfig -> Platform
    ncgPlatform NCGConfig
    config
             arch :: Arch
    arch = Platform -> Arch
    platformArch Platform
    platform
         case CmmExpr
    expr of
            CmmLoad CmmExpr
    addr CmmType
    rep AlignmentSpec
    align
              -> do CmmExpr
    addr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprNative ReferenceKind
    DataReference CmmExpr
    addr
                    forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
    CmmLoad CmmExpr
    addr' CmmType
    rep AlignmentSpec
    align

            CmmMachOp MachOp
    mop [CmmExpr]
    args
              -> do [CmmExpr]
    args' <- forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprNative ReferenceKind
    DataReference) [CmmExpr]
    args
                    forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp MachOp
    mop [CmmExpr]
    args'

            CmmLit (CmmBlock Label
    id)
              -> ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprNative ReferenceKind
    referenceKind (CmmLit -> CmmExpr
    CmmLit (CLabel -> CmmLit
    CmmLabel (Label -> CLabel
    infoTblLbl Label
    id)))
              -- we must convert block Ids to CLabels here, because we
              -- might have to do the PIC transformation.  Hence we must
              -- not modify BlockIds beyond this point.

            CmmLit (CmmLabel CLabel
    lbl)
              -> forall (m :: * -> *).
    CmmMakeDynamicReferenceM m =>
    NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
    cmmMakeDynamicReference NCGConfig
    config ReferenceKind
    referenceKind CLabel
    lbl
            CmmLit (CmmLabelOff CLabel
    lbl Int
    off)
              -> do CmmExpr
    dynRef <- forall (m :: * -> *).
    CmmMakeDynamicReferenceM m =>
    NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
    cmmMakeDynamicReference NCGConfig
    config ReferenceKind
    referenceKind CLabel
    lbl
                    -- need to optimize here, since it's late
                    forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ Platform -> MachOp -> [CmmExpr] -> CmmExpr
    cmmMachOpFold Platform
    platform (Width -> MachOp
    MO_Add (Platform -> Width
    wordWidth Platform
    platform)) [
                        CmmExpr
    dynRef,
                        (CmmLit -> CmmExpr
    CmmLit forall a b. (a -> b) -> a -> b
    $ Integer -> Width -> CmmLit
    CmmInt (forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    off) (Platform -> Width
    wordWidth Platform
    platform))
                      ]

            -- On powerpc (non-PIC), it's easier to jump directly to a label than
            -- to use the register table, so we replace these registers
            -- with the corresponding labels:
            CmmReg (CmmGlobal GlobalReg
    EagerBlackholeInfo)
              | Arch
    arch forall a. Eq a => a -> a -> Bool
    == Arch
    ArchPPC Bool -> Bool -> Bool
    && Bool -> Bool
    not (NCGConfig -> Bool
    ncgPIC NCGConfig
    config)
              -> ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprNative ReferenceKind
    referenceKind forall a b. (a -> b) -> a -> b
    $
                 CmmLit -> CmmExpr
    CmmLit (CLabel -> CmmLit
    CmmLabel (UnitId -> FastString -> CLabel
    mkCmmCodeLabel UnitId
    rtsUnitId (String -> FastString
    fsLit String
    "__stg_EAGER_BLACKHOLE_info")))
            CmmReg (CmmGlobal GlobalReg
    GCEnter1)
              | Arch
    arch forall a. Eq a => a -> a -> Bool
    == Arch
    ArchPPC Bool -> Bool -> Bool
    && Bool -> Bool
    not (NCGConfig -> Bool
    ncgPIC NCGConfig
    config)
              -> ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprNative ReferenceKind
    referenceKind forall a b. (a -> b) -> a -> b
    $
                 CmmLit -> CmmExpr
    CmmLit (CLabel -> CmmLit
    CmmLabel (UnitId -> FastString -> CLabel
    mkCmmCodeLabel UnitId
    rtsUnitId (String -> FastString
    fsLit String
    "__stg_gc_enter_1")))
            CmmReg (CmmGlobal GlobalReg
    GCFun)
              | Arch
    arch forall a. Eq a => a -> a -> Bool
    == Arch
    ArchPPC Bool -> Bool -> Bool
    && Bool -> Bool
    not (NCGConfig -> Bool
    ncgPIC NCGConfig
    config)
              -> ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprNative ReferenceKind
    referenceKind forall a b. (a -> b) -> a -> b
    $
                 CmmLit -> CmmExpr
    CmmLit (CLabel -> CmmLit
    CmmLabel (UnitId -> FastString -> CLabel
    mkCmmCodeLabel UnitId
    rtsUnitId (String -> FastString
    fsLit String
    "__stg_gc_fun")))

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

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

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

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

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

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