[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Fix a bug in continuation capture across multiple stack chunks
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Oct 3 20:51:50 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
95ead839 by Alexis King at 2022-10-01T00:37:43-04:00
Fix a bug in continuation capture across multiple stack chunks
- - - - -
22096652 by Bodigrim at 2022-10-01T00:38:22-04:00
Enforce internal invariant of OrdList and fix bugs in viewCons / viewSnoc
`viewCons` used to ignore `Many` constructor completely, returning `VNothing`.
`viewSnoc` violated internal invariant of `Many` being a non-empty list.
- - - - -
cceea0f1 by Brandon Chinn at 2022-10-02T11:13:38-07:00
Fix docs for pattern synonyms
- - - - -
acfd1986 by Oleg Grenrus at 2022-10-03T16:51:31-04:00
Use sameByteArray# in sameByteArray
- - - - -
6 changed files:
- compiler/GHC/Data/OrdList.hs
- docs/users_guide/exts/pattern_synonyms.rst
- libraries/base/Data/Array/Byte.hs
- rts/Continuation.c
- testsuite/tests/rts/continuations/all.T
- + testsuite/tests/rts/continuations/cont_stack_overflow.hs
Changes:
=====================================
compiler/GHC/Data/OrdList.hs
=====================================
@@ -28,6 +28,8 @@ import GHC.Utils.Misc (strictMap)
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup as Semigroup
infixl 5 `appOL`
@@ -37,7 +39,7 @@ infixr 5 `consOL`
data OrdList a
= None
| One a
- | Many [a] -- Invariant: non-empty
+ | Many (NonEmpty a)
| Cons a (OrdList a)
| Snoc (OrdList a) a
| Two (OrdList a) -- Invariant: non-empty
@@ -100,8 +102,12 @@ pattern ConsOL :: a -> OrdList a -> OrdList a
pattern ConsOL x xs <- (viewCons -> VJust x xs) where
ConsOL x xs = consOL x xs
{-# COMPLETE NilOL, ConsOL #-}
+
viewCons :: OrdList a -> VMaybe a (OrdList a)
-viewCons (One a) = VJust a NilOL
+viewCons None = VNothing
+viewCons (One a) = VJust a NilOL
+viewCons (Many (a :| [])) = VJust a NilOL
+viewCons (Many (a :| b : bs)) = VJust a (Many (b :| bs))
viewCons (Cons a as) = VJust a as
viewCons (Snoc as a) = case viewCons as of
VJust a' as' -> VJust a' (Snoc as' a)
@@ -109,15 +115,18 @@ viewCons (Snoc as a) = case viewCons as of
viewCons (Two as1 as2) = case viewCons as1 of
VJust a' as1' -> VJust a' (Two as1' as2)
VNothing -> viewCons as2
-viewCons _ = VNothing
pattern SnocOL :: OrdList a -> a -> OrdList a
pattern SnocOL xs x <- (viewSnoc -> VJust xs x) where
SnocOL xs x = snocOL xs x
{-# COMPLETE NilOL, SnocOL #-}
+
viewSnoc :: OrdList a -> VMaybe (OrdList a) a
-viewSnoc (One a) = VJust NilOL a
-viewSnoc (Many (reverse -> a:as)) = VJust (Many (reverse as)) a
+viewSnoc None = VNothing
+viewSnoc (One a) = VJust NilOL a
+viewSnoc (Many as) = (`VJust` NE.last as) $ case NE.init as of
+ [] -> NilOL
+ b : bs -> Many (b :| bs)
viewSnoc (Snoc as a) = VJust as a
viewSnoc (Cons a as) = case viewSnoc as of
VJust as' a' -> VJust (Cons a as') a'
@@ -125,18 +134,17 @@ viewSnoc (Cons a as) = case viewSnoc as of
viewSnoc (Two as1 as2) = case viewSnoc as2 of
VJust as2' a' -> VJust (Two as1 as2') a'
VNothing -> viewSnoc as1
-viewSnoc _ = VNothing
headOL None = panic "headOL"
headOL (One a) = a
-headOL (Many as) = head as
+headOL (Many as) = NE.head as
headOL (Cons a _) = a
headOL (Snoc as _) = headOL as
headOL (Two as _) = headOL as
lastOL None = panic "lastOL"
lastOL (One a) = a
-lastOL (Many as) = last as
+lastOL (Many as) = NE.last as
lastOL (Cons _ as) = lastOL as
lastOL (Snoc _ a) = a
lastOL (Two _ as) = lastOL as
@@ -164,7 +172,7 @@ fromOL a = go a []
go (Cons a b) acc = a : go b acc
go (Snoc a b) acc = go a (b:acc)
go (Two a b) acc = go a (go b acc)
- go (Many xs) acc = xs ++ acc
+ go (Many xs) acc = NE.toList xs ++ acc
fromOLReverse :: OrdList a -> [a]
fromOLReverse a = go a []
@@ -175,7 +183,7 @@ fromOLReverse a = go a []
go (Cons a b) acc = go b (a : acc)
go (Snoc a b) acc = b : go a acc
go (Two a b) acc = go b (go a acc)
- go (Many xs) acc = reverse xs ++ acc
+ go (Many xs) acc = reverse (NE.toList xs) ++ acc
mapOL :: (a -> b) -> OrdList a -> OrdList b
mapOL = fmap
@@ -192,7 +200,9 @@ mapOL' f (Snoc xs x) = let !x1 = f x
mapOL' f (Two b1 b2) = let !b1' = mapOL' f b1
!b2' = mapOL' f b2
in Two b1' b2'
-mapOL' f (Many xs) = Many $! strictMap f xs
+mapOL' f (Many (x :| xs)) = let !x1 = f x
+ !xs1 = strictMap f xs
+ in Many (x1 :| xs1)
foldrOL :: (a->b->b) -> b -> OrdList a -> b
foldrOL _ z None = z
@@ -214,7 +224,7 @@ foldlOL k z (Many xs) = foldl' k z xs
toOL :: [a] -> OrdList a
toOL [] = None
toOL [x] = One x
-toOL xs = Many xs
+toOL (x : xs) = Many (x :| xs)
reverseOL :: OrdList a -> OrdList a
reverseOL None = None
@@ -222,7 +232,7 @@ reverseOL (One x) = One x
reverseOL (Cons a b) = Snoc (reverseOL b) a
reverseOL (Snoc a b) = Cons b (reverseOL a)
reverseOL (Two a b) = Two (reverseOL b) (reverseOL a)
-reverseOL (Many xs) = Many (reverse xs)
+reverseOL (Many xs) = Many (NE.reverse xs)
-- | Compare not only the values but also the structure of two lists
strictlyEqOL :: Eq a => OrdList a -> OrdList a -> Bool
=====================================
docs/users_guide/exts/pattern_synonyms.rst
=====================================
@@ -524,9 +524,9 @@ Pragmas for pattern synonyms
----------------------------
The :ref:`inlinable-pragma`, :ref:`inline-pragma` and :ref:`noinline-pragma` are supported for pattern
-synonyms. For example: ::
+synonyms as of GHC 9.2. For example: ::
- patternInlinablePattern x = [x]
+ pattern InlinablePattern x = [x]
{-# INLINABLE InlinablePattern #-}
pattern InlinedPattern x = [x]
{-# INLINE InlinedPattern #-}
=====================================
libraries/base/Data/Array/Byte.hs
=====================================
@@ -185,8 +185,7 @@ compareByteArraysFromBeginning (ByteArray ba1#) (ByteArray ba2#) (I# n#)
-- | Do two byte arrays share the same pointer?
sameByteArray :: ByteArray# -> ByteArray# -> Bool
sameByteArray ba1 ba2 =
- case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of
- r -> isTrue# r
+ case sameByteArray# ba1 ba2 of r -> isTrue# r
-- | @since 4.17.0.0
instance Eq ByteArray where
=====================================
rts/Continuation.c
=====================================
@@ -472,12 +472,14 @@ StgClosure *captureContinuationAndAbort(Capability *cap, StgTSO *tso, StgPromptT
stack = pop_stack_chunk(cap, tso);
for (StgWord i = 0; i < full_chunks; i++) {
- memcpy(cont_stack, stack->sp, stack->stack_size * sizeof(StgWord));
- cont_stack += stack->stack_size;
+ const size_t chunk_words = stack->stack + stack->stack_size - stack->sp - sizeofW(StgUnderflowFrame);
+ memcpy(cont_stack, stack->sp, chunk_words * sizeof(StgWord));
+ cont_stack += chunk_words;
stack = pop_stack_chunk(cap, tso);
}
memcpy(cont_stack, stack->sp, last_chunk_words * sizeof(StgWord));
+ cont_stack += last_chunk_words;
stack->sp += last_chunk_words;
}
=====================================
testsuite/tests/rts/continuations/all.T
=====================================
@@ -2,3 +2,4 @@ test('cont_simple_shift', [extra_files(['ContIO.hs'])], multimod_compile_and_run
test('cont_exn_masking', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_exn_masking', ''])
test('cont_missing_prompt_err', [extra_files(['ContIO.hs']), exit_code(1)], multimod_compile_and_run, ['cont_missing_prompt_err', ''])
test('cont_nondet_handler', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_nondet_handler', ''])
+test('cont_stack_overflow', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_stack_overflow', '-with-rtsopts "-ki1k -kc2k -kb256"'])
=====================================
testsuite/tests/rts/continuations/cont_stack_overflow.hs
=====================================
@@ -0,0 +1,32 @@
+-- This test is run with RTS options that instruct GHC to use a small stack
+-- chunk size (2k), which ensures this test exercises multi-chunk continuation
+-- captures and restores.
+
+import Control.Monad (unless)
+import ContIO
+
+data Answer
+ = Done Int
+ | Yield (IO Int -> IO Answer)
+
+getAnswer :: Answer -> Int
+getAnswer (Done n) = n
+getAnswer (Yield _) = error "getAnswer"
+
+main :: IO ()
+main = do
+ tag <- newPromptTag
+ Yield k <- prompt tag $
+ Done <$> buildBigCont tag 6000
+ n <- getAnswer <$> k (getAnswer <$> k (pure 0))
+ unless (n == 36006000) $
+ error $ "produced wrong value: " ++ show n
+
+buildBigCont :: PromptTag Answer
+ -> Int
+ -> IO Int
+buildBigCont tag size
+ | size <= 0 = control0 tag (\k -> pure (Yield k))
+ | otherwise = do
+ n <- buildBigCont tag (size - 1)
+ pure $! n + size
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2de0bcf0672eda4fc8f701ae53bfecc8524bde48...acfd198662ef745ffa872ed38a6140b9f6a45628
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2de0bcf0672eda4fc8f701ae53bfecc8524bde48...acfd198662ef745ffa872ed38a6140b9f6a45628
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/20221003/d3def07b/attachment-0001.html>
More information about the ghc-commits
mailing list