Simon Peyton Jones pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: ea554055 by Simon Peyton Jones at 2025-04-27T23:01:40+01:00 Wibbles - - - - - 1 changed file: - compiler/GHC/Core/Opt/Specialise.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiWayIf #-} + {- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 @@ -14,7 +16,6 @@ import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst ) --- import GHC.Core.Multiplicity import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe ) import GHC.Core.Predicate import GHC.Core.Class( classMethods ) @@ -3072,7 +3073,7 @@ mkCallUDs' env f args emptyUDs where - _trace_doc = vcat [ppr f, ppr args, ppr ci_key, ppr (se_subst env)] + _trace_doc = vcat [ppr f, ppr args, ppr ci_key] pis = fst $ splitPiTys $ idType f constrained_tyvars = tyCoVarsOfTypes $ getTheta pis @@ -3097,7 +3098,7 @@ mkCallUDs' env f args -- on this argument; if so, SpecDict, if not UnspecArg mk_spec_arg arg (Anon _pred af) | isInvisibleFunArg af - , interestingDict (ISE (substInScopeSet $ se_subst env) realIdUnfolding) arg + , interestingDict env arg -- , interestingDict arg (scaledThing pred) -- See Note [Interesting dictionary arguments] = SpecDict arg @@ -3121,7 +3122,7 @@ site, so we only look through ticks that RULE matching looks through -} wantCallsFor :: SpecEnv -> Id -> Bool -wantCallsFor _env _f = True +wantCallsFor _env f = not (isDataConId f) -- Better version coming in !14242 -- We could reduce the size of the UsageDetails by being less eager -- about collecting calls for LocalIds: there is no point for -- ones that are lambda-bound. We can't decide this by looking at @@ -3177,7 +3178,7 @@ case we can clearly specialise. But there are wrinkles: whole it's only a small win: 2.2% improvement in allocation for ansi, 1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. -(ID4) We must be very careful not to specialise on a "dictionry" that is, or contains +(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains an implicit parameter, because implicit parameters are emphatically not singleton types. See #25999: useImplicit :: (?i :: Int) => Int @@ -3247,24 +3248,41 @@ in the NonRec case of specBind. (This is too exotic to trouble with the Rec case.) -} -interestingDict :: InScopeEnv -> CoreExpr -> Bool +interestingDict :: SpecEnv -> CoreExpr -> Bool +-- This is a subtle and important function -- See Note [Interesting dictionary arguments] interestingDict env (Var v) -- See (ID3) and (ID5) | Just rhs <- expandUnfolding_maybe (idUnfolding v) = interestingDict env rhs -interestingDict env (Cast arg _) -- See (ID5) - = interestingDict env arg + interestingDict env arg -- Main Plan: use exprIsConApp_maybe - | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe env arg + | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg , Just cls <- tyConClass_maybe (dataConTyCon data_con) - , (not . couldBeIPLike) (exprType arg) -- See (ID4) - = if null (classMethods cls) -- See (ID6) + , (not . couldBeIPLike) arg_ty -- See (ID4) + = if null (classMethods cls) -- See (ID6) then any (interestingDict env) args else True - | exprIsHNF arg -- See (ID7) - = True + + | Cast inner_arg _ <- arg -- See (ID5) + = if | isConstraintKind $ typeKind $ exprType inner_arg + -- If coercions were always homo-kinded, we'd know + -- that this would be the only case + -> interestingDict env inner_arg + + -- Cheeck for an implicit parameter + | Just (cls,_) <- getClassPredTys_maybe arg_ty + , isIPClass cls -- See (ID4) + -> False + + -- Otherwise we are unwrapping a unary type class + | otherwise + -> exprIsHNF arg -- See (ID7) + | otherwise = False + where + arg_ty = exprType arg + in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding thenUDs :: UsageDetails -> UsageDetails -> UsageDetails thenUDs (MkUD {ud_binds = db1, ud_calls = calls1}) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ea5540556ad257083dddc11ac068c173... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ea5540556ad257083dddc11ac068c173... You're receiving this email because of your account on gitlab.haskell.org.