GitLab

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)