IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor,

         -- * Core rule data types

         RuleName, RuleFun, IdUnfoldingFun, InScopeEnv(..), RuleOpts,

         -- ** Operations on 'CoreRule's

         ruleArity, ruleName, ruleIdName, ruleActivation,

         setRuleIdName, ruleModule,

 import GHC.Utils.Outputable

 import GHC.Utils.Panic

 import Data.Data hiding (TyCon)

 import Data.Int

 import Data.List.NonEmpty (nonEmpty)

     }

                 -- See Note [Extra args in the target] in GHC.Core.Rules

 -- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are

 -- currently in scope. See Note [The InScopeSet invariant].

 setRuleIdName :: Name -> CoreRule -> CoreRule

 setRuleIdName nm ru = ru { ru_fn = nm }

 {-

 ************************************************************************

 *                                                                      *

         mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,

         MkStringIds (..), getMkStringIds,

         -- * Constructing small tuples

         mkCoreVarTupTy, mkCoreTup, mkCoreUnboxedTuple, mkCoreUnboxedSum,

         mkCoreTupBoxity, unitExpr,

         -- * Constructing Maybe expressions

         mkNothingExpr, mkJustExpr,

         -- * Error Ids

         mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds,

         rEC_CON_ERROR_ID,

 import GHC.Types.Demand

 import GHC.Types.Name      hiding ( varName )

 import GHC.Types.Literal

 import GHC.Types.Unique.Supply

 import GHC.Core

   = Case scrut scrut_var (exprType body)

          [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars body]

 {-

 ************************************************************************

 *                                                                      *

 mkJustExpr ty val = mkConApp justDataCon [Type ty, val]

 {-

 ************************************************************************

 *                                                                      *

 -- useful shorthands

 mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule

 mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)

             -> [RuleM CoreExpr] -> Maybe CoreRule

 ************************************************************************

 -}

 -- Gives the Rule the same name as the primop itself

   deriving (Functor)

 instance Applicative RuleM where

 builtinRules :: [CoreRule]

 -- Rules for non-primops that can't be expressed using a RULE pragma

 builtinRules

         [ nonZeroLit 1 >> binaryLit (intOp2 div)

         , leftZero

         , do

           Just n <- return $ exactLog2 d

           platform <- getPlatform

           return $ Var (primOpId IntSraOp) `App` arg `App` mkIntVal platform n

         [ nonZeroLit 1 >> binaryLit (intOp2 mod)

         , leftZero

         , do

       encodeLitDouble LitDouble

   ]

   where

     integer_to_lit str name convert = mkRule str name 1 $ do

       [a0] <- getArgs

 --

 -- CString version

 match_cstring_append_lit_C = match_cstring_append_lit unpackCStringAppendIdKey unpackCStringIdKey

 -- CStringUTF8 version

 match_cstring_append_lit_utf8 = match_cstring_append_lit unpackCStringAppendUtf8IdKey unpackCStringUtf8IdKey

 {-# INLINE match_cstring_append_lit #-}

 match_cstring_append_lit append_key unpack_key _ env _ [lit1, e2]

   | Just (LitString s1) <- exprIsLiteral_maybe env lit1

   , (strTicks, Var unpk `App` lit2) <- stripStrTopTicks env e2

 -- See also Note [String literals in GHC] in CString.hs

 -- CString version

 match_cstring_foldr_lit_C = match_cstring_foldr_lit unpackCStringFoldrIdKey

 -- CStringUTF8 version

 match_cstring_foldr_lit_utf8 = match_cstring_foldr_lit unpackCStringFoldrUtf8IdKey

 {-# INLINE match_cstring_foldr_lit #-}

 match_cstring_foldr_lit foldVariant _ env _

         [ Type ty1

         , lit1

 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2

 -- Also  matches unpackCStringUtf8#

 match_eq_string _ env _ [e1, e2]

   | (ticks1, Var unpk1 `App` lit1) <- stripStrTopTicks env e1

   , (ticks2, Var unpk2 `App` lit2) <- stripStrTopTicks env e2

 -- helpful when using OverloadedStrings to create a ByteString since the

 -- function computing the length of such ByteStrings can often be constant

 -- folded.

 match_cstring_length rule_env env _ [lit1]

   | Just (LitString str) <- exprIsLiteral_maybe env lit1

     -- If elemIndex returns Just, it has the index of the first embedded NUL

   Also, don't forget about 'inline's type argument!

 -}

   -- Maybe Monad ahead:

   where

     go (Var f)      = -- Ignore the IdUnfoldingFun here!

     go (Tick t e)   = do { app <- go e; pure (Tick t app) }

     go _            = Nothing

 --------------------------------------------------------

 -- Note [Constant folding through nested expressions]

                           , typeArity, arityTypeArity, etaExpandAT )

 import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )

 import GHC.Core.FVs     ( mkRuleInfo {- exprsFreeIds -} )

 import GHC.Core.Multiplicity

 import GHC.Hs.Extension

                      else return Nothing

        ; case mb_match of {

              Just (RM { rm_rule = rule, rm_rhs = rhs

                   -> simplExprF env rhs' $

                      dropContArgs (ruleArity rule) cont

                   where

                            mkApps rhs rhs_args

            ; Nothing ->

               -> SimplM (SimplFloats, CoreExpr)

 fireRuleAFTER env rule_match arg_specs cont

   | RM { rm_rule = rule, rm_rhs = rhs, rm_args = rhs_args

        ; (floats, e') <- simplExprF env' rhs $

                          pushOutArgs (exprType rhs) rhs_args $

                          pushArgSpecs (drop (ruleArity rule) arg_specs) cont

        ; return $

          then (floats, e')

                                  wrapFloats floats e') }

     -- scale_float scales case-floats by the multiplicity of the continuation hole

     -- (see Note [Scaling in case-of-case]).

     -- Let floats are _not_ scaled, because they are aliases anyway.

     scale_id id = scaleVarBy holeScaling id

              (CP { cp_qvars = vs2, cp_args = as2 })

   | equalLength as1 as2

   = case matchExprs ise vs1 as1 as2 of

   | otherwise -- We must handle patterns of unequal length separately (#24282)

   = False  -- For the pattern with more args, the last arg is "interesting"

   | otherwise

   = case lookupRule ropts in_scope_env is_active fn args rules of

       Just (RM { rm_rule = rule, rm_rhs = rule_rhs

       Nothing -> Nothing

   where

     dflags       = se_dflags env

 instance OutputableBndr b => Outputable (Alt b) where

     ppr expr = pprCoreAlt expr

 {-

 ************************************************************************

 *                                                                      *

 ************************************************************************

 -}

 -- | The main rule matching function. Attempts to apply all (active)

 -- supplied rules to this instance of an application in a given

     go ms [] = ms

     go ms (r:rs)

       | Just rm <- matchRule opts rule_env is_active fn args' rough_args r

       | otherwise

       = -- pprTrace "match failed" (ppr r $$ ppr args $$

         --   ppr [ (arg_id, maybeUnfoldingTemplate unf)

 -- of the actual arguments.

 matchRule opts rule_env _is_active fn args _rough_args

   = do { guard (roBuiltinRules opts)

 matchRule _opts rule_env is_active _fn target_es rough_args

           rule@(Rule { ru_act = act, ru_rough = tpl_tops

   | ruleCantMatch tpl_tops rough_args

   = Nothing

   | otherwise

         ; return (RM { rm_rule  = rule

                      , rm_rhs   = mkLams tpl_vars rhs

                      , rm_args  = matched_es

 matchExprs :: HasDebugCallStack

            => InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr]

 matchExprs (ISE in_scope id_unf) tmpl_vars tmpl_es target_es

   = do  { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es

         ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst)

                                           (mkEmptySubst in_scope) $

                                 tmpl_vars `zip` tmpl_vars1

   where

     (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars

                   -- See Note [Cloning the template binders]

 import GHC.Core.Utils

 import GHC.Core.Opt.Arity

 import GHC.Core.Lint    ( EndPassConfig(..), endPassIO )

 import GHC.Core.Subst

 import GHC.Core.Type

 import GHC.Core.Coercion

 import GHC.Core.TyCon

 -- See Note [Floating in CorePrep]

 -- and Note [BindInfo and FloatInfo]

 data FloatingBind

   = Float !CoreBind !BindInfo !FloatInfo    -- Never a join-point binding

   | UnsafeEqualityCase !CoreExpr !CoreBndr !AltCon ![CoreBndr]

 import GHC.Core.Predicate (typeDeterminesValue, mkNomEqPred)

 import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe)

 import GHC.Core.Utils     (exprType)

 import GHC.Data.FastString

 import GHC.Types.SrcLoc

     -- This is the built-in rule that goes

     --      op (dfT d1 d2) --->  opT d1 d2

         -- The strictness signature is of the form U(AAAVAAAA) -> T

         -- where the V depends on which item we are selecting

                                 -- varToCoreExpr needed for equality superclass selectors

                                 --   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }

 -- Tries to persuade the argument to look like a constructor

 -- application, using exprIsConApp_maybe, and then selects

 -- from it

 --       sel_i t1..tk (D t1..tk op1 ... opm) = opi

 --

 -- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance

 {-

 ************************************************************************