[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Enable ghci tests for unboxed tuples
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu May 25 19:07:20 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
a487ba9e by Krzysztof Gogolewski at 2023-05-25T14:35:56-04:00
Enable ghci tests for unboxed tuples
The tests were originally skipped because ghci used not to support
unboxed tuples/sums.
- - - - -
54e0f20f by Matthew Pickering at 2023-05-25T15:07:06-04:00
rts: Build ticky GHC with single-threaded RTS
The threaded RTS allows you to use ticky profiling but only for the
counters in the generated code. The counters used in the C portion of
the RTS are disabled. Updating the counters is also racy using the
threaded RTS which can lead to misleading or incorrect ticky results.
Therefore we change the hadrian flavour to build using the
single-threaded RTS (mainly in order to get accurate C code counter
increments)
Fixes #23430
- - - - -
1882aed5 by sheaf at 2023-05-25T15:07:12-04:00
Propagate long-distance info in generated code
When desugaring generated pattern matches, we skip pattern match checks.
However, this ended up also discarding long-distance information, which
might be needed for user-written sub-expressions.
Example:
```haskell
okay (GADT di) cd =
let sr_field :: ()
sr_field = case getFooBar di of { Foo -> () }
in case cd of { SomeRec _ -> SomeRec sr_field }
```
With sr_field a generated FunBind, we still want to propagate the outer
long-distance information from the GADT pattern match into the checks
for the user-written RHS of sr_field.
Fixes #23445
- - - - -
10 changed files:
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/Tc/Gen/Expr.hs
- hadrian/src/Flavour.hs
- + testsuite/tests/pmcheck/should_compile/T23445.hs
- testsuite/tests/pmcheck/should_compile/all.T
- testsuite/tests/primops/should_run/all.T
- testsuite/tests/typecheck/should_run/all.T
- testsuite/tests/unboxedsums/all.T
Changes:
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -218,7 +218,7 @@ mkMatchGroup :: AnnoBody p body
-> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup origin matches = MG { mg_ext = origin
- , mg_alts = matches }
+ , mg_alts = matches }
mkLamCaseMatchGroup :: AnnoBody p body
=> Origin
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -36,7 +36,7 @@ import GHC.Hs.Syn.Type
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad
import GHC.HsToCore.Pmc
-import GHC.HsToCore.Pmc.Types ( Nablas, initNablas )
+import GHC.HsToCore.Pmc.Types ( Nablas )
import GHC.HsToCore.Monad
import GHC.HsToCore.Binds
import GHC.HsToCore.GuardedRHSs
@@ -783,16 +783,24 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
-- Pattern match check warnings for /this match-group/.
-- @rhss_nablas@ is a flat list of covered Nablas for each RHS.
-- Each Match will split off one Nablas for its RHSs from this.
- ; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt
+ ; matches_nablas <-
+ if isMatchContextPmChecked dflags origin ctxt
+
+ -- See Note [Long-distance information] in GHC.HsToCore.Pmc
then addHsScrutTmCs (concat scrs) new_vars $
- -- See Note [Long-distance information]
pmcMatches (DsMatchContext ctxt locn) new_vars matches
- else pure (initNablasMatches matches)
+
+ -- When we're not doing PM checks on the match group,
+ -- we still need to propagate long-distance information.
+ -- See Note [Long-distance information in matchWrapper]
+ else do { ldi_nablas <- getLdiNablas
+ ; pure $ initNablasMatches ldi_nablas matches }
; eqns_info <- zipWithM mk_eqn_info matches matches_nablas
- ; result_expr <- handleWarnings $
+ ; result_expr <- discard_warnings_if_generated origin $
matchEquations ctxt new_vars eqns_info rhs_ty
+
; return (new_vars, result_expr) }
where
-- Called once per equation in the match, or alternative in the case
@@ -810,19 +818,67 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
, eqn_orig = FromSource
, eqn_rhs = match_result } }
- handleWarnings = if isGenerated origin
- then discardWarningsDs
- else id
+ discard_warnings_if_generated orig =
+ if isGenerated orig
+ then discardWarningsDs
+ else id
+
+ initNablasMatches :: Nablas -> [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
+ initNablasMatches ldi_nablas ms
+ = map (\(L _ m) -> (ldi_nablas, initNablasGRHSs ldi_nablas (m_grhss m))) ms
+
+ initNablasGRHSs :: Nablas -> GRHSs GhcTc b -> NonEmpty Nablas
+ initNablasGRHSs ldi_nablas m
+ = expectJust "GRHSs non-empty"
+ $ NEL.nonEmpty
+ $ replicate (length (grhssGRHSs m)) ldi_nablas
+
+{- Note [Long-distance information in matchWrapper]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The pattern match checking in matchWrapper is done conditionally, depending
+on isMatchContextPmChecked. This means that we don't perform pattern match
+checking on e.g. generated pattern matches.
+
+However, when we skip pattern match checking, we still need to keep track
+of long-distance information in case we need it in a nested context.
+
+This came up in #23445. For example:
- initNablasMatches :: [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
- initNablasMatches ms
- = map (\(L _ m) -> (initNablas, initNablasGRHSs (m_grhss m))) ms
+ data GADT a where
+ IsUnit :: GADT ()
- initNablasGRHSs :: GRHSs GhcTc b -> NonEmpty Nablas
- initNablasGRHSs m = expectJust "GRHSs non-empty"
- $ NEL.nonEmpty
- $ replicate (length (grhssGRHSs m)) initNablas
+ data Foo b where
+ FooUnit :: Foo ()
+ FooInt :: Foo Int
+ data SomeRec = SomeRec { fld :: () }
+
+ bug :: GADT a -> Foo a -> SomeRec -> SomeRec
+ bug IsUnit foo r =
+ let gen_fld :: ()
+ gen_fld = case foo of { FooUnit -> () }
+ in case r of { SomeRec _ -> SomeRec gen_fld }
+
+Here the body of 'bug' was generated by 'desugarRecordUpd' from the user-written
+record update
+
+ cd { fld = case foo of { FooUnit -> () } }
+
+As a result, we have a generated FunBind gen_fld whose RHS
+
+ case foo of { FooUnit -> () }
+
+is user-written. This all happens after the GADT pattern match on IsUnit,
+which brings into scope the Given equality [G] a ~ (). We need to make sure
+that this long distance information is visible when pattern match checking the
+user-written case statement.
+
+To propagate this long-distance information in 'matchWrapper', when we skip
+pattern match checks, we make sure to manually pass the long-distance
+information to 'mk_eqn_info', which is responsible for recurring further into
+the expression (in this case, it will end up recursively calling 'matchWrapper'
+on the user-written case statement).
+-}
matchEquations :: HsMatchContext GhcRn
-> [MatchId] -> [EquationInfo] -> Type
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -39,7 +39,7 @@ module GHC.HsToCore.Pmc (
isMatchContextPmChecked,
-- See Note [Long-distance information]
- addTyCs, addCoreScrutTmCs, addHsScrutTmCs
+ addTyCs, addCoreScrutTmCs, addHsScrutTmCs, getLdiNablas
) where
import GHC.Prelude
@@ -142,8 +142,8 @@ pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do
-- Returns one non-empty 'Nablas' for 1.) each pattern of a 'Match' and 2.)
-- each of a 'Match'es 'GRHS' for Note [Long-distance information].
--
--- Special case: When there are /no matches/, then the functionassumes it
--- checks and @-XEmptyCase@ with only a single match variable.
+-- Special case: When there are /no matches/, then the function assumes it
+-- checks an @-XEmptyCase@ with only a single match variable.
-- See Note [Checking EmptyCase].
pmcMatches
:: DsMatchContext -- ^ Match context, for warnings messages
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1070,7 +1070,7 @@ Wrinkle [GADT result type in tcRecordUpd]
-}
--- | Desugars a record update @record_expr { fld1 = e1, fld2 = e2}@ into a case expression
+-- | Desugars a record update @record_expr { fld1 = e1, fld2 = e2 }@ into a case expression
-- that matches on the constructors of the record @r@, as described in
-- Note [Record Updates].
--
=====================================
hadrian/src/Flavour.hs
=====================================
@@ -145,11 +145,13 @@ enableDebugInfo = addArgs $ notStage0 ? mconcat
-- | Enable the ticky-ticky profiler in stage2 GHC
enableTickyGhc :: Flavour -> Flavour
-enableTickyGhc =
- addArgs $ orM [stage1, cross] ? mconcat
+enableTickyGhc f =
+ (addArgs (orM [stage1, cross] ? mconcat
[ builder (Ghc CompileHs) ? tickyArgs
, builder (Ghc LinkHs) ? tickyArgs
- ]
+ ]) f) { ghcThreaded = (< Stage2) }
+ -- Build single-threaded ghc because ticky profiling is racy with threaded
+ -- RTS and the C counters are disabled. (See #23439)
tickyArgs :: Args
tickyArgs = mconcat
=====================================
testsuite/tests/pmcheck/should_compile/T23445.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE GADTs #-}
+
+module T23445 where
+
+data GADT a where
+ IsUnit :: GADT ()
+
+data Foo b where
+ FooUnit :: Foo ()
+ FooInt :: Foo Int
+
+data SomeRec = SomeRec { fld :: () }
+
+bug :: GADT a -> Foo a -> SomeRec -> SomeRec
+bug IsUnit foo r =
+ r { fld = case foo of { FooUnit -> () } }
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -112,6 +112,10 @@ test('CaseOfKnownCon', [], compile, [overlapping_incomplete])
test('TooManyDeltas', [], compile, [overlapping_incomplete+'-fmax-pmcheck-models=0'])
test('LongDistanceInfo', [], compile, [overlapping_incomplete])
test('T21662', [], compile, [overlapping_incomplete])
+test('T19271', [], compile, [overlapping_incomplete])
+test('T21761', [], compile, [overlapping_incomplete])
+test('T22964', [], compile, [overlapping_incomplete])
+test('T23445', [], compile, [overlapping_incomplete])
# Series (inspired) by Luke Maranget
@@ -156,6 +160,4 @@ test('EmptyCase007', [], compile, [overlapping_incomplete])
test('EmptyCase008', [], compile, [overlapping_incomplete])
test('EmptyCase009', [], compile, [overlapping_incomplete])
test('EmptyCase010', [], compile, [overlapping_incomplete])
-test('T19271', [], compile, [overlapping_incomplete])
-test('T21761', [], compile, [overlapping_incomplete])
-test('T22964', [], compile, [overlapping_incomplete])
+
=====================================
testsuite/tests/primops/should_run/all.T
=====================================
@@ -1,9 +1,8 @@
test('T6135', normal, compile_and_run, [''])
test('T7689', normal, compile_and_run, [''])
-# These tests are using unboxed tuples, so omit ghci
-test('T9430', omit_ways(['ghci']), compile_and_run, [''])
+test('T9430', normal, compile_and_run, [''])
test('T4442',
- [omit_ways(['ghci']), when(wordsize(32), expect_broken(15184))],
+ [when(wordsize(32), expect_broken(15184))],
compile_and_run, [''])
test('T10481', exit_code(1), compile_and_run, [''])
test('T10678',
@@ -18,13 +17,12 @@ test('T16164', normal, compile_and_run, [''])
test('ShowPrim', normal, compile_and_run, [''])
test('T12492', normal, compile_and_run, [''])
-# These tests use unboxed tuples, which GHCi doesn't support
-test('ArithInt8', omit_ways(['ghci']), compile_and_run, [''])
-test('ArithWord8', omit_ways(['ghci']), compile_and_run, [''])
-test('ArithInt16', omit_ways(['ghci']), compile_and_run, [''])
-test('ArithWord16', omit_ways(['ghci']), compile_and_run, [''])
-test('ArithInt32', omit_ways(['ghci']), compile_and_run, [''])
-test('ArithWord32', omit_ways(['ghci']), compile_and_run, [''])
+test('ArithInt8', normal, compile_and_run, [''])
+test('ArithWord8', normal, compile_and_run, [''])
+test('ArithInt16', normal, compile_and_run, [''])
+test('ArithWord16', normal, compile_and_run, [''])
+test('ArithInt32', normal, compile_and_run, [''])
+test('ArithWord32', normal, compile_and_run, [''])
test('CmpInt8', normal, compile_and_run, [''])
test('CmpWord8', normal, compile_and_run, [''])
=====================================
testsuite/tests/typecheck/should_run/all.T
=====================================
@@ -122,11 +122,9 @@ test('TypeRep', normal, compile_and_run, [''])
test('T11120', normal, compile_and_run, [''])
test('KindInvariant', normal, ghci_script, ['KindInvariant.script'])
-# We omit the ghci way in these 3 tests because they use
-# unboxed sums and ghci does not support those yet.
-test('StrictPats', omit_ways(['ghci']), compile_and_run, [''])
-test('T12809', omit_ways(['ghci']), compile_and_run, [''])
-test('EtaExpandLevPoly', [omit_ways(['ghci'])], compile_and_run, [''])
+test('StrictPats', normal, compile_and_run, [''])
+test('T12809', normal, compile_and_run, [''])
+test('EtaExpandLevPoly', normal, compile_and_run, [''])
test('TestTypeableBinary', normal, compile_and_run, [''])
test('Typeable1', normal, compile_fail, ['-Werror'])
=====================================
testsuite/tests/unboxedsums/all.T
=====================================
@@ -3,29 +3,29 @@ test('unboxedsums_unit_tests',
compile_and_run,
['-package ghc'])
-test('unarise', omit_ways(['ghci']), compile_and_run, [''])
-test('unboxedsums1', omit_ways(['ghci']), compile_and_run, [''])
-test('unboxedsums2', omit_ways(['ghci']), compile_and_run, [''])
-test('unboxedsums3', omit_ways(['ghci']), compile_and_run, [''])
-test('unboxedsums4', omit_ways(['ghci']), compile_fail, [''])
-test('unboxedsums5', omit_ways(['ghci']), compile, [''])
-test('unboxedsums6', omit_ways(['ghci']), compile_and_run, [''])
-test('unboxedsums7', omit_ways(['ghci']), compile_and_run, [''])
-test('unboxedsums8', omit_ways(['ghci']), compile_and_run, [''])
-test('unboxedsums9', omit_ways(['ghci']), compile_and_run, [''])
-test('unboxedsums10', omit_ways(['ghci']), compile_and_run, [''])
-test('unboxedsums11', omit_ways(['ghci']), compile_and_run, [''])
-test('unboxedsums12', omit_ways(['ghci']), compile, [''])
+test('unarise', normal, compile_and_run, [''])
+test('unboxedsums1', normal, compile_and_run, [''])
+test('unboxedsums2', omit_ways(['ghci']), compile_and_run, ['']) # broken on ghci because of #23412
+test('unboxedsums3', normal, compile_and_run, [''])
+test('unboxedsums4', normal, compile_fail, [''])
+test('unboxedsums5', normal, compile, [''])
+test('unboxedsums6', normal, compile_and_run, [''])
+test('unboxedsums7', normal, compile_and_run, [''])
+test('unboxedsums8', normal, compile_and_run, [''])
+test('unboxedsums9', normal, compile_and_run, [''])
+test('unboxedsums10', normal, compile_and_run, [''])
+test('unboxedsums11', normal, compile_and_run, [''])
+test('unboxedsums12', normal, compile, [''])
-test('UnboxedSumsTH', [req_th,omit_ways(['ghci'])], compile, [''])
-test('UnboxedSumsTH_Fail', [req_th,omit_ways(['ghci'])], compile_fail, [''])
+test('UnboxedSumsTH', [req_th], compile, [''])
+test('UnboxedSumsTH_Fail', [req_th], compile_fail, [''])
test('ffi1', normal, compile_fail, [''])
test('thunk', only_ways(['normal']), compile_and_run, [''])
test('T12375', only_ways(['normal']), compile_and_run, [''])
test('empty_sum', only_ways(['normal']), compile_and_run, [''])
test('sum_rr', normal, compile, [''])
-test('T12711', only_ways(['ghci']), ghci_script, ['T12711.script'])
+test('T12711', normal, ghci_script, ['T12711.script'])
test('UbxSumLevPoly', normal, compile, ['-Wno-overlapping-patterns'])
test('T14051', normal, multi_compile, ['T14051.hs', [('T14051a.hs', '')], '-O2 -v0'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d219c89225b1fc9df0850becde1e879933515250...1882aed59297fd4ae492d577dedfc88eefc5bca8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d219c89225b1fc9df0850becde1e879933515250...1882aed59297fd4ae492d577dedfc88eefc5bca8
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/20230525/53d054ee/attachment-0001.html>
More information about the ghc-commits
mailing list