[Git][ghc/ghc][wip/T23109] Make newtype instances opaque
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Aug 10 07:09:48 UTC 2023
Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC
Commits:
b9e37522 by Simon Peyton Jones at 2023-08-10T08:09:10+01:00
Make newtype instances opaque
I think this will help with #23109
Wibbles
Allow SelCo for newtype classes
Experimental change
Wibble
Furher wibbles
Further improvments
Further wibbles
esp exprIsConLike
Run classop rule first
Newtype classops are small
needs comments
- - - - -
24 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/TyThing.hs
- testsuite/tests/numeric/should_compile/T15547.stderr
- testsuite/tests/simplCore/should_compile/T17366.stderr
- testsuite/tests/simplCore/should_compile/T17966.stderr
- testsuite/tests/stranal/sigs/T21888.stderr
Changes:
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -45,7 +45,7 @@ module GHC.Core.Coercion (
mkPhantomCo,
mkHoleCo, mkUnivCo, mkSubCo,
mkAxiomInstCo, mkProofIrrelCo,
- downgradeRole, mkAxiomRuleCo,
+ downgradeRole, upgradeRole, mkAxiomRuleCo,
mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,
mkKindCo,
castCoercionKind, castCoercionKind1, castCoercionKind2,
@@ -75,7 +75,7 @@ module GHC.Core.Coercion (
coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo,
mkFunResMCo, mkPiMCos,
- isReflMCo, checkReflexiveMCo,
+ isReflMCo, checkReflexiveMCo, isSubCo_maybe,
-- ** Coercion variables
mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,
@@ -1172,12 +1172,7 @@ mkSelCo_maybe cs co
go _ _ = Nothing
- -- Assertion checking
- bad_call_msg = vcat [ text "Coercion =" <+> ppr co
- , text "LHS ty =" <+> ppr ty1
- , text "RHS ty =" <+> ppr ty2
- , text "cs =" <+> ppr cs
- , text "coercion role =" <+> ppr (coercionRole co) ]
+ ------ Assertion checking only below here ---------
-- good_call checks the typing rules given in Note [SelCo]
good_call SelForAll
@@ -1201,6 +1196,12 @@ mkSelCo_maybe cs co
good_call _ = False
+ bad_call_msg = vcat [ text "Coercion =" <+> ppr co
+ , text "LHS ty =" <+> ppr ty1
+ , text "RHS ty =" <+> ppr ty2
+ , text "cs =" <+> ppr cs
+ , text "coercion role =" <+> ppr (coercionRole co) ]
+
-- | Extract the nth field of a FunCo
getNthFun :: FunSel
-> a -- ^ multiplicity
@@ -1294,6 +1295,10 @@ mkSubCo co@(FunCo { fco_role = Nominal, fco_arg = arg, fco_res = res })
mkSubCo co = assertPpr (coercionRole co == Nominal) (ppr co <+> ppr (coercionRole co)) $
SubCo co
+isSubCo_maybe :: Coercion -> Maybe Coercion
+isSubCo_maybe (SubCo co) = Just co
+isSubCo_maybe _ = Nothing
+
-- | Changes a role, but only a downgrade. See Note [Role twiddling functions]
downgradeRole_maybe :: Role -- ^ desired role
-> Role -- ^ current role
@@ -1321,6 +1326,10 @@ downgradeRole r1 r2 co
Just co' -> co'
Nothing -> pprPanic "downgradeRole" (ppr co)
+upgradeRole :: Coercion -> Coercion
+upgradeRole (SubCo co) = co
+upgradeRole co = co
+
mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion
mkAxiomRuleCo = AxiomRuleCo
@@ -1939,16 +1948,16 @@ type LiftCoEnv = VarEnv Coercion
-- Also maps coercion variables to ProofIrrelCos.
-- like liftCoSubstWith, but allows for existentially-bound types as well
-liftCoSubstWithEx :: Role -- desired role for output coercion
- -> [TyVar] -- universally quantified tyvars
+liftCoSubstWithEx :: [TyVar] -- universally quantified tyvars
-> [Coercion] -- coercions to substitute for those
-> [TyCoVar] -- existentially quantified tycovars
-> [Type] -- types and coercions to be bound to ex vars
- -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args)
-liftCoSubstWithEx role univs omegas exs rhos
+ -> (Type -> CoercionR, [Type]) -- (lifting function, converted ex args)
+ -- Returned coercion has Representational role
+liftCoSubstWithEx univs omegas exs rhos
= let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas)
psi = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos)
- in (ty_co_subst psi role, substTys (lcSubstRight psi) (mkTyCoVarTys exs))
+ in (ty_co_subst psi Representational, substTys (lcSubstRight psi) (mkTyCoVarTys exs))
liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion
liftCoSubstWith r tvs cos ty
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -2498,8 +2498,11 @@ lintCoercion the_co@(SelCo cs co)
; return (SelCo cs co') }
| otherwise
- -> failWithL (hang (text "Bad SelCo:")
- 2 (ppr the_co $$ ppr s $$ ppr t)) }
+ -> failWithL $ hang (text "Bad SelCo:") 2 $
+ vcat [ text "the_co:" <+> ppr the_co
+ , text "lhs type:" <+> ppr s
+ , text "rhs type:" <+> ppr t
+ , text "role:" <+> ppr co_role ] }
lintCoercion the_co@(LRCo lr co)
= do { co' <- lintCoercion co
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -52,7 +52,7 @@ import GHC.Core
import GHC.Core.FVs
import GHC.Core.Utils
import GHC.Core.DataCon
-import GHC.Core.TyCon ( tyConArity )
+import GHC.Core.TyCon ( TyCon, tyConArity, isInjectiveTyCon )
import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc )
import GHC.Core.Predicate ( isDictTy, isEvVar, isCallStackPredTy )
import GHC.Core.Multiplicity
@@ -2946,14 +2946,14 @@ pushCoercionIntoLambda in_scope x e co
| otherwise
= Nothing
-pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion
+pushCoDataCon :: DataCon -> [CoreExpr] -> CoercionR
-> Maybe (DataCon
, [Type] -- Universal type args
, [CoreExpr]) -- All other args incl existentials
-- Implement the KPush reduction rule as described in "Down with kinds"
-- The transformation applies iff we have
-- (C e1 ... en) `cast` co
--- where co :: (T t1 .. tn) ~ to_ty
+-- where co :: (T t1 .. tn) ~ (T s1 .. sn)
-- The left-hand one must be a T, because exprIsConApp returned True
-- but the right-hand one might not be. (Though it usually will.)
pushCoDataCon dc dc_args co
@@ -2968,39 +2968,17 @@ pushCoDataCon dc dc_args co
-- where S is a type function. In fact, exprIsConApp
-- will probably not be called in such circumstances,
-- but there's nothing wrong with it
-
- = let
- tc_arity = tyConArity to_tc
- dc_univ_tyvars = dataConUnivTyVars dc
- dc_ex_tcvars = dataConExTyCoVars dc
- arg_tys = dataConRepArgTys dc
-
- non_univ_args = dropList dc_univ_tyvars dc_args
- (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args
-
- -- Make the "Psi" from the paper
- omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc)
- (psi_subst, to_ex_arg_tys)
- = liftCoSubstWithEx Representational
- dc_univ_tyvars
- omegas
- dc_ex_tcvars
- (map exprToType ex_args)
-
- -- Cast the value arguments (which include dictionaries)
- new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args
- cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty)
-
- to_ex_args = map Type to_ex_arg_tys
-
- dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars,
- ppr arg_tys, ppr dc_args,
- ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc
- , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ]
- in
- assertPpr (eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args))) dump_doc $
- assertPpr (equalLength val_args arg_tys) dump_doc $
- Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)
+ = case isSubCo_maybe co of
+ Just co' -> Just (push_data_con to_tc to_tc_arg_tys dc dc_args co' Nominal)
+ _ | isInjectiveTyCon to_tc Representational
+ -> Just (push_data_con to_tc to_tc_arg_tys dc dc_args co Representational)
+ | otherwise
+ -> pprTrace "Yikes"
+ (vcat [ text "Scrut:" <+> ppr dc -- <+> ppr dc_args
+ , text "Co:" <+> ppr co
+-- , text "of type:" <+> ppr (coercionType co)
+ , text "role:" <+> ppr (coercionRole co) ])
+ Nothing
| otherwise
= Nothing
@@ -3008,6 +2986,46 @@ pushCoDataCon dc dc_args co
where
Pair from_ty to_ty = coercionKind co
+push_data_con :: TyCon -> [Type] -> DataCon -> [CoreExpr]
+ -> Coercion -> Role -- Coercion and its role
+ -> (DataCon, [Type], [CoreExpr])
+push_data_con to_tc to_tc_arg_tys dc dc_args co role
+ = assertPpr (eqType from_ty dc_app_ty) dump_doc $
+ assertPpr (equalLength val_args arg_tys) dump_doc $
+ assertPpr (role == coercionRole co) dump_doc $
+ assertPpr (isInjectiveTyCon to_tc role) dump_doc $
+ (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)
+ where
+ Pair from_ty to_ty = coercionKind co
+ tc_arity = tyConArity to_tc
+ dc_univ_tyvars = dataConUnivTyVars dc
+ dc_ex_tcvars = dataConExTyCoVars dc
+ arg_tys = dataConRepArgTys dc
+
+ dc_app_ty = mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)
+
+ non_univ_args = dropList dc_univ_tyvars dc_args
+ (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args
+
+ -- Make the "Psi" from the paper
+ omegas = decomposeCo tc_arity co (tyConRolesX role to_tc)
+ (psi_subst, to_ex_arg_tys)
+ = liftCoSubstWithEx dc_univ_tyvars
+ omegas
+ dc_ex_tcvars
+ (map exprToType ex_args)
+
+ -- Cast the value arguments (which include dictionaries)
+ new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args
+ cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty)
+
+ to_ex_args = map Type to_ex_arg_tys
+
+ dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars
+ , ppr arg_tys, ppr dc_args
+ , ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc
+ , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ]
+
collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)
-- Collect lambda binders, pushing coercions inside if possible
-- E.g. (\x.e) |> g g :: <Int> -> blah
@@ -3063,7 +3081,33 @@ collectBindersPushingCo e
| otherwise = (reverse bs, mkCast (Lam b e) co)
-{-
+{- Note [pushCoDataCon for newtypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ newtype N a = MkN (Maybe a)
+and the expression
+ MkN @Int e |> co
+where
+ d :: Maybe Int
+ co :: N Int ~R# N T is a coercion
+
+Then can we use pushCoDataCon to transform this to
+ MkInt @T (e |> Maybe co')
+where
+ (co' : Int ~R# T) = SelCo (SelTc 0 R) co
+
+Well, no. Look at Note [SelCo] in GHC.Core.TyCo.Rep, and especially
+Note [SelCo and newtypes]. We can't use SelCo on a representational
+coercion for a newtype -- it is not injective.
+
+But what if it happens that co = Sub co2 where
+ co2 : N Int ~N# N T
+Well, now we *can* use co2 to give
+ MkInt @T (e |> Maybe (Sub co'))
+where
+ (co' : Int ~N# T) = SelCo (SelTc 0 N) co2
+
+This is a rather common case.
Note [collectBindersPushingCo]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -12,13 +12,13 @@ module GHC.Core.Opt.Simplify.Env (
smPedanticBottoms, smPlatform,
-- * Environments
- SimplEnv(..), pprSimplEnv, -- Temp not abstract
+ SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract
seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle,
seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames,
seOptCoercionOpts, sePedanticBottoms, sePhase, sePlatform, sePreInline,
seRuleOpts, seRules, seUnfoldingOpts,
mkSimplEnv, extendIdSubst,
- extendTvSubst, extendCvSubst,
+ extendTvSubst, extendCvSubst, extendSubstForDFun,
zapSubstEnv, setSubstEnv, bumpCaseDepth,
getInScope, setInScopeFromE, setInScopeFromF,
setInScopeSet, modifyInScope, addNewInScopeIds,
@@ -153,6 +153,8 @@ following table:
-}
+type StaticEnv = SimplEnv -- Just the static part is relevant
+
data SimplEnv
= SimplEnv {
----------- Static part of the environment -----------
@@ -379,7 +381,6 @@ data SimplSR
-- and ja = Just a <=> x is a join-point of arity a
-- See Note [Join arity in SimplIdSubst]
-
| DoneId OutId
-- If x :-> DoneId v is in the SimplIdSubst
-- then replace occurrences of x by v
@@ -547,6 +548,20 @@ extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co
= assert (isCoVar var) $
env {seCvSubst = extendVarEnv csubst var co}
+extendSubstForDFun :: SimplEnv -> [OutVar] -> [(InExpr,StaticEnv)] -> SimplEnv
+extendSubstForDFun env bndrs args
+ = foldl2 extend env bndrs args
+ where
+ extend env@(SimplEnv {seIdSubst = ids, seCvSubst = cvs, seTvSubst = tvs})
+ bndr (arg,arg_se)
+ | isTyVar bndr, Type ty <- arg
+ = env { seTvSubst = extendVarEnv tvs bndr (substTy arg_se ty) }
+ | isCoVar bndr, Coercion co <- arg
+ = env { seCvSubst = extendVarEnv cvs bndr (substCo arg_se co) }
+ | otherwise
+ = assertPpr (isId bndr) (ppr bndr) $
+ env { seIdSubst = extendVarEnv ids bndr (mkContEx arg_se arg) }
+
---------------------
getInScope :: SimplEnv -> InScopeSet
getInScope env = seInScope env
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -18,6 +18,7 @@ import GHC.Platform
import GHC.Driver.Flags
import GHC.Core
+import GHC.Core.Class( Class, classArity )
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Opt.ConstantFold
import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )
@@ -66,6 +67,7 @@ import GHC.Builtin.Names( runRWKey )
import GHC.Data.Maybe ( isNothing, orElse, mapMaybe )
import GHC.Data.FastString
+import GHC.Data.List.SetOps( getNth )
import GHC.Unit.Module ( moduleName )
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -2144,25 +2146,65 @@ simplIdF env var cont
where
env' = setSubstEnv env tvs cvs ids
- DoneId var1 ->
- do { rule_base <- getSimplRules
- ; let cont' = trimJoinCont var1 (idJoinPointHood var1) cont
- info = mkArgInfo env rule_base var1 cont'
- ; rebuildCall env info cont' }
+ DoneId var1 -> simplCall env var1 cont'
+ where
+ cont' = trimJoinCont var1 (idJoinPointHood var1) cont
DoneEx e mb_join -> simplExprF env' e cont'
where
cont' = trimJoinCont var mb_join cont
env' = zapSubstEnv env -- See Note [zapSubstEnv]
+simplCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)
+simplCall env var cont
+ | ClassOpId clas idx _ <- idDetails var
+ , Just (env', arg', cont') <- classOpDictApp_maybe env clas idx cont
+ = simplExprF env' arg' cont'
+
+ | otherwise
+ = do { rule_base <- getSimplRules
+ ; let info = mkArgInfo env rule_base var cont
+ ; rebuildCall env info cont }
+
+classOpDictApp_maybe :: SimplEnv -> Class -> Int -> SimplCont
+ -> Maybe (SimplEnv, InExpr, SimplCont)
+classOpDictApp_maybe env cls idx cont
+ = go cont
+ where
+ go (ApplyToTy { sc_cont = cont })
+ = go cont -- Discard leading type args
+ go (ApplyToVal { sc_arg = dict_arg, sc_env = dict_se, sc_cont = cont })
+ | Just (dfun, dfun_args) <- splitInApp dict_se dict_arg [] -- dfun_args :: [InExpr]
+ , DFunUnfolding { df_bndrs = bndrs, df_args = dict_args } <- idUnfolding dfun
+ , bndrs `equalLength` dfun_args -- See Note [DFun arity check]
+ , let arg_env = extendSubstForDFun (zapSubstEnv env) bndrs dfun_args
+ the_arg = getNth (drop (classArity cls) dict_args) idx -- An OutExpr
+ = Just (arg_env, the_arg, cont)
+ go _ = Nothing
+
+ splitInApp :: StaticEnv -> InExpr -> [(InExpr,StaticEnv)]
+ -> Maybe (OutVar, [(InExpr,StaticEnv)])
+ splitInApp env (App fun arg) args
+ = splitInApp env fun ((arg,env):args)
+ splitInApp env (Var v) args
+ = case substId env v of
+ DoneId v' -> Just (v', args)
+ ContEx tvs cvs ids e -> splitInApp (setSubstEnv env tvs cvs ids) e args
+ DoneEx e _ -> splitInApp (zapSubstEnv env) e args
+ splitInApp _ _ _
+ = Nothing
+
---------------------------------------------------------
-- Dealing with a call site
-rebuildCall :: SimplEnv -> ArgInfo -> SimplCont
+rebuildCall, rebuildCall' :: SimplEnv -> ArgInfo -> SimplCont
-> SimplM (SimplFloats, OutExpr)
---------- Bottoming applications --------------
-rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont
+rebuildCall env ai cont
+ = rebuildCall' env ai cont
+
+rebuildCall' env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont
-- When we run out of strictness args, it means
-- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo
-- Then we want to discard the entire strict continuation. E.g.
@@ -2189,7 +2231,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) con
-- If there are rewrite rules we'll skip this case until we have
-- simplified enough args to satisfy nr_wanted==0 in the TryRules case below
-- Then we'll try the rules, and if that fails, we'll do TryInlining
-rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
+rebuildCall' env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
, ai_rewrite = TryInlining }) cont
= do { logger <- getLogger
; let full_cont = pushSimplifiedRevArgs env rev_args cont
@@ -2204,7 +2246,7 @@ rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
---------- Try rewrite RULES, if ai_rewrite = TryRules --------------
-- See Note [Rewrite rules and inlining]
-- See also Note [Trying rewrite rules]
-rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
+rebuildCall' env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
, ai_rewrite = TryRules nr_wanted rules }) cont
| nr_wanted == 0 || no_more_args
= -- We've accumulated a simplified call in <fun,rev_args>
@@ -2224,10 +2266,10 @@ rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
_ -> True
---------- Simplify type applications and casts --------------
-rebuildCall env info (CastIt co cont)
+rebuildCall' env info (CastIt co cont)
= rebuildCall env (addCastTo info co) cont
-rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })
+rebuildCall' env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })
= rebuildCall env (addTyArgTo info arg_ty hole_ty) cont
---------- The runRW# rule. Do this after absorbing all arguments ------
@@ -2235,7 +2277,7 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_c
--
-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o
-- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ])
-rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
+rebuildCall' env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_cont = cont, sc_hole_ty = fun_ty })
| fun_id `hasKey` runRWKey
@@ -2269,7 +2311,7 @@ rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
; return (emptyFloats env, call') }
---------- Simplify value arguments --------------------
-rebuildCall env fun_info
+rebuildCall' env fun_info
(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_dup = dup_flag, sc_hole_ty = fun_ty
, sc_cont = cont })
@@ -2297,7 +2339,7 @@ rebuildCall env fun_info
; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont }
---------- No further useful info, revert to generic rebuild ------------
-rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
+rebuildCall' env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
= rebuild env (argInfoExpr fun rev_args) cont
-----------------------------------
@@ -2385,7 +2427,7 @@ The simplifier arranges to do this, as follows. In effect, the ai_rewrite
field of the ArgInfo record is the state of a little state-machine:
* mkArgInfo sets the ai_rewrite field to TryRules if there are any rewrite
- rules avaialable for that function.
+ rules available for that function.
* rebuildCall simplifies arguments until enough are simplified to match the
rule with greatest arity. See Note [RULES apply to simplified arguments]
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -212,8 +212,6 @@ data SimplCont
CoreTickish -- Tick tickish <hole>
SimplCont
-type StaticEnv = SimplEnv -- Just the static part is relevant
-
data FromWhat = FromLet | FromBeta OutType
-- See Note [DupFlag invariants]
@@ -732,7 +730,6 @@ which it is on the LHS of a rule (see updModeForRules), then don't
make use of the strictness info for the function.
-}
-
{-
************************************************************************
* *
@@ -1405,6 +1402,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
| isExitJoinId bndr = Nothing -- Note [Do not inline exit join points]
-- in module Exitify
| not (one_occ (idOccInfo bndr)) = Nothing
+ | isDFunId bndr = Nothing
| not (isStableUnfolding unf) = Just $! (extend_subst_with rhs)
-- See Note [Stable unfoldings and preInlineUnconditionally]
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -1335,7 +1335,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
-- and that is the business of callSiteInline.
-- In practice, without this test, most of the "hits" were
-- CPR'd workers getting inlined back into their wrappers,
- | idArity fun == 0
+ | isConLikeUnfolding unfolding
, Just rhs <- expandUnfolding_maybe unfolding
, let in_scope' = extend_in_scope (exprFreeVars rhs)
= go (Left in_scope') floats rhs cont
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -968,7 +968,7 @@ instance Outputable Coercion where
ppr = pprCo
instance Outputable CoSel where
- ppr (SelTyCon n _r) = text "Tc" <> parens (int n)
+ ppr (SelTyCon n r) = text "Tc" <> parens (int n <> comma <> ppr r)
ppr SelForAll = text "All"
ppr (SelFun fs) = text "Fun" <> parens (ppr fs)
@@ -1075,26 +1075,28 @@ The Coercion form SelCo allows us to decompose a structural coercion, one
between ForallTys, or TyConApps, or FunTys.
There are three forms, split by the CoSel field inside the SelCo:
-SelTyCon, SelForAll, and SelFun.
+SelTyCon, SelForAll, and SelFun. The typing rules below are directly
+checked by the SelCo case of GHC.Core.Lint.lintCoercion.
* SelTyCon:
- co : (T s1..sn) ~r0 (T t1..tn)
- T is a data type, not a newtype, nor an arrow type
- r = tyConRole tc r0 i
+ co : (T s1..sn) ~r (T t1..tn)
+ T is not a saturated FunTyCon (use SelFun for that)
+ T is injective at role r
+ ri = tyConRole tc r i
i < n (i is zero-indexed)
----------------------------------
- SelCo (SelTyCon i r) : si ~r ti
+ SelCo (SelTyCon i ri) co : si ~ri ti
- "Not a newtype": see Note [SelCo and newtypes]
- "Not an arrow type": see SelFun below
+ "Injective at role r": see Note [SelCo and newtypes]
+ "Not saturated FunTyCon": see SelFun below
See Note [SelCo Cached Roles]
* SelForAll:
co : forall (a:k1).t1 ~r0 forall (a:k2).t2
----------------------------------
- SelCo SelForAll : k1 ~N k2
+ SelCo SelForAll co : k1 ~N k2
NB: SelForAll always gives a Nominal coercion.
@@ -1104,17 +1106,17 @@ SelTyCon, SelForAll, and SelFun.
co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2)
r = funRole r0 SelMult
----------------------------------
- SelCo (SelFun SelMult) : m1 ~r m2
+ SelCo (SelFun SelMult) co : m1 ~r m2
co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2)
r = funRole r0 SelArg
----------------------------------
- SelCo (SelFun SelArg) : s1 ~r s2
+ SelCo (SelFun SelArg) co : s1 ~r s2
co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2)
r = funRole r0 SelRes
----------------------------------
- SelCo (SelFun SelRes) : t1 ~r t2
+ SelCo (SelFun SelRes) co : t1 ~r t2
Note [FunCo]
~~~~~~~~~~~~
@@ -1452,6 +1454,10 @@ SelCo, we'll get out a representational coercion. That is:
Yikes! Clearly, this is terrible. The solution is simple: forbid
SelCo to be used on newtypes if the internal coercion is representational.
+More specifically, we use isInjectiveTyCon to determine whether
+T is injective at role r:
+* Newtypes and datatypes are both injective at Nominal role, but
+* Newtypes are not injective at Representational role
See the SelCo equation for GHC.Core.Lint.lintCoercion.
This is not just some corner case discovered by a segfault somewhere;
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -68,7 +68,7 @@ module GHC.Core.TyCon(
isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe,
tyConInjectivityInfo,
isBuiltInSynFamTyCon_maybe,
- isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs,
+ isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon,
isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe,
isImplicitTyCon,
isTyConWithSrcDataCons,
@@ -1988,23 +1988,39 @@ isTypeDataTyCon (TyCon { tyConDetails = details })
-- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Equality"
isInjectiveTyCon :: TyCon -> Role -> Bool
isInjectiveTyCon (TyCon { tyConDetails = details }) role
- = go details role
+ = go details
where
- go _ Phantom = True -- Vacuously; (t1 ~P t2) holds for all t1, t2!
- go (AlgTyCon {}) Nominal = True
- go (AlgTyCon {algTcRhs = rhs}) Representational = isGenInjAlgRhs rhs
- go (SynonymTyCon {}) _ = False
- go (FamilyTyCon { famTcFlav = DataFamilyTyCon _ })
- Nominal = True
- go (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj
- go (FamilyTyCon {}) _ = False
- go (PrimTyCon {}) _ = True
- go (PromotedDataCon {}) _ = True
- go (TcTyCon {}) _ = True
+ go _ | Phantom <- role = True -- Vacuously; (t1 ~P t2) holds for all t1, t2!
+
+ go (AlgTyCon {algTcRhs = rhs, algTcFlavour = flav})
+ | Nominal <- role = True
+ | Representational <- role = go_alg_rep rhs flav
- -- Reply True for TcTyCon to minimise knock on type errors
- -- See (W1) in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl
+ go (FamilyTyCon { famTcFlav = DataFamilyTyCon _ })
+ | Nominal <- role = True
+ go (FamilyTyCon { famTcInj = Injective inj })
+ | Nominal <- role = and inj
+ go (FamilyTyCon {}) = False
+ go (SynonymTyCon {}) = False
+ go (PrimTyCon {}) = True
+ go (PromotedDataCon {}) = True
+ go (TcTyCon {}) = True
+ -- Reply True for TcTyCon to minimise knock on type errors
+ -- See (W1) in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl
+
+ -- go_alg_rep used only at Representational role
+ go_alg_rep (TupleTyCon {}) _ = True
+ go_alg_rep (SumTyCon {}) _ = True
+ go_alg_rep (DataTyCon {}) _ = True
+ go_alg_rep (AbstractTyCon {}) _ = False
+ go_alg_rep (NewTyCon {}) (ClassTyCon {}) = True -- See Note [Newtype classes]
+ go_alg_rep (NewTyCon {}) _ = False
+
+{- Note [Newtype classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+ToDo: write this up
+-}
-- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds
-- (where r is the role passed in):
@@ -2024,14 +2040,6 @@ isGenerativeTyCon tc@(TyCon { tyConDetails = details }) role
-- In all other cases, injectivity implies generativity
go r _ = isInjectiveTyCon tc r
--- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective
--- with respect to representational equality?
-isGenInjAlgRhs :: AlgTyConRhs -> Bool
-isGenInjAlgRhs (TupleTyCon {}) = True
-isGenInjAlgRhs (SumTyCon {}) = True
-isGenInjAlgRhs (DataTyCon {}) = True
-isGenInjAlgRhs (AbstractTyCon {}) = False
-isGenInjAlgRhs (NewTyCon {}) = False
-- | Is this 'TyCon' that for a @newtype@
isNewTyCon :: TyCon -> Bool
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -39,20 +39,26 @@ import GHC.Prelude
import GHC.Core
import GHC.Core.Utils
-import GHC.Types.Id
import GHC.Core.DataCon
+import GHC.Core.Class( Class, classTyCon )
+import GHC.Core.TyCon( isNewTyCon )
+import GHC.Core.Type
+
+import GHC.Types.Id
import GHC.Types.Literal
-import GHC.Builtin.PrimOps
import GHC.Types.Id.Info
import GHC.Types.RepType ( isZeroBitTy )
import GHC.Types.Basic ( Arity, RecFlag )
-import GHC.Core.Type
+import GHC.Types.Tickish
+import GHC.Types.ForeignCall
+
+import GHC.Builtin.PrimOps
import GHC.Builtin.Names
+
import GHC.Data.Bag
+
import GHC.Utils.Misc
import GHC.Utils.Outputable
-import GHC.Types.ForeignCall
-import GHC.Types.Tickish
import qualified Data.ByteString as BS
@@ -578,11 +584,11 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize
size_up_call fun val_args voids
= case idDetails fun of
- FCallId _ -> sizeN (callSize (length val_args) voids)
- DataConWorkId dc -> conSize dc (length val_args)
- PrimOpId op _ -> primOpSize op (length val_args)
- ClassOpId {} -> classOpSize opts top_args val_args
- _ -> funSize opts top_args fun (length val_args) voids
+ FCallId _ -> sizeN (callSize (length val_args) voids)
+ DataConWorkId dc -> conSize dc (length val_args)
+ PrimOpId op _ -> primOpSize op (length val_args)
+ ClassOpId cls _ _ -> classOpSize opts cls top_args val_args
+ _ -> funSize opts top_args fun (length val_args) voids
------------
size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10
@@ -647,21 +653,26 @@ litSize _other = 0 -- Must match size of nullary constructors
-- Key point: if x |-> 4, then x must inline unconditionally
-- (eg via case binding)
-classOpSize :: UnfoldingOpts -> [Id] -> [CoreExpr] -> ExprSize
+classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize
-- See Note [Conlike is interesting]
-classOpSize _ _ []
+
+classOpSize _ cls _ _
+ | isNewTyCon (classTyCon cls)
= sizeZero
-classOpSize opts top_args (arg1 : other_args)
- = SizeIs size arg_discount 0
+
+classOpSize opts _ top_args args
+ = case args of
+ [] -> sizeZero
+ (arg1:other_args) -> SizeIs (size other_args) (arg_discount arg1) 0
where
- size = 20 + (10 * length other_args)
+ size other_args = 20 + (10 * length other_args)
+
-- If the class op is scrutinising a lambda bound dictionary then
-- give it a discount, to encourage the inlining of this function
-- The actual discount is rather arbitrarily chosen
- arg_discount = case arg1 of
- Var dict | dict `elem` top_args
- -> unitBag (dict, unfoldingDictDiscount opts)
- _other -> emptyBag
+ arg_discount (Var dict) | dict `elem` top_args
+ = unitBag (dict, unfoldingDictDiscount opts)
+ arg_discount _ = emptyBag
-- | The size of a function call
callSize
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -1652,7 +1652,7 @@ app_ok fun_ok primop_ok fun args
-- See #20749 and Note [How untagged pointers can
-- end up in strict fields] in GHC.Stg.InferTags
- ClassOpId _ is_terminating_result
+ ClassOpId _ _ is_terminating_result
| is_terminating_result -- See Note [exprOkForSpeculation and type classes]
-> assertPpr (n_val_args == 1) (ppr fun $$ ppr args) $
True
@@ -1927,7 +1927,22 @@ exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding
-- data constructors. Conlike arguments are considered interesting by the
-- inliner.
exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP
-exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding
+-- exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding
+-- Trying: just a constructor application
+exprIsConLike (Var v) = isConLikeId v
+exprIsConLike (Lit l) = not (isLitRubbish l)
+exprIsConLike (App f a) = exprIsTrivial a && exprIsConLike f
+exprIsConLike (Lam b e)
+ | isRuntimeVar b = False
+ | otherwise = exprIsConLike e
+exprIsConLike (Tick t e)
+ | tickishCounts t = False
+ | otherwise = exprIsConLike e
+exprIsConLike (Cast e _) = exprIsConLike e
+exprIsConLike (Let {}) = False
+exprIsConLike (Case {}) = False
+exprIsConLike (Type {}) = False
+exprIsConLike (Coercion {}) = False
-- | Returns true for values or value-like expressions. These are lambdas,
-- constructors / CONLIKE functions (as determined by the function argument)
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -2070,8 +2070,8 @@ reifyThing (AGlobal (AnId id))
= do { ty <- reifyType (idType id)
; let v = reifyName id
; case idDetails id of
- ClassOpId cls _ -> return (TH.ClassOpI v ty (reifyName cls))
- _ -> return (TH.VarI v ty Nothing)
+ ClassOpId cls _ _ -> return (TH.ClassOpI v ty (reifyName cls))
+ _ -> return (TH.VarI v ty Nothing)
}
reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -30,12 +30,15 @@ import GHC.Builtin.Types.Prim
import GHC.Builtin.Names
import GHC.Types.FieldLabel
-import GHC.Types.Name.Reader
import GHC.Types.SafeHaskell
-import GHC.Types.Name ( Name )
+import GHC.Types.Name ( Name, getOccName )
+import GHC.Types.Name.Reader
+import GHC.Types.Name.Occurrence( occNameString, mkVarOcc )
import GHC.Types.Var.Env ( VarEnv )
import GHC.Types.Id
+import GHC.Types.Id.Info
import GHC.Types.Var
+import GHC.Types.Basic( dfunInlinePragma )
import GHC.Core.Predicate
import GHC.Core.Coercion
@@ -45,8 +48,9 @@ import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams )
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Class
+import GHC.Core.Unfold.Make( mkDFunUnfolding )
-import GHC.Core ( Expr(Var, App, Cast) )
+import GHC.Core ( Expr(..), Bind(..), mkConApp )
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -398,26 +402,42 @@ makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult
-- The process is mirrored for Symbols:
-- String -> SSymbol n
-- SSymbol n -> KnownSymbol n
-makeLitDict clas ty et
- | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]
- -- co_dict :: KnownNat n ~ SNat n
- , [ meth ] <- classMethods clas
- , Just tcRep <- tyConAppTyCon_maybe (classMethodTy meth)
- -- If the method type is forall n. KnownNat n => SNat n
- -- then tcRep is SNat
- , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
- -- SNat n ~ Integer
- , let ev_tm = mkEvCast et (mkSymCo (mkTransCo co_dict co_rep))
- = return $ OneInst { cir_new_theta = []
- , cir_mk_ev = \_ -> ev_tm
- , cir_canonical = True
- , cir_what = BuiltinInstance }
+makeLitDict clas lit_ty lit_expr
+ | [meth] <- classMethods clas
+ , Just rep_tc <- tyConAppTyCon_maybe (classMethodTy meth)
+ -- If the method type is forall n. KnownNat n => SNat n
+ -- then rep_tc :: TyCon is SNat
+ , [dict_con] <- tyConDataCons (classTyCon clas)
+ , [rep_con] <- tyConDataCons rep_tc
+ , let pred_ty = mkClassPred clas [lit_ty]
+ dict_args = [ Type lit_ty, mkConApp rep_con [Type lit_ty, lit_expr] ]
+ dfun_rhs = mkConApp dict_con dict_args
+ dfun_info = vanillaIdInfo `setUnfoldingInfo` mkDFunUnfolding [] dict_con dict_args
+ `setInlinePragInfo` dfunInlinePragma
+ dfun_occ_str :: String
+ = "$f" ++ occNameString (getOccName clas) ++
+ occNameString (getDFunTyKey lit_ty)
+
+ = do { df_name <- newName (mkVarOcc dfun_occ_str)
+ ; let dfun_id = mkLocalVar (DFunId True) df_name ManyTy pred_ty dfun_info
+ ev_tm = EvExpr (Let (NonRec dfun_id dfun_rhs) (Var dfun_id))
+ ; return $ OneInst { cir_new_theta = []
+ , cir_mk_ev = \_ -> ev_tm
+ , cir_coherence = True
+ , cir_what = BuiltinInstance } }
| otherwise
= pprPanic "makeLitDict" $
text "Unexpected evidence for" <+> ppr (className clas)
$$ vcat (map (ppr . idType) (classMethods clas))
+{- Here is what we are making
+ let $dfKnownNat17 :: KnownNat 17
+ [Unfolding = DFun :DKnownNat @17 (UnsafeSNat @17 17)]
+ $dfKnownNat17 = :DKnownNat @17 (UnsafeSNat @17 17)
+ in $dfKnownNat17
+-}
+
{- ********************************************************************
* *
Class lookup for WithDict
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -982,8 +982,8 @@ This is the very /definition/ of injectivity: injectivity means result
is the same => arguments are the same, modulo the role shift.
See comments on GHC.Core.TyCon.isInjectiveTyCon. This is also
the CO_NTH rule in Fig 5 of the paper, except in the paper only
-newtypes are non-injective at representation role, so the rule says "H
-is not a newtype".
+newtypes are non-injective at representation role, so the rule says
+"H is not a newtype".
Injectivity is a bit subtle:
Nominal Representational
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -53,11 +53,12 @@ import GHC.Tc.Utils.Env
import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.Unify
import GHC.Builtin.Names ( unsatisfiableIdName )
-import GHC.Core ( Expr(..), mkApps, mkVarApps, mkLams )
+import GHC.Core ( Expr(..), mkVarApps )
import GHC.Core.Make ( nO_METHOD_BINDING_ERROR_ID )
-import GHC.Core.Unfold.Make ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
+-- import GHC.Core.Unfold.Make ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
+import GHC.Core.Unfold.Make (mkDFunUnfolding )
import GHC.Core.Type
-import GHC.Core.SimpleOpt
+-- import GHC.Core.SimpleOpt
import GHC.Core.Predicate( classMethodInstTy )
import GHC.Tc.Types.Evidence
import GHC.Core.TyCon
@@ -1334,10 +1335,10 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
inst_tv_tys = mkTyVarTys inst_tyvars
arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
- is_newtype = isNewTyCon class_tc
+-- is_newtype = isNewTyCon class_tc
dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids
dfun_spec_prags
- | is_newtype = SpecPrags []
+-- | is_newtype = SpecPrags []
| otherwise = SpecPrags spec_inst_prags
-- Newtype dfuns just inline unconditionally,
-- so don't attempt to specialise them
@@ -1374,15 +1375,15 @@ addDFunPrags :: DFunId -> [Id] -> DFunId
-- the DFunId rather than from the skolem pieces that the typechecker
-- is messing with.
addDFunPrags dfun_id sc_meth_ids
- | is_newtype
- = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity defaultSimpleOpts StableSystemSrc 0 con_app
- `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
- | otherwise
+-- xx | is_newtype
+-- = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity defaultSimpleOpts StableSystemSrc 0 con_app
+-- `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
+-- xx | otherwise
= dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args
`setInlinePragma` dfunInlinePragma
where
- con_app = mkLams dfun_bndrs $
- mkApps (Var (dataConWrapId dict_con)) dict_args
+-- con_app = mkLams dfun_bndrs $
+-- mkApps (Var (dataConWrapId dict_con)) dict_args
-- This application will satisfy the Core invariants
-- from Note [Representation polymorphism invariants] in GHC.Core,
-- because typeclass method types are never unlifted.
@@ -1394,7 +1395,7 @@ addDFunPrags dfun_id sc_meth_ids
dfun_bndrs = dfun_tvs ++ ev_ids
clas_tc = classTyCon clas
dict_con = tyConSingleDataCon clas_tc
- is_newtype = isNewTyCon clas_tc
+-- is_newtype = isNewTyCon clas_tc
wrapId :: HsWrapper -> Id -> HsExpr GhcTc
wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLocA id))
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -2334,20 +2334,25 @@ dmdTransformDataConSig str_marks sd = case viewProd arity body_sd of
-- on the result into the indicated dictionary component (if saturated).
-- See Note [Demand transformer for a dictionary selector].
dmdTransformDictSelSig :: DmdSig -> DmdTransformer
--- NB: This currently doesn't handle newtype dictionaries.
--- It should simply apply call_sd directly to the dictionary, I suppose.
-dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod])) call_sd
+dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* dict_dmd])) call_sd
+ -- NB: dict_dmd comes from the demand signature of the class-op
+ -- which is created in GHC.Types.Id.Make.mkDictSelId
| (n, sd') <- peelCallDmd call_sd
- , Prod _ sig_ds <- prod
= multDmdType n $
- DmdType nopDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)]
- | otherwise
- = nopDmdType -- See Note [Demand transformer for a dictionary selector]
+ DmdType nopDmdEnv [enhance_dict_dmd sd' dict_dmd]
where
- enhance _ AbsDmd = AbsDmd
- enhance _ BotDmd = BotDmd
- enhance sd _dmd_var = C_11 :* sd -- This is the one!
- -- C_11, because we multiply with n above
+ enhance_dict_dmd sd' dict_dmd
+ | Prod _ sig_ds <- dict_dmd
+ = C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)
+
+ | otherwise -- Newtype dictionary
+ = C_11 :* sd' -- Apply sd' to the dictionary
+
+ enhance _ AbsDmd = AbsDmd
+ enhance _ BotDmd = BotDmd
+ enhance sd' _dmd_var = C_11 :* sd' -- This is the one!
+ -- C_11, because we multiply with n above
+
dmdTransformDictSelSig sig sd = pprPanic "dmdTransformDictSelSig: no args" (ppr sig $$ ppr sd)
{-
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -496,8 +496,8 @@ isClassOpId id = case Var.idDetails id of
_other -> False
isClassOpId_maybe id = case Var.idDetails id of
- ClassOpId cls _ -> Just cls
- _other -> Nothing
+ ClassOpId cls _ _ -> Just cls
+ _other -> Nothing
isPrimOpId id = case Var.idDetails id of
PrimOpId {} -> True
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -168,6 +168,7 @@ data IdDetails
| ClassOpId -- ^ The 'Id' is a superclass selector or class operation
Class -- for this class
+ Int -- 0-indexed selector for which class method this is
Bool -- True <=> given a non-bottom dictionary, the class op will
-- definitely return a non-bottom result
-- and Note [exprOkForSpeculation and type classes]
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -474,7 +474,7 @@ mkDictSelId :: Name -- Name of one of the *value* selectors
-- (dictionary superclass or method)
-> Class -> Id
mkDictSelId name clas
- = mkGlobalId (ClassOpId clas terminating) name sel_ty info
+ = mkGlobalId (ClassOpId clas val_index terminating) name sel_ty info
where
tycon = classTyCon clas
sel_names = map idName (classAllSelIds clas)
@@ -500,8 +500,9 @@ mkDictSelId name clas
`setDmdSigInfo` strict_sig
`setCprSigInfo` topCprSig
- info | new_tycon
- = base_info `setInlinePragInfo` alwaysInlinePragma
+ info | new_tycon -- Same as non-new case; ToDo: explain
+ = base_info `setRuleInfo` mkRuleInfo [rule]
+ `setInlinePragInfo` neverInlinePragma
`setUnfoldingInfo` mkInlineUnfoldingWithArity defaultSimpleOpts
StableSystemSrc 1
(mkDictSelRhs clas val_index)
=====================================
compiler/GHC/Types/TyThing.hs
=====================================
@@ -266,7 +266,7 @@ tyThingParent_maybe (AnId id) = case idDetails id of
Just (ATyCon tc)
RecSelId { sel_tycon = RecSelPatSyn ps } ->
Just (AConLike (PatSynCon ps))
- ClassOpId cls _ ->
+ ClassOpId cls _ _ ->
Just (ATyCon (classTyCon cls))
_other -> Nothing
tyThingParent_maybe _other = Nothing
=====================================
testsuite/tests/numeric/should_compile/T15547.stderr
=====================================
@@ -1,29 +1,29 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 36, types: 100, coercions: 56, joins: 0/0}
+ = {terms: 40, types: 122, coercions: 26, joins: 0/0}
nat2Word#
= \ @n $dKnownNat _ ->
- naturalToWord# ($dKnownNat `cast` <Co:5> :: ...)
+ naturalToWord# ((natSing $dKnownNat) `cast` <Co:2> :: ...)
foo = \ _ -> 18##
fd
= \ @n $dKnownNat _ ->
- naturalToWord# ($dKnownNat `cast` <Co:13> :: ...)
+ naturalToWord# ((natSing $dKnownNat) `cast` <Co:6> :: ...)
d = \ _ -> 3##
fm
= \ @n $dKnownNat _ ->
- naturalToWord# ($dKnownNat `cast` <Co:17> :: ...)
+ naturalToWord# ((natSing $dKnownNat) `cast` <Co:8> :: ...)
m = \ _ -> 9##
fp
= \ @n $dKnownNat _ ->
- naturalToWord# ($dKnownNat `cast` <Co:21> :: ...)
+ naturalToWord# ((natSing $dKnownNat) `cast` <Co:10> :: ...)
p = \ _ -> 512##
=====================================
testsuite/tests/simplCore/should_compile/T17366.stderr
=====================================
@@ -1,2 +1,4 @@
+Rule fired: Class op c (BUILTIN)
+Rule fired: Class op c (BUILTIN)
Rule fired: SPEC/T17366 f @Identity @_ (T17366)
Rule fired: SPEC/T17366 f @(Tagged tag) @_ (T17366)
=====================================
testsuite/tests/simplCore/should_compile/T17966.stderr
=====================================
@@ -1,309 +1,298 @@
==================== Specialise ====================
Result size of Specialise
- = {terms: 166, types: 158, coercions: 24, joins: 0/0}
+ = {terms: 162, types: 155, coercions: 10, joins: 0/0}
-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
-$dShow_sRN :: Show (Maybe Integer)
+$dShow_sTQ :: Show (Maybe Integer)
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=True,
- WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}]
-$dShow_sRN = GHC.Show.$fShowMaybe @Integer GHC.Show.$fShowInteger
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=False, ConLike=True, WorkFree=False, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
+$dShow_sTQ = GHC.Show.$fShowMaybe @Integer GHC.Show.$fShowInteger
-Rec {
--- RHS size: {terms: 2, types: 1, coercions: 4, joins: 0/0}
-$dC_sRM :: C Bool ()
-[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 60}]
-$dC_sRM
- = ($cm_aHo @() GHC.Show.$fShow())
- `cast` (Sym (T17966.N:C[0] <Bool>_N <()>_N)
- :: (forall c. Show c => Bool -> () -> c -> String) ~R# C Bool ())
-
--- RHS size: {terms: 30, types: 24, coercions: 0, joins: 0/0}
-$s$cm_sRQ [InlPrag=[0]]
- :: forall {c}. Show c => Bool -> () -> c -> [Char]
-[LclId, Arity=4]
-$s$cm_sRQ
- = \ (@c_aHr)
- ($dShow_aHs :: Show c_aHr)
- (a_aBf :: Bool)
- (b_aBg :: ())
- (c_aBh :: c_aHr) ->
+-- RHS size: {terms: 28, types: 22, coercions: 0, joins: 0/0}
+$s$cm_sTX [InlPrag=INLINABLE[0]]
+ :: Bool -> () -> Maybe Integer -> [Char]
+[LclId, Arity=3]
+$s$cm_sTX
+ = \ (a_aD5 :: Bool) (b_aD6 :: ()) (c_aD7 :: Maybe Integer) ->
GHC.Base.augment
@Char
- (\ (@b_aQg)
- (c_aQh [OS=OneShot] :: Char -> b_aQg -> b_aQg)
- (n_aQi [OS=OneShot] :: b_aQg) ->
+ (\ (@b_aSj)
+ (c_aSk [OS=OneShot] :: Char -> b_aSj -> b_aSj)
+ (n_aSl [OS=OneShot] :: b_aSj) ->
GHC.Base.foldr
@Char
- @b_aQg
- c_aQh
- n_aQi
- (case a_aBf of {
+ @b_aSj
+ c_aSk
+ n_aSl
+ (case a_aD5 of {
False -> GHC.Show.$fShowBool5;
True -> GHC.Show.$fShowBool4
}))
(GHC.Base.augment
@Char
- (\ (@b_aQg)
- (c_aQh [OS=OneShot] :: Char -> b_aQg -> b_aQg)
- (n_aQi [OS=OneShot] :: b_aQg) ->
+ (\ (@b_aSj)
+ (c_aSk [OS=OneShot] :: Char -> b_aSj -> b_aSj)
+ (n_aSl [OS=OneShot] :: b_aSj) ->
GHC.Base.foldr
- @Char @b_aQg c_aQh n_aQi (GHC.Show.$fShow()_$cshow b_aBg))
- (show @c_aHr $dShow_aHs c_aBh))
+ @Char @b_aSj c_aSk n_aSl (GHC.Show.$fShowUnit_$cshow b_aD6))
+ (GHC.Show.$fShowMaybe_$cshow
+ @Integer GHC.Show.$fShowInteger c_aD7))
-- RHS size: {terms: 33, types: 28, coercions: 0, joins: 0/0}
-$cm_aHo [InlPrag=INLINABLE[0]]
+$cm_aJa [InlPrag=INLINABLE[0]]
:: forall b c. (Show b, Show c) => Bool -> b -> c -> String
[LclId,
Arity=5,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=StableUser, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=IF_ARGS [30 30 30 0 0] 140 0
- Tmpl= \ (@b_aHl)
- ($dShow_aHm [Occ=Once1] :: Show b_aHl)
- (@c_aHr)
- ($dShow_aHs [Occ=Once1] :: Show c_aHr)
- (a_aBf [Occ=Once1!] :: Bool)
- (b_aBg [Occ=Once1] :: b_aHl)
- (c_aBh [Occ=Once1] :: c_aHr) ->
+ Tmpl= \ (@b_aJ7)
+ ($dShow_aJ8 [Occ=Once1] :: Show b_aJ7)
+ (@c_aJd)
+ ($dShow_aJe [Occ=Once1] :: Show c_aJd)
+ (a_aD5 [Occ=Once1!] :: Bool)
+ (b_aD6 [Occ=Once1] :: b_aJ7)
+ (c_aD7 [Occ=Once1] :: c_aJd) ->
++
@Char
- (case a_aBf of {
+ (case a_aD5 of {
False -> GHC.Show.$fShowBool5;
True -> GHC.Show.$fShowBool4
})
(++
@Char
- (show @b_aHl $dShow_aHm b_aBg)
- (show @c_aHr $dShow_aHs c_aBh))},
- RULES: "SPEC $cm @()" [0]
- forall ($dShow_sRP :: Show ()). $cm_aHo @() $dShow_sRP = $s$cm_sRQ]
-$cm_aHo
- = \ (@b_aHl)
- ($dShow_aHm :: Show b_aHl)
- (@c_aHr)
- ($dShow_aHs :: Show c_aHr)
- (a_aBf :: Bool)
- (b_aBg :: b_aHl)
- (c_aBh :: c_aHr) ->
+ (show @b_aJ7 $dShow_aJ8 b_aD6)
+ (show @c_aJd $dShow_aJe c_aD7))},
+ RULES: "SPEC $cm @() @(Maybe Integer)" [0]
+ forall ($dShow_sTS :: Show ())
+ ($dShow_sTT :: Show (Maybe Integer)).
+ $cm_aJa @() $dShow_sTS @(Maybe Integer) $dShow_sTT
+ = $s$cm_sTX]
+$cm_aJa
+ = \ (@b_aJ7)
+ ($dShow_aJ8 :: Show b_aJ7)
+ (@c_aJd)
+ ($dShow_aJe :: Show c_aJd)
+ (a_aD5 :: Bool)
+ (b_aD6 :: b_aJ7)
+ (c_aD7 :: c_aJd) ->
GHC.Base.augment
@Char
- (\ (@b_aQg)
- (c_aQh [OS=OneShot] :: Char -> b_aQg -> b_aQg)
- (n_aQi [OS=OneShot] :: b_aQg) ->
+ (\ (@b_aSj)
+ (c_aSk [OS=OneShot] :: Char -> b_aSj -> b_aSj)
+ (n_aSl [OS=OneShot] :: b_aSj) ->
GHC.Base.foldr
@Char
- @b_aQg
- c_aQh
- n_aQi
- (case a_aBf of {
+ @b_aSj
+ c_aSk
+ n_aSl
+ (case a_aD5 of {
False -> GHC.Show.$fShowBool5;
True -> GHC.Show.$fShowBool4
}))
(GHC.Base.augment
@Char
- (\ (@b_aQg)
- (c_aQh [OS=OneShot] :: Char -> b_aQg -> b_aQg)
- (n_aQi [OS=OneShot] :: b_aQg) ->
+ (\ (@b_aSj)
+ (c_aSk [OS=OneShot] :: Char -> b_aSj -> b_aSj)
+ (n_aSl [OS=OneShot] :: b_aSj) ->
GHC.Base.foldr
- @Char @b_aQg c_aQh n_aQi (show @b_aHl $dShow_aHm b_aBg))
- (show @c_aHr $dShow_aHs c_aBh))
-end Rec }
+ @Char @b_aSj c_aSk n_aSl (show @b_aJ7 $dShow_aJ8 b_aD6))
+ (show @c_aJd $dShow_aJe c_aD7))
-- RHS size: {terms: 1, types: 0, coercions: 10, joins: 0/0}
-T17966.$fCBoolb [InlPrag=INLINE (sat-args=0)]
- :: forall b. Show b => C Bool b
+T17966.$fCBoolb [InlPrag=CONLIKE] :: forall b. Show b => C Bool b
[LclIdX[DFunId(nt)],
Arity=5,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
- Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True)
- Tmpl= $cm_aHo
- `cast` (forall (b :: <*>_N).
- <Show b>_R %<'Many>_N ->_R Sym (T17966.N:C[0] <Bool>_N <b>_N)
- :: (forall {b} c. (Show b, Show c) => Bool -> b -> c -> String)
- ~R# (forall {b}. Show b => C Bool b))}]
+ Unf=DFun: \ (@b_anK) (v_B1 :: Show b_anK) ->
+ T17966.C:C TYPE: Bool TYPE: b_anK $cm_aJa @b_anK v_B1]
T17966.$fCBoolb
- = $cm_aHo
+ = $cm_aJa
`cast` (forall (b :: <*>_N).
- <Show b>_R %<'Many>_N ->_R Sym (T17966.N:C[0] <Bool>_N <b>_N)
+ <Show b>_R %<Many>_N ->_R Sym (T17966.N:C[0] <Bool>_N <b>_N)
:: (forall {b} c. (Show b, Show c) => Bool -> b -> c -> String)
~R# (forall {b}. Show b => C Bool b))
--- RHS size: {terms: 18, types: 15, coercions: 3, joins: 0/0}
-$sf_sRO [InlPrag=[0]] :: Bool -> () -> Maybe Integer -> [Char]
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+$dC_sTP :: C Bool ()
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 60}]
+$dC_sTP = T17966.$fCBoolb @() GHC.Show.$fShowUnit
+
+-- RHS size: {terms: 19, types: 16, coercions: 0, joins: 0/0}
+$sf_sTR [InlPrag=INLINABLE[0]]
+ :: Bool -> () -> Maybe Integer -> [Char]
[LclId, Arity=3]
-$sf_sRO
- = \ (a_aBl :: Bool) (b_aBm :: ()) (c_aBn :: Maybe Integer) ->
+$sf_sTR
+ = \ (a_aDe :: Bool) (b_aDf :: ()) (c_aDg :: Maybe Integer) ->
GHC.Base.build
@Char
- (\ (@b_aQz)
- (c_aQA [OS=OneShot] :: Char -> b_aQz -> b_aQz)
- (n_aQB [OS=OneShot] :: b_aQz) ->
+ (\ (@b_aSC)
+ (c_aSD [OS=OneShot] :: Char -> b_aSC -> b_aSC)
+ (n_aSE [OS=OneShot] :: b_aSC) ->
GHC.Base.foldr
@Char
- @b_aQz
- c_aQA
- (GHC.CString.unpackFoldrCString# @b_aQz "!"# c_aQA n_aQB)
- (($dC_sRM
- `cast` (T17966.N:C[0] <Bool>_N <()>_N
- :: C Bool () ~R# (forall c. Show c => Bool -> () -> c -> String)))
- @(Maybe Integer) $dShow_sRN a_aBl b_aBm c_aBn))
+ @b_aSC
+ c_aSD
+ (GHC.CString.unpackFoldrCString# @b_aSC "!"# c_aSD n_aSE)
+ ($cm_aJa
+ @()
+ GHC.Show.$fShowUnit
+ @(Maybe Integer)
+ $dShow_sTQ
+ a_aDe
+ b_aDf
+ c_aDg))
--- RHS size: {terms: 23, types: 21, coercions: 3, joins: 0/0}
+-- RHS size: {terms: 24, types: 23, coercions: 0, joins: 0/0}
f [InlPrag=INLINABLE[0]]
:: forall a b c. (C a b, Show c) => a -> b -> c -> String
[LclIdX,
Arity=5,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 0 0 0 0] 120 0
- Tmpl= \ (@a_aFi)
- (@b_aFj)
- (@c_aFk)
- ($dC_aFl [Occ=Once1] :: C a_aFi b_aFj)
- ($dShow_aFm [Occ=Once1] :: Show c_aFk)
- (a_aBl [Occ=Once1] :: a_aFi)
- (b_aBm [Occ=Once1] :: b_aFj)
- (c_aBn [Occ=Once1] :: c_aFk) ->
+ Unf=Unf{Src=StableUser, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [30 0 0 0 0] 130 0
+ Tmpl= \ (@a_aF9)
+ (@b_aFa)
+ (@c_aFb)
+ ($dC_aFc [Occ=Once1] :: C a_aF9 b_aFa)
+ ($dShow_aFd [Occ=Once1] :: Show c_aFb)
+ (a_aDe [Occ=Once1] :: a_aF9)
+ (b_aDf [Occ=Once1] :: b_aFa)
+ (c_aDg [Occ=Once1] :: c_aFb) ->
++
@Char
- (($dC_aFl
- `cast` (T17966.N:C[0] <a_aFi>_N <b_aFj>_N
- :: C a_aFi b_aFj
- ~R# (forall c. Show c => a_aFi -> b_aFj -> c -> String)))
- @c_aFk $dShow_aFm a_aBl b_aBm c_aBn)
+ (m @a_aF9 @b_aFa $dC_aFc @c_aFb $dShow_aFd a_aDe b_aDf c_aDg)
(GHC.CString.unpackCString# "!"#)},
RULES: "SPEC f @Bool @() @(Maybe Integer)" [0]
- forall ($dC_sRM :: C Bool ()) ($dShow_sRN :: Show (Maybe Integer)).
- f @Bool @() @(Maybe Integer) $dC_sRM $dShow_sRN
- = $sf_sRO]
-f = \ (@a_aFi)
- (@b_aFj)
- (@c_aFk)
- ($dC_aFl :: C a_aFi b_aFj)
- ($dShow_aFm :: Show c_aFk)
- (a_aBl :: a_aFi)
- (b_aBm :: b_aFj)
- (c_aBn :: c_aFk) ->
+ forall ($dC_sTP :: C Bool ()) ($dShow_sTQ :: Show (Maybe Integer)).
+ f @Bool @() @(Maybe Integer) $dC_sTP $dShow_sTQ
+ = $sf_sTR]
+f = \ (@a_aF9)
+ (@b_aFa)
+ (@c_aFb)
+ ($dC_aFc :: C a_aF9 b_aFa)
+ ($dShow_aFd :: Show c_aFb)
+ (a_aDe :: a_aF9)
+ (b_aDf :: b_aFa)
+ (c_aDg :: c_aFb) ->
GHC.Base.build
@Char
- (\ (@b_aQz)
- (c_aQA [OS=OneShot] :: Char -> b_aQz -> b_aQz)
- (n_aQB [OS=OneShot] :: b_aQz) ->
+ (\ (@b_aSC)
+ (c_aSD [OS=OneShot] :: Char -> b_aSC -> b_aSC)
+ (n_aSE [OS=OneShot] :: b_aSC) ->
GHC.Base.foldr
@Char
- @b_aQz
- c_aQA
- (GHC.CString.unpackFoldrCString# @b_aQz "!"# c_aQA n_aQB)
- (($dC_aFl
- `cast` (T17966.N:C[0] <a_aFi>_N <b_aFj>_N
- :: C a_aFi b_aFj
- ~R# (forall c. Show c => a_aFi -> b_aFj -> c -> String)))
- @c_aFk $dShow_aFm a_aBl b_aBm c_aBn))
+ @b_aSC
+ c_aSD
+ (GHC.CString.unpackFoldrCString# @b_aSC "!"# c_aSD n_aSE)
+ (m @a_aF9 @b_aFa $dC_aFc @c_aFb $dShow_aFd a_aDe b_aDf c_aDg))
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-$trModule_sRG :: GHC.Prim.Addr#
+$trModule_sTJ :: GHC.Prim.Addr#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
-$trModule_sRG = "main"#
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
+$trModule_sTJ = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-$trModule_sRH :: GHC.Types.TrName
+$trModule_sTK :: GHC.Types.TrName
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
-$trModule_sRH = GHC.Types.TrNameS $trModule_sRG
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
+$trModule_sTK = GHC.Types.TrNameS $trModule_sTJ
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-$trModule_sRI :: GHC.Prim.Addr#
+$trModule_sTL :: GHC.Prim.Addr#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
-$trModule_sRI = "T17966"#
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
+$trModule_sTL = "T17966"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-$trModule_sRJ :: GHC.Types.TrName
+$trModule_sTM :: GHC.Types.TrName
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
-$trModule_sRJ = GHC.Types.TrNameS $trModule_sRI
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
+$trModule_sTM = GHC.Types.TrNameS $trModule_sTL
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T17966.$trModule :: GHC.Types.Module
[LclIdX,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
-T17966.$trModule = GHC.Types.Module $trModule_sRH $trModule_sRJ
-
--- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
-$krep_aPr [InlPrag=[~]] :: GHC.Types.KindRep
-[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
-$krep_aPr
- = GHC.Types.KindRepTyConApp
- GHC.Types.$tcConstraint (GHC.Types.[] @GHC.Types.KindRep)
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
+T17966.$trModule = GHC.Types.Module $trModule_sTK $trModule_sTM
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep_aPq [InlPrag=[~]] :: GHC.Types.KindRep
+$krep_aRp [InlPrag=[~]] :: GHC.Types.KindRep
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
-$krep_aPq = GHC.Types.KindRepFun GHC.Types.krep$* $krep_aPr
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
+$krep_aRp
+ = GHC.Types.KindRepFun GHC.Types.krep$* GHC.Types.krep$Constraint
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep_aPp [InlPrag=[~]] :: GHC.Types.KindRep
+$krep_aRo [InlPrag=[~]] :: GHC.Types.KindRep
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
-$krep_aPp = GHC.Types.KindRepFun GHC.Types.krep$* $krep_aPq
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
+$krep_aRo = GHC.Types.KindRepFun GHC.Types.krep$* $krep_aRp
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-$tcC_sRK :: GHC.Prim.Addr#
+$tcC_sTN :: GHC.Prim.Addr#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
-$tcC_sRK = "C"#
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
+$tcC_sTN = "C"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-$tcC_sRL :: GHC.Types.TrName
+$tcC_sTO :: GHC.Types.TrName
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
-$tcC_sRL = GHC.Types.TrNameS $tcC_sRK
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
+$tcC_sTO = GHC.Types.TrNameS $tcC_sTN
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
T17966.$tcC :: GHC.Types.TyCon
[LclIdX,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T17966.$tcC
= GHC.Types.TyCon
12503088876068780286#Word64
926716241154773768#Word64
T17966.$trModule
- $tcC_sRL
+ $tcC_sTO
0#
- $krep_aPp
+ $krep_aRo
--- RHS size: {terms: 10, types: 7, coercions: 4, joins: 0/0}
+-- RHS size: {terms: 10, types: 7, coercions: 0, joins: 0/0}
x :: String
[LclIdX,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 120 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 120 0}]
x = f @Bool
@()
@(Maybe Integer)
- (($cm_aHo @() GHC.Show.$fShow())
- `cast` (Sym (T17966.N:C[0] <Bool>_N <()>_N)
- :: (forall c. Show c => Bool -> () -> c -> String) ~R# C Bool ()))
+ (T17966.$fCBoolb @() GHC.Show.$fShowUnit)
(GHC.Show.$fShowMaybe @Integer GHC.Show.$fShowInteger)
GHC.Types.True
- GHC.Tuple.()
+ GHC.Tuple.Prim.()
(GHC.Maybe.Just @Integer (GHC.Num.Integer.IS 42#))
=====================================
testsuite/tests/stranal/sigs/T21888.stderr
=====================================
@@ -2,8 +2,8 @@
==================== Strictness signatures ====================
Data.MemoTrie.$fHasTrieBool: <1!P(L,L)>
Data.MemoTrie.$fHasTrieEither: <1C(1,L)><1C(1,L)><1!P(L,L)>
-Data.MemoTrie.$fHasTrieInteger: <1!P(1!P(S,1!P(1!P(S,1L),1!P(S,1L))),1!P(S,1!P(1!P(S,1L),1!P(S,1L))))>b
-Data.MemoTrie.$fHasTrieList: <SC(S,L)><1!P(L,L)>
+Data.MemoTrie.$fHasTrieInteger: <1!P(L,L)>
+Data.MemoTrie.$fHasTrieList: <L>
Data.MemoTrie.$fHasTrieTuple2: <1C(1,L)><LC(S,L)><L>
Data.MemoTrie.$fHasTrieUnit: <L>
@@ -22,8 +22,8 @@ Data.MemoTrie.$fHasTrieUnit:
==================== Strictness signatures ====================
Data.MemoTrie.$fHasTrieBool: <1!P(L,L)>
Data.MemoTrie.$fHasTrieEither: <1C(1,L)><1C(1,L)><1!P(L,L)>
-Data.MemoTrie.$fHasTrieInteger: <1!P(1!P(B,1!P(1!P(B,1!P(L,L)),1!P(B,1!P(L,L)))),1!P(B,1!P(1!B,1!B)))>b
-Data.MemoTrie.$fHasTrieList: <SC(S,L)><1!P(L,L)>
+Data.MemoTrie.$fHasTrieInteger: <1!P(L,L)>
+Data.MemoTrie.$fHasTrieList: <L>
Data.MemoTrie.$fHasTrieTuple2: <1C(1,L)><LC(S,L)><L>
Data.MemoTrie.$fHasTrieUnit: <L>
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9e375222ecae6c38695684affe6b317c13fc39c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9e375222ecae6c38695684affe6b317c13fc39c
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230810/2256fc0f/attachment-0001.html>
More information about the ghc-commits
mailing list