[Git][ghc/ghc][wip/backports-9.8] 3 commits: Make STG rewriter produce updatable closures
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Mon Sep 18 17:24:28 UTC 2023
Ben Gamari pushed to branch wip/backports-9.8 at Glasgow Haskell Compiler / GHC
Commits:
101a4f52 by Jaro Reinders at 2023-09-18T10:01:23-04:00
Make STG rewriter produce updatable closures
(cherry picked from commit 3930d793901d72f42b1535c85b746f32d5f3b677)
- - - - -
b3a66711 by Sylvain Henry at 2023-09-18T10:06:35-04:00
Add missing int64/word64-to-double/float rules (#23907)
CLC proposal: https://github.com/haskell/core-libraries-committee/issues/203
(cherry picked from commit 5126a2fef0385e206643b6af0543d10ff0c219d8)
- - - - -
5f425fe6 by Alan Zimmerman at 2023-09-18T11:36:35-04:00
EPA: track unicode version for unrestrictedFunTyCon
Closes #23885
Updates haddock submodule
(cherry picked from commit f9d79a6cb78d3ee606249b5393ccaf100577d7dc)
- - - - -
17 changed files:
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- libraries/base/GHC/Float.hs
- libraries/base/changelog.md
- libraries/unix
- + testsuite/tests/numeric/should_compile/T23907.hs
- + testsuite/tests/numeric/should_compile/T23907.stderr
- testsuite/tests/numeric/should_compile/all.T
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test23885.hs
- testsuite/tests/printer/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/ExactPrint.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -773,9 +773,9 @@ identifier :: { LocatedN RdrName }
| qvarop { $1 }
| qconop { $1 }
| '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
+ (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }
| '->' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnnRArrow (glAA $1) []) }
+ (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }
-----------------------------------------------------------------------------
-- Backpack stuff
@@ -3665,7 +3665,7 @@ ntgtycon :: { LocatedN RdrName } -- A "general" qualified tycon, excluding unit
| '(#' bars '#)' {% amsrn (sLL $1 $> $ getRdrName (sumTyCon (snd $2 + 1)))
(NameAnnBars NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
| '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
+ (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }
| '[' ']' {% amsrn (sLL $1 $> $ listTyCon_RDR)
(NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }
@@ -3747,7 +3747,8 @@ otycon :: { LocatedN RdrName }
op :: { LocatedN RdrName } -- used in infix decls
: varop { $1 }
| conop { $1 }
- | '->' { sL1n $1 $ getRdrName unrestrictedFunTyCon }
+ | '->' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
+ (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }
varop :: { LocatedN RdrName }
: varsym { $1 }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -757,7 +757,10 @@ data NameAnn
}
-- | Used for @->@, as an identifier
| NameAnnRArrow {
+ nann_unicode :: Bool,
+ nann_mopen :: Maybe EpaLocation,
nann_name :: EpaLocation,
+ nann_mclose :: Maybe EpaLocation,
nann_trailing :: [TrailingAnn]
}
-- | Used for an item with a leading @'@. The annotation for
@@ -1288,8 +1291,8 @@ instance Outputable NameAnn where
= text "NameAnnBars" <+> ppr a <+> ppr o <+> ppr n <+> ppr b <+> ppr t
ppr (NameAnnOnly a o c t)
= text "NameAnnOnly" <+> ppr a <+> ppr o <+> ppr c <+> ppr t
- ppr (NameAnnRArrow n t)
- = text "NameAnnRArrow" <+> ppr n <+> ppr t
+ ppr (NameAnnRArrow u o n c t)
+ = text "NameAnnRArrow" <+> ppr u <+> ppr o <+> ppr n <+> ppr c <+> ppr t
ppr (NameAnnQuote q n t)
= text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t
ppr (NameAnnTrailing t)
=====================================
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 $
=====================================
libraries/base/GHC/Float.hs
=====================================
@@ -1702,3 +1702,22 @@ foreign import prim "stg_doubleToWord64zh"
"Word# -> Natural -> Double#"
forall x. naturalToDouble# (NS x) = word2Double# x #-}
+
+-- We don't have word64ToFloat/word64ToDouble primops (#23908), only
+-- word2Float/word2Double, so we can only perform these transformations when
+-- word-size is 64-bit.
+#if WORD_SIZE_IN_BITS == 64
+{-# RULES
+
+"Int64# -> Integer -> Float#"
+ forall x. integerToFloat# (integerFromInt64# x) = int2Float# (int64ToInt# x)
+
+"Int64# -> Integer -> Double#"
+ forall x. integerToDouble# (integerFromInt64# x) = int2Double# (int64ToInt# x)
+
+"Word64# -> Integer -> Float#"
+ forall x. integerToFloat# (integerFromWord64# x) = word2Float# (word64ToWord# x)
+
+"Word64# -> Integer -> Double#"
+ forall x. integerToDouble# (integerFromWord64# x) = word2Double# (word64ToWord# x) #-}
+#endif
=====================================
libraries/base/changelog.md
=====================================
@@ -33,6 +33,11 @@
* Implement `GHC.IORef.atomicSwapIORef` via a new dedicated primop `atomicSwapMutVar#` ([CLC proposal #139](https://github.com/haskell/core-libraries-committee/issues/139))
* Change codebuffers to use an unboxed implementation, while providing a compatibility layer using pattern synonyms. ([CLC proposal #134](https://github.com/haskell/core-libraries-committee/issues/134))
* Add nominal role annotations to SNat/SSymbol/SChar ([CLC proposal #170](https://github.com/haskell/core-libraries-committee/issues/170))
+ * Make `Semigroup`'s `stimes` specializable. ([CLC proposal #8](https://github.com/haskell/core-libraries-committee/issues/8))
+ * Deprecate `Data.List.NonEmpty.unzip` ([CLC proposal #86](https://github.com/haskell/core-libraries-committee/issues/86))
+ * Fixed exponent overflow/underflow bugs in the `Read` instances for `Float` and `Double` ([CLC proposal #192](https://github.com/haskell/core-libraries-committee/issues/192))
+ * Implement `copyBytes`, `fillBytes`, `moveBytes` and `stimes` for `Data.Array.Byte.ByteArray` using primops ([CLC proposal #188](https://github.com/haskell/core-libraries-committee/issues/188))
+ * Add rewrite rules for conversion between Int64/Word64 and Float/Double on 64-bit architectures ([CLC proposal #203](https://github.com/haskell/core-libraries-committee/issues/203)).
## 4.18.0.0 *March 2023*
* Shipped with GHC 9.6.1
=====================================
libraries/unix
=====================================
@@ -1 +1 @@
-Subproject commit 3f0d217b5b3de5ccec54154d5cd5c7b0d07708df
+Subproject commit 5c3f316cf13b1c5a2c8622065cccd8eb81a81b89
=====================================
testsuite/tests/numeric/should_compile/T23907.hs
=====================================
@@ -0,0 +1,67 @@
+module T23907 (loop) where
+
+import Data.Word
+import Data.Bits
+
+{-# NOINLINE loop #-}
+loop :: Int -> Double -> SMGen -> (Double, SMGen)
+loop 0 !a !s = (a, s)
+loop n !a !s = loop (n - 1) (a + b) t where (b, t) = nextDouble s
+
+mix64 :: Word64 -> Word64
+mix64 z0 =
+ -- MurmurHash3Mixer
+ let z1 = shiftXorMultiply 33 0xff51afd7ed558ccd z0
+ z2 = shiftXorMultiply 33 0xc4ceb9fe1a85ec53 z1
+ z3 = shiftXor 33 z2
+ in z3
+
+shiftXor :: Int -> Word64 -> Word64
+shiftXor n w = w `xor` (w `shiftR` n)
+
+shiftXorMultiply :: Int -> Word64 -> Word64 -> Word64
+shiftXorMultiply n k w = shiftXor n w * k
+
+nextWord64 :: SMGen -> (Word64, SMGen)
+nextWord64 (SMGen seed gamma) = (mix64 seed', SMGen seed' gamma)
+ where
+ seed' = seed + gamma
+
+nextDouble :: SMGen -> (Double, SMGen)
+nextDouble g = case nextWord64 g of
+ (w64, g') -> (fromIntegral (w64 `shiftR` 11) * doubleUlp, g')
+
+data SMGen = SMGen !Word64 !Word64 -- seed and gamma; gamma is odd
+
+mkSMGen :: Word64 -> SMGen
+mkSMGen s = SMGen (mix64 s) (mixGamma (s + goldenGamma))
+
+goldenGamma :: Word64
+goldenGamma = 0x9e3779b97f4a7c15
+
+floatUlp :: Float
+floatUlp = 1.0 / fromIntegral (1 `shiftL` 24 :: Word32)
+
+doubleUlp :: Double
+doubleUlp = 1.0 / fromIntegral (1 `shiftL` 53 :: Word64)
+
+mix64variant13 :: Word64 -> Word64
+mix64variant13 z0 =
+ -- Better Bit Mixing - Improving on MurmurHash3's 64-bit Finalizer
+ -- http://zimbry.blogspot.fi/2011/09/better-bit-mixing-improving-on.html
+ --
+ -- Stafford's Mix13
+ let z1 = shiftXorMultiply 30 0xbf58476d1ce4e5b9 z0 -- MurmurHash3 mix constants
+ z2 = shiftXorMultiply 27 0x94d049bb133111eb z1
+ z3 = shiftXor 31 z2
+ in z3
+
+mixGamma :: Word64 -> Word64
+mixGamma z0 =
+ let z1 = mix64variant13 z0 .|. 1 -- force to be odd
+ n = popCount (z1 `xor` (z1 `shiftR` 1))
+ -- see: http://www.pcg-random.org/posts/bugs-in-splitmix.html
+ -- let's trust the text of the paper, not the code.
+ in if n >= 24
+ then z1
+ else z1 `xor` 0xaaaaaaaaaaaaaaaa
=====================================
testsuite/tests/numeric/should_compile/T23907.stderr
=====================================
@@ -0,0 +1,57 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 90, types: 62, coercions: 0, joins: 0/3}
+
+$WSMGen
+ = \ conrep conrep1 ->
+ case conrep of { W64# unbx ->
+ case conrep1 of { W64# unbx1 -> SMGen unbx unbx1 }
+ }
+
+Rec {
+$wloop
+ = \ ww ww1 ww2 ww3 ->
+ case ww of ds {
+ __DEFAULT ->
+ let { seed' = plusWord64# ww2 ww3 } in
+ let {
+ x#
+ = timesWord64#
+ (xor64# seed' (uncheckedShiftRL64# seed' 33#))
+ 18397679294719823053#Word64 } in
+ let {
+ x#1
+ = timesWord64#
+ (xor64# x# (uncheckedShiftRL64# x# 33#))
+ 14181476777654086739#Word64 } in
+ $wloop
+ (-# ds 1#)
+ (+##
+ ww1
+ (*##
+ (word2Double#
+ (word64ToWord#
+ (uncheckedShiftRL64#
+ (xor64# x#1 (uncheckedShiftRL64# x#1 33#)) 11#)))
+ 1.1102230246251565e-16##))
+ seed'
+ ww3;
+ 0# -> (# ww1, ww2, ww3 #)
+ }
+end Rec }
+
+loop
+ = \ ds a s ->
+ case ds of { I# ww ->
+ case a of { D# ww1 ->
+ case s of { SMGen ww2 ww3 ->
+ case $wloop ww ww1 ww2 ww3 of { (# ww4, ww5, ww6 #) ->
+ (D# ww4, SMGen ww5 ww6)
+ }
+ }
+ }
+ }
+
+
+
=====================================
testsuite/tests/numeric/should_compile/all.T
=====================================
@@ -20,3 +20,4 @@ test('T20448', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-b
test('T19641', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds -dsuppress-uniques'])
test('T15547', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds -dsuppress-uniques'])
test('T23019', normal, compile, ['-O'])
+test('T23907', [ when(wordsize(32), expect_broken(23908))], compile, ['-ddump-simpl -O2 -dsuppress-all -dno-typeable-binds -dsuppress-uniques'])
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -800,3 +800,9 @@ Test23465:
Test23465:
$(CHECK_PPR) $(LIBDIR) Test23887.hs
$(CHECK_EXACT) $(LIBDIR) Test23887.hs
+
+.PHONY: Test23885
+Test23885:
+ # ppr is not currently unicode aware
+ # $(CHECK_PPR) $(LIBDIR) Test23885.hs
+ $(CHECK_EXACT) $(LIBDIR) Test23885.hs
=====================================
testsuite/tests/printer/Test23885.hs
=====================================
@@ -0,0 +1,25 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE UnicodeSyntax #-}
+module Test23885 where
+
+import Control.Monad (Monad(..), join, ap)
+import Data.Monoid (Monoid(..))
+import Data.Semigroup (Semigroup(..))
+
+class Monoidy to comp id m | m to → comp id where
+ munit :: id `to` m
+ mjoin :: (m `comp` m) `to` m
+
+newtype Sum a = Sum a deriving Show
+instance Num a ⇒ Monoidy (→) (,) () (Sum a) where
+ munit _ = Sum 0
+ mjoin (Sum x, Sum y) = Sum $ x + y
+
+data NT f g = NT { runNT :: ∀ α. f α → g α }
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -192,3 +192,4 @@ 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'])
+test('Test23885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23885'])
=====================================
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/ExactPrint.hs
=====================================
@@ -4087,7 +4087,7 @@ instance ExactPrint (LocatedN RdrName) where
NameAnn a o l c t -> do
mn <- markName a o (Just (l,n)) c
case mn of
- (o', (Just (l',_n)), c') -> do -- (o', (Just (l',n')), c')
+ (o', (Just (l',_n)), c') -> do
t' <- markTrailing t
return (NameAnn a o' l' c' t')
_ -> error "ExactPrint (LocatedN RdrName)"
@@ -4109,10 +4109,23 @@ instance ExactPrint (LocatedN RdrName) where
(o',_,c') <- markName a o Nothing c
t' <- markTrailing t
return (NameAnnOnly a o' c' t')
- NameAnnRArrow nl t -> do
- (AddEpAnn _ nl') <- markKwC NoCaptureComments (AddEpAnn AnnRarrow nl)
+ NameAnnRArrow unicode o nl c t -> do
+ o' <- case o of
+ Just o0 -> do
+ (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn AnnOpenP o0)
+ return (Just o')
+ Nothing -> return Nothing
+ (AddEpAnn _ nl') <-
+ if unicode
+ then markKwC NoCaptureComments (AddEpAnn AnnRarrowU nl)
+ else markKwC NoCaptureComments (AddEpAnn AnnRarrow nl)
+ c' <- case c of
+ Just c0 -> do
+ (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn AnnCloseP c0)
+ return (Just c')
+ Nothing -> return Nothing
t' <- markTrailing t
- return (NameAnnRArrow nl' t')
+ return (NameAnnRArrow unicode o' nl' c' t')
NameAnnQuote q name t -> do
debugM $ "NameAnnQuote"
(AddEpAnn _ q') <- markKwC NoCaptureComments (AddEpAnn AnnSimpleQuote q)
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 250d94539f110f66e24c82ff491423813fc1e8fa
+Subproject commit 44c9290ab7482e96c2b4cab54ed39c7f45051dbd
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d475a709564fb28498d7e7593822c5992de5dae2...5f425fe618d0430d9a9c950104580604740174ad
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d475a709564fb28498d7e7593822c5992de5dae2...5f425fe618d0430d9a9c950104580604740174ad
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/20230918/961c78e5/attachment-0001.html>
More information about the ghc-commits
mailing list