[Git][ghc/ghc][wip/T22227] 2 commits: Loopification in OccurAnal (#22227, #14068)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Sat Oct 1 11:57:25 UTC 2022
Sebastian Graf pushed to branch wip/T22227 at Glasgow Haskell Compiler / GHC
Commits:
313531a1 by Sebastian Graf at 2022-10-01T13:56:34+02:00
Loopification in OccurAnal (#22227, #14068)
- - - - -
86ef6fa3 by Sebastian Graf at 2022-10-01T13:56:45+02:00
DmdAnal: Look through DataConWrappers (#22241)
- - - - -
10 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- testsuite/tests/linear/should_compile/LinearLetRec.hs
- + testsuite/tests/simplCore/should_compile/T22227.hs
- + testsuite/tests/simplCore/should_compile/T22227.stderr
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/stranal/sigs/T22241.hs
- + testsuite/tests/stranal/sigs/T22241.stderr
- testsuite/tests/stranal/sigs/T5075.hs
- testsuite/tests/stranal/sigs/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -932,6 +932,9 @@ dmdTransform env var sd
| isDataConWorkId var
= -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr var $$ ppr sd $$ ppr ty) $
dmdTransformDataConSig (idArity var) sd
+ | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var)
+ , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs
+ = dmd_ty
-- Dictionary component selectors
-- Used to be controlled by a flag.
-- See #18429 for some perf measurements.
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -58,7 +58,7 @@ import GHC.Utils.Trace
import GHC.Builtin.Names( runRWKey )
import GHC.Unit.Module( Module )
-import Data.List (mapAccumL, mapAccumR)
+import Data.List (mapAccumL, mapAccumR, find)
{-
************************************************************************
@@ -856,15 +856,31 @@ occAnalRec !_ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs
-- See Note [Recursive bindings: the grand plan]
-- See Note [Loop breaking]
occAnalRec env lvl (CyclicSCC details_s) (WithUsageDetails body_uds binds)
- | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds
+ | null used_bndrs
= WithUsageDetails body_uds binds -- See Note [Dead code]
+ | [loop_entry] <- used_bndrs
+ , let orig_occ = lookupDetails body_uds loop_entry
+ , NoTailCallInfo <- tailCallInfo orig_occ
+--- , case orig_occ of OneOcc{occ_in_lam=NotInsideLam}->False; _ -> True
+ , let unadj_uds = foldr (andUDs . nd_uds) emptyDetails details_s
+ , decideJoinPointHood lvl unadj_uds bndrs
+ , AlwaysTailCalled arity <- tailCallInfo $ lookupDetails unadj_uds loop_entry
+ , Just loop_nds <- find ((== loop_entry) . nd_bndr) details_s
+ , (!lam_bndrs,_) <- collectNBinders arity (nd_rhs loop_nds)
+ , let !loop_body_uds = mkOneOcc loop_entry IsInteresting arity
+ , WithUsageDetails new_rhs_uds loop_binds <- occAnalRec env lvl (CyclicSCC details_s) (WithUsageDetails loop_body_uds [])
+ , (body_uds',loop_entry') <- tagNonRecBinder lvl body_uds loop_entry
+ , let new_bind = NonRec loop_entry' (mkLams lam_bndrs (mkLets loop_binds (mkVarApps (Var loop_entry') lam_bndrs)))
+ = WithUsageDetails (markAllNonTail new_rhs_uds `andUDs` body_uds') (new_bind : binds)
+
| otherwise -- At this point we always build a single Rec
= -- pprTrace "occAnalRec" (ppr loop_breaker_nodes)
WithUsageDetails final_uds (Rec pairs : binds)
where
bndrs = map nd_bndr details_s
+ used_bndrs = filter (`usedIn` body_uds) bndrs -- NB: look at body_uds, not total_uds
all_simple = all nd_simple details_s
------------------------------
=====================================
testsuite/tests/linear/should_compile/LinearLetRec.hs
=====================================
@@ -8,4 +8,13 @@ extendOrigNameCache _ _ = Name
initNameCache :: Int -> [Name] -> NameCache
initNameCache us names
- = NameCache us (foldl extendOrigNameCache Name names)
+ = NameCache us (go Name names)
+ where
+ -- go will become a join point once $WNameCache inlines. That join point
+ -- has a nullary exit join point with a problematic linearity.
+ -- The NOINLINE makes sure that call-site loopification doesn't turn go into
+ -- a joinrec before $WNameCache inlines
+ go acc [] = acc
+ -- head names `seq` ... so that `go` doesn't float to top-level
+ go acc (n:ns) = head names `seq` go (extendOrigNameCache acc n) ns
+ {-# NOINLINE go #-} -- see above comment
=====================================
testsuite/tests/simplCore/should_compile/T22227.hs
=====================================
@@ -0,0 +1,39 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Unboxed (test) where
+
+import GHC.Exts
+import GHC.IO
+
+data Step s a = Yield a s | Done
+
+uninitialised = undefined
+
+test :: Int# -> Int# -> Array# Double -> (# Int#, Int#, Array# Double #)
+test off n oldArr = runRW# $ \s0 ->
+ case newArray# n uninitialised s0
+ of { (# s1, newArr #) ->
+ let
+ step' i
+ | isTrue# (i >=# n) = Done
+ | otherwise =
+ let (# D# x #) = indexArray# oldArr (off +# i) in
+ if isTrue# (x >## 10.0##)
+ then Yield (D# x) (I# (i +# 1#))
+ else step' (i +# 1#)
+ loop i j s2 =
+ case step' i of
+ Yield x (I# s') ->
+ case writeArray# newArr j (x + 1) s2
+ of { s3 ->
+ loop s' (j +# 1#) s3
+ }
+ Done ->
+ case unsafeFreezeArray# newArr s2
+ of { (# s3, out #) ->
+ (# 0#, j, out #)
+ }
+ in
+ loop 0# 0# s1
+ }
=====================================
testsuite/tests/simplCore/should_compile/T22227.stderr
=====================================
@@ -0,0 +1,326 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 213, types: 211, coercions: 4, joins: 5/5}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+lvl_rUP :: Addr#
+[GblId, Unf=OtherCon []]
+lvl_rUP = "undefined"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl1_rUQ :: [Char]
+[GblId]
+lvl1_rUQ = unpackCString# lvl_rUP
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$trModule4 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+Unboxed.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl2_rUR :: [Char]
+[GblId]
+lvl2_rUR = unpackCString# Unboxed.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$trModule2 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+Unboxed.$trModule2 = "Unboxed"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl3_rUS :: [Char]
+[GblId]
+lvl3_rUS = unpackCString# Unboxed.$trModule2
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+lvl4_rUT :: Addr#
+[GblId, Unf=OtherCon []]
+lvl4_rUT = "T22227.hs"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl5_rUU :: [Char]
+[GblId]
+lvl5_rUU = unpackCString# lvl4_rUT
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl6_rUV :: Int
+[GblId, Unf=OtherCon []]
+lvl6_rUV = GHC.Types.I# 11#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl7_rUW :: Int
+[GblId, Unf=OtherCon []]
+lvl7_rUW = GHC.Types.I# 17#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl8_rUX :: Int
+[GblId, Unf=OtherCon []]
+lvl8_rUX = GHC.Types.I# 26#
+
+-- RHS size: {terms: 8, types: 0, coercions: 0, joins: 0/0}
+lvl9_rUY :: GHC.Stack.Types.SrcLoc
+[GblId, Unf=OtherCon []]
+lvl9_rUY
+ = GHC.Stack.Types.SrcLoc
+ lvl2_rUR lvl3_rUS lvl5_rUU lvl6_rUV lvl7_rUW lvl6_rUV lvl8_rUX
+
+-- RHS size: {terms: 4, types: 0, coercions: 0, joins: 0/0}
+lvl10_rUZ :: GHC.Stack.Types.CallStack
+[GblId, Unf=OtherCon []]
+lvl10_rUZ
+ = GHC.Stack.Types.PushCallStack
+ lvl1_rUQ lvl9_rUY GHC.Stack.Types.EmptyCallStack
+
+-- RHS size: {terms: 3, types: 3, coercions: 4, joins: 0/0}
+uninitialised :: forall {a}. a
+[GblId, Str=b, Cpr=b]
+uninitialised
+ = \ (@a_aCz) ->
+ undefined
+ @LiftedRep
+ @a_aCz
+ (lvl10_rUZ
+ `cast` (Sym (GHC.Classes.N:IP[0]
+ <"callStack">_N <GHC.Stack.Types.CallStack>_N)
+ :: GHC.Stack.Types.CallStack
+ ~R# (?callStack::GHC.Stack.Types.CallStack)))
+
+-- RHS size: {terms: 90, types: 151, coercions: 0, joins: 5/5}
+test
+ :: Int# -> Int# -> Array# Double -> (# Int#, Int#, Array# Double #)
+[GblId,
+ Arity=3,
+ Str=<L><L><L>,
+ Cpr=1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0 0] 137 0}]
+test
+ = \ (off_axL :: Int#)
+ (n_axM :: Int#)
+ (oldArr_axN :: Array# Double) ->
+ runRW#
+ @('TupleRep '[ 'IntRep, 'IntRep, UnliftedRep])
+ @(# Int#, Int#, Array# Double #)
+ (\ (s_sSR [OS=OneShot] :: State# RealWorld) ->
+ case newArray#
+ @'Lifted @Double @RealWorld n_axM (uninitialised @Double) s_sSR
+ of
+ { (# ipv_sSS, ipv1_sST #) ->
+ join {
+ exit_X0 [Dmd=SC(S,C(1,!P(L,L,L)))]
+ :: Int# -> State# RealWorld -> (# Int#, Int#, Array# Double #)
+ [LclId[JoinId(2)(Nothing)], Arity=2, Str=<L><L>]
+ exit_X0 (j_ay1 [OS=OneShot] :: Int#)
+ (s2_ay2 [OS=OneShot] :: State# RealWorld)
+ = case unsafeFreezeArray#
+ @'Lifted @RealWorld @Double ipv1_sST s2_ay2
+ of
+ { (# ipv2_sT8, ipv3_sT9 #) ->
+ (# 0#, j_ay1, ipv3_sT9 #)
+ } } in
+ joinrec {
+ loop_sTq [Occ=LoopBreaker, Dmd=SC(S,C(1,C(1,L)))]
+ :: Int#
+ -> Int# -> State# RealWorld -> (# Int#, Int#, Array# Double #)
+ [LclId[JoinId(3)(Nothing)],
+ Arity=3,
+ Str=<L><L><L>,
+ Unf=OtherCon []]
+ loop_sTq (i_ay0 :: Int#)
+ (j_ay1 :: Int#)
+ (s2_ay2 :: State# RealWorld)
+ = join {
+ exit1_X4 [Dmd=LC(S,C(1,!P(L,L,L)))]
+ :: Int# -> Double# -> (# Int#, Int#, Array# Double #)
+ [LclId[JoinId(2)(Nothing)], Arity=2, Str=<L><L>]
+ exit1_X4 (i1_X1 [OS=OneShot] :: Int#)
+ (x_aPv [OS=OneShot] :: Double#)
+ = case writeArray#
+ @'Lifted
+ @RealWorld
+ @Double
+ ipv1_sST
+ j_ay1
+ (GHC.Types.D# (+## x_aPv 1.0##))
+ s2_ay2
+ of s3_aAH
+ { __DEFAULT ->
+ jump loop_sTq (+# i1_X1 1#) (+# j_ay1 1#) s3_aAH
+ } } in
+ join {
+ $j_sTM [Dmd=L!P(L,L,L)] :: (# Int#, Int#, Array# Double #)
+ [LclId[JoinId(0)(Nothing)]]
+ $j_sTM = jump exit_X0 j_ay1 s2_ay2 } in
+ joinrec {
+ step'_sTs [Occ=LoopBreaker, Dmd=SC(S,!P(L,L,L))]
+ :: Int# -> (# Int#, Int#, Array# Double #)
+ [LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>, Unf=OtherCon []]
+ step'_sTs (i1_X1 :: Int#)
+ = case >=# i1_X1 n_axM of {
+ __DEFAULT ->
+ case indexArray# @'Lifted @Double oldArr_axN (+# off_axL i1_X1) of
+ { (# ipv2_sSW #) ->
+ case ipv2_sSW of { D# x_aPv ->
+ case >## x_aPv 10.0## of {
+ __DEFAULT -> jump step'_sTs (+# i1_X1 1#);
+ 1# -> jump exit1_X4 i1_X1 x_aPv
+ }
+ }
+ };
+ 1# -> jump $j_sTM
+ }; } in
+ jump step'_sTs i_ay0; } in
+ jump loop_sTq 0# 0# ipv_sSS
+ })
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$trModule3 = GHC.Types.TrNameS Unboxed.$trModule4
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$trModule1 = GHC.Types.TrNameS Unboxed.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$trModule :: GHC.Types.Module
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$trModule
+ = GHC.Types.Module Unboxed.$trModule3 Unboxed.$trModule1
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep_rV0 :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep_rV0 = GHC.Types.KindRepVar 1#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep1_rV1 :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep1_rV1 = GHC.Types.KindRepVar 0#
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tcStep2 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+Unboxed.$tcStep2 = "Step"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tcStep1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$tcStep1 = GHC.Types.TrNameS Unboxed.$tcStep2
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tcStep :: GHC.Types.TyCon
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$tcStep
+ = GHC.Types.TyCon
+ 9345441458829744813##64
+ 15928240119707513573##64
+ Unboxed.$trModule
+ Unboxed.$tcStep1
+ 0#
+ GHC.Types.krep$*->*->*
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+$krep2_rV2 :: [GHC.Types.KindRep]
+[GblId, Unf=OtherCon []]
+$krep2_rV2
+ = GHC.Types.:
+ @GHC.Types.KindRep $krep_rV0 (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$krep3_rV3 :: [GHC.Types.KindRep]
+[GblId, Unf=OtherCon []]
+$krep3_rV3 = GHC.Types.: @GHC.Types.KindRep $krep1_rV1 $krep2_rV2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Done1 [InlPrag=[~]] :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+Unboxed.$tc'Done1
+ = GHC.Types.KindRepTyConApp Unboxed.$tcStep $krep3_rV3
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Done3 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+Unboxed.$tc'Done3 = "'Done"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Done2 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$tc'Done2 = GHC.Types.TrNameS Unboxed.$tc'Done3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Done :: GHC.Types.TyCon
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$tc'Done
+ = GHC.Types.TyCon
+ 12965714903249458155##64
+ 720712123234526269##64
+ Unboxed.$trModule
+ Unboxed.$tc'Done2
+ 2#
+ Unboxed.$tc'Done1
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep4_rV4 :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep4_rV4 = GHC.Types.KindRepFun $krep1_rV1 Unboxed.$tc'Done1
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Yield1 [InlPrag=[~]] :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+Unboxed.$tc'Yield1 = GHC.Types.KindRepFun $krep_rV0 $krep4_rV4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Yield3 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+Unboxed.$tc'Yield3 = "'Yield"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Yield2 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$tc'Yield2 = GHC.Types.TrNameS Unboxed.$tc'Yield3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Yield :: GHC.Types.TyCon
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$tc'Yield
+ = GHC.Types.TyCon
+ 16456917800457442198##64
+ 7357499335137316903##64
+ Unboxed.$trModule
+ Unboxed.$tc'Yield2
+ 2#
+ Unboxed.$tc'Yield1
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -428,5 +428,7 @@ test('T21763', only_ways(['optasm']), compile, ['-O2 -ddump-rules'])
test('T21763a', only_ways(['optasm']), compile, ['-O2 -ddump-rules'])
test('T22028', normal, compile, ['-O -ddump-rule-firings'])
test('T22114', normal, compile, ['-O'])
-test('T21286', normal, multimod_compile, ['T21286', '-O -ddump-rule-firings'])
+test('T21286', normal, multimod_compile, ['T21286', '-O -ddump-rule-firings'])
+# step should be loopified and turned into a join point
+test('T22227', [grep_errmsg(r'jump \S*step') ], compile, ['-O -ddump-simpl'])
=====================================
testsuite/tests/stranal/sigs/T22241.hs
=====================================
@@ -0,0 +1,12 @@
+module T22241 where
+
+data D = D !Int
+
+-- We should unbox y here, which only happens if DmdAnal sees that $WD will
+-- unbox it.
+f :: Bool -> Int -> D
+f x y = D (go x)
+ where
+ go False = y
+ go True = go False
+{-# NOINLINE f #-}
=====================================
testsuite/tests/stranal/sigs/T22241.stderr
=====================================
@@ -0,0 +1,15 @@
+
+==================== Strictness signatures ====================
+T22241.f: <1L><S!P(L)>
+
+
+
+==================== Cpr signatures ====================
+T22241.f: 1
+
+
+
+==================== Strictness signatures ====================
+T22241.f: <1L><1!P(SL)>
+
+
=====================================
testsuite/tests/stranal/sigs/T5075.hs
=====================================
@@ -17,10 +17,10 @@ g x y = go x
True -> Just x
False -> go (x*2)
--- Here, go is not a join point, but still should be WW'd for Just.
--- Unfortunately, CPR can't see that (+?) returns Just, so h won't get the CPR
--- property. It probably could by only considering the @Just@ case of the
--- inlined (+?).
+-- Here, go is not a join point (call-site loopification doesn't trigger because
+-- it is marked NOINLINE), but still should be WW'd for Just. Unfortunately,
+-- CPR can't see that (+?) returns Just, so h won't get the CPR property. It
+-- probably could by only considering the @Just@ case of the inlined (+?).
h :: Int -> Maybe Int
h x = go x +? go (x+1)
where
@@ -29,3 +29,4 @@ h x = go x +? go (x+1)
go z
| z > 10 = Just (x + z)
| otherwise = go (z*2)
+ {-# NOINLINE go #-}
=====================================
testsuite/tests/stranal/sigs/all.T
=====================================
@@ -36,3 +36,4 @@ test('T21119', normal, compile, [''])
test('T21717', normal, compile, [''])
test('T21888', normal, compile, [''])
test('T21888a', normal, compile, [''])
+test('T22241', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/63c2f0df143bbee2804327f055d8e3fba7509307...86ef6fa321608b146b28e37cdf0db82635573355
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/63c2f0df143bbee2804327f055d8e3fba7509307...86ef6fa321608b146b28e37cdf0db82635573355
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221001/b242331e/attachment-0001.html>
More information about the ghc-commits
mailing list