sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: 8d17a905 by sheaf at 2026-02-02T18:13:58+01:00 WIP: debugging - - - - - 3 changed files: - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Types/Id.hs - testsuite/tests/simplCore/should_compile/QuasiJoinPoints.hs Changes: ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -1080,23 +1080,36 @@ joinPointBinding_maybe bndr rhs -- need to demote it to a quasi join-point. -- See Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. | Just orig_cat <- joinId_maybe bndr - , AlwaysTailCalled - { tailCallArity = _new_arity - , tailCallJoinPointType = new_cat } - <- tailCallInfo (idOccInfo bndr) - = assertPpr (idJoinArity bndr == _new_arity) - ( vcat [ text "joinPointBinding_maybe: incompatible join arities " - , text "bndr:" <+> ppr bndr - , text "rhs:" <+> ppr rhs - , text "prev arity:" <+> ppr (idJoinArity bndr) - , text " new arity:" <+> ppr _new_arity - , text "orig_cat:" <+> ppr orig_cat - , text " new_cat:" <+> ppr new_cat - ] - ) $ Just $ - if orig_cat == new_cat - then (bndr, rhs) - else (asJoinId bndr new_cat (idJoinArity bndr), rhs) + = case tailCallInfo (idOccInfo bndr) of + NoTailCallInfo -> + pprTrace "joinPointBinding_maybe: lost join?" + (vcat + [ text "bndr:" <+> ppr bndr + , text "rhs:" <+> ppr rhs + , text "arity:" <+> ppr (idJoinArity bndr) + , text "cat:" <+> ppr orig_cat + , text "occ_info:" <+> ppr (idOccInfo bndr) + ]) $ + -- SLD TODO: I don't understand how this can happen, but apparently + -- it can. For now I'm preserving the join, but further investigation + -- is needed. + Just (bndr, rhs) + AlwaysTailCalled + { tailCallArity = _new_arity + , tailCallJoinPointType = new_cat } -> + assertPpr (idJoinArity bndr == _new_arity) + ( vcat [ text "joinPointBinding_maybe: incompatible join arities " + , text "bndr:" <+> ppr bndr + , text "rhs:" <+> ppr rhs + , text "prev arity:" <+> ppr (idJoinArity bndr) + , text " new arity:" <+> ppr _new_arity + , text "orig_cat:" <+> ppr orig_cat + , text " new_cat:" <+> ppr new_cat + ] + ) $ Just $ + if orig_cat == new_cat + then (bndr, rhs) + else (asJoinId bndr new_cat (idJoinArity bndr), rhs) | AlwaysTailCalled { tailCallArity = join_arity ===================================== compiler/GHC/Types/Id.hs ===================================== @@ -692,10 +692,16 @@ idJoinArity id = JoinPoint { joinPointArity = ar } -> ar NotJoinPoint -> pprPanic "idJoinArity" (ppr id) -asJoinId :: Id -> JoinPointCategory -> JoinArity -> JoinId +asJoinId :: HasDebugCallStack => Id -> JoinPointCategory -> JoinArity -> JoinId asJoinId id cat arity = warnPprTrace (not (isLocalId id)) "global id being marked as join var" (ppr id) $ + -- SLD TODO debugging + pprTrace "asJoinId" + ( vcat [ text "id:" <+> ppr id + , text "cat:" <+> ppr cat + , text "callstack:" <+> callStackDoc + ]) $ id `setIdDetails` JoinId cat arity cbv_info where cbv_info = case Var.idDetails id of ===================================== testsuite/tests/simplCore/should_compile/QuasiJoinPoints.hs ===================================== @@ -133,3 +133,50 @@ testQuasiTransitivity b n = True -> {-# SCC "ticked" #-} j3 10 False -> j3 20 ) + +-------------------------------------------------------------------------------- +-- Extracted from a GHC bootstrapping bug + +data AB = A | B + +data Int2 = MkInt2 + +expt :: Int2 -> Int2 +expt _ = MkInt2 +{-# NOINLINE expt #-} + +add :: Int2 -> Int2 -> Int2 +add _ _ = MkInt2 +{-# NOINLINE add #-} + +big :: Int2 -> AB +big _ = A +{-# NOINLINE big #-} + +baz :: Int2 +baz = MkInt2 +{-# NOINLINE baz #-} + +no :: a +no = no +{-# NOINLINE no #-} + +mul :: Int2 -> Int2 -> Int2 +mul !_ !_ = no +{-# INLINE mul #-} + +data T2 a b = MkT2 a b + +floatToDigits2 :: T2 Int2 Int2 -> T2 Int2 Int2 +floatToDigits2 ( MkT2 f0 e0 ) = + let + MkT2 f e = + let n = e0 + in + case big n of + A -> MkT2 f0 ( add e0 n ) + B -> MkT2 f0 e0 + r = let be = expt e in mul f be + + in + MkT2 r baz View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8d17a90585f186ee1d46776fcfc62a24... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8d17a90585f186ee1d46776fcfc62a24... You're receiving this email because of your account on gitlab.haskell.org.