Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 3405e84e by Simon Peyton Jones at 2025-06-13T17:43:53+01:00 More wibbles - - - - - 3 changed files: - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/HsToCore/Binds.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -29,13 +29,11 @@ import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable , mkCast, exprType , stripTicksTop, mkInScopeSetBndrs ) import GHC.Core.FVs -import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) import GHC.Core.Opt.Arity( collectBindersPushingCo ) --- import GHC.Core.Ppr( pprIds ) import GHC.Builtin.Types ( unboxedUnitTy ) -import GHC.Data.Maybe ( maybeToList, isJust ) +import GHC.Data.Maybe ( isJust ) import GHC.Data.Bag import GHC.Data.OrdList import GHC.Data.List.SetOps @@ -46,7 +44,7 @@ import GHC.Types.Unique.DFM import GHC.Types.Name import GHC.Types.Tickish import GHC.Types.Id.Make ( voidArgId, voidPrimId ) -import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg, mkLocalVar ) +import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id @@ -56,6 +54,7 @@ import GHC.Types.Error import GHC.Utils.Error ( mkMCDiagnostic ) import GHC.Utils.Monad ( foldlM ) import GHC.Utils.Misc +import GHC.Utils.FV import GHC.Utils.Outputable import GHC.Utils.Panic @@ -1612,12 +1611,17 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs is_dfun = isDFunId fn dflags = se_dflags env this_mod = se_module env + subst = se_subst env + in_scope = Core.substInScopeSet subst -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs -- See Note [Account for casts in binding] + not_in_scope :: InterestingVarFun + not_in_scope v = isLocalVar v && not (v `elemInScopeSet` in_scope) + ---------------------------------------------------------- -- Specialise to one particular call pattern spec_call :: SpecInfo -- Accumulating parameter @@ -1628,25 +1632,40 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs do { let all_call_args | is_dfun = saturating_call_args -- See Note [Specialising DFuns] | otherwise = call_args saturating_call_args = call_args ++ map mk_extra_dfun_arg (dropList call_args rhs_bndrs) - mk_extra_dfun_arg bndr | isTyVar bndr = UnspecType (tyVarKind bndr) -- ToDo: right? - | otherwise = UnspecArg (idType bndr) - - ; (useful, rule_bndrs, rule_lhs_args, spec_bndrs1, spec_args) <- specHeader env all_call_args - --- ; 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 "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_extra_dfun_arg bndr | isTyVar bndr = UnspecType + | otherwise = UnspecArg + + -- Find qvars, the type variables to add to the binders for the rule + -- Namely those free in `ty` that aren't in scope + -- See (MP2) in Note [Specialising polymorphic dictionaries] + ; let poly_qvars = scopedSort $ fvVarList $ specArgsFVs not_in_scope call_args + poly_qvar_es = map varToCoreExpr poly_qvars -- Account for CoVars + + subst' = subst `Core.extendSubstInScopeList` poly_qvars + -- Maybe we should clone the poly_qvars telescope? + + -- Any free Ids will have caused the call to be dropped + ; massertPpr (all isTyCoVar poly_qvars) + (ppr fn $$ ppr all_call_args $$ ppr poly_qvars) + + ; (useful, subst'', rule_bndrs, rule_lhs_args, spec_bndrs, spec_args) + <- specHeader subst' rhs_bndrs all_call_args + ; (rule_bndrs, rule_lhs_args, spec_bndrs, spec_args) + <- return ( poly_qvars ++ rule_bndrs, poly_qvar_es ++ rule_lhs_args + , poly_qvars ++ spec_bndrs, poly_qvar_es ++ spec_args ) + + ; pprTrace "spec_call" (vcat + [ text "fun: " <+> ppr fn + , text "call info: " <+> ppr _ci + , text "poly_qvars: " <+> ppr poly_qvars + , text "useful: " <+> ppr useful + , text "rule_bndrs:" <+> ppr rule_bndrs + , text "rule_lhs_args:" <+> ppr rule_lhs_args + , text "spec_bndrs:" <+> ppr spec_bndrs + , text "spec_args: " <+> ppr spec_args + , text "rhs_bndrs" <+> ppr rhs_bndrs + , text "rhs_body" <+> ppr rhs_body ]) $ + return () ; let all_rules = rules_acc ++ existing_rules -- all_rules: we look both in the rules_acc (generated by this invocation @@ -1657,27 +1676,28 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs then return spec_acc else do { -- Run the specialiser on the specialised RHS - -- The "1" suffix is before we maybe add the void arg - ; (rhs_body', rhs_uds) <- specRhs env rhs_bndrs rhs_body spec_args + (rhs_body', rhs_uds) <- specExpr (env { se_subst = subst'' }) $ + mkLams (dropList spec_args rhs_bndrs) rhs_body + -- Add the { d1' = dx1; d2' = dx2 } usage stuff -- to the rhs_uds; see Note [Specialising Calls] ; let (spec_uds, dumped_dbs) = dumpUDs spec_bndrs1 rhs_uds - spec_rhs1 = mkLams spec_bndrs1 $ - wrapDictBindsE dumped_dbs rhs_body' - spec_fn_ty1 = exprType spec_rhs1 + spec_rhs = mkLams spec_bndrs $ + wrapDictBindsE dumped_dbs rhs_body' + spec_fn_ty = exprType spec_rhs -- Maybe add a void arg to the specialised function, -- to avoid unlifted bindings -- See Note [Specialisations Must Be Lifted] -- C.f. GHC.Core.Opt.WorkWrap.Utils.needsVoidWorkerArg - add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn) - (spec_bndrs, spec_rhs, spec_fn_ty) - | add_void_arg = ( voidPrimId : spec_bndrs1 - , Lam voidArgId spec_rhs1 - , mkVisFunTyMany unboxedUnitTy spec_fn_ty1) - | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1) + add_void_arg = isUnliftedType spec_fn_ty && not (isJoinId fn) + (spec_bndrs1, spec_rhs1, spec_fn_ty1) + | add_void_arg = ( voidPrimId : spec_bndrs + , Lam voidArgId spec_rhs + , mkVisFunTyMany unboxedUnitTy spec_fn_ty) + | otherwise = (spec_bndrs, spec_rhs, spec_fn_ty) - join_arity_decr = length rule_lhs_args - length spec_bndrs + join_arity_decr = length rule_lhs_args - length spec_bndrs1 -------------------------------------- -- Add a suitable unfolding; see Note [Inline specialisations] @@ -1685,7 +1705,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- arguments, not forgetting to wrap the dx_binds around the outside (#22358) simpl_opts = initSimpleOpts dflags wrap_unf_body body = body `mkApps` spec_args - spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body + spec_unf = specUnfolding simpl_opts spec_bndrs1 wrap_unf_body rule_lhs_args fn_unf -------------------------------------- @@ -1693,7 +1713,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- See Note [Arity decrease] in GHC.Core.Opt.Simplify -- Copy InlinePragma information from the parent Id. -- So if f has INLINE[1] so does spec_fn - arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs + arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs1 spec_inl_prag | not is_local -- See Note [Specialising imported functions] @@ -1715,7 +1735,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs DFunId unary -> DFunId unary _ -> VanillaId - ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info + ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty1 spec_fn_details spec_fn_info ; let -- The rule to put in the function's specialisation is: -- forall x @b d1' d2'. @@ -1728,12 +1748,12 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs spec_rule = mkSpecRule dflags this_mod True inl_act herald fn rule_bndrs rule_lhs_args - (mkVarApps (Var spec_fn) spec_bndrs) + (mkVarApps (Var spec_fn) spec_bndrs1) spec_f_w_arity = spec_fn _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type - , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty + , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty1 , ppr rhs_bndrs, ppr call_args , ppr spec_rule , text "acc" <+> ppr rules_acc @@ -1742,7 +1762,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs ; -- pprTrace "spec_call: rule" _rule_trace_doc return ( spec_rule : rules_acc - , (spec_f_w_arity, spec_rhs) : pairs_acc + , (spec_f_w_arity, spec_rhs1) : pairs_acc , spec_uds `thenUDs` uds_acc ) } } @@ -1763,13 +1783,16 @@ alreadyCovered env bndrs fn args is_active rules where in_scope = substInScopeSet (se_subst env) -specRhs :: SpecEnv -> [Var] -> CoreExpr -> [CoreExpr] - -> SpecM (CoreExpr, UsageDetails) +{- +specRhs :: SpecEnv -> [InVar] -> InExpr -> [OutExpr] + -> SpecM (OutExpr, UsageDetails) -specRhs env bndrs body [] - = specLam env bndrs body +specRhs env bndrs body [] -- Like specExpr (Lam bndrs body) + = specLam env' bndrs' body + where + (env', bndrs') = substBndrs env bndrs -specRhs env [] body args +specRhs _env [] body args = -- The caller should have ensured that there are no more -- args than we have binders on the RHS pprPanic "specRhs:too many args" (ppr args $$ ppr body) @@ -1781,15 +1804,22 @@ specRhs env@(SE { se_subst = subst }) (bndr:bndrs) body (arg:args) | otherwise -- Non-trivial argument; it must be a dictionary - = do { fresh_dict_id <- newIdBndr "dx" (idType bndr) - ; let fresh_dict_id' = fresh_dict_id `addDictUnfolding` arg - dict_bind = mkDB (NonRec fresh_dict_id' arg) - env2 = env1 { se_subst = Core.extendSubst subst bndr (Var fresh_dict_id') - `Core.extendSubstInScope` fresh_dict_id' } + = do { fresh_id <- newIdBndr "dx" (exprType arg) + ; let fresh_id' = fresh_id `addDictUnfolding` arg + dict_bind = mkDB (NonRec fresh_id' arg) + env' = env { se_subst = Core.extendSubst subst bndr (Var fresh_id') + `Core.extendSubstInScope` fresh_id' } -- Ensure the new unfolding is in the in-scope set - ; (body', uds) <- specRhs env2 bndrs body args + ; (body', uds) <- specRhs env' bndrs body args ; return (body', dict_bind `consDictBind` uds) } +consDictBind :: DictBind -> UsageDetails -> UsageDetails +consDictBind db uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}} + = uds { ud_binds = FDB{ fdb_binds = db `consOL` binds + , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } } + +-} + -- Convenience function for invoking lookupRule from Specialise -- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr] specLookupRule :: SpecEnv -> Id -> [CoreExpr] @@ -2105,17 +2135,20 @@ defeated specialisation! Hence the use of collectBindersPushingCo. Note [Evidence foralls] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose (#12212) that we are specialising - f :: forall a b. (Num a, F a ~ F b) => blah + f :: forall a b. (Num a, F a ~# F b) => blah with a=b=Int. Then the RULE will be something like - RULE forall (d:Num Int) (g :: F Int ~ F Int). + RULE forall (d:Num Int) (g :: F Int ~# F Int). f Int Int d g = f_spec +where that `g` is really (Coercion (CoVar g)), since `g` is a +coercion variable and can't appear as (Var g). + But both varToCoreExpr (when constructing the LHS args), and the simplifier (when simplifying the LHS args), will transform to RULE forall (d:Num Int) (g :: F Int ~ F Int). f Int Int d <F Int> = f_spec by replacing g with Refl. So now 'g' is unbound, which results in a later crash. So we use Refl right off the bat, and do not forall-quantify 'g': - * varToCoreExpr generates a Refl + * varToCoreExpr generates a (Coercion Refl) * exprsFreeIdsList returns the Ids bound by the args, which won't include g @@ -2447,7 +2480,7 @@ data SpecArg SpecType Type -- | Type arguments that should remain polymorphic. - | UnspecType Kind + | UnspecType -- | Dictionaries that should be specialised. mkCallUDs ensures -- that only "interesting" dictionary arguments get a SpecDict; @@ -2455,25 +2488,25 @@ data SpecArg | SpecDict DictExpr -- | Value arguments that should not be specialised. - | UnspecArg Type + | UnspecArg instance Outputable SpecArg where - ppr (SpecType t) = text "SpecType" <+> ppr t - ppr (UnspecType k) = text "UnspecType" - ppr (SpecDict d) = text "SpecDict" <+> ppr d - ppr (UnspecArg t) = text "UnspecArg" - -specArgFreeIds :: SpecArg -> IdSet -specArgFreeIds (SpecType {}) = emptyVarSet -specArgFreeIds (SpecDict dx) = exprFreeIds dx -specArgFreeIds (UnspecType {}) = emptyVarSet -specArgFreeIds (UnspecArg {}) = emptyVarSet - -specArgFreeVars :: SpecArg -> VarSet -specArgFreeVars (SpecType ty) = tyCoVarsOfType ty -specArgFreeVars (UnspecType ki) = tyCoVarsOfType ki -specArgFreeVars (SpecDict dx) = exprFreeVars dx -specArgFreeVars (UnspecArg ty) = tyCoVarsOfType ty + ppr (SpecType t) = text "SpecType" <+> ppr t + ppr (SpecDict d) = text "SpecDict" <+> ppr d + ppr UnspecType = text "UnspecType" + ppr UnspecArg = text "UnspecArg" + +specArgsFVs :: InterestingVarFun -> [SpecArg] -> FV +-- Find the free vars of the SpecArgs that are not already in scope +specArgsFVs interesting args + = filterFV interesting $ + foldr (unionFV . get) emptyFV args + where + get :: SpecArg -> FV + get (SpecType ty) = tyCoFVsOfType ty + get (SpecDict dx) = exprFVs dx + get UnspecType = emptyFV + get UnspecArg = emptyFV isSpecDict :: SpecArg -> Bool isSpecDict (SpecDict {}) = True @@ -2523,12 +2556,15 @@ isSpecDict _ = False -- , [T1, T2, c, i, dEqT1, dShow1] -- ) specHeader - :: SpecEnv + :: Core.Subst -- This substitution applies to the [InBndr] + -> [InBndr] -- Binders from the original function `f` -> [SpecArg] -- From the CallInfo -> SpecM ( Bool -- True <=> some useful specialisation happened -- Not the same as any (isSpecDict args) because -- the args might be longer than bndrs + , Core.Subst -- Apply this to the body + -- RULE helpers , [OutBndr] -- Binders for the RULE , [OutExpr] -- Args for the LHS of the rule @@ -2539,63 +2575,57 @@ specHeader -- Same length as "Args for LHS of rule" ) +-- If we run out of binders, stop immediately +-- See Note [Specialisation Must Preserve Sharing] +specHeader subst [] _ = pure (False, subst, [], [], [], []) +specHeader subst _ [] = pure (False, subst, [], [], [], []) + -- We want to specialise on type 'T1', and so we must construct a substitution -- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding -- details. -specHeader env (SpecType ty : args) - = do { -- Find qvars, the type variables to add to the binders for the rule - -- Namely those free in `ty` that aren't in scope - -- See (MP2) in Note [Specialising polymorphic dictionaries] - let in_scope = Core.substInScopeSet (se_subst env) - qvars = scopedSort $ - filterOut (`elemInScopeSet` in_scope) $ - tyCoVarsOfTypeList ty - ; (useful, rule_bs, rule_args, spec_bs, spec_args) <- specHeader env args - ; pure ( useful - , qvars ++ rule_bs - , Type ty : rule_args - , qvars ++ spec_bs - , Type ty : spec_args - ) - } +specHeader subst (bndr:bndrs) (SpecType ty : args) + = do { let subst1 = Core.extendTvSubst subst bndr ty + ; (useful, subst2, rule_bs, rule_args, spec_bs, spec_args) + <- specHeader subst1 bndrs args + ; pure ( useful, subst2 + , rule_bs, Type ty : rule_args + , spec_bs, Type ty : spec_args ) } -- Next we have a type that we don't want to specialise. We need to perform -- a substitution on it (in case the type refers to 'a'). Additionally, we need -- to produce a binder, LHS argument and RHS argument for the resulting rule, -- /and/ a binder for the specialised body. -specHeader env (UnspecType kind : args) - = do { (useful, rule_bs, rule_es, spec_bs, spec_args) <- specHeader env' bndrs args - ; tv <- newTyVarBndr kind - ; pure ( useful - , bndr' : rule_bs - , varToCoreExpr bndr' : rule_es - , bndr' : spec_bs - , varToCoreExpr bndr' : spec_args - ) - } +specHeader subst (bndr:bndrs) (UnspecType : args) + = do { let (subst1, bndr') = Core.substBndr subst bndr + ; (useful, subst2, rule_bs, rule_es, spec_bs, spec_args) + <- specHeader subst1 bndrs args + ; let ty_e' = Type (mkTyVarTy bndr') + ; pure ( useful, subst2 + , bndr' : rule_bs, ty_e' : rule_es + , bndr' : spec_bs, ty_e' : spec_args ) } + +specHeader subst (bndr:bndrs) (_ : args) + | isDeadBinder bndr + , let (subst1, bndr') = Core.substBndr subst bndr + , Just rubbish_lit <- mkLitRubbish (idType bndr') + = -- See Note [Drop dead args from specialisations] + do { (useful, subst2, rule_bs, rule_es, spec_bs, spec_args) <- specHeader subst1 bndrs args + ; pure ( useful, subst2 + , bndr' : rule_bs, Var bndr' : rule_es + , spec_bs, rubbish_lit : spec_args ) } -- Next we want to specialise the 'Eq a' dict away. We need to construct -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for -- the nitty-gritty), as a LHS rule and unfolding details. -specHeader env (SpecDict dict_arg : args) - | not (isDeadBinder bndr) - , allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d) - -- See Note [Weird special case for SpecDict] - = do { (_, rule_bs, rule_es, spec_bs, spec_args) <- specHeader env bndrs args - ; new_dict_id <- newIdBndr "dx" (exprType dict_arg) - ; let new_dict_expr = varToCoreExpr new_dict_id - -- See Note [Evidence foralls] - ; pure ( True -- Ha! A useful specialisation! - , exprFreeIdsList new_dict_expr ++ rule_bs - , new_dict_expr : rule_es - , spec_bs - , dict_arg : spec_args - ) - } +specHeader subst (bndr:bndrs) (SpecDict dict_arg : args) + = do { let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr) + -- zapIdOccInfo: see Note [Zap occ info in rule binders] + ; (_, subst2, rule_bs, rule_es, spec_bs, spec_args) <- specHeader subst1 bndrs args + ; pure ( True, subst2 -- Ha! A useful specialisation! + , bndr' : rule_bs, Var bndr' : rule_es + , spec_bs, dict_arg : spec_args ) } -- Finally, we don't want to specialise on this argument 'i': --- - It's an UnSpecArg, or --- - It's a dead dictionary -- We need to produce a binder, LHS and RHS argument for the RULE, and -- a binder for the specialised body. -- @@ -2603,46 +2633,21 @@ specHeader env (SpecDict dict_arg : args) -- why 'i' doesn't appear in our RULE above. But we have no guarantee that -- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so -- this case must be here. -specHeader env (arg : args) - -- The "_" can be UnSpecArg, or SpecDict where the bndr is dead - = do { -- see Note [Zap occ info in rule binders] - ; (useful, rule_bs, rule_es, spec_bs, spec_args) <- specHeader env bndrs args - - ; spec_bndr <- case arg of - SpecDict d -> newIdBndr "dx" (exprType d) - UnspecArg t -> newIdBndr "x" t - ; let bndr_ty = idType bndr' - - -- See Note [Drop dead args from specialisations] - -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let - (mb_spec_bndr, spec_arg) - | isDeadBinder bndr - , Just lit_expr <- mkLitRubbish bndr_ty - = (Nothing, lit_expr) - | otherwise - = (Just bndr', varToCoreExpr bndr') - - ; pure ( useful - , bndr' : rule_bs - , varToCoreExpr bndr' : rule_es - , case mb_spec_bndr of - Just b -> b : spec_bs - Nothing -> spec_bs - , spec_arg : spec_args - ) - } +specHeader subst (bndr:bndrs) (UnspecArg : args) + = do { let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr) + -- zapIdOccInfo: see Note [Zap occ info in rule binders] + ; (useful, subst2, rule_bs, rule_es, spec_bs, spec_args) <- specHeader subst1 bndrs args --- If we run out of binders, stop immediately --- See Note [Specialisation Must Preserve Sharing] -specHeader env [] _ = pure (False, env, [], [], [], [], [], []) + ; let dummy_arg = varToCoreExpr bndr' + -- dummy_arg is usually just (Var bndr), + -- but if bndr :: t1 ~# t2, it'll be (Coercion (CoVar bndr)) + -- or even Coercion Refl (if t1=t2) + -- See Note [Evidence foralls] + bndrs = exprFreeIdsList dummy_arg --- Return all remaining binders from the original function. These have the --- invariant that they should all correspond to unspecialised arguments, so --- it's safe to stop processing at this point. -specHeader env bndrs [] - = pure (False, env', bndrs', [], [], [], [], []) - where - (env', bndrs') = substBndrs env bndrs + ; pure ( useful, subst2 + , bndrs ++ rule_bs, dummy_arg : rule_es + , bndrs ++ spec_bs, dummy_arg : spec_args ) } {- @@ -2672,12 +2677,12 @@ bindAuxiliaryDict env@(SE { se_subst = subst }) -- Ensure the new unfolding is in the in-scope set in -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id') $ (env', Just dict_bind, Var fresh_dict_id') --} addDictUnfolding :: Id -> CoreExpr -> Id -- Add unfolding for freshly-bound Ids: see Note [Make the new dictionaries interesting] -- and Note [Specialisation modulo dictionary selectors] addDictUnfolding id rhs = id `setIdUnfolding` mkSimpleUnfolding defaultUnfoldingOpts rhs +-} {- Note [Make the new dictionaries interesting] @@ -2985,14 +2990,12 @@ singleCall spec_env id args = MkUD {ud_binds = emptyFDBs, ud_calls = unitDVarEnv id $ CIS id $ unitBag (CI { ci_key = args - , ci_fvs = call_fvs }) } + , ci_fvs = fvVarSet call_fvs }) } where - call_fvs = foldr (unionVarSet . free_var_fn) emptyVarSet args - - free_var_fn = - if gopt Opt_PolymorphicSpecialisation (se_dflags spec_env) - then specArgFreeIds - else specArgFreeVars + call_fvs | gopt Opt_PolymorphicSpecialisation (se_dflags spec_env) + = specArgsFVs isLocalVar args + | otherwise + = specArgsFVs isLocalId args -- specArgFreeIds: we specifically look for free Ids, not TyVars -- see (MP1) in Note [Specialising polymorphic dictionaries] @@ -3033,9 +3036,9 @@ mkCallUDs' env f args | binderVar bndr `elemVarSet` constrained_tyvars = SpecType ty | otherwise - = UnspecType (typeKind ty) + = UnspecType mk_spec_arg non_type_arg (Named bndr) - = = pprPanic "ci_key" $ (ppr non_type_arg $$ ppr bndr) + = pprPanic "ci_key" $ (ppr non_type_arg $$ ppr bndr) -- For "invisibleFunArg", which are the type-class dictionaries, -- we decide on a case by case basis if we want to specialise @@ -3046,7 +3049,7 @@ mkCallUDs' env f args -- See Note [Interesting dictionary arguments] = SpecDict arg - | otherwise = UnspecArg (exprType arg) + | otherwise = UnspecArg {- Note [Ticks on applications] @@ -3285,11 +3288,6 @@ snocDictBinds uds@MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs = uds { ud_binds = FDB { fdb_binds = binds `appOL` (toOL dbs) , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } } -consDictBind :: DictBind -> UsageDetails -> UsageDetails -consDictBind db uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}} - = uds { ud_binds = FDB{ fdb_binds = db `consOL` binds - , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } } - wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind] wrapDictBinds (FDB { fdb_binds = dbs }) binds = foldr add binds dbs @@ -3402,10 +3400,10 @@ beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 }) go _ _ = False go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2) - go_arg (UnspecType {}) (UnspecType {}) = True - go_arg (SpecDict {}) (SpecDict {}) = True - go_arg (UnspecArg {}) (UnspecArg {}) = True - go_arg _ _ = False + go_arg (SpecDict {}) (SpecDict {}) = True + go_arg UnspecType UnspecType = True + go_arg UnspecArg UnspecArg = True + go_arg _ _ = False ---------------------- splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, OrdList DictBind, IdSet) @@ -3471,9 +3469,9 @@ mapAndCombineSM f (x:xs) = do (y, uds1) <- f x (ys, uds2) <- mapAndCombineSM f xs return (y:ys, uds1 `thenUDs` uds2) -extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv -extendTvSubst env tv ty - = env { se_subst = Core.extendTvSubst (se_subst env) tv ty } +-- extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv +-- extendTvSubst env tv ty +-- = env { se_subst = Core.extendTvSubst (se_subst env) tv ty } extendInScope :: SpecEnv -> OutId -> SpecEnv extendInScope env@(SE { se_subst = subst }) bndr @@ -3521,18 +3519,6 @@ newSpecIdSM old_name new_ty details info ; return (assert (not (isCoVarType new_ty)) $ mkLocalVar details new_name ManyTy new_ty info) } -newIdBndr :: String -> Type -> SpecM (SpecEnv, CoreBndr) --- Make up completely fresh binders for the dictionaries --- Their bindings are going to float outwards -newIdBndr env@(SE { se_subst = subst }) str ty - = do { uniq <- getUniqueM - ; return (mkUserLocal (mkVarOcc str) uniq ManyTy ty noSrcSpan) } - -newTyVarBndr :: Kind -> SpecM TyVar -newTyVarBndr kind - = do { uniq <- getUniqueM - ; let name = mkInternalName uniq (mkTyVarOcc "a") noSrcSpan - ; return (mkTyVar name kind } {- Old (but interesting) stuff about unboxed bindings ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -163,12 +163,14 @@ extendIdSubstList (Subst in_scope ids tvs cvs) prs -- | Add a substitution appropriate to the thing being substituted -- (whether an expression, type, or coercion). See also -- 'extendIdSubst', 'extendTvSubst', 'extendCvSubst' -extendSubst :: Subst -> Var -> CoreArg -> Subst +extendSubst :: HasDebugCallStack => Subst -> Var -> CoreArg -> Subst extendSubst subst var arg = case arg of - Type ty -> assert (isTyVar var) $ extendTvSubst subst var ty - Coercion co -> assert (isCoVar var) $ extendCvSubst subst var co - _ -> assert (isId var) $ extendIdSubst subst var arg + Type ty -> assertPpr (isTyVar var) doc $ extendTvSubst subst var ty + Coercion co -> assertPpr (isCoVar var) doc $ extendCvSubst subst var co + _ -> assertPpr (isId var) doc $ extendIdSubst subst var arg + where + doc = ppr var <+> text ":=" <+> ppr arg extendSubstWithVar :: Subst -> Var -> Var -> Subst extendSubstWithVar subst v1 v2 ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -1056,25 +1056,6 @@ dsSpec poly_rhs (SpecPrag poly_id spec_co spec_inl) dsSpec_help (idName poly_id) poly_id poly_rhs spec_inl spec_bndrs (core_app (Var poly_id)) -{- - do { dflags <- getDynFlags - ; case decomposeRuleLhs dflags spec_bndrs (core_app (Var poly_id)) - (mkVarSet spec_bndrs) of { - Left msg -> do { diagnosticDs msg; return Nothing } ; - Right (rule_bndrs, poly_id, rule_lhs_args) -> - - do { tracePm "dsSpec(old route)" $ - vcat [ text "poly_id" <+> ppr poly_id - , text "spec_bndrs" <+> ppr spec_bndrs - , text "the_call" <+> ppr (core_app (Var poly_id)) - , text "rule_bndrs" <+> ppr rule_bndrs - , text "rule_lhs_args" <+> ppr rule_lhs_args ] - - ; finishSpecPrag (idName poly_id) poly_rhs - rule_bndrs poly_id rule_lhs_args - spec_bndrs core_app spec_inl } } } --} - dsSpec poly_rhs (SpecPragE { spe_fn_nm = poly_nm , spe_fn_id = poly_id , spe_inl = inl View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3405e84ed1b7d4afd30b577c38b2bb5c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3405e84ed1b7d4afd30b577c38b2bb5c... You're receiving this email because of your account on gitlab.haskell.org.