Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: f04e3882 by Simon Peyton Jones at 2026-04-08T16:21:16+01:00 More wibbles This now works - - - - - 2 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Specialise.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2657,7 +2657,7 @@ fireRuleAFTER env rule_match arg_specs cont pushArgs env' Simplified (exprType rhs) rhs_args $ pushArgSpecs env' (drop (ruleArity rule) arg_specs) cont ; return $ - if isEmptyBindWrapper wrap + if isEmptyBindWrapper wrap -- Not very pretty then (floats, e') else (emptyFloats env', applyBindWrapper wrap $ wrapFloats floats e') } @@ -2733,7 +2733,7 @@ tryRules env rules fn args trySeqRules :: SimplEnv -> OutExpr -> InExpr -- Scrutinee and RHS -> SimplCont - -> SimplM (Maybe (CoreExpr, SimplCont)) + -> SimplM (Maybe (RuleMatch, [ArgSpec], SimplCont)) -- See Note [User-defined RULES for seq] -- `in_env` applies to `rhs :: InExpr` but not to `scrut :: OutExpr` trySeqRules in_env scrut rhs cont @@ -2742,7 +2742,7 @@ trySeqRules in_env scrut rhs cont ; mb_match <- tryRules in_env seq_rules seqId out_args ; case mb_match of Nothing -> return Nothing - Just rule_match -> Just <$> fireRuleAFTER in_env rule_match out_arg_specs cont } + Just rule_match -> return (Just (rule_match, arg_specs, rule_cont)) } where no_cast_scrut = drop_casts scrut @@ -2756,21 +2756,23 @@ trySeqRules in_env scrut rhs cont rhs_ty = substTy in_env (exprType rhs) rhs_rep = getRuntimeRep rhs_ty - out_args = [Type rhs_rep, Type scrut_ty, Type rhs_ty, no_cast_scrut] - -- Cheaper than (map argSpecArg out_arg_specs) - out_arg_specs = [ TyArg { as_arg_ty = rhs_rep - , as_hole_ty = seq_id_ty } - , TyArg { as_arg_ty = scrut_ty - , as_hole_ty = res1_ty } - , TyArg { as_arg_ty = rhs_ty - , as_hole_ty = res2_ty } - , ValArg { as_arg = no_cast_scrut - , as_dmd = seqDmd - , as_hole_ty = res3_ty } ] + arg_specs :: [ArgSpec] + arg_specs = [ TyArg { as_arg_ty = rhs_rep + , as_hole_ty = seq_id_ty } + , TyArg { as_arg_ty = scrut_ty + , as_hole_ty = res1_ty } + , TyArg { as_arg_ty = rhs_ty + , as_hole_ty = res2_ty } + , ValArg { as_arg = no_cast_scrut + , as_dmd = seqDmd + , as_hole_ty = res3_ty } ] rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs , sc_env = in_env, sc_cont = cont , sc_hole_ty = res4_ty } + out_args = [Type rhs_rep, Type scrut_ty, Type rhs_ty, no_cast_scrut] + -- Cheaper than (map argSpecArg out_arg_specs) + -- Lazily evaluated, so we don't do most of this drop_casts (Cast e _) = drop_casts e drop_casts e = e @@ -3196,8 +3198,8 @@ rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont | is_plain_seq = do { mb_rule <- trySeqRules env scrut rhs cont ; case mb_rule of - Just (rule_rhs, cont') -> simplExprF (zapSubstEnv env) rule_rhs cont' - Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + Just (rm, ass, rcont) -> fireRuleAFTER env rm ass rcont + Nothing -> reallyRebuildCase env scrut case_bndr alts cont } -------------------------------------------------- -- 3. Primop-related case-rules ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1801,7 +1801,7 @@ alreadyCovered :: SpecEnv alreadyCovered env bndrs fn args is_active rules = case specLookupRule env fn args is_active rules of Nothing -> False - Just (rule, _,_) + Just (rule, _) | isAutoRule rule -> -- Discard identical rules -- We know that (fn args) is an instance of RULE -- Check if RULE is an instance of (fn args) @@ -1821,7 +1821,10 @@ specLookupRule env fn args is_active rules = Nothing -- Saves building a few thunks in the common case | otherwise = case lookupRule ropts in_scope_env is_active fn args rules of - Just (rule, rule_rhs, rule_args) -> Just (rule, mkApps rule_rhs rule_args) + Just (RM { rm_rule = rule, rm_rhs = rule_rhs + , rm_binds = wrap, rm_args = rule_args }) + -> Just (rule, applyBindWrapper wrap (mkApps rule_rhs rule_args)) + Nothing -> Nothing where dflags = se_dflags env in_scope = substInScopeSet (se_subst env) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f04e3882d7bd57bbd14b08f6b1d00c13... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f04e3882d7bd57bbd14b08f6b1d00c13... You're receiving this email because of your account on gitlab.haskell.org.