+{-# LANGUAGE MultiWayIf #-}

+

+import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe )

+import GHC.Core.Class( classMethods )

+                          , mkCast, exprType, exprIsHNF

+import GHC.Core.Ppr( pprIds )

+import GHC.Core.TyCon (tyConClass_maybe)

+import GHC.Core.DataCon (dataConTyCon)

+

+import Control.Monad

+    --  [ text "function" <+> ppr fn

+    --  , text "calls:" <+> ppr calls_for_me

+    --  , text "subst" <+> ppr (se_subst env) ]) $

+          ; when False $ pprTrace "spec_call" (vcat

+               [ text "fun:       "  <+> ppr fn

+               , text "call info: "  <+> ppr _ci

+               , text "useful:    "  <+> ppr useful

+               , text "rule_bndrs:"  <+> ppr rule_bndrs

+               , text "lhs_args:  "  <+> ppr rule_lhs_args

+               , text "spec_bndrs1:" <+> ppr spec_bndrs1

+               , text "leftover_bndrs:" <+> pprIds leftover_bndrs

+               , text "spec_args: "  <+> ppr spec_args

+               , text "dx_binds:  "  <+> ppr dx_binds

+               , text "rhs_bndrs"     <+> ppr rhs_bndrs

+               , text "rhs_body"     <+> ppr rhs_body

+               , text "rhs_env2:  "  <+> ppr (se_subst rhs_env2)

+               , ppr dx_binds ]) $

+            return ()

+    mk_spec_arg arg (Anon _pred af)

+      , interestingDict env arg

+      -- , interestingDict arg (scaledThing pred)

+interestingDict :: SpecEnv -> CoreExpr -> Bool

+-- This is a subtle and important function

+-- See Note [Interesting dictionary arguments]

+interestingDict env (Var v)  -- See (ID3) and (ID5)

+  | Just rhs <- maybeUnfoldingTemplate (idUnfolding v)

+  -- might fail for loop breaker dicts but that seems fine.

+  = interestingDict env rhs

+

+interestingDict env arg  -- Main Plan: use exprIsConApp_maybe

+  | Cast inner_arg _ <- arg  -- See (ID5)

+  = if | isConstraintKind $ typeKind $ exprType inner_arg

+       -- If coercions were always homo-kinded, we'd know

+       -- that this would be the only case

+       -> interestingDict env inner_arg

+

+       -- Check for an implicit parameter at the top

+       | Just (cls,_) <- getClassPredTys_maybe arg_ty

+       , isIPClass cls      -- See (ID4)

+       -> False

+

+       -- Otherwise we are unwrapping a unary type class

+       | otherwise

+       -> exprIsHNF arg   -- See (ID7)

+

+  | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg

+  , Just cls <- tyConClass_maybe (dataConTyCon data_con)

+  , not_ip_like                  -- See (ID4)

+  = if null (classMethods cls)   -- See (ID6)

+    then any (interestingDict env) args

+    else True

+

+  | otherwise

+  = not (exprIsTrivial arg) && not_ip_like  -- See (ID8)

+  where

+    arg_ty       = exprType arg

+    not_ip_like  = not (couldBeIPLike arg_ty)

+    in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding

+

+{- Note [Ticks on applications]

+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+Ticks such as source location annotations can sometimes make their way

+onto applications (see e.g. #21697). So if we see something like

+

+    App (Tick _ f) e

+

+we need to descend below the tick to find what the real function being

+applied is.

+

+The resulting RULE also has to be able to match this annotated use

+site, so we only look through ticks that RULE matching looks through

+(see Note [Tick annotations in RULE matching] in GHC.Core.Rules).

+

+Note [wantCallsFor]

+~~~~~~~~~~~~~~~~~~~

+Consider this

+         \a.\d:Eq a.  let f = ... in ...(f d)...

+There really is not much point in specialising f wrt the dictionary d,

+because the code for the specialised f is not improved at all, because

+d is lambda-bound.  We simply get junk specialisations.

+

+What is "interesting"?  Our Main Plan is to use `exprIsConApp_maybe` to see

+if the argument is a dictionary constructor applied to some arguments, in which

+case we can clearly specialise. But there are wrinkles:

+

+(ID1) Note that we look at the argument /term/, not its /type/.  Suppose the

+  argument is

+         (% d1, d2 %) |> co

+  where co :: (% Eq [a], Show [a] %) ~ F Int a, and `F` is a type family.

+  Then its type (F Int a) looks very un-informative, but the term is super

+  helpful.  See #19747 (where missing this point caused a 70x slow down)

+  and #7785.

+

+(ID2) Note that the Main Plan works fine for an argument that is a DFun call,

+   e.g.    $fOrdList $dOrdInt

+   because `exprIsConApp_maybe` cleverly deals with DFunId applications.  Good!

+

+(ID3) For variables, we look in the variable's /unfolding/.  And that means

+   that we must be careful to ensure that dictionaries /have/ unfoldings:

+   * cloneBndrSM discards non-Stable unfoldings

+   * specBind updates the unfolding after specialisation

+     See Note [Update unfolding after specialisation]

+   * bindAuxiliaryDict adds an unfolding for an aux dict

+     see Note [Specialisation modulo dictionary selectors]

+   * specCase adds unfoldings for the new bindings it creates

+

+   We accidentally lost accurate tracking of local variables for a long

+   time, because cloned variables didn't have unfoldings. But makes a

+   massive difference in a few cases, eg #5113. For nofib as a

+   whole it's only a small win: 2.2% improvement in allocation for ansi,

+   1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size.

+

+(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains

+   an implicit parameter, because implicit parameters are emphatically not singleton

+   types.  See #25999:

+     useImplicit :: (?i :: Int) => Int

+     useImplicit = ?i + 1

+

+     foo = let ?i = 1 in (useImplicit, let ?i = 2 in useImplicit)

+   Both calls to `useImplicit` are at type `?i::Int`, but they pass different values.

+   We must not specialise on implicit parameters!  Hence the call to `couldBeIPLike`.

+

+(ID5) Suppose the argument is (e |> co).  Can we rely on `exprIsConApp_maybe` to deal

+   with the coercion.  No!  That only works if (co :: C t1 ~ C t2) with the same type

+   constructor at the top of both sides.  But see the example in (ID1), where that

+   is not true.  For thes same reason, we can't rely on `exprIsConApp_maybe` to look

+   through unfoldings (because there might be a cast inside), hence dealing with

+   expandable unfoldings in `interestingDict` directly.

+

+(ID6) The Main Plan says that it's worth specialising if the argument is an application

+   of a dictionary contructor.  But what if the dictionary has no methods?  Then we

+   gain nothing by specialising, unless the /superclasses/ are interesting.   A case

+   in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class

+   with N superclasses and no methods.

+

+(ID7) A unary (single-method) class is currently represented by (meth |> co).  We

+   will unwrap the cast (see (ID5)) and then want to reply "yes" if the method

+   has any struture.  We rather arbitrarily use `exprIsHNF` for this.  (We plan a

+   new story for unary classes, see #23109, and this special case will become

+   irrelevant.)

+

+(ID8) Sadly, if `exprIsConApp_maybe` says Nothing, we still want to treat a

+   non-trivial argument as interesting. In T19695 we have this:

+      askParams :: Monad m => blah

+      mhelper   :: MonadIO m => blah

+      mhelper (d:MonadIO m) = ...(askParams @m ($p1 d))....

+   where `$p1` is the superclass selector for `MonadIO`.  Now, if `mhelper` is

+   specialised at `Handler` we'll get this call in the specialised `$smhelper`:

+            askParams @Handler ($p1 $fMonadIOHandler)

+   and we /definitely/ want to specialise that, even though the argument isn't

+   visibly a dictionary application.  In fact the specialiser fires the superclass

+   selector rule (see Note [Fire rules in the specialiser]), so we get

+            askParams @Handler ($cp1MonadIO $fMonadIOIO)

+   but it /still/ doesn't look like a dictionary application.

+

+   Conclusion: we optimistically assume that any non-trivial argument is worth

+   specialising on.

+

+   So why do the `exprIsConApp_maybe` and `Cast` stuff? Because we want to look

+   under type-family casts (ID1) and constraint tuples (ID6).

+

+  couldBeIPLike, mightMentionIP, isIPTyCon, isIPClass,

+-- | Is the type *guaranteed* to determine the value?

+--

+-- Might say No even if the type does determine the value. (See the Note)

+typeDeterminesValue ty = isDictTy ty && not (couldBeIPLike ty)

+

+It's also not always possible to infer that a type determines the value

+if type families are in play. See #19747 for one such example.

+

+-- --------------------- couldBeIPLike and mightMentionIP  --------------------------

+couldBeIPLike :: Type -> Bool

+couldBeIPLike pred

+  = might_mention_ip1 initIPRecTc (const True) (const True) pred

+

+mightMentionIP :: (Type -> Bool) -- ^ predicate on the string

+               -> (Type -> Bool) -- ^ predicate on the type

+               -> Class

+               -> [Type] -> Bool

+-- ^ @'mightMentionIP' str_cond ty_cond cls tys@ returns @True@ if:

+mightMentionIP = might_mention_ip initIPRecTc

+might_mention_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool

+might_mention_ip rec_clss str_cond ty_cond cls tys

+  = or [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)

+might_mention_ip1 :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool

+might_mention_ip1 rec_clss str_cond ty_cond ty

+  = might_mention_ip rec_clss' str_cond ty_cond cls tys

+The function couldBeIPLike tells if this predicate, or any of its

+So couldBeIPLike checks whether this is an implicit parameter, or has

+  matters in the cases for which couldBeIPLike is used, and it's pretty

+Note [Using typesAreApart when calling mightMentionIP]

+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+We call 'mightMentionIP' in two situations:

+    (ips, non_ips) = partition couldBeIPLike theta

+  , not (couldBeIPLike (ctEvPred ev_w))   -- Not for implicit parameters (#18627)

+       | couldBeIPLike pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork  else KeepInert

+       | otherwise          = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork

+       -- For the couldBeIPLike case see Note [Shadowing of implicit parameters]

+      = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys

+        -- See Note [Using typesAreApart when calling mightMentionIP]

+               mightMentionIP

+    -- per Note [Using typesAreApart when calling mightMentionIP].

+    -- See Note [Using isCallStackTy in mightMentionIP].

+Note [Using isCallStackTy in mightMentionIP]

+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+Note [Using typesAreApart when calling mightMentionIP] we don't want to simply do:

+  mightMentionIP

+  isClassPred, isEqPred, couldBeIPLike, isEqClassPred,

+    captured pred = couldBeIPLike pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)

+{-# OPTIONS_GHC -fspecialise-aggressively #-}

+{-# OPTIONS_GHC -fno-spec-constr #-}

+module Main(main) where

+

+import SpecTyFam_Import (specMe, MaybeShowNum)

+import GHC.Exts

+

+-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime.

+

+{-# NOINLINE foo #-}

+foo :: Int -> (String,Int)

+-- We want specMe to be specialized, but not inlined

+foo x = specMe True x

+

+main = print $ sum $ map (snd . foo) [1..1000 :: Int]

+500500

+{-# LANGUAGE TypeFamilies #-}

+{-# LANGUAGE BangPatterns #-}

+

+module SpecTyFam_Import (specMe, MaybeShowNum) where

+

+import Data.Kind

+

+type family MaybeShowNum a n :: Constraint where

+  MaybeShowNum a n = (Show a, Num n)

+

+{-# INLINABLE specMe #-}

+specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n)

+specMe s !n = (show s, n+1 `div` 2)

+

+# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats

+# See also #19747

+test('SpecTyFamRun', [ grep_errmsg(r'foo')

+                    , extra_files(['SpecTyFam_Import.hs'])

+                    , only_ways(['optasm'])

+                    , collect_stats('bytes allocated', 5)],

+     multimod_compile_and_run,

+     ['SpecTyFamRun', '-O2'])

+{-# OPTIONS_GHC -fspecialise-aggressively #-}

+{-# OPTIONS_GHC -fno-spec-constr #-}

+

+module T26051(main, foo) where

+

+import T26051_Import (specMe, MaybeShowNum)

+import GHC.Exts

+

+-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime.

+

+{-# OPAQUE foo #-}

+foo :: Int -> (String,Int)

+foo x = specMe True x

+

+main = print $ sum $ map (snd . foo) [1..1000 :: Int]

+[1 of 2] Compiling T26051_Import    ( T26051_Import.hs, T26051_Import.o )

+

+==================== Specialise ====================

+Result size of Specialise = {terms: 31, types: 39, coercions: 8, joins: 0/1}

+

+-- RHS size: {terms: 30, types: 27, coercions: 8, joins: 0/1}

+specMe [InlPrag=INLINABLE] :: forall n a. (Integral n, MaybeShowNum a n) => a -> n -> (String, n)

+[LclIdX,

+ Arity=4,

+ Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 0 0 20] 260 10

+         Tmpl= \ (@n) (@a) ($dIntegral [Occ=Once1] :: Integral n) (irred :: MaybeShowNum a n) (eta [Occ=Once1] :: a) (eta [Occ=Once1] :: n) ->

+                 let {

+                   $dNum :: Num n

+                   [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}]

+                   $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (T26051_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in

+                 case eta of n [Occ=Once1] { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (T26051_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }}]

+specMe

+  = \ (@n) (@a) ($dIntegral :: Integral n) (irred :: MaybeShowNum a n) (eta :: a) (eta :: n) ->

+      let {

+        $dNum :: Num n

+        [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}]

+        $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (T26051_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in

+      case eta of n { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (T26051_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }

+

+

+

+[2 of 2] Compiling T26051           ( T26051.hs, T26051.o )

+

+==================== Specialise ====================

+Result size of Specialise = {terms: 84, types: 86, coercions: 13, joins: 0/1}

+

+Rec {

+-- RHS size: {terms: 3, types: 4, coercions: 0, joins: 0/0}

+$dCTuple2 :: (Show Bool, Num Int)

+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]

+$dCTuple2 = (GHC.Internal.Show.$fShowBool, GHC.Internal.Num.$fNumInt)

+

+-- RHS size: {terms: 19, types: 9, coercions: 0, joins: 0/1}

+$s$wspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (# String, Int #)

+[LclId, Arity=2]

+$s$wspecMe

+  = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) ->

+      let {

+        $dNum :: Num Int

+        [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]

+        $dNum = GHC.Internal.Num.$fNumInt } in

+      case eta1 of n1 [Occ=Once1] { __DEFAULT -> (# GHC.Internal.Show.$fShowBool_$cshow eta, GHC.Internal.Num.$fNumInt_$c+ n1 (GHC.Internal.Real.$fIntegralInt_$cdiv (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 1#)) (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 2#))) #) }

+

+-- RHS size: {terms: 12, types: 13, coercions: 5, joins: 0/0}

+$sspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (String, Int)

+[LclId,

+ Arity=2,

+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)

+         Tmpl= \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case T26051_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (T26051_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }}]

+$sspecMe = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case T26051_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (T26051_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }

+end Rec }

+

+-- RHS size: {terms: 6, types: 3, coercions: 5, joins: 0/0}

+foo [InlPrag=OPAQUE] :: Int -> (String, Int)

+[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 50 0}]

+foo = \ (x :: Int) -> specMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (T26051_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) GHC.Internal.Types.True x

+

+-- RHS size: {terms: 37, types: 26, coercions: 0, joins: 0/0}

+main :: State# RealWorld -> (# State# RealWorld, () #)

+[LclId, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 301 0}]

+main = \ (eta [OS=OneShot] :: State# RealWorld) -> GHC.Internal.IO.Handle.Text.hPutStr2 GHC.Internal.IO.StdHandles.stdout (case GHC.Internal.Enum.eftIntFB @(Int -> Int) (GHC.Internal.Base.mapFB @Int @(Int -> Int) @Int (\ (ds :: Int) (ds1 [OS=OneShot] :: Int -> Int) (v [OS=OneShot] :: Int) -> case v of { I# ipv -> ds1 (case ds of { I# y -> GHC.Internal.Types.I# (+# ipv y) }) }) (\ (x :: Int) -> case foo x of { (_ [Occ=Dead], y) -> y })) (breakpoint @Int) 1# 1000# (GHC.Internal.Types.I# 0#) of { I# n -> GHC.Internal.Show.itos n (GHC.Internal.Types.[] @Char) }) GHC.Internal.Types.True eta

+

+-- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0}

+main :: IO ()

+[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]

+main = main `cast` (Sym (GHC.Internal.Types.N:IO <()>_R) :: (State# RealWorld -> (# State# RealWorld, () #)) ~R# IO ())

+

+

+------ Local rules for imported ids --------

+"SPEC/T26051 $wspecMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). T26051_Import.$wspecMe @Int @Bool $dIntegral irred = $s$wspecMe

+"SPEC/T26051 specMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). specMe @Int @Bool $dIntegral irred = $sspecMe

+

+

+{-# LANGUAGE TypeFamilies #-}

+{-# LANGUAGE BangPatterns #-}

+{-# LANGUAGE ImplicitParams #-}

+

+module T26051_Import (specMe, MaybeShowNum) where

+

+import Data.Kind

+

+type family MaybeShowNum a n :: Constraint where

+  MaybeShowNum a n = (Show a, Num n)

+

+{-# INLINABLE specMe #-}

+specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n)

+specMe s !n = (show s, n+1 `div` 2)

+# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats

+test('T26051',   [ grep_errmsg(r'\$wspecMe')

+                    , extra_files(['T26051_Import.hs'])

+                    , only_ways(['optasm'])],

+     multimod_compile,

+     ['T26051', '-O2 -ddump-spec -dsuppress-uniques -dno-typeable-binds -dppr-cols=1000'])