GitLab

sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC

Commits:

e4500d48
by sheaf at 2026-01-26T23:46:57+01:00
```
fix fix
```
5239e258
by sheaf at 2026-01-27T00:01:20+01:00
```
working?
```

4 changed files:

compiler/GHC/Core/Lint.hs
compiler/GHC/Core/Opt/OccurAnal.hs
compiler/GHC/Core/Opt/SetLevels.hs
compiler/GHC/Core/Opt/Simplify/Iteration.hs

Changes:

@@ -1151,7 +1151,11 @@ lintJoinBndrType :: OutType -- Type of the body
  -- E.g. join j x = rhs in body
  --      The type of 'rhs' must be the same as the type of 'body'
  lintJoinBndrType body_ty bndr
 -  | JoinPoint { joinPointArity = arity } <- idJoinPointHood bndr
 +  | JoinPoint
 +    { joinPointArity = arity
 +    , joinPointType = TrueJoinPoint
 +      -- SLD TODO: quasi join points can have intervening casts
 +    } <- idJoinPointHood bndr
    , let bndr_ty = idType bndr
    , (bndrs, res) <- splitPiTys bndr_ty
    = do let msg =

compiler/GHC/Core/Opt/OccurAnal.hs

@@ -1127,7 +1127,7 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs
      -- returned by of occAnalLamTail. It's totally OK for them to mismatch;
      -- hence adjust the UDs from the RHS
 -    WUD adj_rhs_uds final_rhs = adjustNonRecRhs (joinPointHoodArity mb_join) $
 +    WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $
                                  occAnalLamTail rhs_env rhs
      final_bndr_with_rules
        | noBinderSwaps env = bndr -- See Note [Unfoldings and rules]
@@ -1217,7 +1217,7 @@ occAnalRec !_ lvl
    = WUD body_uds binds
    | otherwise
    = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr
 -        !(WUD rhs_uds' rhs') = adjustNonRecRhs (joinPointHoodArity mb_join) wtuds
 +        !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds
      in WUD (body_uds `andUDs` rhs_uds')
             (NonRec bndr' rhs' : binds)
    where
@@ -2621,7 +2621,7 @@ occAnal env app@(App _ _)
    = occAnalApp env (collectArgsTicks tickishFloatable app)
  occAnal env expr@(Lam {})
 -  = adjustNonRecRhs Nothing $ -- Nothing <=> markAllManyNonTail
 +  = adjustNonRecRhs NotJoinPoint $ -- NotJoinPoint <=> markAllManyNonTail
      occAnalLamTail env expr
  occAnal env (Case scrut bndr ty alts)
@@ -2749,7 +2749,7 @@ occAnalApp env (Var fun, args, ticks)
    --     This caused #18296
    | fun `hasKey` runRWKey
    , [t1, t2, arg]  <- args
 -  , WUD usage arg' <- adjustNonRecRhs (Just 1) $ occAnalLamTail env arg
 +  , WUD usage arg' <- adjustNonRecRhs (JoinPoint TrueJoinPoint 1) $ occAnalLamTail env arg
    = let app_out = mkTicks ticks $ mkApps (Var fun) [t1, t2, arg']
      in WUD usage app_out
@@ -3975,21 +3975,21 @@ lookupOccInfoByUnique (UD { ud_env       = env
  -------------------
  -- See Note [Adjusting right-hand sides]
 -adjustNonRecRhs :: Maybe JoinArity
 +adjustNonRecRhs :: JoinPointHood
                  -> WithTailUsageDetails CoreExpr
                  -> WithUsageDetails CoreExpr
  -- ^ This function concentrates shared logic between occAnalNonRecBind and the
  -- AcyclicSCC case of occAnalRec.
  -- It returns the adjusted rhs UsageDetails combined with the body usage
 -adjustNonRecRhs mb_join_arity (WTUD (TUD rhs_ja uds) rhs)
 +adjustNonRecRhs mb_join (WTUD (TUD rhs_ja uds) rhs)
    = WUD (adjustTailUsage exact_join rhs uds) rhs
    where
      exact_join =
 -      case mb_join_arity of
 -        Nothing -> Nothing
 -        Just ja' ->
 +      case mb_join of
 +        NotJoinPoint -> Nothing
 +        JoinPoint { joinPointArity = ja', joinPointType = ty } ->
            if ja' == rhs_ja
 -          then Just TrueJoinPoint
 +          then Just ty
            else Nothing
  adjustTailUsage :: HasDebugCallStack
@@ -4120,11 +4120,8 @@ decideRecJoinPointHood :: TopLevelFlag -> UsageDetails
                         -> [CoreBndr] -> Maybe JoinPointType
  decideRecJoinPointHood lvl usage bndrs = do
    bndrsNE <- NE.nonEmpty bndrs
 -  res <- Semi.sconcat <$> traverse ok bndrsNE  -- Invariant 3: Either all are join points or none are
 -  pprTraceM "decideRecJoinPointHood" $
 -    vcat [ text "bndrs:" <+> ppr bndrs
 -         , text "res:" <+> ppr res ]
 -  return res
 +  -- Invariant 3: Either all are join points or none are
 +  Semi.sconcat <$> traverse ok bndrsNE
    where
      ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr)
@@ -4132,10 +4129,11 @@ okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Maybe JoinPointType
      -- See Note [Invariants on join points]; invariants cited by number below.
      -- Invariant 2 is always satisfiable by the simplifier by eta expansion.
  okForJoinPoint lvl bndr tail_call_info
 -  | Just join_ty <- joinId_maybe bndr
 +  | isJoinId bndr
    -- A current join point should still be one!
    = warnPprTrace lost_join "Lost join point" lost_join_doc $
 -    Just join_ty
 +      mb_valid_join
 +    -- NB: we might downgrade 'TrueJoinPoint' to 'QuasiJoinPoint'.
    | otherwise
    = mb_valid_join
    where

compiler/GHC/Core/Opt/SetLevels.hs

@@ -1895,7 +1895,7 @@ newPolyBndrs dest_lvl
        , not dest_is_top
        = asJoinId new_bndr
            join_ty
 -          ( join_arity + length abs_vars )
 +          (join_arity + length abs_vars)
        | otherwise
        = new_bndr

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

@@ -2088,7 +2088,7 @@ simplNonRecJoinPoint env bndr rhs body cont
          ; return (floats1 `addFloats` floats2, body') }
    where
      do_case_case
 -      | Just TrueJoinPoint <- occInfoJoinPointType_maybe (idOccInfo bndr)
 +      | Just TrueJoinPoint <- joinId_maybe bndr
        = seCaseCase env
        | otherwise
        = False
@@ -2114,7 +2114,7 @@ simplRecJoinPoint env pairs body cont
         ; return (floats1 `addFloats` floats2, body') }
    where
      do_case_case =
 -      if all ((== Just TrueJoinPoint) . occInfoJoinPointType_maybe . idOccInfo . fst) pairs
 +      if all ((== Just TrueJoinPoint) . joinId_maybe . fst) pairs
        then seCaseCase env
        else False
@@ -2154,15 +2154,15 @@ trimJoinCont :: Id         -- Used only in error message
  trimJoinCont _ NotJoinPoint cont
    = cont -- Not a jump
  trimJoinCont var (JoinPoint { joinPointType = join_ty, joinPointArity = arity }) cont
 -  | QuasiJoinPoint <- join_ty
 -  -- SLD TODO
 -  = cont
 -  | otherwise
    = trim arity cont
    where
      trim 0 cont@(Stop {})
        = cont
      trim 0 cont
 +      | QuasiJoinPoint <- join_ty
 +      -- SLD TODO explain
 +      = cont
 +      | otherwise
        = mkBoringStop (contResultType cont)
      trim n cont@(ApplyToVal { sc_cont = k })
        = cont { sc_cont = trim (n-1) k }