sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: de6b5a96 by sheaf at 2026-01-27T13:18:15+01:00 try to fix - - - - - 1 changed file: - compiler/GHC/Core/Opt/Simplify/Iteration.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2056,16 +2056,19 @@ is a join point, and what 'cont' is, in a value of type MaybeJoinCont of a SpecConstr-generated RULE for a join point. -} --- SLD TODO horrible logic that must be removed -peelJoinResTy :: Int -> Type -> Type -peelJoinResTy 0 ty = ty -peelJoinResTy n ty - | Just (_bndr, inner_ty) <- splitForAllTyCoVar_maybe ty - = peelJoinResTy n inner_ty - | Just (_, _mult, _arg, res_ty) <- splitFunTy_maybe ty - = peelJoinResTy (n-1) res_ty - | otherwise - = ty +joinResTy :: HasDebugCallStack => JoinArity -> Type -> Type +joinResTy n0 ty0 = go n0 ty0 + where + go !n ty + | Just (_bndr, res_ty) <- splitPiTy_maybe ty + = go (n-1) res_ty + | otherwise + = pprPanic "joinResTy" $ + vcat [ text "join arity:" <+> ppr n0 + , text "join ty:" <+> ppr ty0 + , text "n:" <+> ppr n + , text "ty:" <+> ppr ty + ] simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr -> InExpr -> SimplCont @@ -2078,12 +2081,18 @@ simplNonRecJoinPoint env bndr rhs body cont ; let (mult, res_ty) -- SLD TODO | Just QuasiJoinPoint <- joinId_maybe bndr - = (idMult bndr, peelJoinResTy (idJoinArity bndr) $ substTy env (idType bndr)) + = (idMult bndr, joinResTy (idJoinArity bndr) $ substTy env (idType bndr)) | otherwise = (contHoleScaling cont, contResultType cont) + + -- SLD TODO explain, refactor + ; let bind_cont + | do_case_case = cont + | otherwise = mkBoringStop res_ty + ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont) - ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env) + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive bind_cont) + ; (floats1, env3) <- simplJoinBind NonRecursive bind_cont (bndr,env) (bndr2,env2) (rhs,env) ; (floats2, body') <- simplExprF env3 body cont ; return (floats1 `addFloats` floats2, body') } where @@ -2096,23 +2105,30 @@ simplNonRecJoinPoint env bndr rhs body cont simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplRecJoinPoint env pairs body cont - = wrapJoinCont do_case_case env cont $ \ env cont -> +simplRecJoinPoint env pairs body cont0 + = wrapJoinCont do_case_case env cont0 $ \ env cont -> do { let bndrs = map fst pairs (mult, res_ty) -- SLD TODO - | [b] <- bndrs + | b:_ <- bndrs , Just QuasiJoinPoint <- joinId_maybe b - = (idMult b, peelJoinResTy (idJoinArity b) $ substTy env (idType b)) + = (idMult b, joinResTy (idJoinArity b) $ substTy env (idType b)) | otherwise = (contHoleScaling cont, contResultType cont) ; env1 <- simplRecJoinBndrs env bndrs mult res_ty -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down - ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs + + -- SLD TODO explain, refactor + ; let bind_cont + | do_case_case = cont + | otherwise = mkBoringStop res_ty + + ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive bind_cont) pairs ; (floats2, body') <- simplExprF env2 body cont ; return (floats1 `addFloats` floats2, body') } where + do_case_case = if all ((== Just TrueJoinPoint) . joinId_maybe . fst) pairs then seCaseCase env View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/de6b5a969c27b3efee23166710b8a23b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/de6b5a969c27b3efee23166710b8a23b... You're receiving this email because of your account on gitlab.haskell.org.