[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: In mkDataConRep, ensure the in-scope set is right
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Feb 29 21:45:43 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
b4cae4ec by Simon Peyton Jones at 2024-02-29T02:10:08-05:00
In mkDataConRep, ensure the in-scope set is right
A small change that fixes #24489
- - - - -
50dbeb87 by Cheng Shao at 2024-02-29T16:45:37-05:00
testsuite: fix T23540 fragility on 32-bit platforms
T23540 is fragile on 32-bit platforms. The root cause is usage of
`getEvidenceTreesAtPoint`, which internally relies on `Name`'s `Ord`
instance, which is indeterministic. The solution is adding a
deterministic `Ord` instance for `EvidenceInfo` and sorting the
evidence trees before pretty printing. Fixes #24449.
- - - - -
32bbeddf by Teo Camarasu at 2024-02-29T16:45:37-05:00
Reduce AtomicModifyIORef increment count
This test leads to a lot of contention when N>2 and becomes very slow. Let's reduce the amount of work we do to compensate. Resolves #24490
- - - - -
9 changed files:
- compiler/GHC/Iface/Ext/Utils.hs
- compiler/GHC/Types/Id/Make.hs
- libraries/base/tests/AtomicModifyIORef.hs
- libraries/base/tests/AtomicModifyIORef.stdout
- + testsuite/tests/deSugar/should_compile/T24489.hs
- testsuite/tests/deSugar/should_compile/all.T
- testsuite/tests/hiefile/should_run/T23540.stdout
- testsuite/tests/hiefile/should_run/TestUtils.hs
- testsuite/tests/hiefile/should_run/all.T
Changes:
=====================================
compiler/GHC/Iface/Ext/Utils.hs
=====================================
@@ -107,7 +107,13 @@ data EvidenceInfo a
, evidenceSpan :: RealSrcSpan
, evidenceType :: a
, evidenceDetails :: Maybe (EvVarSource, Scope, Maybe Span)
- } deriving (Eq,Ord,Functor)
+ } deriving (Eq, Functor)
+
+instance Ord a => Ord (EvidenceInfo a) where
+ compare (EvidenceInfo name span typ dets) (EvidenceInfo name' span' typ' dets') =
+ case stableNameCmp name name' of
+ EQ -> compare (span, typ, dets) (span', typ', dets')
+ r -> r
instance (Outputable a) => Outputable (EvidenceInfo a) where
ppr (EvidenceInfo name span typ dets) =
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -946,8 +946,7 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con
mk_boxer boxers = DCB (\ ty_args src_vars ->
do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars
subst1 = zipTvSubst univ_tvs ty_args
- subst2 = extendTCvSubstList subst1 ex_tvs
- (mkTyCoVarTys ex_vars)
+ subst2 = foldl2 extendTvSubstWithClone subst1 ex_tvs ex_vars
; (rep_ids, binds) <- go subst2 boxers term_vars
; return (ex_vars ++ rep_ids, binds) } )
=====================================
libraries/base/tests/AtomicModifyIORef.hs
=====================================
@@ -5,7 +5,7 @@ import Data.IORef
main :: IO ()
main = do
let nThreads = 10
- nIncrs = 10000000
+ nIncrs = 10000
ref <- newIORef (42 :: Int)
dones <- replicateM nThreads $ do
=====================================
libraries/base/tests/AtomicModifyIORef.stdout
=====================================
@@ -8,4 +8,4 @@
.
.
.
-100000042
+100042
=====================================
testsuite/tests/deSugar/should_compile/T24489.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE GADTs #-}
+module A where
+
+data Term where
+ BinaryTerm :: {-# UNPACK #-} !Bool -> tag -> Term
+
+f :: Term -> String
+f (BinaryTerm _ _) = "hello"
=====================================
testsuite/tests/deSugar/should_compile/all.T
=====================================
@@ -114,3 +114,4 @@ test('T19969', [grep_errmsg('LoopBreaker')], compile, ['-ddump-simpl -dsuppress-
test('T19883', normal, compile, [''])
test('T22719', normal, compile, ['-ddump-simpl -dsuppress-uniques -dno-typeable-binds'])
test('T23550', normal, compile, [''])
+test('T24489', normal, compile, ['-O'])
=====================================
testsuite/tests/hiefile/should_run/T23540.stdout
=====================================
@@ -124,35 +124,35 @@ At point (49,14), we found:
At point (61,7), we found:
==========================
┌
-│ $dFunctor at T23540.hs:1:1, of type: Functor Identity'
-│ is an evidence variable bound by a let, depending on: [$fFunctorIdentity']
+│ $dApplicative at T23540.hs:1:1, of type: Applicative Identity'
+│ is an evidence variable bound by a let, depending on: [$fApplicativeIdentity']
│ with scope: ModuleScope
│
│ Defined at <no location info>
└
|
`- ┌
- │ $fFunctorIdentity' at T23540.hs:54:10-26, of type: Functor Identity'
- │ is an evidence variable bound by an instance of class Functor
+ │ $fApplicativeIdentity' at T23540.hs:56:10-30, of type: Applicative Identity'
+ │ is an evidence variable bound by an instance of class Applicative
│ with scope: ModuleScope
│
- │ Defined at T23540.hs:54:10
+ │ Defined at T23540.hs:56:10
└
┌
-│ $dApplicative at T23540.hs:1:1, of type: Applicative Identity'
-│ is an evidence variable bound by a let, depending on: [$fApplicativeIdentity']
+│ $dFunctor at T23540.hs:1:1, of type: Functor Identity'
+│ is an evidence variable bound by a let, depending on: [$fFunctorIdentity']
│ with scope: ModuleScope
│
│ Defined at <no location info>
└
|
`- ┌
- │ $fApplicativeIdentity' at T23540.hs:56:10-30, of type: Applicative Identity'
- │ is an evidence variable bound by an instance of class Applicative
+ │ $fFunctorIdentity' at T23540.hs:54:10-26, of type: Functor Identity'
+ │ is an evidence variable bound by an instance of class Functor
│ with scope: ModuleScope
│
- │ Defined at T23540.hs:56:10
+ │ Defined at T23540.hs:54:10
└
==========================
@@ -202,33 +202,34 @@ At point (69,4), we found:
At point (82,6), we found:
==========================
┌
-│ $dOrd at T23540.hs:1:1, of type: Ord Modulo1
-│ is an evidence variable bound by a let, depending on: [$fOrdModulo1]
+│ $dNum at T23540.hs:1:1, of type: Num Modulo1
+│ is an evidence variable bound by a let, depending on: [$fNumModulo1]
│ with scope: ModuleScope
│
│ Defined at <no location info>
└
|
`- ┌
- │ $fOrdModulo1 at T23540.hs:8:35-37, of type: Ord Modulo1
- │ is an evidence variable bound by an instance of class Ord
+ │ $fNumModulo1 at T23540.hs:10:10-20, of type: Num Modulo1
+ │ is an evidence variable bound by an instance of class Num
│ with scope: ModuleScope
│
- │ Defined at T23540.hs:8:35
+ │ Defined at T23540.hs:10:10
└
┌
-│ $dNum at T23540.hs:1:1, of type: Num Modulo1
-│ is an evidence variable bound by a let, depending on: [$fNumModulo1]
+│ $dOrd at T23540.hs:1:1, of type: Ord Modulo1
+│ is an evidence variable bound by a let, depending on: [$fOrdModulo1]
│ with scope: ModuleScope
│
│ Defined at <no location info>
└
|
`- ┌
- │ $fNumModulo1 at T23540.hs:10:10-20, of type: Num Modulo1
- │ is an evidence variable bound by an instance of class Num
+ │ $fOrdModulo1 at T23540.hs:8:35-37, of type: Ord Modulo1
+ │ is an evidence variable bound by an instance of class Ord
│ with scope: ModuleScope
│
- │ Defined at T23540.hs:10:10
- └
\ No newline at end of file
+ │ Defined at T23540.hs:8:35
+ └
+
=====================================
testsuite/tests/hiefile/should_run/TestUtils.hs
=====================================
@@ -10,6 +10,7 @@ module TestUtils
) where
import System.Environment
+import Data.List (sort)
import Data.Tree
import GHC.Types.Name.Cache
import GHC.Types.SrcLoc
@@ -20,13 +21,13 @@ import qualified GHC.Utils.Outputable as O
import GHC.Iface.Ext.Binary
import GHC.Iface.Ext.Types
import GHC.Iface.Ext.Utils
-
+
import GHC.Driver.Session
import GHC.SysTools
makeNc :: IO NameCache
makeNc = initNameCache 'z' []
-
+
dynFlagsForPrinting :: String -> IO DynFlags
dynFlagsForPrinting libdir = do
systemSettings <- initSysTools libdir
@@ -53,7 +54,7 @@ explainEv df hf refmap point = do
putStrLn $ replicate 26 '='
putStr $ drawForest ptrees
where
- trees = getEvidenceTreesAtPoint hf refmap point
+ trees = sort $ getEvidenceTreesAtPoint hf refmap point
ptrees = fmap (pprint . fmap expandType) <$> trees
=====================================
testsuite/tests/hiefile/should_run/all.T
=====================================
@@ -5,5 +5,5 @@ test('T23492', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUti
test('RecordDotTypes', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('SpliceTypes', [req_th, extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('HieVdq', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
-test('T23540', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs']), when(arch('i386'), fragile(24449))], compile_and_run, ['-package ghc -fwrite-ide-info'])
+test('T23540', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('T23120', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6bb7301d3f4a2ce64e1755ae878607bdf980e8ec...32bbeddf760ea20702cafd1a23d248b1c20af615
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6bb7301d3f4a2ce64e1755ae878607bdf980e8ec...32bbeddf760ea20702cafd1a23d248b1c20af615
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/20240229/278b0098/attachment-0001.html>
More information about the ghc-commits
mailing list