[Git][ghc/ghc][wip/T23209] Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Nov 28 23:26:55 UTC 2023
Simon Peyton Jones pushed to branch wip/T23209 at Glasgow Haskell Compiler / GHC
Commits:
82ebf9cb by Simon Peyton Jones at 2023-11-28T23:26:35+00:00
Wibbles
- - - - -
9 changed files:
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Rules.hs
- + testsuite/tests/simplCore/should_compile/T23209.hs
- + testsuite/tests/simplCore/should_compile/T23209_Aux.hs
- + testsuite/tests/simplCore/should_compile/T23209a.hs
- + testsuite/tests/simplCore/should_compile/T23209a.stderr
- + testsuite/tests/simplCore/should_compile/T23209b.hs
- + testsuite/tests/simplCore/should_compile/T23209b.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -1818,20 +1818,20 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
-- OPAQUE things.
, not (null arg_bndrs) -- Only specialise functions
, Just all_calls <- lookupVarEnv bind_calls fn -- Some calls to it
- = pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $
+ = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $
do { (boring_call, pats_discarded, new_pats)
<- callsToNewPats env fn spec_info arg_occs all_calls
; let n_pats = length new_pats
- ; when (not (null new_pats) || isJust mb_unspec) $
- pprTraceM "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"
- , text "boring_call:" <+> ppr boring_call
- , text "pats_discarded:" <+> ppr pats_discarded
- , text "old spec_count" <+> ppr spec_count
- , text "spec count limit" <+> ppr (sc_count (sc_opts env))
- , text "mb_unspec" <+> ppr (isJust mb_unspec)
- , text "arg_occs" <+> ppr arg_occs
- , text "new_pats" <+> ppr new_pats])
+-- ; when (not (null new_pats) || isJust mb_unspec) $
+-- pprTraceM "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"
+-- , text "boring_call:" <+> ppr boring_call
+-- , text "pats_discarded:" <+> ppr pats_discarded
+-- , text "old spec_count" <+> ppr spec_count
+-- , text "spec count limit" <+> ppr (sc_count (sc_opts env))
+-- , text "mb_unspec" <+> ppr (isJust mb_unspec)
+-- , text "arg_occs" <+> ppr arg_occs
+-- , text "new_pats" <+> ppr new_pats])
; let spec_env = decreaseSpecCount env n_pats
; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
@@ -2387,16 +2387,16 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
good_pats :: [CallPat]
good_pats = catMaybes mb_pats
- ise = ISE (getSubstInScope (sc_subst env)) (const noUnfolding)
+ in_scope = getSubstInScope (sc_subst env)
-- Remove patterns we have already done
new_pats = filterOut is_done good_pats
is_done p = any is_better done_specs
where
- is_better done = betterPat ise (os_pat done) p
+ is_better done = betterPat in_scope (os_pat done) p
-- Remove duplicates
- non_dups = subsumePats ise new_pats
+ non_dups = subsumePats in_scope new_pats
-- Remove ones that have too many worker variables
small_pats = filterOut too_many_worker_args non_dups
@@ -2412,13 +2412,13 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
-- Discard specialisations if there are too many of them
(pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats
- ; pprTraceM "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls
- , text "good_pats:" <+> ppr good_pats
- , text "new_pats:" <+> ppr new_pats
- , text "non_dups:" <+> ppr non_dups
- , text "small_pats:" <+> ppr small_pats
- , text "done_specs:" <+> ppr (map os_pat done_specs)
- , text "trimmed_pats:" <+> ppr trimmed_pats ])
+-- ; pprTraceM "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls
+-- , text "good_pats:" <+> ppr good_pats
+-- , text "new_pats:" <+> ppr new_pats
+-- , text "non_dups:" <+> ppr non_dups
+-- , text "small_pats:" <+> ppr small_pats
+-- , text "done_specs:" <+> ppr (map os_pat done_specs)
+-- , text "trimmed_pats:" <+> ppr trimmed_pats ])
; return (have_boring_call, pats_were_discarded, trimmed_pats) }
-- If any of the calls does not give rise to a specialisation, either
@@ -2807,25 +2807,27 @@ valueIsWorkFree :: Value -> Bool
valueIsWorkFree LambdaVal = True
valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args
-betterPat :: InScopeEnv -> CallPat -> CallPat -> Bool
+betterPat :: InScopeSet -> CallPat -> CallPat -> Bool
-- pat1 f @a (Just @a (x::a))
-- is better than
-- pat2 f @Int (Just @Int (x::Int))
-- That is, we can instantiate
-betterPat ise (CP { cp_qvars = vs1, cp_args = as1 })
- (CP { cp_args = as2 })
+betterPat is (CP { cp_qvars = vs1, cp_args = as1 })
+ (CP { cp_qvars = vs2, cp_args = as2 })
= case matchExprs ise vs1 as1 as2 of
Just (_, ms) -> all exprIsTrivial ms
Nothing -> False
+ where
+ ise = ISE (is `extendInScopeSetList` vs2) (const noUnfolding)
-subsumePats :: InScopeEnv -> [CallPat] -> [CallPat]
+subsumePats :: InScopeSet -> [CallPat] -> [CallPat]
-- Remove any patterns subsumed by others
-subsumePats ise pats = foldr add [] pats
+subsumePats is pats = foldr add [] pats
where
add :: CallPat -> [CallPat] -> [CallPat]
add ci [] = [ci]
- add ci1 (ci2:cis) | betterPat ise ci2 ci1 = ci2:cis
- | betterPat ise ci1 ci2 = ci1:cis
+ add ci1 (ci2:cis) | betterPat is ci2 ci1 = ci2:cis
+ | betterPat is ci1 ci2 = ci1:cis
| otherwise = ci2 : add ci1 cis
{-
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -1068,20 +1068,16 @@ match renv subst e1 (Cast e2 co2) mco
-- This is important: see Note [Cancel reflexive casts]
match renv subst (Cast e1 co1) e2 mco
- | pprTrace "matchCast" (vcat
- [ text "tmpl" <+> ppr e1
- , text "co1" <+> ppr co1
- , text "e2" <+> ppr e2
- , text "subst" <+> ppr current_subst
- , text "tmpls" <+> ppr (rv_tmpls renv) ]) $
- isEmptyVarSet $ fvVarSet $
+ | isEmptyVarSet $ fvVarSet $
filterFV (`elemVarSet` rv_tmpls renv) $
tyCoFVsOfCo substed_co
- = -- See Note [Casts in the template]
+ = -- This is the good path
+ -- See Note [Casts in the template]
match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoL mco (mkSymCo substed_co)))
| otherwise
- = do { let co2 = case mco of
+ = -- This is the Deeply Suspicious Path
+ do { let co2 = case mco of
MRefl -> mkRepReflCo (exprType e2)
MCo co2 -> co2
; subst1 <- match_co renv subst co1 co2
@@ -1094,7 +1090,11 @@ match renv subst (Cast e1 co1) e2 mco
current_subst :: Subst
current_subst = mkTCvSubst (rnInScopeSet (rv_lcl renv))
(rs_tv_subst subst)
- emptyCvSubstEnv -- Ugh!
+ emptyCvSubstEnv
+ -- emptyCvSubstEnv: ugh!
+ -- If there were any CoVar substitutions they would be in
+ -- rs_id_subst; but we don't expect there to be any; see
+ -- Note [Casts in the template]
------------------------ Literals ---------------------
match _ subst (Lit lit1) (Lit lit2) mco
=====================================
testsuite/tests/simplCore/should_compile/T23209.hs
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# OPTIONS_GHC -O2 #-}
+
+-- This gave a Lint crash
+
+module T23209 where
+
+import T23209_Aux
+
+f a = let w = if a then Allocator (ArrayWriter s)
+ else Allocator (ArrayWriter e)
+ in case combine w w of
+ (# z #) -> (# \s -> z (z s) #)
=====================================
testsuite/tests/simplCore/should_compile/T23209_Aux.hs
=====================================
@@ -0,0 +1,20 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# OPTIONS_GHC -O #-}
+module T23209_Aux where
+
+newtype I = MkI { uI :: () -> () }
+newtype ArrayWriter = ArrayWriter (() -> I)
+data Allocator = Allocator !ArrayWriter
+
+combine :: Allocator -> Allocator -> (# () -> () #)
+combine (Allocator (ArrayWriter w1)) (Allocator (ArrayWriter w2)) =
+ (# \s -> id' (uI (w1 ()) (uI (w2 ()) s)) #)
+
+e, s :: () -> I
+e x = MkI id
+s x = MkI id
+{-# NOINLINE s #-}
+
+id' :: () -> ()
+id' x = x
+{-# NOINLINE id' #-}
=====================================
testsuite/tests/simplCore/should_compile/T23209a.hs
=====================================
@@ -0,0 +1,14 @@
+module T23209a where
+
+newtype N a = MkN a
+
+foo :: Int -> N (a,a) -> Maybe (a,a)
+foo 0 (MkN p) = Just p
+foo n (MkN (x,y)) = foo (n-1) (MkN (y,x))
+
+-- We should generate ONE specialisation for $wfoo,
+-- and it should fire TWICE, regardless of the order
+-- of the following two definitions.
+
+wombat1 = foo 20 (MkN ("yes", "no"))
+wombat2 xs ys = foo 3 (MkN (xs, ys))
=====================================
testsuite/tests/simplCore/should_compile/T23209a.stderr
=====================================
@@ -0,0 +1,38 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core = {terms: 79, types: 106, coercions: 8, joins: 0/0}
+
+Rec {
+foo_$s$wfoo
+ = \ @a_aTK sc_sVV sc1_sVW sc2_sVU ->
+ case sc2_sVU of ds_X2 {
+ __DEFAULT -> foo_$s$wfoo sc1_sVW sc_sVV (-# ds_X2 1#);
+ 0# -> (# (sc_sVV, sc1_sVW) #)
+ }
+end Rec }
+
+foo
+ = \ @a_sVs ds_sVt ds1_sVx ->
+ case ds_sVt of { I# ww_sVv ->
+ case ww_sVv of ds2_X2 {
+ __DEFAULT -> case ds1_sVx `cast` <Co:4> :: ... of { (x_awV, y_awW) -> case foo_$s$wfoo y_awW x_awV (-# ds2_X2 1#) of { (# ww1_sVH #) -> Just ww1_sVH } };
+ 0# -> Just (ds1_sVx `cast` <Co:4> :: ...)
+ }
+ }
+
+wombat7 = "yes"#
+
+wombat6 = unpackCString# wombat7
+
+wombat5 = "no"#
+
+wombat4 = unpackCString# wombat5
+
+wombat1 = case foo_$s$wfoo wombat6 wombat4 20# of { (# ww_sVH #) -> Just ww_sVH }
+
+wombat8 = I# 3#
+
+wombat2 = \ @a_aTK xs_azB ys_azC -> case foo_$s$wfoo xs_azB ys_azC 3# of { (# ww_sVH #) -> Just ww_sVH }
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/T23209b.hs
=====================================
@@ -0,0 +1,14 @@
+module T23209b where
+
+newtype N a = MkN a
+
+foo :: Int -> N (a,a) -> Maybe (a,a)
+foo 0 (MkN p) = Just p
+foo n (MkN (x,y)) = foo (n-1) (MkN (y,x))
+
+-- We should generate ONE specialisation for $wfoo,
+-- and it should fire TWICE, regardless of the order
+-- of the following two definitions.
+
+wombat2 xs ys = foo 3 (MkN (xs, ys))
+wombat1 = foo 20 (MkN ("yes", "no"))
=====================================
testsuite/tests/simplCore/should_compile/T23209b.stderr
=====================================
@@ -0,0 +1,38 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core = {terms: 79, types: 106, coercions: 8, joins: 0/0}
+
+Rec {
+foo_$s$wfoo
+ = \ @a_aTz sc_sVS sc1_sVT sc2_sVR ->
+ case sc2_sVR of ds_X2 {
+ __DEFAULT -> foo_$s$wfoo sc1_sVT sc_sVS (-# ds_X2 1#);
+ 0# -> (# (sc_sVS, sc1_sVT) #)
+ }
+end Rec }
+
+foo
+ = \ @a_sVs ds_sVt ds1_sVx ->
+ case ds_sVt of { I# ww_sVv ->
+ case ww_sVv of ds2_X2 {
+ __DEFAULT -> case ds1_sVx `cast` <Co:4> :: ... of { (x_awV, y_awW) -> case foo_$s$wfoo y_awW x_awV (-# ds2_X2 1#) of { (# ww1_sVH #) -> Just ww1_sVH } };
+ 0# -> Just (ds1_sVx `cast` <Co:4> :: ...)
+ }
+ }
+
+wombat8 = I# 3#
+
+wombat2 = \ @a_aTz xs_azB ys_azC -> case foo_$s$wfoo xs_azB ys_azC 3# of { (# ww_sVH #) -> Just ww_sVH }
+
+wombat7 = "yes"#
+
+wombat6 = unpackCString# wombat7
+
+wombat5 = "no"#
+
+wombat4 = unpackCString# wombat5
+
+wombat1 = case foo_$s$wfoo wombat6 wombat4 20# of { (# ww_sVH #) -> Just ww_sVH }
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -508,4 +508,6 @@ test('T24014', normal, compile, ['-dcore-lint'])
test('T24029', normal, compile, [''])
test('T21348', normal, compile, ['-O'])
test('T21917', normal, compile, ['-O -fkeep-auto-rules -ddump-rules'])
-
+test('T23209', [extra_files(['T23209_Aux.hs'])], multimod_compile, ['T23209', '-v0 -O'])
+test('T23209a', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dppr-cols=99999'])
+test('T23209b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dppr-cols=99999'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82ebf9cb43db31ce2d4f3043cd0826dec8f326e5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82ebf9cb43db31ce2d4f3043cd0826dec8f326e5
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/20231128/825c52be/attachment-0001.html>
More information about the ghc-commits
mailing list