From 913492c021fc49752137e202bba154c9bd20035e Mon Sep 17 00:00:00 2001 From: Sebastian Graf Date: Sat, 2 Apr 2022 20:11:34 +0200 Subject: test --- compiler/GHC/Core/Lint.hs | 2 +- compiler/GHC/Core/Opt/Arity.hs | 5 +-- compiler/GHC/Core/Opt/Specialise.hs | 63 ++++++++++++++++++++++++------------- compiler/GHC/CoreToStg/Prep.hs | 6 ++++ 4 files changed, 51 insertions(+), 25 deletions(-) diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index b9ca990f3d..660428936e 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -2300,7 +2300,7 @@ lintCoercion the_co@(NthCo r0 n co) ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of { (Just (tc_s, tys_s), Just (tc_t, tys_t)) | tc_s == tc_t - , isInjectiveTyCon tc_s r + , isInjectiveTyCon tc_s r || isClassTyCon tc_s -- see Note [NthCo and newtypes] in GHC.Core.TyCo.Rep , tys_s `equalLength` tys_t , tys_s `lengthExceeds` n diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index ab38be413c..9e2bfe1efd 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -37,7 +37,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 import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc ) import GHC.Core.Predicate ( isDictTy, isCallStackPredTy ) import GHC.Core.Multiplicity @@ -1812,7 +1812,8 @@ 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 - + , not (isNewDataCon dc) || isClassTyCon to_tc + -- see Note [NthCo and newtypes] in GHC.Core.TyCo.Rep = let tc_arity = tyConArity to_tc dc_univ_tyvars = dataConUnivTyVars dc diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 0a733abb6b..be14d1769f 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -615,7 +615,12 @@ specProgram guts@(ModGuts { mg_module = this_mod go [] = return ([], emptyUDs) go (bind:binds) = do (binds', uds) <- go binds - (bind', uds') <- specBind top_env bind uds + let env = bringFloatedDictsIntoScope top_env uds + (bind', uds') <- specBind env bind uds + -- let db_bndrs = unionVarSets $ map (mkVarSet . filter isLocalId . bindersOf . db_bind) (bagToList (ud_binds uds)) + -- let not_in_scope = db_bndrs `minusVarSet` getInScopeVars (Core.substInScope (se_subst top_env)) + -- massertPpr (isEmptyVarSet not_in_scope) + -- (text "not in scope above" $$ ppr (bindersOf bind) $$ ppr (ud_binds uds) $$ ppr not_in_scope) return (bind' ++ binds', uds') -- Specialise the bindings of this module @@ -650,7 +655,7 @@ See #10491 {- ********************************************************************* * * - Specialising imported functions + Specialising imported functions * * ********************************************************************* -} @@ -1129,13 +1134,13 @@ specExpr env expr@(App {}) } where -- See Note [Specialisation modulo dictionary selectors] - rewrite_class_ops :: CoreExpr -> [CoreExpr] -> (CoreExpr, [CoreExpr]) + rewrite_class_ops :: InExpr -> [OutExpr] -> (InExpr, [OutExpr]) rewrite_class_ops (Var f) args | isClassOpId f -- If we see `op_sel $fCInt`, we rewrite to `$copInt` -- , pprTrace "class op" (ppr f <+> ppr args) True , Just (rule, expr) <- specLookupRule env f args (idCoreRules f) , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target] - -- , pprTrace "class op rewritten" (ppr expr <+> ppr rest_args) True + , pprTrace "class op rewritten" (ppr f <+> ppr args $$ ppr expr <+> ppr rest_args) True , (fun, args) <- collectArgs expr = rewrite_class_ops fun (args++rest_args) rewrite_class_ops fun args = (fun, args) @@ -1165,10 +1170,11 @@ specExpr env (Let bind body) ; (body', body_uds) <- specExpr body_env body -- Deal with the bindings - ; (binds', uds) <- specBind rhs_env bind' body_uds + ; let rhs_env' = bringFloatedDictsIntoScope rhs_env body_uds + ; (binds', uds) <- specBind rhs_env' bind' body_uds - -- All done - ; return (foldr Let body' binds', uds) } + -- All done + ; return (foldr Let body' binds', uds) } -------------- specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails) @@ -1303,6 +1309,14 @@ to substitute sc -> sc_flt in the RHS ************************************************************************ -} +bringFloatedDictsIntoScope :: SpecEnv -> UsageDetails -> SpecEnv +bringFloatedDictsIntoScope env uds = + -- pprTrace "brought into scope" (ppr dx_bndrs) $ + env{se_subst=subst'} + where + dx_bndrs = bindersOfBinds (map db_bind (bagToList (ud_binds uds))) + subst' = se_subst env `Core.extendInScopeList` dx_bndrs + specBind :: SpecEnv -- Use this for RHSs -> CoreBind -- Binders are already cloned by cloneBindSM, -- but RHSs are un-processed @@ -1496,16 +1510,17 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , rule_bndrs, rule_lhs_args , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args --- ; pprTrace "spec_call" (vcat [ text "call info: " <+> ppr _ci --- , text "useful: " <+> ppr useful --- , text "rule_bndrs:" <+> ppr rule_bndrs --- , text "lhs_args: " <+> ppr rule_lhs_args --- , text "spec_bndrs:" <+> ppr spec_bndrs1 --- , text "spec_args: " <+> ppr spec_args --- , text "dx_binds: " <+> ppr dx_binds --- , text "rhs_env2: " <+> ppr (se_subst rhs_env2) --- , ppr dx_binds ]) $ --- return () + ; 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_bndrs:" <+> ppr spec_bndrs1 + , text "spec_args: " <+> ppr spec_args + , text "dx_binds: " <+> ppr dx_binds + , text "rhs_env2: " <+> ppr (se_subst rhs_env2) + , ppr dx_binds ]) $ + return () ; if not useful -- No useful specialisation || already_covered rules_acc rule_lhs_args @@ -2458,7 +2473,8 @@ bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting }) `Core.extendInScope` dict_id -- See Note [Keep the old dictionaries interesting] , se_interesting = interesting `extendVarSet` dict_id } - in (env', Nothing, dict_expr) + in -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $ + (env', Nothing, dict_expr) | otherwise -- Non-trivial dictionary arg; make an auxiliary binding = let dict_unf = mkSimpleUnfolding defaultUnfoldingOpts dict_expr @@ -2466,10 +2482,12 @@ bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting }) -- See Note [Specialisation modulo dictionary selectors] for the unfolding dict_bind = mkDB (NonRec fresh_dict_id' dict_expr) env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id') - `Core.extendInScope` fresh_dict_id' + `Core.extendInScope` fresh_dict_id' + `Core.extendInScopeList` exprFreeVarsList dict_expr -- See Note [Make the new dictionaries interesting] , se_interesting = interesting `extendVarSet` fresh_dict_id' } - in (env', Just dict_bind, Var fresh_dict_id') + in -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id' $$ ppr dict_expr $$ ppr (exprFreeVarsList dict_expr)) $ + (env', Just dict_bind, Var fresh_dict_id') {- Note [Make the new dictionaries interesting] @@ -2727,7 +2745,7 @@ singleCall id args -- -- We don't include the 'id' itself. -mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails +mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [OutExpr] -> UsageDetails mkCallUDs env f args = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ]) res @@ -2757,7 +2775,7 @@ mkCallUDs' env f args -- which broadens its applicability, since rules only -- fire when saturated - mk_spec_arg :: CoreExpr -> TyCoBinder -> SpecArg + mk_spec_arg :: OutExpr -> TyCoBinder -> SpecArg mk_spec_arg arg (Named bndr) | binderVar bndr `elemVarSet` constrained_tyvars = case arg of @@ -3120,6 +3138,7 @@ cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec ; let (subst', bndr') = Core.cloneIdBndr subst us bndr interesting' | typeDeterminesValue (idType bndr) , interestingDict env rhs + , pprTrace "cloneBindSM:interesting" (ppr bndr <> arrow <> ppr bndr') True = interesting `extendVarSet` bndr' | otherwise = interesting ; return (env, env { se_subst = subst', se_interesting = interesting' } diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 5fa3bbdf14..2a0a34e3a5 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -1098,6 +1098,12 @@ cpeApp top_env expr | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest +-- cpe_app env (Var f) args +-- | isClassOpId f +-- , Just tmpl <- maybeUnfoldingTemplate (idUnfolding f) +-- , pprTrace "cpe_app:class op" (ppr f $$ ppr tmpl) +-- = cpe_app env tmpl args + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 -- cgit v1.2.1