GitLab

Simon Peyton Jones pushed to branch wip/T26615 at Glasgow Haskell Compiler / GHC

Commits:

0d62261b
by Simon Peyton Jones at 2025-11-28T17:33:16+00:00
```
Comments and tracing only
```

3 changed files:

compiler/GHC/Core/Opt/SpecConstr.hs
compiler/GHC/Core/Opt/Specialise.hs
compiler/GHC/Core/Utils.hs

Changes:

@@ -1781,7 +1781,8 @@ specRec :: ScEnv
                                             --     plus details of specialisations
  specRec env body_calls rhs_infos
 -  = go 1 body_calls nullUsage (map initSpecInfo rhs_infos) []
 +  = -- pprTrace "specRec" (ppr (map ri_fn rhs_infos) $$ ppr body_calls) $
 +    go 1 body_calls nullUsage (map initSpecInfo rhs_infos) []
      -- body_calls: see Note [Seeding recursive groups]
      -- NB: 'go' always calls 'specialise' once, which in turn unleashes
      --     si_mb_unspec if there are any boring calls in body_calls,
@@ -1801,7 +1802,7 @@ specRec env body_calls rhs_infos
      go n_iter seed_calls usg_so_far spec_infos ws_so_far
        = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)
          --                           , text "iteration" <+> int n_iter
 -        --                          , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)
 +        --                           , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)
          --                    ]) $
          do  { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos

compiler/GHC/Core/Opt/Specialise.hs

@@ -68,7 +68,6 @@ import GHC.Unit.Module.ModGuts
  import GHC.Core.Unfold
  import Data.List( partition )
 --- import Data.List.NonEmpty ( NonEmpty (..) )
  {-
  ************************************************************************
@@ -1617,11 +1616,12 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
      fn_type   = idType fn
      fn_arity  = idArity fn
      fn_unf    = realIdUnfolding fn  -- Ignore loop-breaker-ness here
 -    inl_prag  = idInlinePragma fn
 -    inl_act   = inlinePragmaActivation inl_prag
 +    fn_prag   = idInlinePragma fn
 +    rule_act  = inlinePragmaActivation fn_prag
 +                -- rule_act: see Note [Auto-specialisation and RULES]
      is_active :: Activation -> Bool
 -    is_active = isActive (SimplPhaseRange (beginPhase inl_act) (endPhase inl_act))
 -         -- is_active: inl_act is the activation we are going to put in the new
 +    is_active = isActive (SimplPhaseRange (beginPhase rule_act) (endPhase rule_act))
 +         -- is_active: rule_act is the activation we are going to put in the new
           --   SPEC rule; so we want to see if it is covered by another rule with
           --   that same activation.
      is_local  = isLocalId fn
@@ -1643,7 +1643,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
        , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal
        = neverInlinePragma
        | otherwise
 -      = inl_prag
 +      = fn_prag
      not_in_scope :: InterestingVarFun
      not_in_scope v = isLocalVar v && not (v `elemInScopeSet` in_scope)
@@ -1785,7 +1785,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
                         | otherwise = -- Specialising local fn
                                       text "SPEC"
 -                spec_rule = mkSpecRule dflags this_mod True inl_act
 +                spec_rule = mkSpecRule dflags this_mod True rule_act
                                      herald fn all_rule_bndrs rule_lhs_args
                                      (mkVarApps (Var spec_fn) rule_rhs_args1)
@@ -1795,9 +1795,10 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
                                         , ppr spec_rule
                                         , text "acc" <+> ppr rules_acc
                                         , text "existing" <+> ppr existing_rules
 +                                       , text "rule_act" <+> ppr rule_act
+                                        ]
 -           ; -- pprTrace "spec_call: rule" _rule_trace_doc
 +           ; pprTrace "spec_call: rule" _rule_trace_doc
               return ( spec_rule            : rules_acc
                      , (spec_fn, spec_rhs1) : pairs_acc
                      , rhs_uds2 `thenUDs` uds_acc
@@ -2380,12 +2381,13 @@ Thus when adding
  also add
          RULE f g_spec = 0
 -But that's a bit complicated.  For now we ask the programmer's help,
 -by *copying the INLINE activation pragma* to the auto-specialised
 -rule.  So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule
 -will also not be active until phase 2.  And that's what programmers
 -should jolly well do anyway, even aside from specialisation, to ensure
 -that g doesn't inline too early.
 +But that's a bit complicated.  For now we lean on the programmer:
 + * Set the activation of the RULE is the same as the activation of the Id,
 +   i.e. (idInlineActivation g)
++
 +So if `g` says {-# NOINLINE[2] g #-}, then the auto-spec rule will also not be
 +active until phase 2.  And that's what programmers should jolly well do anyway,
 +even aside from specialisation, to ensure that `g` doesn't inline too early.
  This in turn means that the RULE would never fire for a NOINLINE
  thing so not much point in generating a specialisation at all.

compiler/GHC/Core/Utils.hs

@@ -703,8 +703,14 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
        = do { (joins, alts) <- go body
               -- Check for capture; but only if we could otherwise do a merge
 -           ; let capture = outer_bndr `elem` bindersOf bind
 -                           || outer_bndr `elemVarSet` bindFreeVars bind
 +             --    (i.e. the recursive `go` succeeds)
 +             -- "Capture" means
 +             --    (a) case x of r { DEFAULT -> join r = ... in ...r... }
 +             --    (b) case x of r { DEFAULT -> join j = ...r.. in ... }
 +             -- In both cases we can't float the join point out
 +             -- because r changes its meaning
 +           ; let capture = outer_bndr `elem` bindersOf bind          -- (a)
 +                        || outer_bndr `elemVarSet` bindFreeVars bind -- (b)
             ; guard (not capture)
             ; return (bind:joins, alts ) }