GitLab

sheaf pushed to branch wip/debug-join-point at Glasgow Haskell Compiler / GHC

Commits:

3677cb90
by sheaf at 2026-02-03T14:03:13+01:00
```
WIP: debug panic
```

2 changed files:

compiler/GHC/Core/Opt/Simplify/Iteration.hs
compiler/GHC/Core/SimpleOpt.hs

Changes:

compiler/GHC/Core/Opt/Simplify/Iteration.hs

@@ -316,8 +316,8 @@ simplLazyBind :: TopLevelFlag -> RecFlag
  -- Precondition: Ids only, no TyVars; not a JoinId
  -- Precondition: rhs obeys the let-can-float invariant
  simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se)
 -  = assert (isId bndr )
 -    assertPpr (not (isJoinId bndr)) (ppr bndr) $
 +  = assert (isId bndr)
 +    assertPpr (isNothing (joinPointBinding_maybe bndr rhs)) (ppr bndr) $
      -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
      do  { let   !rhs_env     = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]
                  (tvs, body) = case collectTyAndValBinders rhs of
@@ -399,7 +399,7 @@ simplAuxBind :: String
  -- Precondition: rhs satisfies the let-can-float invariant
  simplAuxBind _str env bndr new_rhs
 -  | assertPpr (isId bndr && not (isJoinId bndr)) (ppr bndr) $
 +  | assertPpr (isId bndr && isNothing (joinPointBinding_maybe bndr new_rhs)) (ppr bndr) $
      isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
    = return (emptyFloats env, env)    --  Here c is dead, and we avoid
                                       --  creating the binding c = (a,b)
@@ -1905,7 +1905,7 @@ simplNonRecE :: HasDebugCallStack
  -- Otherwise it may or may not satisfy it.
  simplNonRecE env from_what bndr (rhs, rhs_se) body cont
 -  | assert (isId bndr && not (isJoinId bndr) ) $
 +  | assert (isId bndr && isNothing (joinPointBinding_maybe bndr rhs)) $
      is_strict_bind
    = -- Evaluate RHS strictly
      simplExprF (rhs_se `setInScopeFromE` env) rhs
@@ -1943,7 +1943,7 @@ simplRecE :: SimplEnv
  -- Precondition: not a join-point binding
  simplRecE env pairs body cont
    = do  { let bndrs = map fst pairs
 -        ; massert (all (not . isJoinId) bndrs)
 +        ; massert (isNothing $ joinPointBindings_maybe pairs)
          ; env1 <- simplRecBndrs env bndrs
                  -- NB: bndrs' don't have unfoldings or rules
                  -- We add them as we go down
@@ -2051,7 +2051,7 @@ simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr
                       -> InExpr -> SimplCont
                       -> SimplM (SimplFloats, OutExpr)
  simplNonRecJoinPoint env bndr rhs body cont
 -   = assert (isJoinId bndr ) $
 +   = assert (isJust $ joinPointBinding_maybe bndr rhs) $
       wrapJoinCont env cont $ \ env cont ->
       do { -- We push join_cont into the join RHS and the body;
            -- and wrap wrap_cont around the whole thing
@@ -4574,22 +4574,24 @@ simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf
    | isStableUnfolding unf
    = simplStableUnfolding env bind_cxt id rhs_ty arity unf
 -  | freshly_born_join_point id
 -  = -- This is a tricky one!
 -    -- See wrinkle (JU1) in Note [Do not add unfoldings to join points at birth]
 -    return noUnfolding
+-
    | isExitJoinId id
    = -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify
      return noUnfolding
 -  | otherwise
 -  = mkLetUnfolding env (bindContextLevel bind_cxt) VanillaSrc id is_join_point new_rhs
 +  | freshly_born_join_point
 +  = -- This is a tricky one!
 +    -- See wrinkle (JU1) in Note [Do not add unfoldings to join points at birth]
 +    return noUnfolding
 +  | otherwise
 +  = mkLetUnfolding env (bindContextLevel bind_cxt) VanillaSrc id' is_join new_rhs'
    where
 -    is_join_point = isJoinId id
 -    freshly_born_join_point id = is_join_point && isManyOccs (idOccInfo id)
 -      -- OLD: too_many_occs (OneOcc { occ_n_br = n }) = n > 10 -- See #23627
 +    (id', new_rhs', is_join) =
 +      case joinPointBinding_maybe id new_rhs of
 +        Nothing -> (id, new_rhs, False)
 +        Just (id', new_rhs') -> (id', new_rhs', True)
 +    freshly_born_join_point =
 +      is_join && (not (isJoinId id) || isManyOccs (idOccInfo id))
  -------------------
  mkLetUnfolding :: SimplEnv -> TopLevelFlag -> UnfoldingSource

compiler/GHC/Core/SimpleOpt.hs

@@ -1059,28 +1059,27 @@ and again its arity increases (#15517)
  -}
 --- | Returns Just (bndr,rhs) if the binding is a join point:
 --- If it's a JoinId, just return it
 --- If it's not yet a JoinId but is always tail-called,
 ---    make it into a JoinId and return it.
 --- In the latter case, eta-expand the RHS if necessary, to make the
 --- lambdas explicit, as is required for join points
 ---
 --- Precondition: the InBndr has been occurrence-analysed,
 ---               so its OccInfo is valid
 +-- | Returns @Just (bndr,rhs)@ if the binding is a join point or can be made
 +-- into a join point (it is always tail called). In the latter case, eta-expand
 +-- the RHS if necessary, to make the lambdas explicit, as is required for join points.
  joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
  joinPointBinding_maybe bndr rhs
    | not (isId bndr)
    = Nothing
 +  -- NB: the 'OccInfo' of the 'InBndr' may have been zapped, e.g. if we
 +  -- have inlined it. In this case, we may lose the join-point-hood of the
 +  -- original binder. A later occurrence analysis pass may recover it.
    | isJoinId bndr
 -  = Just (bndr, rhs)
 +  = case tailCallInfo (idOccInfo bndr) of
 +      NoTailCallInfo -> Nothing
 +      AlwaysTailCalled {} -> Just (bndr, rhs)
    | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)
    , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs
    , let str_sig   = idDmdSig bndr
          str_arity = count isId bndrs  -- Strictness demands are for Ids only
 -        join_bndr = bndr `asJoinId`        join_arity
 +        join_bndr = bndr `asJoinId`    join_arity
                           `setIdDmdSig` etaConvertDmdSig str_arity str_sig
    = Just (join_bndr, mkLams bndrs body)