[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Make STG rewriter produce updatable closures
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Sep 7 10:48:45 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
3930d793 by Jaro Reinders at 2023-09-06T18:42:55-04:00
Make STG rewriter produce updatable closures
- - - - -
0104221a by Krzysztof Gogolewski at 2023-09-06T18:43:32-04:00
configure: update message to use hadrian (#22616)
- - - - -
f6111cb0 by Alan Zimmerman at 2023-09-07T06:48:28-04:00
EPA: Incorrect locations for UserTyVar with '@'
In T13343.hs, the location for the @ is not within the span of the
surrounding UserTyVar.
type Bad @v = (forall (v1 :: RuntimeRep) (a1 :: TYPE v). a1) :: TYPE v
Widen it so it is captured.
Closes #23887
- - - - -
d44df85b by Finley McIlwaine at 2023-09-07T06:48:30-04:00
Bump haddock submodule to fix #23920
Removes the fake export of `FUN` from Prelude. Fixes #23920.
Bumps haddock submodule.
- - - - -
239d7568 by Krzysztof Gogolewski at 2023-09-07T06:48:30-04:00
Fix wrong role in mkSelCo_maybe
In the Lint failure in #23938, we start with a coercion Refl :: T a ~R T a,
and call mkSelCo (SelTyCon 1 nominal) Refl.
The function incorrectly returned Refl :: a ~R a. The returned role
should be nominal, according to the SelCo rule:
co : (T s1..sn) ~r0 (T t1..tn)
r = tyConRole tc r0 i
----------------------------------
SelCo (SelTyCon i r) : si ~r ti
In this test case, r is nominal while r0 is representational.
- - - - -
17 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- configure.ac
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test23887.hs
- testsuite/tests/printer/all.T
- + testsuite/tests/simplCore/should_compile/T23938.hs
- + testsuite/tests/simplCore/should_compile/T23938A.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/simplStg/should_run/T23783.hs
- + testsuite/tests/simplStg/should_run/T23783a.hs
- testsuite/tests/simplStg/should_run/all.T
- utils/check-exact/Main.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -1148,8 +1148,12 @@ mkSelCo_maybe cs co
Pair ty1 ty2 = coercionKind co
go cs co
- | Just (ty, r) <- isReflCo_maybe co
- = Just (mkReflCo r (getNthFromType cs ty))
+ | Just (ty, _co_role) <- isReflCo_maybe co
+ = let new_role = coercionRole (SelCo cs co)
+ in Just (mkReflCo new_role (getNthFromType cs ty))
+ -- The role of the result (new_role) does not have to
+ -- be equal to _co_role, the role of co, per Note [SelCo].
+ -- This was revealed by #23938.
go SelForAll (ForAllCo { fco_kind = kind_co })
= Just kind_co
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -464,9 +464,12 @@ hsScopedKvs (L _ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndr
hsScopedKvs _ = []
---------------------
+hsTyVarLName :: HsTyVarBndr flag (GhcPass p) -> LIdP (GhcPass p)
+hsTyVarLName (UserTyVar _ _ n) = n
+hsTyVarLName (KindedTyVar _ _ n _) = n
+
hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
-hsTyVarName (UserTyVar _ _ (L _ n)) = n
-hsTyVarName (KindedTyVar _ _ (L _ n) _) = n
+hsTyVarName = unLoc . hsTyVarLName
hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName = hsTyVarName . unLoc
@@ -488,10 +491,12 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = kvs
, hsq_explicit = tvs })
= kvs ++ hsLTyVarNames tvs
-hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p))
-hsLTyVarLocName (L l a) = L (l2l l) (hsTyVarName a)
+hsLTyVarLocName :: Anno (IdGhcP p) ~ SrcSpanAnnN
+ => LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p))
+hsLTyVarLocName (L _ a) = hsTyVarLName a
-hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]
+hsLTyVarLocNames :: Anno (IdGhcP p) ~ SrcSpanAnnN
+ => LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
-- | Get the kind signature of a type, ignoring parentheses:
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -1039,7 +1039,7 @@ realSrcSpan :: SrcSpan -> RealSrcSpan
realSrcSpan (RealSrcSpan s _) = s
realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary
where
- l = mkRealSrcLoc (fsLit "foo") (-1) (-1)
+ l = mkRealSrcLoc (fsLit "realSrcSpan") (-1) (-1)
srcSpan2e :: SrcSpan -> EpaLocation
srcSpan2e (RealSrcSpan s mb) = EpaSpan s mb
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -963,19 +963,30 @@ checkTyVars pp_what equals_or_where tc tparms
= let
an = (reverse ops) ++ cps
in
- return (L (widenLocatedAn (l Semi.<> annt) an)
- (KindedTyVar (addAnns (annk Semi.<> ann) an cs) bvis (L lv tv) k))
+ return (L (widenLocatedAn (l Semi.<> annt) (for_widening bvis:an))
+ (KindedTyVar (addAnns (annk Semi.<> ann Semi.<> for_widening_ann bvis) an cs)
+ bvis (L lv tv) k))
chk ops cps cs bvis (L l (HsTyVar ann _ (L ltv tv)))
| isRdrTyVar tv
= let
an = (reverse ops) ++ cps
in
- return (L (widenLocatedAn l an)
- (UserTyVar (addAnns ann an cs) bvis (L ltv tv)))
+ return (L (widenLocatedAn l (for_widening bvis:an))
+ (UserTyVar (addAnns (ann Semi.<> for_widening_ann bvis) an cs)
+ bvis (L ltv tv)))
chk _ _ _ _ t@(L loc _)
= addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
(PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where)
+ -- Return an AddEpAnn for use in widenLocatedAn. The AnnKeywordId is not used.
+ for_widening :: HsBndrVis GhcPs -> AddEpAnn
+ for_widening (HsBndrInvisible (L (TokenLoc loc) _)) = AddEpAnn AnnAnyclass loc
+ for_widening _ = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) [])
+
+ for_widening_ann :: HsBndrVis GhcPs -> EpAnn [AddEpAnn]
+ for_widening_ann (HsBndrInvisible (L (TokenLoc (EpaSpan r _mb)) _)) = EpAnn (realSpanAsAnchor r) [] emptyComments
+ for_widening_ann _ = EpAnnNotUsed
+
whereDots, equalsDots :: SDoc
-- Second argument to checkTyVars
=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -368,7 +368,10 @@ rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args typ) = {-# SCC rewrit
fvs <- fvArgs args
-- lcls <- getFVs
-- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls)
- return $! (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) typ
+
+ -- We mark the closure updatable to retain sharing in the case that
+ -- conExpr is an infinite recursive data type. See #23783.
+ return $! (StgRhsClosure fvs ccs Updatable [] $! conExpr) typ
rewriteRhs _binding (StgRhsClosure fvs ccs flag args body typ) = do
withBinders NotTopLevel args $
withClosureLcls fvs $
=====================================
configure.ac
=====================================
@@ -1313,13 +1313,17 @@ echo "----------------------------------------------------------------------
"
echo "\
-For a standard build of GHC (fully optimised with profiling), type (g)make.
+For a standard build of GHC (fully optimised with profiling), type
+ ./hadrian/build
-To make changes to the default build configuration, copy the file
-mk/build.mk.sample to mk/build.mk, and edit the settings in there.
+You can customise the build with flags such as
+ ./hadrian/build -j --flavour=devel2 [--freeze1]
+
+To make changes to the default build configuration, see the file
+ hadrian/src/UserSettings.hs
For more information on how to configure your GHC build, see
- https://gitlab.haskell.org/ghc/ghc/wikis/building
+ https://gitlab.haskell.org/ghc/ghc/-/wikis/building/hadrian
"]
# Currently we don't validate the /host/ GHC toolchain because configure
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -800,3 +800,8 @@ Test22771:
Test23465:
$(CHECK_PPR) $(LIBDIR) Test23464.hs
$(CHECK_EXACT) $(LIBDIR) Test23464.hs
+
+.PHONY: Test23887
+Test23465:
+ $(CHECK_PPR) $(LIBDIR) Test23887.hs
+ $(CHECK_EXACT) $(LIBDIR) Test23887.hs
=====================================
testsuite/tests/printer/Test23887.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE PolyKinds #-}
+module Test23887 where
+-- based on T13343.hs
+import GHC.Exts
+
+type Bad :: forall v . TYPE v
+type Bad @v = (forall (v1 :: RuntimeRep) (a1 :: TYPE v). a1) :: TYPE v
+
+-- Note v /= v1.
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -192,3 +192,4 @@ test('HsDocTy', [ignore_stderr, req_ppr_deps], makefile_test, ['HsDocTy'])
test('Test22765', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22765'])
test('Test22771', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22771'])
test('Test23464', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23464'])
+test('Test23887', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23887'])
=====================================
testsuite/tests/simplCore/should_compile/T23938.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE MagicHash #-}
+module T23938 where
+
+import T23938A
+import Control.Monad.ST
+
+genIndexes :: () -> ST RealWorld (GVector RealWorld (T Int))
+genIndexes = new f
=====================================
testsuite/tests/simplCore/should_compile/T23938A.hs
=====================================
@@ -0,0 +1,60 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+
+module T23938A where
+
+import GHC.Exts
+import GHC.ST
+import Data.Kind
+
+class Monad m => PrimMonad m where
+ type PrimState m
+ primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
+
+instance PrimMonad (ST s) where
+ type PrimState (ST s) = s
+ primitive = ST
+ {-# INLINE primitive #-}
+
+{-# INLINE stToPrim #-}
+stToPrim (ST m) = primitive m
+
+data family MVector s a
+data instance MVector s Int = MyVector (MutableByteArray# s)
+
+data T (x :: Type)
+
+data family GVector s a
+data instance GVector s (T a) = MV_2 (MVector s a)
+
+new :: (PrimMonad m) => CVector a -> () -> m (GVector (PrimState m) (T a))
+{-# INLINE new #-}
+new e _ = stToPrim (unsafeNew e >>= \v -> ini e v >> return v)
+
+ini :: CVector a -> GVector s (T a) -> ST s ()
+ini e (MV_2 as) = basicInitialize e as
+
+unsafeNew :: (PrimMonad m) => CVector a -> m (GVector (PrimState m) (T a))
+{-# INLINE unsafeNew #-}
+unsafeNew e = stToPrim (basicUnsafeNew e >>= \(!z) -> pure (MV_2 z))
+
+data CVector a = CVector {
+ basicUnsafeNew :: forall s. ST s (MVector s a),
+ basicInitialize :: forall s. MVector s a -> ST s ()
+}
+
+f :: CVector Int
+f = CVector {
+ basicUnsafeNew = ST (\s -> case newByteArray# 4# s of
+ (# s', a #) -> (# s', MyVector a #)),
+
+ basicInitialize = \(MyVector dst) ->
+ ST (\s -> case setByteArray# dst 0# 0# 0# s of s' -> (# s', () #))
+}
+{-# INLINE f #-}
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -497,3 +497,4 @@ test('T23567', [extra_files(['T23567A.hs'])], multimod_compile, ['T23567', '-O -
# The -ddump-simpl of T22404 should have no let-bindings
test('T22404', [only_ways(['optasm']), check_errmsg(r'let') ], compile, ['-ddump-simpl -dsuppress-uniques'])
test('T23864', normal, compile, ['-O -dcore-lint -package ghc -Wno-gadt-mono-local-binds'])
+test('T23938', [extra_files(['T23938A.hs'])], multimod_compile, ['T23938', '-O -v0'])
=====================================
testsuite/tests/simplStg/should_run/T23783.hs
=====================================
@@ -0,0 +1,18 @@
+module Main where
+import T23783a
+import GHC.Conc
+
+expensive :: Int -> Int
+{-# OPAQUE expensive #-}
+expensive x = x
+
+{-# OPAQUE f #-}
+f xs = let ys = expensive xs
+ h zs = let t = wombat t ys in ys `seq` (zs, t, ys)
+ in h
+
+main :: IO ()
+main = do
+ setAllocationCounter 100000
+ enableAllocationLimit
+ case f 0 () of (_, t, _) -> seqT 16 t `seq` pure ()
=====================================
testsuite/tests/simplStg/should_run/T23783a.hs
=====================================
@@ -0,0 +1,8 @@
+module T23783a where
+import Debug.Trace
+data T a = MkT (T a) (T a) !a !Int
+wombat t x = MkT t t x 2
+
+seqT :: Int -> T a -> ()
+seqT 0 _ = ()
+seqT n (MkT x y _ _) = seqT (n - 1) x `seq` seqT (n - 1) y `seq` ()
=====================================
testsuite/tests/simplStg/should_run/all.T
=====================================
@@ -20,3 +20,4 @@ test('T13536a',
test('inferTags001', normal, multimod_compile_and_run, ['inferTags001', 'inferTags001_a'])
test('T22042', [extra_files(['T22042a.hs']),only_ways('normal'),unless(have_dynamic(), skip)], makefile_test, ['T22042'])
+test('T23783', normal, multimod_compile_and_run, ['T23783', '-O -v0'])
\ No newline at end of file
=====================================
utils/check-exact/Main.hs
=====================================
@@ -36,10 +36,10 @@ import GHC.Data.FastString
-- ---------------------------------------------------------------------
_tt :: IO ()
-_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib/"
+-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib/"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib/"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
--- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
+_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
-- "../../testsuite/tests/ghc-api/exactprint/RenameCase1.hs" (Just changeRenameCase1)
-- "../../testsuite/tests/ghc-api/exactprint/LayoutLet2.hs" (Just changeLayoutLet2)
@@ -205,7 +205,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/printer/Test16279.hs" Nothing
-- "../../testsuite/tests/printer/HsDocTy.hs" Nothing
-- "../../testsuite/tests/printer/Test22765.hs" Nothing
- "../../testsuite/tests/printer/Test22771.hs" Nothing
+ -- "../../testsuite/tests/printer/Test22771.hs" Nothing
+ "../../testsuite/tests/typecheck/should_fail/T22560_fail_c.hs" Nothing
-- cloneT does not need a test, function can be retired
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 394920426d99cee7822d5854bc83bbaab4970c7a
+Subproject commit 1130973f07aecc37a37943f4b1cc529aabd15e61
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b15e487657f34b93b07316b75627e4db6f840cf2...239d756810498c7496e77d1b296a1e3b816486a6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b15e487657f34b93b07316b75627e4db6f840cf2...239d756810498c7496e77d1b296a1e3b816486a6
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/20230907/1fb2eb16/attachment-0001.html>
More information about the ghc-commits
mailing list