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

    {-# LANGUAGE PatternSynonyms #-}
    {-# LANGUAGE UnboxedTuples #-}

    module GHC.Cmm.GenericOpt
       ( cmmToCmm
       )
    where

    import GHC.Prelude hiding (head)
    import GHC.Platform
    import GHC.CmmToAsm.PIC
    import GHC.CmmToAsm.Config
    import GHC.CmmToAsm.Types
    import GHC.Cmm.BlockId
    import GHC.Cmm
    import GHC.Cmm.Utils
    import GHC.Cmm.Dataflow.Block
    import GHC.Cmm.Opt           ( cmmMachOpFold )
    import GHC.Cmm.CLabel
    import GHC.Data.FastString
    import GHC.Unit
    import Control.Monad

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

    {-
    Here we do:

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
    cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
    cmmBlockConFold CmmBlock
    block = do
      let (CmmNode 'Closed 'Open
    entry, Block CmmNode 'Open 'Open
    middle, CmmNode 'Open 'Closed
    last) = CmmBlock
    -> (CmmNode 'Closed 'Open, Block CmmNode 'Open 'Open,
        CmmNode 'Open 'Closed)
    forall (n :: Extensibility -> Extensibility -> *).
    Block n 'Closed 'Closed
    -> (n 'Closed 'Open, Block n 'Open 'Open, n 'Open 'Closed)
    blockSplit CmmBlock
    block
          stmts :: [CmmNode 'Open 'Open]
    stmts = Block CmmNode 'Open 'Open -> [CmmNode 'Open 'Open]
    forall (n :: Extensibility -> Extensibility -> *).
    Block n 'Open 'Open -> [n 'Open 'Open]
    blockToList Block CmmNode 'Open 'Open
    middle
      stmts' <- (CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open))
    -> [CmmNode 'Open 'Open] -> CmmOptM [CmmNode 'Open 'Open]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM CmmNode 'Open 'Open -> CmmOptM (CmmNode 'Open 'Open)
    forall (e :: Extensibility) (x :: Extensibility).
    CmmNode e x -> CmmOptM (CmmNode e x)
    cmmStmtConFold [CmmNode 'Open 'Open]
    stmts
      last' <- cmmStmtConFold last
      return $ blockJoin entry (blockFromList stmts') 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 src' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprConFold ReferenceKind
    DataReference CmmExpr
    src
                     return $ case src' of
                       CmmReg CmmReg
    reg' | CmmReg
    reg CmmReg -> CmmReg -> Bool
    forall a. Eq a => a -> a -> Bool
    == CmmReg
    reg' -> FastString -> CmmNode 'Open 'Open
    CmmComment (String -> FastString
    fsLit String
    "nop")
                       CmmExpr
    new_src -> CmmReg -> CmmExpr -> CmmNode 'Open 'Open
    CmmAssign CmmReg
    reg CmmExpr
    new_src

            CmmStore CmmExpr
    addr CmmExpr
    src AlignmentSpec
    align
               -> do addr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprConFold ReferenceKind
    DataReference CmmExpr
    addr
                     src'  <- cmmExprConFold DataReference src
                     return $ CmmStore addr' src' align

            CmmCall { cml_target :: CmmNode 'Open 'Closed -> CmmExpr
    cml_target = CmmExpr
    addr }
               -> do addr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprConFold ReferenceKind
    JumpReference CmmExpr
    addr
                     return $ stmt { cml_target = addr' }

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

            CmmCondBranch CmmExpr
    test BlockId
    true BlockId
    false Maybe Bool
    likely
               -> do test' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprConFold ReferenceKind
    DataReference CmmExpr
    test
                     return $ case test' of
                       CmmLit (CmmInt Integer
    0 Width
    _) -> BlockId -> CmmNode 'Open 'Closed
    CmmBranch BlockId
    false
                       CmmLit (CmmInt Integer
    _ Width
    _) -> BlockId -> CmmNode 'Open 'Closed
    CmmBranch BlockId
    true
                       CmmExpr
    _other -> CmmExpr
    -> BlockId -> BlockId -> Maybe Bool -> CmmNode 'Open 'Closed
    CmmCondBranch CmmExpr
    test' BlockId
    true BlockId
    false Maybe Bool
    likely

            CmmSwitch CmmExpr
    expr SwitchTargets
    ids
               -> do expr' <- ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
    cmmExprConFold ReferenceKind
    DataReference CmmExpr
    expr
                     return $ CmmSwitch expr' ids

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

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

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

        cmmExprNative referenceKind expr'

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

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

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

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

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

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

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