[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: hadrian: Add dependency from lib/settings to mk/config.mk
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Mar 1 06:37:22 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
2b7a96cc by Ben Gamari at 2023-03-01T01:37:12-05:00
hadrian: Add dependency from lib/settings to mk/config.mk
In 81975ef375de07a0ea5a69596b2077d7f5959182 we attempted to fix #20253
by adding logic to the bindist Makefile to regenerate the `settings`
file from information gleaned by the bindist `configure` script.
However, this fix had no effect as `lib/settings` is shipped in the
binary distribution (to allow in-place use of the binary distribution).
As `lib/settings` already existed and its rule declared no dependencies,
`make` would fail to use the added rule to regenerate it.
Fix this by explicitly declaring a dependency from `lib/settings` on
`mk/config.mk`.
Fixes #22982.
- - - - -
5c22c053 by Sebastian Graf at 2023-03-01T01:37:13-05:00
Revert the main payload of "Make `drop` and `dropWhile` fuse (#18964)"
This reverts the bits affecting fusion of `drop` and `dropWhile` of commit
0f7588b5df1fc7a58d8202761bf1501447e48914 and keeps just the small refactoring
unifying `flipSeqTake` and `flipSeqScanl'` into `flipSeq`.
It also adds a new test for #23021 (which was the reason for reverting) as
well as adds a clarifying comment to T18964.
Fixes #23021, unfixes #18964.
Metric Increase:
T18964
Metric Decrease:
T18964
- - - - -
7be1029c by Simon Peyton Jones at 2023-03-01T01:37:13-05:00
Refine the test for naughty record selectors
The test for naughtiness in record selectors is surprisingly subtle.
See the revised Note [Naughty record selectors] in GHC.Tc.TyCl.Utils.
Fixes #23038.
- - - - -
ae30c8a9 by romes at 2023-03-01T01:37:14-05:00
fix: Consider strictness annotation in rep_bind
Fixes #23036
- - - - -
14 changed files:
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- hadrian/bindist/Makefile
- libraries/base/GHC/List.hs
- + testsuite/tests/patsyn/should_compile/T23038.hs
- + testsuite/tests/patsyn/should_compile/T23038.stderr
- testsuite/tests/patsyn/should_compile/all.T
- testsuite/tests/perf/should_run/T18964.hs
- + testsuite/tests/perf/should_run/T23021.hs
- + testsuite/tests/perf/should_run/T23021.stdout
- testsuite/tests/perf/should_run/all.T
- + testsuite/tests/th/T23036.hs
- + testsuite/tests/th/T23036.stderr
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1899,12 +1899,18 @@ rep_bind (L loc (FunBind
fun_matches = MG { mg_alts
= (L _ [L _ (Match
{ m_pats = []
- , m_grhss = GRHSs _ guards wheres }
- )]) } }))
+ , m_grhss = GRHSs _ guards wheres
+ -- For a variable declaration I'm pretty
+ -- sure we always have a FunRhs
+ , m_ctxt = FunRhs { mc_strictness = strictessAnn }
+ } )]) } }))
= do { (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; fn' <- lookupNBinder fn
- ; p <- repPvar fn'
+ ; p <- repPvar fn' >>= case strictessAnn of
+ SrcLazy -> repPtilde
+ SrcStrict -> repPbang
+ NoSrcStrict -> pure
; ans <- repVal p guardcore wherecore
; ans' <- wrapGenSyms ss ans
; return (locA loc, ans') }
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -903,19 +903,30 @@ mkOneRecordSelector all_cons idDetails fl has_sel
con1 = assert (not (null cons_w_field)) $ head cons_w_field
-- Selector type; Note [Polymorphic selectors]
- field_ty = conLikeFieldType con1 lbl
- data_tv_set = tyCoVarsOfTypes (data_ty : req_theta)
- data_tvbs = filter (\tvb -> binderVar tvb `elemVarSet` data_tv_set) $
- conLikeUserTyVarBinders con1
+ (univ_tvs, _, _, _, req_theta, _, data_ty) = conLikeFullSig con1
+
+ field_ty = conLikeFieldType con1 lbl
+ field_ty_tvs = tyCoVarsOfType field_ty
+ data_ty_tvs = tyCoVarsOfType data_ty
+ sel_tvs = field_ty_tvs `unionVarSet` data_ty_tvs
+ sel_tvbs = filter (\tvb -> binderVar tvb `elemVarSet` sel_tvs) $
+ conLikeUserTyVarBinders con1
-- is_naughty: see Note [Naughty record selectors]
- is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set)
- || has_sel == NoFieldSelectors -- No field selectors => all are naughty
- -- thus suppressing making a binding
- -- A slight hack!
+ is_naughty = not ok_scoping || no_selectors
+ ok_scoping = case con1 of
+ RealDataCon {} -> field_ty_tvs `subVarSet` data_ty_tvs
+ PatSynCon {} -> field_ty_tvs `subVarSet` mkVarSet univ_tvs
+ -- In the PatSynCon case, the selector type is (data_ty -> field_ty), but
+ -- fvs(data_ty) are all universals (see Note [Pattern synonym result type] in
+ -- GHC.Core.PatSyn, so no need to check them.
+
+ no_selectors = has_sel == NoFieldSelectors -- No field selectors => all are naughty
+ -- thus suppressing making a binding
+ -- A slight hack!
sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors]
- | otherwise = mkForAllTys (tyVarSpecToBinders data_tvbs) $
+ | otherwise = mkForAllTys (tyVarSpecToBinders sel_tvbs) $
-- Urgh! See Note [The stupid context] in GHC.Core.DataCon
mkPhiTy (conLikeStupidTheta con1) $
-- req_theta is empty for normal DataCon
@@ -926,7 +937,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- fields in all the constructor have multiplicity Many.
field_ty
- -- Make the binding: sel (C2 { fld = x }) = x
+ -- make the binding: sel (C2 { fld = x }) = x
-- sel (C7 { fld = x }) = x
-- where cons_w_field = [C2,C7]
sel_bind = mkTopFunBind Generated sel_lname alts
@@ -976,8 +987,6 @@ mkOneRecordSelector all_cons idDetails fl has_sel
where
inst_tys = dataConResRepTyArgs dc
- (_, _, _, _, req_theta, _, data_ty) = conLikeFullSig con1
-
unit_rhs = mkLHsTupleExpr [] noExtField
msg_lit = HsStringPrim NoSourceText (bytesFS (field_label lbl))
@@ -1036,36 +1045,42 @@ so that if the user tries to use 'x' as a selector we can bleat
helpfully, rather than saying unhelpfully that 'x' is not in scope.
Hence the sel_naughty flag, to identify record selectors that don't really exist.
-In general, a field is "naughty" if its type mentions a type variable that
-isn't in
- * the (original, user-written) result type of the constructor, or
- * the "required theta" for the constructor
-
-Note that this *allows* GADT record selectors (Note [GADT record
-selectors]) whose types may look like sel :: T [a] -> a
-
-The "required theta" part is illustrated by test patsyn/should_run/records_run
-where we have
-
- pattern ReadP :: Read a => a -> String
- pattern ReadP {readp} <- (read -> readp)
-
-The selector is defined like this:
-
- $selreadp :: ReadP a => String -> a
- $selReadP s = readp s
-
-Perfectly fine! The (ReadP a) constraint lets us contructor a value
-of type 'a' from a bare String. NB: "required theta" is empty for
-data cons (see conLikeFullSig), so this reasoning only bites for
-patttern synonyms.
-
For naughty selectors we make a dummy binding
sel = ()
so that the later type-check will add them to the environment, and they'll be
exported. The function is never called, because the typechecker spots the
sel_naughty field.
+To determine naughtiness we distingish two cases:
+
+* For RealDataCons, a field is "naughty" if its type mentions a
+ type variable that isn't in the (original, user-written) result type
+ of the constructor. Note that this *allows* GADT record selectors
+ (Note [GADT record selectors]) whose types may look like sel :: T [a] -> a
+
+* For a PatSynCon, a field is "naughty" if its type mentions a type variable
+ that isn't in the universal type variables.
+
+ This is a bit subtle. Consider test patsyn/should_run/records_run:
+ pattern ReadP :: forall a. ReadP a => a -> String
+ pattern ReadP {fld} <- (read -> readp)
+ The selector is defined like this:
+ $selReadPfld :: forall a. ReadP a => String -> a
+ $selReadPfld @a (d::ReadP a) s = readp @a d s
+ Perfectly fine! The (ReadP a) constraint lets us contruct a value of type
+ 'a' from a bare String.
+
+ Another curious case (#23038):
+ pattern N :: forall a. () => forall. () => a -> Any
+ pattern N { fld } <- ( unsafeCoerce -> fld1 ) where N = unsafeCoerce
+ The selector looks like this
+ $selNfld :: forall a. Any -> a
+ $selNfld @a x = unsafeCoerce @Any @a x
+ Pretty strange (but used in the `cleff` package).
+
+ TL;DR for pattern synonyms, the selector is OK if the field type mentions only
+ the universal type variables of the pattern synonym.
+
Note [NoFieldSelectors and naughty record selectors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Under NoFieldSelectors (see Note [NoFieldSelectors] in GHC.Rename.Env), record
=====================================
hadrian/bindist/Makefile
=====================================
@@ -77,7 +77,7 @@ endif
WrapperBinsDir=${bindir}
# N.B. this is duplicated from includes/ghc.mk.
-lib/settings :
+lib/settings : config.mk
$(call removeFiles,$@)
@echo '[("GCC extra via C opts", "$(GccExtraViaCOpts)")' >> $@
@echo ',("C compiler command", "$(SettingsCCompilerCommand)")' >> $@
=====================================
libraries/base/GHC/List.hs
=====================================
@@ -886,23 +886,12 @@ takeWhileFB p c n = \x r -> if p x then x `c` r else n
-- []
-- >>> dropWhile (< 0) [1,2,3]
-- [1,2,3]
-{-# NOINLINE [1] dropWhile #-}
dropWhile :: (a -> Bool) -> [a] -> [a]
dropWhile _ [] = []
dropWhile p xs@(x:xs')
| p x = dropWhile p xs'
| otherwise = xs
-{-# INLINE [0] dropWhileFB #-} -- See Note [Inline FB functions]
-dropWhileFB :: (a -> Bool) -> (a -> b -> b) -> b -> a -> (Bool -> b) -> Bool -> b
-dropWhileFB p c _n x xs = \drp -> if drp && p x then xs True else x `c` xs False
-
-{-# RULES
-"dropWhile" [~1] forall p xs. dropWhile p xs =
- build (\c n -> foldr (dropWhileFB p c n) (flipSeq n) xs True)
-"dropWhileList" [1] forall p xs. foldr (dropWhileFB p (:) []) (flipSeq []) xs True = dropWhile p xs
- #-}
-
-- | 'take' @n@, applied to a list @xs@, returns the prefix of @xs@
-- of length @n@, or @xs@ itself if @n >= 'length' xs at .
--
@@ -998,31 +987,17 @@ drop n xs | n <= 0 = xs
drop _ [] = []
drop n (_:xs) = drop (n-1) xs
#else /* hack away */
-{-# INLINE[1] drop #-} -- Why [1]? See justification on take! => RULES
+{-# INLINE drop #-}
drop n ls
| n <= 0 = ls
| otherwise = unsafeDrop n ls
-
--- A version of drop that drops the whole list if given an argument
--- less than 1
-{-# NOINLINE [0] unsafeDrop #-} -- See Note [Inline FB functions]
-unsafeDrop :: Int -> [a] -> [a]
-unsafeDrop !_ [] = []
-unsafeDrop 1 (_:xs) = xs
-unsafeDrop m (_:xs) = unsafeDrop (m - 1) xs
-
-{-# RULES
-"drop" [~1] forall n xs . drop n xs =
- build (\c nil -> if n <= 0
- then foldr c nil xs
- else foldr (dropFB c nil) (flipSeq nil) xs n)
-"unsafeDropList" [1] forall n xs . foldr (dropFB (:) []) (flipSeq []) xs n
- = unsafeDrop n xs
- #-}
-
-{-# INLINE [0] dropFB #-} -- See Note [Inline FB functions]
-dropFB :: (a -> b -> b) -> b -> a -> (Int -> b) -> Int -> b
-dropFB c _n x xs = \ m -> if m <= 0 then x `c` xs m else xs (m-1)
+ where
+ -- A version of drop that drops the whole list if given an argument
+ -- less than 1
+ unsafeDrop :: Int -> [a] -> [a]
+ unsafeDrop !_ [] = []
+ unsafeDrop 1 (_:xs) = xs
+ unsafeDrop m (_:xs) = unsafeDrop (m - 1) xs
#endif
-- | 'splitAt' @n xs@ returns a tuple where first element is @xs@ prefix of
=====================================
testsuite/tests/patsyn/should_compile/T23038.hs
=====================================
@@ -0,0 +1,19 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns, ScopedTypeVariables #-}
+
+module T23038 where
+
+import GHC.Types( Any )
+import Unsafe.Coerce( unsafeCoerce )
+
+pattern N1 :: forall a. () => forall. () => a -> Any
+pattern N1 { fld1 } <- ( unsafeCoerce -> fld1 )
+ where N1 = unsafeCoerce
+
+pattern N2 :: forall. () => forall a. () => a -> Any
+pattern N2 { fld2 } <- ( unsafeCoerce -> fld2 )
+ where N2 = unsafeCoerce
+
+test1, test2 :: forall a. Any -> a
+
+test1 = fld1 -- Should be OK
+test2 = fld2 -- Should be rejected
=====================================
testsuite/tests/patsyn/should_compile/T23038.stderr
=====================================
@@ -0,0 +1,6 @@
+
+T23038.hs:19:9: error: [GHC-55876]
+ • Cannot use record selector ‘fld2’ as a function due to escaped type variables
+ • In the expression: fld2
+ In an equation for ‘test2’: test2 = fld2
+ Suggested fix: Use pattern-matching syntax instead
=====================================
testsuite/tests/patsyn/should_compile/all.T
=====================================
@@ -83,3 +83,4 @@ test('T17775-singleton', normal, compile, [''])
test('T14630', normal, compile, ['-Wname-shadowing'])
test('T21531', [ grep_errmsg(r'INLINE') ], compile, ['-ddump-ds'])
test('T22521', normal, compile, [''])
+test('T23038', normal, compile_fail, [''])
=====================================
testsuite/tests/perf/should_run/T18964.hs
=====================================
@@ -3,6 +3,9 @@ import Data.Int
main :: IO ()
main = do
+ -- This test aims to track #18964, the fix of which had to be reverted in the
+ -- wake of #23021. The comments below apply to a world where #18964 is fixed.
+ --------------------
-- drop should fuse away and the program should consume O(1) space
-- If fusion fails, this allocates about 640MB.
print $ sum $ drop 10 [0..10000000::Int64]
=====================================
testsuite/tests/perf/should_run/T23021.hs
=====================================
@@ -0,0 +1,30 @@
+-- The direct implementation of drop and dropWhile operates in O(1) space.
+-- This regression test asserts that potential fusion rules for dropWhile/drop
+-- maintain that property for the fused pipelines in dropWhile2 and drop2 (which
+-- are marked NOINLINE for that purpose).
+-- #23021 was opened because we had fusion rules in place that did not maintain
+-- this property.
+
+dropWhile2 :: Int -> [Int] -> [Int]
+dropWhile2 n = dropWhile (< n) . dropWhile (< n)
+{-# NOINLINE dropWhile2 #-}
+
+drop2 :: Int -> [Int] -> [Int]
+drop2 n = drop n . drop n
+{-# NOINLINE drop2 #-}
+
+main :: IO ()
+main = do
+ let xs = [0..9999999]
+ print $ last $ dropWhile2 0 xs
+ print $ last $ dropWhile2 1 xs
+ print $ last $ dropWhile2 2 xs
+ print $ last $ dropWhile2 3 xs
+ print $ last $ dropWhile2 4 xs
+ print $ last $ dropWhile2 5 xs
+ print $ last $ drop2 0 xs
+ print $ last $ drop2 1 xs
+ print $ last $ drop2 2 xs
+ print $ last $ drop2 3 xs
+ print $ last $ drop2 4 xs
+ print $ last $ drop2 5 xs
=====================================
testsuite/tests/perf/should_run/T23021.stdout
=====================================
@@ -0,0 +1,12 @@
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
=====================================
testsuite/tests/perf/should_run/all.T
=====================================
@@ -411,4 +411,7 @@ test('T21839r',
compile_and_run,
['-O'])
+# #18964 should be marked expect_broken, but it's still useful to track that
+# perf doesn't regress further, so it is not marked as such.
test('T18964', [collect_stats('bytes allocated', 1), only_ways(['normal'])], compile_and_run, ['-O'])
+test('T23021', [collect_stats('bytes allocated', 1), only_ways(['normal'])], compile_and_run, ['-O2'])
=====================================
testsuite/tests/th/T23036.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T23036 where
+
+import Language.Haskell.TH
+
+a, b, c :: ()
+a = $([|let x = undefined in ()|])
+b = $([|let !x = undefined in ()|])
+c = $([|let ~x = undefined in ()|])
+
+-- Test strictness annotations are also correctly handled in function and pattern binders
+d, e, f:: ()
+d = $([|let !(x,y) = undefined in ()|])
+e = $([|let (!x,y,~z) = undefined in ()|])
+f = $([|let f !x ~y z = undefined in ()|])
+
=====================================
testsuite/tests/th/T23036.stderr
=====================================
@@ -0,0 +1,18 @@
+T23036.hs:7:6-34: Splicing expression
+ [| let x = undefined in () |] ======> let x = undefined in ()
+T23036.hs:8:6-35: Splicing expression
+ [| let !x = undefined in () |] ======> let !x = undefined in ()
+T23036.hs:9:6-35: Splicing expression
+ [| let ~x = undefined in () |] ======> let ~x = undefined in ()
+T23036.hs:13:6-39: Splicing expression
+ [| let !(x, y) = undefined in () |]
+ ======>
+ let !(x, y) = undefined in ()
+T23036.hs:14:6-42: Splicing expression
+ [| let (!x, y, ~z) = undefined in () |]
+ ======>
+ let (!x, y, ~z) = undefined in ()
+T23036.hs:15:6-42: Splicing expression
+ [| let f !x ~y z = undefined in () |]
+ ======>
+ let f !x ~y z = undefined in ()
=====================================
testsuite/tests/th/all.T
=====================================
@@ -559,3 +559,4 @@ test('T22784', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T22818', normal, compile, ['-v0'])
test('T22819', normal, compile, ['-v0'])
test('TH_fun_par', normal, compile, [''])
+test('T23036', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b8140c68fb2cbe994f9723e9adc9658b216fcb74...ae30c8a98791d7254bf3c15b979add63ec56e585
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b8140c68fb2cbe994f9723e9adc9658b216fcb74...ae30c8a98791d7254bf3c15b979add63ec56e585
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/20230301/3889de61/attachment-0001.html>
More information about the ghc-commits
mailing list