-- (c) The University of Glasgow 2006

 {-# LANGUAGE CPP #-}

 import GHC.Prelude

 import GHC.Data.TrieMap

 import GHC.Utils.Outputable

 import GHC.Utils.Misc

 import GHC.Utils.Panic

 %*                                                                      *

 %********************************************************************* -}

 -- Apply optCoercion to all coercions in /expressions/

 -- There may also be coercions in /types/ but we `optCoProgram` doesn't

 -- look at them; they are typically fewer and smaller, and it doesn't seem

 -- worth the cost of traversing and rebuilding all the types in the program.

   = map go binds

   where

     in_scope = mkInScopeSetList (bindersOfBinds binds)

        -- Put all top-level binders into scope; it is possible to have

        -- forward references.  See Note [Glomming] in GHC.Core.Opt.OccurAnal

 optCoExpr is (App e1 e2)   = App (optCoExpr is e1) (optCoExpr is e2)

 optCoExpr is (Coercion co) = Coercion (optCo is co)

 optCoExpr is (Cast e co)   = Cast (optCoExpr is e) (optCo is co)

 optCoExpr is (Tick t e)    = Tick t (optCoExpr is e)

 {- **********************************************************************

 optCoRefl :: Bool -> Subst -> Coercion -> Coercion

 -- See Note [optCoRefl]

 optCoRefl check_stuff subst in_co

   | otherwise  -- Do expensive checks

   = let out_co = opt_co_refl subst in_co

         (Pair in_l in_r) = coercionKind in_co

         in_co' = substCo subst in_co

         in_sz = coercionSize in_co'

         out_sz = coercionSize out_co

 opt_co_refl :: Subst -> InCoercion -> OutCoercion

 opt_co_refl subst co = go co

     go (HoleCo h)                    = HoleCo $!! go_hole h

     go (SymCo co)                    = mkSymCo $!! go co

     go (KindCo co)                   = mkKindCo $!! go co

     go (SelCo n co)                  = mkSelCo n $!! go co

     go (FunCo r afl afr com coa cor) = mkFunCo2 r afl afr

                                            $!! go com $!! go coa $!! go cor

     go (TyConAppCo r tc cos)         = mkTyConAppCo r tc $!! go_s cos

     go (AxiomCo ax cos)              = mkAxiomCo ax $!! (go_s cos)

     go (ForAllCo v vl vr mco co)     = mkForAllCo v' vl vr

 data GobbleState = GS OutCoercion (TypeMap GobbleState)

                    -- The map is keyed by OutType

 {- **********************************************************************

 %*                                                                      *

                     optCoercion

 %*                                                                      *

 %********************************************************************* -}

 -- ^ optCoercion applies a substitution to a coercion,

 --   *and* optimises it to reduce its size

 -- The substitution is a vestige of an earlier era, when the coercion optimiser

 --   was called by the Simplifier; now it is always empty

 --   But I have not removed it in case we ever want it back.

         (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co

                        , text "in_ty1:" <+> ppr in_ty1

                        , text "in_ty2:" <+> ppr in_ty2

                        , text "out_co:" <+> ppr out_co

                        , text "out_role:" <+> ppr out_role

                        ]

     in

     -- The coercion optimiser should usually optimise

     --     co:ty~ty   -->  Refl ty

     -- But given a silly `newtype N = MkN N`, the axiom has type (N ~ N),

     -- and so that can trigger this warning (e.g. test str002).

     -- Maybe we should optimise that coercion to (Refl N), but it

     -- just doesn't seem worth the bother

 type NormalCo    = Coercion

   -- Invariants:

         deps' = map (opt_co1 env sym) deps

         (ty1'', ty2'') = swapSym sym (ty1', ty2')

     in

 {-

 opt_univ env PhantomProv cvs _r ty1 ty2

     strictness    = gopt Opt_Strictness                   dflags

     full_laziness = gopt Opt_FullLaziness                 dflags

     do_specialise = gopt Opt_Specialise                   dflags

     do_float_in   = gopt Opt_FloatIn                      dflags

     cse           = gopt Opt_CSE                          dflags

     spec_constr   = gopt Opt_SpecConstr                   dflags

     ww_on         = gopt Opt_WorkerWrapper                dflags

     static_ptrs   = xopt LangExt.StaticPointers           dflags

     profiling     = ways dflags `hasWay` WayProf

     do_simpl3      = const_fold || rules_on -- TODO: any other optimizations benefit from three-phase simplification?

         -- Without -O, just take what the desugarer produced

         -- I tried running it right after desugaring, regardless of -O,

         -- but that was worse (longer compile times).

         if full_laziness then

            CoreDoFloatOutwards $ FloatOutSwitches

     CoreCSE                   -> {-# SCC "CommonSubExpr" #-}

                                  updateBinds cseProgram

     CoreLiberateCase          -> {-# SCC "LiberateCase" #-}

                                  updateBinds (liberateCase (initLiberateCaseOpts dflags))

   | CoreDoSpecialising

   | CoreDoSpecConstr

   | CoreCSE

   | CoreDoRuleCheck CompilerPhase String  -- Check for non-application of rules

                                        -- matching this string

   | CoreDoNothing                -- Useful when building up

   ppr CoreDoSpecialising       = text "Specialise"

   ppr CoreDoSpecConstr         = text "SpecConstr"

   ppr CoreCSE                  = text "Common sub-expression"

   ppr CoreDesugar              = text "Desugar (before optimization)"

   ppr CoreDesugarOpt           = text "Desugar (after optimization)"

   ppr CoreTidy                 = text "Tidy Core"

   , sm_rule_opts :: !RuleOpts

   , sm_case_folding :: !Bool

   , sm_case_merge :: !Bool

   }

 -- | See Note [SimplPhase]

 simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion

 simplCoercion env co

   where

     mode = seMode env

   , sm_pre_inline = gopt Opt_SimplPreInlining dflags

   , sm_float_enable = floatEnable dflags

   , sm_do_eta_reduction = gopt Opt_DoEtaReduction dflags

   , sm_case_folding = gopt Opt_CaseFolding dflags

   , sm_check_opt_co = dopt Opt_D_opt_co dflags

   }

    | Opt_InlineGenerics

    | Opt_InlineGenericsAggressively

    | Opt_StaticArgumentTransformation

    | Opt_CSE

    | Opt_StgCSE

    | Opt_StgLiftLams

      ------ Language flags -------------------------------------------------

  ++ map (mkFlag turnOn  "f"         setExtensionFlag  ) fLangFlagsDeps

  ++ map (mkFlag turnOn  "X"         setExtensionFlag  ) xFlagsDeps

  ++ map (mkFlag turnOff "XNo"       unSetExtensionFlag) xFlagsDeps

  ++ map (mkFlag turnOn  "X"         setLanguage       ) languageFlagsDeps

         mkUserStyle, cmdlineParserStyle, Depth(..),

         withUserStyle, withErrStyle,

         bPutHDoc

     ) where

 {-# INLINE CONLIKE getPprDebug #-}

 getPprDebug d = docWithContext $ \ctx -> d (sdocPprDebug ctx)

 -- | Says what to do with and without -dppr-debug

 ifPprDebug :: IsOutput doc => doc -> doc -> doc

 {-# INLINE CONLIKE ifPprDebug #-}

 -- | Tracing utilities

 module GHC.Utils.Trace

   ( pprTrace

   , pprTraceM

   , pprTraceDebug

   , pprTraceIt

 import Debug.Trace (trace)

 import Control.Monad.IO.Class

 -- | If debug output is on, show some 'SDoc' on the screen

 pprTrace :: String -> SDoc -> a -> a

 pprTrace str doc x