{-# LANGUAGE BangPatterns #-}

module CmmPipeline (
  -- | Converts C-- with an implicit stack and native C-- calls into
  -- optimized, CPS converted and native-call-less C--.  The latter
  -- C-- can be used to generate assembly.
  cmmPipeline
) where

import GhcPrelude

import Cmm
import CmmLint
import CmmBuildInfoTables
import CmmCommonBlockElim
import CmmImplementSwitchPlans
import CmmProcPoint
import CmmContFlowOpt
import CmmLayoutStack
import CmmSink
import Hoopl.Collections

import UniqSupply
import DynFlags
import ErrUtils
import HscTypes
import Control.Monad
import Outputable
import Platform

-----------------------------------------------------------------------------
-- | Top level driver for C-- pipeline
-----------------------------------------------------------------------------

cmmPipeline
 :: HscEnv -- Compilation env including
           -- dynamic flags: -dcmm-lint -ddump-cmm-cps
 -> ModuleSRTInfo        -- Info about SRTs generated so far
 -> CmmGroup             -- Input C-- with Procedures
 -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C--

cmmPipeline :: HscEnv -> ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroup)
cmmPipeline hsc_env :: HscEnv
hsc_env srtInfo :: ModuleSRTInfo
srtInfo prog :: CmmGroup
prog =
  do let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

     [(CAFEnv, CmmGroup)]
tops <- {-# SCC "tops" #-} (CmmDecl -> IO (CAFEnv, CmmGroup))
-> CmmGroup -> IO [(CAFEnv, CmmGroup)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HscEnv -> CmmDecl -> IO (CAFEnv, CmmGroup)
cpsTop HscEnv
hsc_env) CmmGroup
prog

     (srtInfo :: ModuleSRTInfo
srtInfo, cmms :: CmmGroup
cmms) <- {-# SCC "doSRTs" #-} DynFlags
-> ModuleSRTInfo
-> [(CAFEnv, CmmGroup)]
-> IO (ModuleSRTInfo, CmmGroup)
doSRTs DynFlags
dflags ModuleSRTInfo
srtInfo [(CAFEnv, CmmGroup)]
tops
     DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpWith DynFlags
dflags DumpFlag
Opt_D_dump_cmm_cps "Post CPS Cmm" (CmmGroup -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmGroup
cmms)

     (ModuleSRTInfo, CmmGroup) -> IO (ModuleSRTInfo, CmmGroup)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleSRTInfo
srtInfo, CmmGroup
cmms)


cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, CmmGroup)
cpsTop _ p :: CmmDecl
p@(CmmData {}) = (CAFEnv, CmmGroup) -> IO (CAFEnv, CmmGroup)
forall (m :: * -> *) a. Monad m => a -> m a
return (CAFEnv
forall (map :: * -> *) a. IsMap map => map a
mapEmpty, [CmmDecl
p])
cpsTop hsc_env :: HscEnv
hsc_env proc :: CmmDecl
proc =
    do
       ----------- Control-flow optimisations ----------------------------------

       -- The first round of control-flow optimisation speeds up the
       -- later passes by removing lots of empty blocks, so we do it
       -- even when optimisation isn't turned on.
       --
       CmmProc h :: CmmTopInfo
h l :: CLabel
l v :: [GlobalReg]
v g :: CmmGraph
g <- {-# SCC "cmmCfgOpts(1)" #-}
            CmmDecl -> IO CmmDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmDecl -> IO CmmDecl) -> CmmDecl -> IO CmmDecl
forall a b. (a -> b) -> a -> b
$ Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc Bool
splitting_proc_points CmmDecl
proc
       DumpFlag -> String -> CmmGraph -> IO ()
dump DumpFlag
Opt_D_dump_cmm_cfg "Post control-flow optimisations" CmmGraph
g

       let !TopInfo {stack_info :: CmmTopInfo -> CmmStackInfo
stack_info=StackInfo { arg_space :: CmmStackInfo -> ByteOff
arg_space = ByteOff
entry_off
                                          , do_layout :: CmmStackInfo -> Bool
do_layout = Bool
do_layout }} = CmmTopInfo
h

       ----------- Eliminate common blocks -------------------------------------
       CmmGraph
g <- {-# SCC "elimCommonBlocks" #-}
            GeneralFlag
-> (CmmGraph -> CmmGraph)
-> CmmGraph
-> DumpFlag
-> String
-> IO CmmGraph
condPass GeneralFlag
Opt_CmmElimCommonBlocks CmmGraph -> CmmGraph
elimCommonBlocks CmmGraph
g
                          DumpFlag
Opt_D_dump_cmm_cbe "Post common block elimination"

       -- Any work storing block Labels must be performed _after_
       -- elimCommonBlocks

       CmmGraph
g <- {-# SCC "createSwitchPlans" #-}
            UniqSM CmmGraph -> IO CmmGraph
forall a. UniqSM a -> IO a
runUniqSM (UniqSM CmmGraph -> IO CmmGraph) -> UniqSM CmmGraph -> IO CmmGraph
forall a b. (a -> b) -> a -> b
$ DynFlags -> CmmGraph -> UniqSM CmmGraph
cmmImplementSwitchPlans DynFlags
dflags CmmGraph
g
       DumpFlag -> String -> CmmGraph -> IO ()
dump DumpFlag
Opt_D_dump_cmm_switch "Post switch plan" CmmGraph
g

       ----------- Proc points -------------------------------------------------
       let call_pps :: ProcPointSet
call_pps = {-# SCC "callProcPoints" #-} CmmGraph -> ProcPointSet
callProcPoints CmmGraph
g
       ProcPointSet
proc_points <-
          if Bool
splitting_proc_points
             then do
               ProcPointSet
pp <- {-# SCC "minimalProcPointSet" #-} UniqSM ProcPointSet -> IO ProcPointSet
forall a. UniqSM a -> IO a
runUniqSM (UniqSM ProcPointSet -> IO ProcPointSet)
-> UniqSM ProcPointSet -> IO ProcPointSet
forall a b. (a -> b) -> a -> b
$
                  Platform -> ProcPointSet -> CmmGraph -> UniqSM ProcPointSet
minimalProcPointSet (DynFlags -> Platform
targetPlatform DynFlags
dflags) ProcPointSet
call_pps CmmGraph
g
               DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpWith DynFlags
dflags DumpFlag
Opt_D_dump_cmm_proc "Proc points"
                     (CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
l SDoc -> SDoc -> SDoc
$$ ProcPointSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr ProcPointSet
pp SDoc -> SDoc -> SDoc
$$ CmmGraph -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmGraph
g)
               ProcPointSet -> IO ProcPointSet
forall (m :: * -> *) a. Monad m => a -> m a
return ProcPointSet
pp
             else
               ProcPointSet -> IO ProcPointSet
forall (m :: * -> *) a. Monad m => a -> m a
return ProcPointSet
call_pps

       ----------- Layout the stack and manifest Sp ----------------------------
       (g :: CmmGraph
g, stackmaps :: LabelMap StackMap
stackmaps) <-
            {-# SCC "layoutStack" #-}
            if Bool
do_layout
               then UniqSM (CmmGraph, LabelMap StackMap)
-> IO (CmmGraph, LabelMap StackMap)
forall a. UniqSM a -> IO a
runUniqSM (UniqSM (CmmGraph, LabelMap StackMap)
 -> IO (CmmGraph, LabelMap StackMap))
-> UniqSM (CmmGraph, LabelMap StackMap)
-> IO (CmmGraph, LabelMap StackMap)
forall a b. (a -> b) -> a -> b
$ DynFlags
-> ProcPointSet
-> ByteOff
-> CmmGraph
-> UniqSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack DynFlags
dflags ProcPointSet
proc_points ByteOff
entry_off CmmGraph
g
               else (CmmGraph, LabelMap StackMap) -> IO (CmmGraph, LabelMap StackMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmGraph
g, LabelMap StackMap
forall (map :: * -> *) a. IsMap map => map a
mapEmpty)
       DumpFlag -> String -> CmmGraph -> IO ()
dump DumpFlag
Opt_D_dump_cmm_sp "Layout Stack" CmmGraph
g

       ----------- Sink and inline assignments  --------------------------------
       CmmGraph
g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]
            GeneralFlag
-> (CmmGraph -> CmmGraph)
-> CmmGraph
-> DumpFlag
-> String
-> IO CmmGraph
condPass GeneralFlag
Opt_CmmSink (DynFlags -> CmmGraph -> CmmGraph
cmmSink DynFlags
dflags) CmmGraph
g
                     DumpFlag
Opt_D_dump_cmm_sink "Sink assignments"

       ------------- CAF analysis ----------------------------------------------
       let cafEnv :: CAFEnv
cafEnv = {-# SCC "cafAnal" #-} ProcPointSet -> CLabel -> CmmGraph -> CAFEnv
cafAnal ProcPointSet
call_pps CLabel
l CmmGraph
g
       DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpWith DynFlags
dflags DumpFlag
Opt_D_dump_cmm_caf "CAFEnv" (CAFEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr CAFEnv
cafEnv)

       CmmGroup
g <- if Bool
splitting_proc_points
            then do
               ------------- Split into separate procedures -----------------------
               let pp_map :: LabelMap Status
pp_map = {-# SCC "procPointAnalysis" #-}
                            ProcPointSet -> CmmGraph -> LabelMap Status
procPointAnalysis ProcPointSet
proc_points CmmGraph
g
               DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpWith DynFlags
dflags DumpFlag
Opt_D_dump_cmm_procmap "procpoint map" (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                    LabelMap Status -> SDoc
forall a. Outputable a => a -> SDoc
ppr LabelMap Status
pp_map
               CmmGroup
g <- {-# SCC "splitAtProcPoints" #-} UniqSM CmmGroup -> IO CmmGroup
forall a. UniqSM a -> IO a
runUniqSM (UniqSM CmmGroup -> IO CmmGroup) -> UniqSM CmmGroup -> IO CmmGroup
forall a b. (a -> b) -> a -> b
$
                    DynFlags
-> CLabel
-> ProcPointSet
-> ProcPointSet
-> LabelMap Status
-> CmmDecl
-> UniqSM CmmGroup
splitAtProcPoints DynFlags
dflags CLabel
l ProcPointSet
call_pps ProcPointSet
proc_points LabelMap Status
pp_map
                                      (CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
h CLabel
l [GlobalReg]
v CmmGraph
g)
               DumpFlag -> String -> CmmGroup -> IO ()
forall (t :: * -> *) a.
(Foldable t, Outputable a) =>
DumpFlag -> String -> t a -> IO ()
dumps DumpFlag
Opt_D_dump_cmm_split "Post splitting" CmmGroup
g
               CmmGroup -> IO CmmGroup
forall (m :: * -> *) a. Monad m => a -> m a
return CmmGroup
g
             else do
               -- attach info tables to return points
               CmmGroup -> IO CmmGroup
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmGroup -> IO CmmGroup) -> CmmGroup -> IO CmmGroup
forall a b. (a -> b) -> a -> b
$ [ProcPointSet -> CmmDecl -> CmmDecl
attachContInfoTables ProcPointSet
call_pps (CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
h CLabel
l [GlobalReg]
v CmmGraph
g)]

       ------------- Populate info tables with stack info -----------------
       CmmGroup
g <- {-# SCC "setInfoTableStackMap" #-}
            CmmGroup -> IO CmmGroup
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmGroup -> IO CmmGroup) -> CmmGroup -> IO CmmGroup
forall a b. (a -> b) -> a -> b
$ (CmmDecl -> CmmDecl) -> CmmGroup -> CmmGroup
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap DynFlags
dflags LabelMap StackMap
stackmaps) CmmGroup
g
       DumpFlag -> String -> CmmGroup -> IO ()
forall (t :: * -> *) a.
(Foldable t, Outputable a) =>
DumpFlag -> String -> t a -> IO ()
dumps DumpFlag
Opt_D_dump_cmm_info "after setInfoTableStackMap" CmmGroup
g

       ----------- Control-flow optimisations -----------------------------
       CmmGroup
g <- {-# SCC "cmmCfgOpts(2)" #-}
            CmmGroup -> IO CmmGroup
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmGroup -> IO CmmGroup) -> CmmGroup -> IO CmmGroup
forall a b. (a -> b) -> a -> b
$ if DynFlags -> ByteOff
optLevel DynFlags
dflags ByteOff -> ByteOff -> Bool
forall a. Ord a => a -> a -> Bool
>= 1
                     then (CmmDecl -> CmmDecl) -> CmmGroup -> CmmGroup
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc Bool
splitting_proc_points) CmmGroup
g
                     else CmmGroup
g
       CmmGroup
g <- CmmGroup -> IO CmmGroup
forall (m :: * -> *) a. Monad m => a -> m a
return ((CmmDecl -> CmmDecl) -> CmmGroup -> CmmGroup
forall a b. (a -> b) -> [a] -> [b]
map CmmDecl -> CmmDecl
removeUnreachableBlocksProc CmmGroup
g)
            -- See Note [unreachable blocks]
       DumpFlag -> String -> CmmGroup -> IO ()
forall (t :: * -> *) a.
(Foldable t, Outputable a) =>
DumpFlag -> String -> t a -> IO ()
dumps DumpFlag
Opt_D_dump_cmm_cfg "Post control-flow optimisations" CmmGroup
g

       (CAFEnv, CmmGroup) -> IO (CAFEnv, CmmGroup)
forall (m :: * -> *) a. Monad m => a -> m a
return (CAFEnv
cafEnv, CmmGroup
g)

  where dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        dump :: DumpFlag -> String -> CmmGraph -> IO ()
dump = DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph DynFlags
dflags

        dumps :: DumpFlag -> String -> t a -> IO ()
dumps flag :: DumpFlag
flag name :: String
name
           = (a -> IO ()) -> t a -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpWith DynFlags
dflags DumpFlag
flag String
name (SDoc -> IO ()) -> (a -> SDoc) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr)

        condPass :: GeneralFlag
-> (CmmGraph -> CmmGraph)
-> CmmGraph
-> DumpFlag
-> String
-> IO CmmGraph
condPass flag :: GeneralFlag
flag pass :: CmmGraph -> CmmGraph
pass g :: CmmGraph
g dumpflag :: DumpFlag
dumpflag dumpname :: String
dumpname =
            if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
flag DynFlags
dflags
               then do
                    CmmGraph
g <- CmmGraph -> IO CmmGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmGraph -> IO CmmGraph) -> CmmGraph -> IO CmmGraph
forall a b. (a -> b) -> a -> b
$ CmmGraph -> CmmGraph
pass CmmGraph
g
                    DumpFlag -> String -> CmmGraph -> IO ()
dump DumpFlag
dumpflag String
dumpname CmmGraph
g
                    CmmGraph -> IO CmmGraph
forall (m :: * -> *) a. Monad m => a -> m a
return CmmGraph
g
               else CmmGraph -> IO CmmGraph
forall (m :: * -> *) a. Monad m => a -> m a
return CmmGraph
g

        -- we don't need to split proc points for the NCG, unless
        -- tablesNextToCode is off.  The latter is because we have no
        -- label to put on info tables for basic blocks that are not
        -- the entry point.
        splitting_proc_points :: Bool
splitting_proc_points = DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
/= HscTarget
HscAsm
                             Bool -> Bool -> Bool
|| Bool -> Bool
not (DynFlags -> Bool
tablesNextToCode DynFlags
dflags)
                             Bool -> Bool -> Bool
|| -- Note [inconsistent-pic-reg]
                                Bool
usingInconsistentPicReg
        usingInconsistentPicReg :: Bool
usingInconsistentPicReg
           = case (Platform -> Arch
platformArch Platform
platform, Platform -> OS
platformOS Platform
platform, DynFlags -> Bool
positionIndependent DynFlags
dflags)
             of   (ArchX86, OSDarwin, pic :: Bool
pic) -> Bool
pic
                  _                        -> Bool
False

-- Note [Sinking after stack layout]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- In the past we considered running sinking pass also before stack
-- layout, but after making some measurements we realized that:
--
--   a) running sinking only before stack layout produces slower
--      code than running sinking only before stack layout
--
--   b) running sinking both before and after stack layout produces
--      code that has the same performance as when running sinking
--      only after stack layout.
--
-- In other words sinking before stack layout doesn't buy as anything.
--
-- An interesting question is "why is it better to run sinking after
-- stack layout"? It seems that the major reason are stores and loads
-- generated by stack layout. Consider this code before stack layout:
--
--  c1E:
--      _c1C::P64 = R3;
--      _c1B::P64 = R2;
--      _c1A::P64 = R1;
--      I64[(young<c1D> + 8)] = c1D;
--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
--  c1D:
--      R3 = _c1C::P64;
--      R2 = _c1B::P64;
--      R1 = _c1A::P64;
--      call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8;
--
-- Stack layout pass will save all local variables live across a call
-- (_c1C, _c1B and _c1A in this example) on the stack just before
-- making a call and reload them from the stack after returning from a
-- call:
--
--  c1E:
--      _c1C::P64 = R3;
--      _c1B::P64 = R2;
--      _c1A::P64 = R1;
--      I64[Sp - 32] = c1D;
--      P64[Sp - 24] = _c1A::P64;
--      P64[Sp - 16] = _c1B::P64;
--      P64[Sp - 8] = _c1C::P64;
--      Sp = Sp - 32;
--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
--  c1D:
--      _c1A::P64 = P64[Sp + 8];
--      _c1B::P64 = P64[Sp + 16];
--      _c1C::P64 = P64[Sp + 24];
--      R3 = _c1C::P64;
--      R2 = _c1B::P64;
--      R1 = _c1A::P64;
--      Sp = Sp + 32;
--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
--
-- If we don't run sinking pass after stack layout we are basically
-- left with such code. However, running sinking on this code can lead
-- to significant improvements:
--
--  c1E:
--      I64[Sp - 32] = c1D;
--      P64[Sp - 24] = R1;
--      P64[Sp - 16] = R2;
--      P64[Sp - 8] = R3;
--      Sp = Sp - 32;
--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
--  c1D:
--      R3 = P64[Sp + 24];
--      R2 = P64[Sp + 16];
--      R1 = P64[Sp + 8];
--      Sp = Sp + 32;
--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
--
-- Now we only have 9 assignments instead of 15.
--
-- There is one case when running sinking before stack layout could
-- be beneficial. Consider this:
--
--   L1:
--      x = y
--      call f() returns L2
--   L2: ...x...y...
--
-- Since both x and y are live across a call to f, they will be stored
-- on the stack during stack layout and restored after the call:
--
--   L1:
--      x = y
--      P64[Sp - 24] = L2
--      P64[Sp - 16] = x
--      P64[Sp - 8]  = y
--      Sp = Sp - 24
--      call f() returns L2
--   L2:
--      y = P64[Sp + 16]
--      x = P64[Sp + 8]
--      Sp = Sp + 24
--      ...x...y...
--
-- However, if we run sinking before stack layout we would propagate x
-- to its usage place (both x and y must be local register for this to
-- be possible - global registers cannot be floated past a call):
--
--   L1:
--      x = y
--      call f() returns L2
--   L2: ...y...y...
--
-- Thus making x dead at the call to f(). If we ran stack layout now
-- we would generate less stores and loads:
--
--   L1:
--      x = y
--      P64[Sp - 16] = L2
--      P64[Sp - 8]  = y
--      Sp = Sp - 16
--      call f() returns L2
--   L2:
--      y = P64[Sp + 8]
--      Sp = Sp + 16
--      ...y...y...
--
-- But since we don't see any benefits from running sinking befroe stack
-- layout, this situation probably doesn't arise too often in practice.
--

{- Note [inconsistent-pic-reg]

On x86/Darwin, PIC is implemented by inserting a sequence like

    call 1f
 1: popl %reg

at the proc entry point, and then referring to labels as offsets from
%reg.  If we don't split proc points, then we could have many entry
points in a proc that would need this sequence, and each entry point
would then get a different value for %reg.  If there are any join
points, then at the join point we don't have a consistent value for
%reg, so we don't know how to refer to labels.

Hence, on x86/Darwin, we have to split proc points, and then each proc
point will get its own PIC initialisation sequence.

This isn't an issue on x86/ELF, where the sequence is

    call 1f
 1: popl %reg
    addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg

so %reg always has a consistent value: the address of
_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.

-}

{- Note [unreachable blocks]

The control-flow optimiser sometimes leaves unreachable blocks behind
containing junk code.  These aren't necessarily a problem, but
removing them is good because it might save time in the native code
generator later.

-}

runUniqSM :: UniqSM a -> IO a
runUniqSM :: UniqSM a -> IO a
runUniqSM m :: UniqSM a
m = do
  UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply 'u'
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqSupply -> UniqSM a -> a
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us UniqSM a
m)


dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph dflags :: DynFlags
dflags flag :: DumpFlag
flag name :: String
name g :: CmmGraph
g = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoCmmLinting DynFlags
dflags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CmmGraph -> IO ()
do_lint CmmGraph
g
  DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpWith DynFlags
dflags DumpFlag
flag String
name (CmmGraph -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmGraph
g)
 where
  do_lint :: CmmGraph -> IO ()
do_lint g :: CmmGraph
g = case DynFlags -> CmmGraph -> Maybe SDoc
cmmLintGraph DynFlags
dflags CmmGraph
g of
                 Just err :: SDoc
err -> do { DynFlags -> SDoc -> IO ()
fatalErrorMsg DynFlags
dflags SDoc
err
                                ; DynFlags -> ByteOff -> IO ()
ghcExit DynFlags
dflags 1
                                }
                 Nothing  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpWith dflags :: DynFlags
dflags flag :: DumpFlag
flag txt :: String
txt sdoc :: SDoc
sdoc = do
         -- ToDo: No easy way of say "dump all the cmm, *and* split
         -- them into files."  Also, -ddump-cmm-verbose doesn't play
         -- nicely with -ddump-to-file, since the headers get omitted.
   DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
flag String
txt SDoc
sdoc
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (DumpFlag -> DynFlags -> Bool
dopt DumpFlag
flag DynFlags
dflags)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_cmm_verbose String
txt SDoc
sdoc