sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC
Commits:
-
0bcd1aec
by sheaf at 2026-02-02T17:57:59+01:00
3 changed files:
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Types/Id.hs
- testsuite/tests/simplCore/should_compile/QuasiJoinPoints.hs
Changes:
| ... | ... | @@ -1080,23 +1080,33 @@ joinPointBinding_maybe bndr rhs |
| 1080 | 1080 | -- need to demote it to a quasi join-point.
|
| 1081 | 1081 | -- See Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration.
|
| 1082 | 1082 | | Just orig_cat <- joinId_maybe bndr
|
| 1083 | - , AlwaysTailCalled
|
|
| 1084 | - { tailCallArity = _new_arity
|
|
| 1085 | - , tailCallJoinPointType = new_cat }
|
|
| 1086 | - <- tailCallInfo (idOccInfo bndr)
|
|
| 1087 | - = assertPpr (idJoinArity bndr == _new_arity)
|
|
| 1088 | - ( vcat [ text "joinPointBinding_maybe: incompatible join arities "
|
|
| 1089 | - , text "bndr:" <+> ppr bndr
|
|
| 1090 | - , text "rhs:" <+> ppr rhs
|
|
| 1091 | - , text "prev arity:" <+> ppr (idJoinArity bndr)
|
|
| 1092 | - , text " new arity:" <+> ppr _new_arity
|
|
| 1093 | - , text "orig_cat:" <+> ppr orig_cat
|
|
| 1094 | - , text " new_cat:" <+> ppr new_cat
|
|
| 1095 | - ]
|
|
| 1096 | - ) $ Just $
|
|
| 1097 | - if orig_cat == new_cat
|
|
| 1098 | - then (bndr, rhs)
|
|
| 1099 | - else (asJoinId bndr new_cat (idJoinArity bndr), rhs)
|
|
| 1083 | + = case tailCallInfo (idOccInfo bndr) of
|
|
| 1084 | + NoTailCallInfo ->
|
|
| 1085 | + pprTrace "joinPointBinding_maybe: lost join?"
|
|
| 1086 | + (vcat
|
|
| 1087 | + [ text "bndr:" <+> ppr bndr
|
|
| 1088 | + , text "rhs:" <+> ppr rhs
|
|
| 1089 | + , text "arity:" <+> ppr (idJoinArity bndr)
|
|
| 1090 | + , text "cat:" <+> ppr orig_cat
|
|
| 1091 | + , text "occ_info:" <+> ppr (idOccInfo bndr)
|
|
| 1092 | + ])
|
|
| 1093 | + Nothing
|
|
| 1094 | + AlwaysTailCalled
|
|
| 1095 | + { tailCallArity = _new_arity
|
|
| 1096 | + , tailCallJoinPointType = new_cat } ->
|
|
| 1097 | + assertPpr (idJoinArity bndr == _new_arity)
|
|
| 1098 | + ( vcat [ text "joinPointBinding_maybe: incompatible join arities "
|
|
| 1099 | + , text "bndr:" <+> ppr bndr
|
|
| 1100 | + , text "rhs:" <+> ppr rhs
|
|
| 1101 | + , text "prev arity:" <+> ppr (idJoinArity bndr)
|
|
| 1102 | + , text " new arity:" <+> ppr _new_arity
|
|
| 1103 | + , text "orig_cat:" <+> ppr orig_cat
|
|
| 1104 | + , text " new_cat:" <+> ppr new_cat
|
|
| 1105 | + ]
|
|
| 1106 | + ) $ Just $
|
|
| 1107 | + if orig_cat == new_cat
|
|
| 1108 | + then (bndr, rhs)
|
|
| 1109 | + else (asJoinId bndr new_cat (idJoinArity bndr), rhs)
|
|
| 1100 | 1110 | |
| 1101 | 1111 | | AlwaysTailCalled
|
| 1102 | 1112 | { tailCallArity = join_arity
|
| ... | ... | @@ -692,10 +692,16 @@ idJoinArity id = |
| 692 | 692 | JoinPoint { joinPointArity = ar } -> ar
|
| 693 | 693 | NotJoinPoint -> pprPanic "idJoinArity" (ppr id)
|
| 694 | 694 | |
| 695 | -asJoinId :: Id -> JoinPointCategory -> JoinArity -> JoinId
|
|
| 695 | +asJoinId :: HasDebugCallStack => Id -> JoinPointCategory -> JoinArity -> JoinId
|
|
| 696 | 696 | asJoinId id cat arity
|
| 697 | 697 | = warnPprTrace (not (isLocalId id))
|
| 698 | 698 | "global id being marked as join var" (ppr id) $
|
| 699 | + -- SLD TODO debugging
|
|
| 700 | + pprTrace "asJoinId"
|
|
| 701 | + ( vcat [ text "id:" <+> ppr id
|
|
| 702 | + , text "cat:" <+> ppr cat
|
|
| 703 | + , text "callstack:" <+> callStackDoc
|
|
| 704 | + ]) $
|
|
| 699 | 705 | id `setIdDetails` JoinId cat arity cbv_info
|
| 700 | 706 | where
|
| 701 | 707 | cbv_info = case Var.idDetails id of
|
| ... | ... | @@ -133,3 +133,50 @@ testQuasiTransitivity b n = |
| 133 | 133 | True -> {-# SCC "ticked" #-} j3 10
|
| 134 | 134 | False -> j3 20
|
| 135 | 135 | )
|
| 136 | + |
|
| 137 | +--------------------------------------------------------------------------------
|
|
| 138 | +-- Extracted from a GHC bootstrapping bug
|
|
| 139 | + |
|
| 140 | +data AB = A | B
|
|
| 141 | + |
|
| 142 | +data Int2 = MkInt2
|
|
| 143 | + |
|
| 144 | +expt :: Int2 -> Int2
|
|
| 145 | +expt _ = MkInt2
|
|
| 146 | +{-# NOINLINE expt #-}
|
|
| 147 | + |
|
| 148 | +add :: Int2 -> Int2 -> Int2
|
|
| 149 | +add _ _ = MkInt2
|
|
| 150 | +{-# NOINLINE add #-}
|
|
| 151 | + |
|
| 152 | +big :: Int2 -> AB
|
|
| 153 | +big _ = A
|
|
| 154 | +{-# NOINLINE big #-}
|
|
| 155 | + |
|
| 156 | +baz :: Int2
|
|
| 157 | +baz = MkInt2
|
|
| 158 | +{-# NOINLINE baz #-}
|
|
| 159 | + |
|
| 160 | +no :: a
|
|
| 161 | +no = no
|
|
| 162 | +{-# NOINLINE no #-}
|
|
| 163 | + |
|
| 164 | +mul :: Int2 -> Int2 -> Int2
|
|
| 165 | +mul !_ !_ = no
|
|
| 166 | +{-# INLINE mul #-}
|
|
| 167 | + |
|
| 168 | +data T2 a b = MkT2 a b
|
|
| 169 | + |
|
| 170 | +floatToDigits2 :: T2 Int2 Int2 -> T2 Int2 Int2
|
|
| 171 | +floatToDigits2 ( MkT2 f0 e0 ) =
|
|
| 172 | + let
|
|
| 173 | + MkT2 f e =
|
|
| 174 | + let n = e0
|
|
| 175 | + in
|
|
| 176 | + case big n of
|
|
| 177 | + A -> MkT2 f0 ( add e0 n )
|
|
| 178 | + B -> MkT2 f0 e0
|
|
| 179 | + r = let be = expt e in mul f be
|
|
| 180 | + |
|
| 181 | + in
|
|
| 182 | + MkT2 r baz |