[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: primops: Introduce unsafeThawByteArray#

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Sat Jul 8 17:21:47 UTC 2023



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
8a02ce83 by Ben Gamari at 2023-07-08T13:21:22-04:00
primops: Introduce unsafeThawByteArray#

This addresses an odd asymmetry in the ByteArray# primops, which
previously provided unsafeFreezeByteArray# but no corresponding
thaw operation.

Closes #22710

- - - - -
feb2c1d6 by Bodigrim at 2023-07-08T13:21:31-04:00
Add since annotations for Data.Foldable1

- - - - -
436b87c9 by Sylvain Henry at 2023-07-08T13:21:35-04:00
JS: support -this-unit-id for programs in the linker (#23613)

- - - - -
b90955e6 by Bodigrim at 2023-07-08T13:21:37-04:00
Bump text submodule

- - - - -


16 changed files:

- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Prim.hs
- libraries/base/Data/Foldable1.hs
- libraries/ghc-prim/changelog.md
- libraries/text
- + testsuite/tests/driver/T23613.hs
- testsuite/tests/driver/all.T
- testsuite/tests/driver/multipleHomeUnits/all.T
- testsuite/tests/driver/multipleHomeUnits/hi-dir/all.T
- testsuite/tests/driver/multipleHomeUnits/o-files/all.T
- testsuite/tests/driver/multipleHomeUnits/target-file-path/all.T
- + testsuite/tests/primops/should_run/T22710.hs
- + testsuite/tests/primops/should_run/T22710.stdout
- testsuite/tests/primops/should_run/all.T


Changes:

=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -1922,6 +1922,14 @@ primop  UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp
    with
    has_side_effects = True
 
+primop  UnsafeThawByteArrayOp "unsafeThawByteArray#" GenPrimOp
+   ByteArray# -> State# s -> (# State# s, MutableByteArray# s #)
+   {Make an immutable byte array mutable, without copying.
+
+    @since 0.12.0.0}
+   with
+   has_side_effects = True
+
 primop  SizeofByteArrayOp "sizeofByteArray#" GenPrimOp
    ByteArray# -> Int#
    {Return the size of the array in bytes.}


=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -371,6 +371,10 @@ emitPrimOp cfg primop =
   UnsafeFreezeByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->
     emitAssign (CmmLocal res) arg
 
+--  #define unsafeThawByteArrayzh(r,a)       r=(a)
+  UnsafeThawByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->
+    emitAssign (CmmLocal res) arg
+
 -- Reading/writing pointer arrays
 
   ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->


=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -327,7 +327,7 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache = do
   let (rts_wired_units, rts_wired_functions) = rtsDeps units
 
   -- all the units we want to link together, without their dependencies
-  let root_units = filter (/= mainUnitId)
+  let root_units = filter (/= ue_currentUnit unit_env)
                    $ filter (/= interactiveUnitId)
                    $ nub
                    $ rts_wired_units ++ reverse obj_units ++ reverse units


=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -652,6 +652,7 @@ genPrim prof bound ty op = case op of
   ShrinkMutableByteArrayOp_Char     -> \[]    [a,n]      -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n]
   ResizeMutableByteArrayOp_Char     -> \[r]   [a,n]      -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n]
   UnsafeFreezeByteArrayOp           -> \[a]   [b]        -> PrimInline $ a |= b
+  UnsafeThawByteArrayOp             -> \[a]   [b]        -> PrimInline $ a |= b
   SizeofByteArrayOp                 -> \[r]   [a]        -> PrimInline $ r |= a .^ "len"
   SizeofMutableByteArrayOp          -> \[r]   [a]        -> PrimInline $ r |= a .^ "len"
   GetSizeofMutableByteArrayOp       -> \[r]   [a]        -> PrimInline $ r |= a .^ "len"


=====================================
libraries/base/Data/Foldable1.hs
=====================================
@@ -2,6 +2,9 @@
 -- Copyright: Edward Kmett, Oleg Grenrus
 -- License: BSD-3-Clause
 --
+-- A class of non-empty data structures that can be folded to a summary value.
+--
+-- @since 4.18.0.0
 
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -12,7 +15,6 @@
 {-# LANGUAGE Trustworthy                #-}
 {-# LANGUAGE TypeOperators              #-}
 
--- | A class of non-empty data structures that can be folded to a summary value.
 module Data.Foldable1 (
     Foldable1(..),
     foldr1, foldr1',
@@ -65,6 +67,8 @@ import Data.Coerce (Coercible, coerce)
 -------------------------------------------------------------------------------
 
 -- | Non-empty data structures that can be folded.
+--
+-- @since 4.18.0.0
 class Foldable t => Foldable1 t where
     {-# MINIMAL foldMap1 | foldrMap1 #-}
 
@@ -86,6 +90,8 @@ class Foldable t => Foldable1 t where
     -- them via the semigroup's @('<>')@ operator. This fold is
     -- right-associative and lazy in the accumulator. When you need a strict
     -- left-associative fold, use 'foldMap1'' instead, with 'id' as the map.
+    --
+    -- @since 4.18.0.0
     fold1 :: Semigroup m => t m -> m
     fold1 = foldMap1 id
 
@@ -97,6 +103,7 @@ class Foldable t => Foldable1 t where
     -- >>> foldMap1 (:[]) (1 :| [2, 3, 4])
     -- [1,2,3,4]
     --
+    -- @since 4.18.0.0
     foldMap1 :: Semigroup m => (a -> m) -> t a -> m
     foldMap1 f = foldrMap1 f (\a m -> f a <> m)
 
@@ -107,6 +114,7 @@ class Foldable t => Foldable1 t where
     -- >>> foldMap1' Sum (1 :| [2, 3, 4])
     -- Sum {getSum = 10}
     --
+    -- @since 4.18.0.0
     foldMap1' :: Semigroup m => (a -> m) -> t a -> m
     foldMap1' f = foldlMap1' f (\m a -> m <> f a)
 
@@ -115,6 +123,7 @@ class Foldable t => Foldable1 t where
     -- >>> toNonEmpty (Identity 2)
     -- 2 :| []
     --
+    -- @since 4.18.0.0
     toNonEmpty :: t a -> NonEmpty a
     toNonEmpty = runNonEmptyDList . foldMap1 singleton
 
@@ -123,6 +132,7 @@ class Foldable t => Foldable1 t where
     -- >>> maximum (32 :| [64, 8, 128, 16])
     -- 128
     --
+    -- @since 4.18.0.0
     maximum :: Ord a => t a -> a
     maximum = getMax #. foldMap1' Max
 
@@ -131,6 +141,7 @@ class Foldable t => Foldable1 t where
     -- >>> minimum (32 :| [64, 8, 128, 16])
     -- 8
     --
+    -- @since 4.18.0.0
     minimum :: Ord a => t a -> a
     minimum = getMin #. foldMap1' Min
 
@@ -139,6 +150,7 @@ class Foldable t => Foldable1 t where
     -- >>> head (1 :| [2, 3, 4])
     -- 1
     --
+    -- @since 4.18.0.0
     head :: t a -> a
     head = getFirst #. foldMap1 First
 
@@ -147,6 +159,7 @@ class Foldable t => Foldable1 t where
     -- >>> last (1 :| [2, 3, 4])
     -- 4
     --
+    -- @since 4.18.0.0
     last :: t a -> a
     last = getLast #. foldMap1 Last
 
@@ -168,6 +181,7 @@ class Foldable t => Foldable1 t where
     --
     -- @foldrMap1 f g = foldrMap1 f g . 'toNonEmpty'@
     --
+    -- @since 4.18.0.0
     foldrMap1 :: (a -> b) -> (a -> b -> b) -> t a -> b
     foldrMap1 f g xs =
         appFromMaybe (foldMap1 (FromMaybe #. h) xs) Nothing
@@ -188,6 +202,7 @@ class Foldable t => Foldable1 t where
     --
     -- @foldlMap1' f z = foldlMap1' f z . 'toNonEmpty'@
     --
+    -- @since 4.18.0.0
     foldlMap1' :: (a -> b) -> (b -> a -> b) -> t a -> b
     foldlMap1' f g xs =
         foldrMap1 f' g' xs SNothing
@@ -227,6 +242,7 @@ class Foldable t => Foldable1 t where
     --
     -- @foldlMap1 f g = foldlMap1 f g . 'toNonEmpty'@
     --
+    -- @since 4.18.0.0
     foldlMap1 :: (a -> b) -> (b -> a -> b) -> t a -> b
     foldlMap1 f g xs =
         appFromMaybe (getDual (foldMap1 ((Dual . FromMaybe) #. h) xs)) Nothing
@@ -249,6 +265,7 @@ class Foldable t => Foldable1 t where
     -- poor fit for the task at hand. If the order in which the elements are
     -- combined is not important, use 'foldlMap1'' instead.
     --
+    -- @since 4.18.0.0
     foldrMap1' :: (a -> b) -> (a -> b -> b) -> t a -> b
     foldrMap1' f g xs =
         foldlMap1 f' g' xs SNothing
@@ -264,21 +281,29 @@ class Foldable t => Foldable1 t where
 -------------------------------------------------------------------------------
 
 -- | A variant of 'foldrMap1' where the rightmost element maps to itself.
+--
+-- @since 4.18.0.0
 foldr1 :: Foldable1 t => (a -> a -> a) -> t a -> a
 foldr1 = foldrMap1 id
 {-# INLINE foldr1 #-}
 
 -- | A variant of 'foldrMap1'' where the rightmost element maps to itself.
+--
+-- @since 4.18.0.0
 foldr1' :: Foldable1 t => (a -> a -> a) -> t a -> a
 foldr1' = foldrMap1' id
 {-# INLINE foldr1' #-}
 
 -- | A variant of 'foldlMap1' where the leftmost element maps to itself.
+--
+-- @since 4.18.0.0
 foldl1 :: Foldable1 t => (a -> a -> a) -> t a -> a
 foldl1 = foldlMap1 id
 {-# INLINE foldl1 #-}
 
 -- | A variant of 'foldlMap1'' where the leftmost element maps to itself.
+--
+-- @since 4.18.0.0
 foldl1' :: Foldable1 t => (a -> a -> a) -> t a -> a
 foldl1' = foldlMap1' id
 {-# INLINE foldl1' #-}
@@ -294,6 +319,7 @@ foldl1' = foldlMap1' id
 -- >>> intercalate1 mempty $ "I" :| ["Am", "Fine", "You?"]
 -- "IAmFineYou?"
 --
+-- @since 4.18.0.0
 intercalate1 :: (Foldable1 t, Semigroup m) => m -> t m -> m
 intercalate1 = flip intercalateMap1 id
 
@@ -302,10 +328,14 @@ intercalateMap1 j f = flip joinee j . foldMap1 (JoinWith . const . f)
 
 -- | Monadic fold over the elements of a non-empty structure,
 -- associating to the right, i.e. from right to left.
+--
+-- @since 4.18.0.0
 foldrM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a
 foldrM1 = foldrMapM1 return
 
 -- | Map variant of 'foldrM1'.
+--
+-- @since 4.18.0.0
 foldrMapM1 :: (Foldable1 t, Monad m) => (a -> m b) -> (a -> b -> m b) -> t a -> m b
 foldrMapM1 g f = go . toNonEmpty
   where
@@ -316,16 +346,22 @@ foldrMapM1 g f = go . toNonEmpty
 
 -- | Monadic fold over the elements of a non-empty structure,
 -- associating to the left, i.e. from left to right.
+--
+-- @since 4.18.0.0
 foldlM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a
 foldlM1 = foldlMapM1 return
 
 -- | Map variant of 'foldlM1'.
+--
+-- @since 4.18.0.0
 foldlMapM1 :: (Foldable1 t, Monad m) => (a -> m b) -> (b -> a -> m b) -> t a -> m b
 foldlMapM1 g f t = g x >>= \y -> foldlM f y xs
   where x:|xs = toNonEmpty t
 
 -- | The largest element of a non-empty structure with respect to the
 -- given comparison function.
+--
+-- @since 4.18.0.0
 maximumBy :: Foldable1 t => (a -> a -> Ordering) -> t a -> a
 maximumBy cmp = foldl1' max'
   where max' x y = case cmp x y of
@@ -334,6 +370,8 @@ maximumBy cmp = foldl1' max'
 
 -- | The least element of a non-empty structure with respect to the
 -- given comparison function.
+--
+-- @since 4.18.0.0
 minimumBy :: Foldable1 t => (a -> a -> Ordering) -> t a -> a
 minimumBy cmp = foldl1' min'
   where min' x y = case cmp x y of
@@ -379,6 +417,7 @@ instance Semigroup a => Semigroup (JoinWith a) where
 -- Instances for misc base types
 -------------------------------------------------------------------------------
 
+-- | @since 4.18.0.0
 instance Foldable1 NonEmpty where
     foldMap1 f (x :| xs) = go (f x) xs where
         go y [] = y
@@ -398,9 +437,11 @@ instance Foldable1 NonEmpty where
     head = NE.head
     last = NE.last
 
+-- | @since 4.18.0.0
 instance Foldable1 Down where
     foldMap1 = coerce
 
+-- | @since 4.18.0.0
 instance Foldable1 Complex where
     foldMap1 f (x :+ y) = f x <> f y
 
@@ -412,6 +453,7 @@ instance Foldable1 Complex where
 
 -- 3+ tuples are not Foldable/Traversable
 
+-- | @since 4.18.0.0
 instance Foldable1 Solo where
     foldMap1 f (MkSolo y) = f y
     toNonEmpty (MkSolo x) = x :| []
@@ -420,6 +462,7 @@ instance Foldable1 Solo where
     head (MkSolo x) = x
     last (MkSolo x) = x
 
+-- | @since 4.18.0.0
 instance Foldable1 ((,) a) where
     foldMap1 f (_, y) = f y
     toNonEmpty (_, x) = x :| []
@@ -432,52 +475,68 @@ instance Foldable1 ((,) a) where
 -- Monoid / Semigroup instances
 -------------------------------------------------------------------------------
 
+-- | @since 4.18.0.0
 instance Foldable1 Dual where
     foldMap1 = coerce
 
+-- | @since 4.18.0.0
 instance Foldable1 Sum where
     foldMap1 = coerce
 
+-- | @since 4.18.0.0
 instance Foldable1 Product where
     foldMap1 = coerce
 
+-- | @since 4.18.0.0
 instance Foldable1 Min where
     foldMap1 = coerce
 
+-- | @since 4.18.0.0
 instance Foldable1 Max where
     foldMap1 = coerce
 
+-- | @since 4.18.0.0
 instance Foldable1 First where
     foldMap1 = coerce
 
+-- | @since 4.18.0.0
 instance Foldable1 Last where
     foldMap1 = coerce
 
+-- | @since 4.18.0.0
 deriving instance (Foldable1 f) => Foldable1 (Mon.Alt f)
 
+-- | @since 4.18.0.0
 deriving instance (Foldable1 f) => Foldable1 (Mon.Ap f)
 
 -------------------------------------------------------------------------------
 -- GHC.Generics instances
 -------------------------------------------------------------------------------
 
+-- | @since 4.18.0.0
 instance Foldable1 V1 where
     foldMap1 _ x = x `seq` error "foldMap1 @V1"
 
+-- | @since 4.18.0.0
 instance Foldable1 Par1 where
     foldMap1 = coerce
 
+-- | @since 4.18.0.0
 deriving instance Foldable1 f => Foldable1 (Rec1 f)
 
+-- | @since 4.18.0.0
 deriving instance Foldable1 f => Foldable1 (M1 i c f)
 
+-- | @since 4.18.0.0
 instance (Foldable1 f, Foldable1 g) => Foldable1 (f :+: g) where
     foldMap1 f (L1 x) = foldMap1 f x
     foldMap1 f (R1 y) = foldMap1 f y
 
+-- | @since 4.18.0.0
 instance (Foldable1 f, Foldable1 g) => Foldable1 (f :*: g) where
     foldMap1 f (x :*: y) = foldMap1 f x <> foldMap1 f y
 
+-- | @since 4.18.0.0
 instance (Foldable1 f, Foldable1 g) => Foldable1 (f :.: g) where
     foldMap1 f = foldMap1 (foldMap1 f) . unComp1
 
@@ -485,6 +544,7 @@ instance (Foldable1 f, Foldable1 g) => Foldable1 (f :.: g) where
 -- Extra instances
 -------------------------------------------------------------------------------
 
+-- | @since 4.18.0.0
 instance Foldable1 Identity where
     foldMap1      = coerce
 
@@ -509,6 +569,7 @@ instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Product f g) where
     head (Functor.Pair x _) = head x
     last (Functor.Pair _ y) = last y
 
+-- | @since 4.18.0.0
 instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Sum f g) where
     foldMap1 f (Functor.InL x) = foldMap1 f x
     foldMap1 f (Functor.InR y) = foldMap1 f y
@@ -529,6 +590,7 @@ instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Sum f g) where
     maximum (Functor.InL x) = maximum x
     maximum (Functor.InR y) = maximum y
 
+-- | @since 4.18.0.0
 instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where
     foldMap1 f = foldMap1 (foldMap1 f) . getCompose
 


=====================================
libraries/ghc-prim/changelog.md
=====================================
@@ -1,3 +1,10 @@
+## 0.12.0
+
+- Shipped with GHC 9.10.1
+
+- The `unsafeThawByteArray#` primop was added, serving as a inverse to the existing
+  `unsafeFreezeByteArray#` primop (see #22710).
+
 ## 0.11.0
 
 - Shipped with GHC 9.8.1


=====================================
libraries/text
=====================================
@@ -1 +1 @@
-Subproject commit e815d4d9bc362f4a3a36a850931fd3504eda967e
+Subproject commit a961985e63105e3c50035e7e8dab1d218332dd0f


=====================================
testsuite/tests/driver/T23613.hs
=====================================
@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = return ()


=====================================
testsuite/tests/driver/all.T
=====================================
@@ -320,6 +320,7 @@ test('T21869', [js_broken(22261), when(unregisterised(), skip)], makefile_test,
 test('T22044', normal, makefile_test, [])
 test('T22048', [only_ways(['normal']), grep_errmsg("_rule")], compile, ["-O -fomit-interface-pragmas -ddump-simpl"])
 test('T21722', normal, compile_fail, ['-fno-show-error-context'])
-test('T22669', js_skip, makefile_test, [])
-test('T23339', js_skip, makefile_test, [])
-test('T23339B', [extra_files(['T23339.hs']), js_skip], makefile_test, [])
+test('T22669', req_interp, makefile_test, [])
+test('T23339', req_c, makefile_test, [])
+test('T23339B', [extra_files(['T23339.hs']), req_c], makefile_test, [])
+test('T23613', normal, compile_and_run, ['-this-unit-id=foo'])


=====================================
testsuite/tests/driver/multipleHomeUnits/all.T
=====================================
@@ -1,7 +1,7 @@
 test('multipleHomeUnits_single1', [extra_files([ 'a/', 'unitA'])], multiunit_compile, [['unitA'], '-fhide-source-paths'])
 test('multipleHomeUnits_single2', [extra_files([ 'b/', 'unitB'])], multiunit_compile, [['unitB'], '-fhide-source-paths'])
-test('multipleHomeUnits_single3', [js_broken(22261),extra_files([ 'c/', 'unitC'])], multiunit_compile, [['unitC'], '-fhide-source-paths'])
-test('multipleHomeUnits_single4', [js_broken(22261),extra_files([ 'd/', 'unitD'])], multiunit_compile, [['unitD'], '-fhide-source-paths'])
+test('multipleHomeUnits_single3', [extra_files([ 'c/', 'unitC'])], multiunit_compile, [['unitC'], '-fhide-source-paths'])
+test('multipleHomeUnits_single4', [extra_files([ 'd/', 'unitD'])], multiunit_compile, [['unitD'], '-fhide-source-paths'])
 test('multipleHomeUnits_single5', [req_th,extra_files([ 'th/', 'unitTH'])], multiunit_compile, [['unitTH'], '-fhide-source-paths'])
 test('multipleHomeUnits_cpp', [extra_files([ 'cpp-includes/', 'unitCPPIncludes'])], multiunit_compile, [['unitCPPIncludes'], '-fhide-source-paths'])
 test('multipleHomeUnits_cfile', [extra_files([ 'c-file/', 'unitCFile'])], multiunit_compile, [['unitCFile'], '-fhide-source-paths'])
@@ -24,14 +24,12 @@ test('multipleHomeUnits002',
     [ extra_files(
         [ 'c/', 'd/'
         , 'unitC', 'unitD'])
-    , js_broken(22261)
     ], makefile_test, [])
 
 test('multipleHomeUnits003',
     [ extra_files(
         [ 'a/', 'b/', 'c/', 'd/'
         , 'unitA', 'unitB', 'unitC', 'unitD'])
-    , js_broken(22261)
     ], makefile_test, [])
 
 test('multipleHomeUnits004',


=====================================
testsuite/tests/driver/multipleHomeUnits/hi-dir/all.T
=====================================
@@ -1,7 +1,6 @@
 # This test checks that getRootSummary doesn't cross package boundaries.
 test('multipleHomeUnits_hidir'
     , [extra_files([ 'p1/', 'unitP1'])
-      , js_broken(22261)
       ]
     , makefile_test
     , ['mhu-hidir'])


=====================================
testsuite/tests/driver/multipleHomeUnits/o-files/all.T
=====================================
@@ -1,7 +1,6 @@
 # This test checks that getRootSummary doesn't cross package boundaries.
 test('multipleHomeUnits_o-files'
     , [extra_files([ 'p1/', 'unitP1'])
-      , js_broken(22261)
       , pre_cmd('$MAKE -s --no-print-directory setup')]
     , multiunit_compile
     , [['unitP1'], '-fhide-source-paths'])


=====================================
testsuite/tests/driver/multipleHomeUnits/target-file-path/all.T
=====================================
@@ -1,7 +1,6 @@
 # This test checks that getRootSummary doesn't cross package boundaries.
 test('multipleHomeUnits_target-file-path'
     , [extra_files([ 'p1/', 'unitP1'])
-      , js_broken(22261)
       ]
     , multiunit_compile
     , [['unitP1'], '-fhide-source-paths'])


=====================================
testsuite/tests/primops/should_run/T22710.hs
=====================================
@@ -0,0 +1,55 @@
+-- | Test 'unsafeThawByteArray#'.
+
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+import GHC.Exts (newByteArray#, indexWord8Array#, writeWord8Array#,
+                 unsafeFreezeByteArray#, unsafeThawByteArray#,
+                 ByteArray#, MutableByteArray#, Int(I#))
+import GHC.Word
+import GHC.ST
+import Prelude hiding (toList)
+
+main :: IO ()
+main = do
+    res <- return $ runST $ do
+        let n = 32 :: Int
+        marr <- newByteArray n
+        mapM_ (\i -> writeWord8Array marr i (fromIntegral i)) [0..n-1]
+        arr <- unsafeFreezeByteArray marr
+        marr' <- unsafeThawByteArray arr
+        arr' <- unsafeFreezeByteArray marr'
+        return $ toList arr' 5
+
+    print res
+
+data ByteArray = ByteArray { unBA :: ByteArray# }
+data MByteArray s = MByteArray { unMBA :: MutableByteArray# s }
+
+newByteArray :: Int -> ST s (MByteArray s)
+newByteArray (I# n#) = ST $ \s# -> case newByteArray# n# s# of
+    (# s2#, marr# #) -> (# s2#, MByteArray marr# #)
+
+indexWord8Array :: ByteArray -> Int -> Word8
+indexWord8Array arr (I# i#) = case indexWord8Array# (unBA arr) i# of
+    a -> W8# a
+
+writeWord8Array :: MByteArray s -> Int -> Word8 -> ST s ()
+writeWord8Array marr (I# i#) (W8# a) = ST $ \ s# ->
+    case writeWord8Array# (unMBA marr) i# a s# of
+        s2# -> (# s2#, () #)
+
+unsafeFreezeByteArray :: MByteArray s -> ST s ByteArray
+unsafeFreezeByteArray marr = ST $ \ s# ->
+    case unsafeFreezeByteArray# (unMBA marr) s# of
+        (# s2#, arr# #) -> (# s2#, ByteArray arr# #)
+
+unsafeThawByteArray :: ByteArray -> ST s (MByteArray s)
+unsafeThawByteArray arr = ST $ \ s# ->
+    case unsafeThawByteArray# (unBA arr) s# of
+        (# s2#, marr# #) -> (# s2#, MByteArray marr# #)
+
+toList :: ByteArray -> Int -> [Word8]
+toList arr n = go 0
+  where
+    go i | i >= n = []
+         | otherwise = indexWord8Array arr i : go (i+1)


=====================================
testsuite/tests/primops/should_run/T22710.stdout
=====================================
@@ -0,0 +1 @@
+[0,1,2,3,4]


=====================================
testsuite/tests/primops/should_run/all.T
=====================================
@@ -71,3 +71,4 @@ test('FMA_ConstantFold'
 
 test('T21624', normal, compile_and_run, [''])
 test('T23071', ignore_stdout, compile_and_run, [''])
+test('T22710', normal, compile_and_run, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/53044bd6690fd72c7fd7a7fadef3cdffc7e772dd...b90955e6e20fb20cb65fdf3eb1f3ad80130dfaa9

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/53044bd6690fd72c7fd7a7fadef3cdffc7e772dd...b90955e6e20fb20cb65fdf3eb1f3ad80130dfaa9
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/20230708/bbec266b/attachment-0001.html>


More information about the ghc-commits mailing list