array-primops 0.1.0.0 → 0.2.0.0

raw patch · 7 files changed

+561/−247 lines, 7 filesdep +QuickCheckdep +array-primopsdep +tastydep ~basedep ~ghc-primPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, array-primops, tasty, tasty-quickcheck

Dependency ranges changed: base, ghc-prim

API changes (from Hackage documentation)

Files

• GHC/Prim/Array.hs +32/−6
• GHC/Prim/SmallArray.hs +32/−6
• array-primops.cabal +19/−15
• benchmarks/Benchmarks.hs +178/−119
• cbits/array.cmm +98/−55
• cbits/smallArray.cmm +87/−46
• tests/Tests.hs +115/−0

@@ -3,22 +3,48 @@     MagicHash, ForeignFunctionInterface,     GHCForeignImportPrim, UnliftedFFITypes #-} -module GHC.Prim.Array where+module GHC.Prim.Array (+    consArray#+  , snocArray#+  , snocArrayWithPadding#+  , insertArray#+  , deleteArray#+  ) where -import GHC.Prim (Int#, Array#, Any)+import GHC.Prim  -- | Prepend an element to an array.-foreign import prim "consArray" consArray#+foreign import prim "consArray" consArray_   :: Any -> Array# a -> Array# a  -- | Append an element to the end of an array.-foreign import prim "snocArray" snocArray#+foreign import prim "snocArray" snocArray_   :: Array# a -> Any -> Array# a +foreign import prim "snocArrayWithPadding" snocArrayWithPadding_+  :: Int# -> Any -> Array# a -> Any -> Array# a+ -- | Insert new element at position.-foreign import prim "insertArray" insertArray#+foreign import prim "insertArray" insertArray_   :: Int# -> Any -> Array# a -> Array# a --- | Delete element at position. +-- | Delete element at position. foreign import prim "deleteArray" deleteArray#   :: Int# -> Array# a -> Array# a++consArray# :: a -> Array# a -> Array# a+consArray# a arr = consArray_ (unsafeCoerce# a) arr+{-# inline consArray# #-}++snocArray# :: Array# a -> a -> Array# a+snocArray# arr a = snocArray_ arr (unsafeCoerce# a)+{-# inline snocArray# #-}++snocArrayWithPadding# :: Int# -> a -> Array# a -> a -> Array# a+snocArrayWithPadding# pad padElem arr a =+  snocArrayWithPadding_ pad (unsafeCoerce# padElem) arr (unsafeCoerce# a)+{-# inline snocArrayWithPadding# #-}++insertArray# :: Int# -> a -> Array# a -> Array# a+insertArray# i a arr = insertArray_ i (unsafeCoerce# a) arr+{-# inline insertArray# #-}

@@ -3,22 +3,48 @@     MagicHash, ForeignFunctionInterface,     GHCForeignImportPrim, UnliftedFFITypes #-} -module GHC.Prim.SmallArray where+module GHC.Prim.SmallArray (+    consSmallArray#+  , snocSmallArray#+  , snocSmallArrayWithPadding#+  , insertSmallArray#+  , deleteSmallArray#+  ) where -import GHC.Prim (Int#, SmallArray#, Any)+import GHC.Prim  -- | Prepend an element to an array.-foreign import prim "consSmallArray" consSmallArray#+foreign import prim "consSmallArray" consSmallArray_   :: Any -> SmallArray# a -> SmallArray# a  -- | Append an element to the end of an array.-foreign import prim "snocSmallArray" snocSmallArray#+foreign import prim "snocSmallArray" snocSmallArray_   :: SmallArray# a -> Any -> SmallArray# a +foreign import prim "snocSmallArrayWithPadding" snocSmallArrayWithPadding_+  :: Int# -> Any -> SmallArray# a -> Any -> SmallArray# a+ -- | Insert new element at position.-foreign import prim "insertSmallArray" insertSmallArray#+foreign import prim "insertSmallArray" insertSmallArray_   :: Int# -> Any -> SmallArray# a -> SmallArray# a --- | Delete element at position. +-- | Delete element at position. foreign import prim "deleteSmallArray" deleteSmallArray#   :: Int# -> SmallArray# a -> SmallArray# a++consSmallArray# :: a -> SmallArray# a -> SmallArray# a+consSmallArray# a arr = consSmallArray_ (unsafeCoerce# a) arr+{-# inline consSmallArray# #-}++snocSmallArray# :: SmallArray# a -> a -> SmallArray# a+snocSmallArray# arr a = snocSmallArray_ arr (unsafeCoerce# a)+{-# inline snocSmallArray# #-}++snocSmallArrayWithPadding# :: Int# -> a -> SmallArray# a -> a -> SmallArray# a+snocSmallArrayWithPadding# pad padElem arr a =+  snocSmallArrayWithPadding_ pad (unsafeCoerce# padElem) arr (unsafeCoerce# a)+{-# inline snocSmallArrayWithPadding# #-}++insertSmallArray# :: Int# -> a -> SmallArray# a -> SmallArray# a+insertSmallArray# i a arr = insertSmallArray_ i (unsafeCoerce# a) arr+{-# inline insertSmallArray# #-}

@@ -1,6 +1,6 @@  name:                array-primops-version:             0.1.0.0+version:             0.2.0.0 synopsis:            Extra foreign primops for primitive arrays license:             BSD3 license-file:        LICENSE@@ -34,21 +34,28 @@     c-sources:       cbits/array.cmm   -    if impl(ghc >= 7.10)-    -      exposed-modules:-        GHC.Prim.SmallArray--      build-depends:-        ghc-prim >= 0.4.0.0+  if impl(ghc >= 7.10)+  +    exposed-modules:+      GHC.Prim.SmallArray -      c-sources:-        cbits/smallArray.cmm+    build-depends:+      ghc-prim >= 0.4.0.0 +    c-sources:+      cbits/smallArray.cmm +test-suite tests+  hs-source-dirs: tests+  main-is: Tests.hs+  type: exitcode-stdio-1.0+  build-depends:+    QuickCheck, tasty, tasty-quickcheck, ghc-prim, base, array-primops+  ghc-options: -O2+                 benchmark benchmarks   default-language: Haskell2010-  hs-source-dirs: . benchmarks+  hs-source-dirs: benchmarks    main-is: Benchmarks.hs   type: exitcode-stdio-1.0@@ -56,10 +63,7 @@   build-depends:     base,     ghc-prim,+    array-primops,     criterion >= 1.0--  c-sources: -    cbits/array.cmm,-    cbits/smallArray.cmm    ghc-options: -O2 -fllvm

@@ -4,16 +4,30 @@     BangPatterns, CPP, MagicHash, UnboxedTuples,     UnliftedFFITypes, GHCForeignImportPrim #-} +{-# OPTIONS -fno-full-laziness #-}+ import GHC.Types-import GHC.Prim-import GHC.ST+import GHC.Prim hiding (runSTRep)  import GHC.Prim.Array import GHC.Prim.SmallArray import Criterion.Main import Criterion.Types +#include "MachDeps.h" +runSTRep :: (forall s. State# s -> (# State# s, a #)) -> a+runSTRep f = case f realWorld# of (# _ , a #) -> a+{-# INLINE [0] runSTRep #-}++-- runSA :: (forall s. State# s -> (# State# s, SmallArray# a #)) -> SmallArray# a+-- runSA f = case f realWorld# of (# _ , arr #) -> arr+-- {-# INLINE [0] runSA #-}++-- runA :: (forall s. State# s -> (# State# s, Array# a #)) -> Array# a+-- runA f = case f realWorld# of (# _ , arr #) -> arr+-- {-# INLINE [0] runA #-}+ an  n = fromListA  [(0::Int)..n] san n = fromListSA [(0::Int)..n] @@ -21,140 +35,167 @@ a100  = an 100 a1000 = an 1000 +sa2    = san 2+sa5    = san 5 sa10   = san 10 sa100  = san 100 sa1000 = san 1000 - main = defaultMainWith (defaultConfig {timeLimit = 2}) [-  bgroup "cons" [-     -     bgroup "Array" [-        bgroup "10" [-           bench "prim" $ whnf (consA 0)     a10,-           bench "slow" $ whnf (consASlow 0) a10-           ],-        bgroup "100" [-           bench "prim" $ whnf (consA 0)     a100,-           bench "slow" $ whnf (consASlow 0) a100-           ],-        bgroup "1000" [-           bench "prim" $ whnf (consA 0)     a1000,-           bench "slow" $ whnf (consASlow 0) a1000-           ]-        ],-        +  -- bgroup "cons" [++  --    bgroup "Array" [+  --       bgroup "10" [+  --          bench "prim" $ whnf (consA 0)     a10,+  --          bench "slow" $ whnf (consASlow 0) a10+  --          ],+  --       bgroup "100" [+  --          bench "prim" $ whnf (consA 0)     a100,+  --          bench "slow" $ whnf (consASlow 0) a100+  --          ],+  --       bgroup "1000" [+  --          bench "prim" $ whnf (consA 0)     a1000,+  --          bench "slow" $ whnf (consASlow 0) a1000+  --          ]+  --       ],++  --    bgroup "SmallArray" [+  --       bgroup "10" [+  --          bench "prim" $ whnf (consSA 0)     sa10,+  --          bench "slow" $ whnf (consSASlow 0) sa10+  --          ],+  --       bgroup "100" [+  --          bench "prim" $ whnf (consSA 0)     sa100,+  --          bench "slow" $ whnf (consSASlow 0) sa100+  --          ],+  --       bgroup "1000" [+  --          bench "prim" $ whnf (consSA 0)     sa1000,+  --          bench "slow" $ whnf (consSASlow 0) sa1000+  --          ]+  --       ]+  --    ],++  -- bgroup "snoc" [++  --    bgroup "Array" [+  --       bgroup "10" [+  --          bench "prim" $ whnf (flip snocA 0)     a10,+  --          bench "slow" $ whnf (flip snocASlow 0) a10+  --          ],+  --       bgroup "100" [+  --          bench "prim" $ whnf (flip snocA 0)     a100,+  --          bench "slow" $ whnf (flip snocASlow 0) a100+  --          ],+  --       bgroup "1000" [+  --          bench "prim" $ whnf (flip snocA 0)     a1000,+  --          bench "slow" $ whnf (flip snocASlow 0) a1000+  --          ]+  --       ],++  --    bgroup "SmallArray" [+  --       bgroup "10" [+  --          bench "prim" $ whnf (flip snocSA 0)     sa10,+  --          bench "slow" $ whnf (flip snocSASlow 0) sa10+  --          ],+  --       bgroup "100" [+  --          bench "prim" $ whnf (flip snocSA 0)     sa100,+  --          bench "slow" $ whnf (flip snocSASlow 0) sa100+  --          ],+  --       bgroup "1000" [+  --          bench "prim" $ whnf (flip snocSA 0)     sa1000,+  --          bench "slow" $ whnf (flip snocSASlow 0) sa1000+  --          ]+  --       ]+  --    ],++  bgroup "insert" [++     -- bgroup "Array" [+     --    bgroup "10" [+     --       bench "prim" $ whnf (insertA 5 10)     a10,+     --       bench "slow" $ whnf (insertASlow 5 10) a10+     --       ],+     --    bgroup "100" [+     --       bench "prim" $ whnf (insertA 50 10)     a100,+     --       bench "slow" $ whnf (insertASlow 50 10) a100+     --       ],+     --    bgroup "1000" [+     --       bench "prim" $ whnf (insertA 500 10)     a1000,+     --       bench "slow" $ whnf (insertASlow 500 10) a1000+     --       ]+     --    ],+      bgroup "SmallArray" [-        bgroup "10" [-           bench "prim" $ whnf (consSA 0)     sa10,-           bench "slow" $ whnf (consSASlow 0) sa10+        bgroup "2" [+           bench "prim"   $ whnf (insertSA 0 10)      sa2,+           bench "slow"   $ whnf (insertSASlow 0 10)  sa2+           -- bench "unsafe" $ whnf (insertSAUnsafe 5 10) sa10            ],-        bgroup "100" [-           bench "prim" $ whnf (consSA 0)     sa100,-           bench "slow" $ whnf (consSASlow 0) sa100+        bgroup "5" [+           bench "prim"   $ whnf (insertSA 2 10)      sa5,+           bench "slow"   $ whnf (insertSASlow 2 10)  sa5+           -- bench "unsafe" $ whnf (insertSAUnsafe 5 10) sa10            ],-        bgroup "1000" [-           bench "prim" $ whnf (consSA 0)     sa1000,-           bench "slow" $ whnf (consSASlow 0) sa1000-           ]-        ]-     ],-  -  bgroup "snoc" [-     -     bgroup "Array" [         bgroup "10" [-           bench "prim" $ whnf (flip snocA 0)     a10,-           bench "slow" $ whnf (flip snocASlow 0) a10-           ],-        bgroup "100" [-           bench "prim" $ whnf (flip snocA 0)     a100,-           bench "slow" $ whnf (flip snocASlow 0) a100-           ],-        bgroup "1000" [-           bench "prim" $ whnf (flip snocA 0)     a1000,-           bench "slow" $ whnf (flip snocASlow 0) a1000-           ]-        ],-        -     bgroup "SmallArray" [-        bgroup "10" [-           bench "prim" $ whnf (flip snocSA 0)     sa10,-           bench "slow" $ whnf (flip snocSASlow 0) sa10+           bench "prim"   $ whnf (insertSA 5 10)      sa10,+           bench "slow"   $ whnf (insertSASlow 5 10)  sa10+           -- bench "unsafe" $ whnf (insertSAUnsafe 5 10) sa10            ],         bgroup "100" [-           bench "prim" $ whnf (flip snocSA 0)     sa100,-           bench "slow" $ whnf (flip snocSASlow 0) sa100+           bench "prim"   $ whnf (insertSA 50 10)     sa100,+           bench "slow"   $ whnf (insertSASlow 50 10) sa100+           -- bench "unsafe" $ whnf (insertSAUnsafe 50 10) sa10            ],         bgroup "1000" [-           bench "prim" $ whnf (flip snocSA 0)     sa1000,-           bench "slow" $ whnf (flip snocSASlow 0) sa1000+           bench "prim"   $ whnf (insertSA 500 10)     sa1000,+           bench "slow"   $ whnf (insertSASlow 500 10) sa1000+           -- bench "unsafe" $ whnf (insertSAUnsafe 500 10) sa10            ]         ]      ], -  bgroup "insert" [-     -     bgroup "Array" [-        bgroup "10" [-           bench "prim" $ whnf (insertA 5 10)     a10,-           bench "slow" $ whnf (insertASlow 5 10) a10-           ],-        bgroup "100" [-           bench "prim" $ whnf (insertA 50 10)     a100,-           bench "slow" $ whnf (insertASlow 50 10) a100-           ],-        bgroup "1000" [-           bench "prim" $ whnf (insertA 500 10)     a1000,-           bench "slow" $ whnf (insertASlow 500 10) a1000-           ]-        ],-        +  bgroup "delete" [++     -- bgroup "Array" [+     --    bgroup "10" [+     --       bench "prim" $ whnf (deleteA 5)     a10,+     --       bench "slow" $ whnf (deleteASlow 5) a10+     --       ],+     --    bgroup "100" [+     --       bench "prim" $ whnf (deleteA 50)     a100,+     --       bench "slow" $ whnf (deleteASlow 50) a100+     --       ],+     --    bgroup "1000" [+     --       bench "prim" $ whnf (deleteA 500)     a1000,+     --       bench "slow" $ whnf (deleteASlow 500) a1000+     --       ]+     --    ],+      bgroup "SmallArray" [-        bgroup "10" [-           bench "prim" $ whnf (insertSA 5 10)     sa10,-           bench "slow" $ whnf (insertSASlow 5 10) sa10+        bgroup "2" [+           bench "prim"   $ whnf (deleteSA 0)       sa2,+           bench "slow"   $ whnf (deleteSASlow 0)   sa2+           -- bench "unsafe" $ whnf (deleteSAUnsafe 5) sa10            ],-        bgroup "100" [-           bench "prim" $ whnf (insertSA 50 10)     sa100,-           bench "slow" $ whnf (insertSASlow 50 10) sa100+        bgroup "5" [+           bench "prim"   $ whnf (deleteSA 2)       sa5,+           bench "slow"   $ whnf (deleteSASlow 2)   sa5+           -- bench "unsafe" $ whnf (deleteSAUnsafe 5) sa10            ],-        bgroup "1000" [-           bench "prim" $ whnf (insertSA 500 10)     sa1000,-           bench "slow" $ whnf (insertSASlow 500 10) sa1000-           ]-        ]-     ],-  -  bgroup "delete" [-     -     bgroup "Array" [         bgroup "10" [-           bench "prim" $ whnf (deleteA 5)     a10,-           bench "slow" $ whnf (deleteASlow 5) a10-           ],-        bgroup "100" [-           bench "prim" $ whnf (deleteA 50)     a100,-           bench "slow" $ whnf (deleteASlow 50) a100-           ],-        bgroup "1000" [-           bench "prim" $ whnf (deleteA 500)     a1000,-           bench "slow" $ whnf (deleteASlow 500) a1000-           ]-        ],-        -     bgroup "SmallArray" [-        bgroup "10" [-           bench "prim" $ whnf (deleteSA 5)     sa10,-           bench "slow" $ whnf (deleteSASlow 5) sa10+           bench "prim"   $ whnf (deleteSA 5)       sa10,+           bench "slow"   $ whnf (deleteSASlow 5)   sa10+           -- bench "unsafe" $ whnf (deleteSAUnsafe 5) sa10            ],         bgroup "100" [-           bench "prim" $ whnf (deleteSA 50)     sa100,-           bench "slow" $ whnf (deleteSASlow 50) sa100+           bench "prim"   $ whnf (deleteSA 50)     sa100,+           bench "slow"   $ whnf (deleteSASlow 50) sa100+           -- bench "unsafe" $ whnf (deleteSAUnsafe 50) sa10            ],         bgroup "1000" [-           bench "prim" $ whnf (deleteSA 500)     sa1000,-           bench "slow" $ whnf (deleteSASlow 500) sa1000+           bench "prim"   $ whnf (deleteSA 500)     sa1000,+           bench "slow"   $ whnf (deleteSASlow 500) sa1000+           -- bench "unsafe" $ whnf (deleteSAUnsafe 500) sa10            ]         ]      ]@@ -180,7 +221,7 @@                 (# s , arr #) -> (# s, A arr #)  consA :: a -> A a -> A a-consA a (A arr) = A (consArray# (unsafeCoerce# a) arr)+consA a (A arr) = A (consArray# a arr)  consASlow :: a -> A a -> A a consASlow a (A arr) = runSTRep $ \s ->@@ -192,7 +233,7 @@           (# s, arr #) -> (# s, A arr #)  snocA :: A a -> a -> A a-snocA (A arr) a = A (snocArray# arr (unsafeCoerce# a))+snocA (A arr) a = A (snocArray# arr a)  snocASlow :: A a -> a -> A a snocASlow (A arr) a = runSTRep $ \s ->@@ -204,7 +245,7 @@           (# s, arr #) -> (# s, A arr #)  insertA :: Int -> a -> A a -> A a-insertA (I# i) a (A arr) = A (insertArray# i (unsafeCoerce# a) arr)+insertA (I# i) a (A arr) = A (insertArray# i a arr)  insertASlow :: Int -> a -> A a -> A a insertASlow (I# i) a (A arr) = runSTRep $ \s ->@@ -248,7 +289,7 @@                 (# s , arr #) -> (# s, SA arr #)  consSA :: a -> SA a -> SA a-consSA a (SA arr) = SA (consSmallArray# (unsafeCoerce# a) arr)+consSA a (SA arr) = SA (consSmallArray# a arr)  consSASlow :: a -> SA a -> SA a consSASlow a (SA arr) = runSTRep $ \s ->@@ -260,7 +301,7 @@           (# s, arr #) -> (# s, SA arr #)  snocSA :: SA a -> a -> SA a-snocSA (SA arr) a = SA (snocSmallArray# arr (unsafeCoerce# a))+snocSA (SA arr) a = SA (snocSmallArray# arr a)  snocSASlow :: SA a -> a -> SA a snocSASlow (SA arr) a = runSTRep $ \s ->@@ -272,7 +313,7 @@           (# s, arr #) -> (# s, SA arr #)  insertSA :: Int -> a -> SA a -> SA a-insertSA (I# i) a (SA arr) = SA (insertSmallArray# i (unsafeCoerce# a) arr)+insertSA (I# i) a (SA arr) = SA (insertSmallArray# i a arr)  insertSASlow :: Int -> a -> SA a -> SA a insertSASlow (I# i) a (SA arr) = runSTRep $ \s ->@@ -283,7 +324,7 @@         s -> case copySmallArray# arr i marr (i +# 1#) (size -# i) s of           s -> case unsafeFreezeSmallArray# marr s of             (# s, arr #) -> (# s, SA arr #)-            + deleteSA :: Int -> SA a -> SA a deleteSA (I# i) (SA arr) = SA (deleteSmallArray# i arr) @@ -295,4 +336,22 @@       s -> case copySmallArray# arr (i +# 1#) marr i (size -# i -# 1#) s of         s -> case unsafeFreezeSmallArray# marr s of           (# s, arr #) -> (# s, SA arr #)-                          ++insertSAUnsafe :: Int -> a -> SA a -> SA a+insertSAUnsafe (I# i) a (SA arr) = runSTRep $ \s ->+  let !len = sizeofSmallArray# arr in+  case newByteArray# (SIZEOF_HSWORD# *# (len +# 1#)) s of+    (# s, barr #) -> case copySmallArray# arr (-2#) (unsafeCoerce# barr) (-2#) (i +# 2#) s of+      s -> case writeIntOffAddr# (unsafeCoerce# barr) 1# (len +# 1#) s of+        s -> case writeSmallArray# (unsafeCoerce# barr) i a s of+          s -> case copySmallArray# arr i (unsafeCoerce# barr) (i +# 1#) (len -# i) s of+            s -> (# s, SA (unsafeCoerce# barr) #)++deleteSAUnsafe :: Int -> SA a -> SA a+deleteSAUnsafe (I# i) (SA arr) = runSTRep $ \s ->+  let !len = sizeofSmallArray# arr in+  case newByteArray# (SIZEOF_HSWORD# *# (len -# 1#)) s of+    (# s, barr #) -> case copySmallArray# arr (-2#) (unsafeCoerce# barr) (-2#) (i +# 2#) s of+      s -> case writeIntOffAddr# (unsafeCoerce# barr) 1# (len -# 1#) s of+        s -> case copySmallArray# arr (i +# 1#) (unsafeCoerce# barr) i (len -# i -# 1#) s of+          s -> (# s, SA (unsafeCoerce# barr) #)

@@ -4,93 +4,136 @@ consArray(gcptr elem, gcptr src) {     W_ words, old_ptrs, new_ptrs, new_size;     gcptr dst, dst_p, src_end;-                                                               -    again: MAYBE_GC(again); -             ++    again: MAYBE_GC(again);+     old_ptrs = StgMutArrPtrs_ptrs(src);     new_ptrs = old_ptrs + 1;     new_size = new_ptrs + mutArrPtrsCardWords(new_ptrs);      words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + new_size;-    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); +    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words);     TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(new_size), 0);-    SET_HDR(dst, stg_MUT_ARR_PTRS_FROZEN_info, CCCS);                                 +    SET_HDR(dst, stg_MUT_ARR_PTRS_FROZEN_info, CCCS);     StgMutArrPtrs_ptrs(dst) = new_ptrs;-    StgMutArrPtrs_size(dst) = new_size;                               -                        -    dst_p   = dst + SIZEOF_StgMutArrPtrs;                   +    StgMutArrPtrs_size(dst) = new_size;++    dst_p   = dst + SIZEOF_StgMutArrPtrs;     src     = src + SIZEOF_StgMutArrPtrs;     src_end = src + WDS(old_ptrs);      W_[dst_p] = elem;     dst_p = dst_p + WDS(1); -  while:                                                       -    if (src != src_end) {                                         -        W_[dst_p] = W_[src];                                 -        dst_p = dst_p + WDS(1);                                -        src   = src   + WDS(1);                                -        goto while;                                            -    }                                                          -                                                               +  while:+    if (src != src_end) {+        W_[dst_p] = W_[src];+        dst_p = dst_p + WDS(1);+        src   = src   + WDS(1);+        goto while;+    }+     return (dst); }  snocArray(gcptr src, gcptr elem) {     W_ words, old_ptrs, new_ptrs, new_size;     gcptr dst, dst_p, src_end;-                                                               -    again: MAYBE_GC(again); -             ++    again: MAYBE_GC(again);+     old_ptrs = StgMutArrPtrs_ptrs(src);     new_ptrs = old_ptrs + 1;     new_size = new_ptrs + mutArrPtrsCardWords(new_ptrs);      words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + new_size;-    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); +    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words);     TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(new_size), 0);-    SET_HDR(dst, stg_MUT_ARR_PTRS_FROZEN_info, CCCS);                                 +    SET_HDR(dst, stg_MUT_ARR_PTRS_FROZEN_info, CCCS);     StgMutArrPtrs_ptrs(dst) = new_ptrs;-    StgMutArrPtrs_size(dst) = new_size;                                  -                        -    dst_p   = dst + SIZEOF_StgMutArrPtrs;                   +    StgMutArrPtrs_size(dst) = new_size;++    dst_p   = dst + SIZEOF_StgMutArrPtrs;     src     = src + SIZEOF_StgMutArrPtrs;     src_end = src + WDS(old_ptrs); -  while:                                                       -    if (src != src_end) {                                         -        W_[dst_p] = W_[src];                                 -        dst_p = dst_p + WDS(1);                                -        src   = src   + WDS(1);                                -        goto while;                                            +  while:+    if (src != src_end) {+        W_[dst_p] = W_[src];+        dst_p = dst_p + WDS(1);+        src   = src   + WDS(1);+        goto while;     }-    -    W_[dst_p] = elem;                                             -                                                               ++    W_[dst_p] = elem;+     return (dst); } +snocArrayWithPadding(W_ padding, gcptr padElem, gcptr src, gcptr elem) {+    W_ words, old_ptrs, new_ptrs, new_size;+    gcptr dst, dst_p, src_end, dst_end;++    again: MAYBE_GC(again);++    old_ptrs = StgMutArrPtrs_ptrs(src);+    new_ptrs = old_ptrs + 1 + padding;+    new_size = new_ptrs + mutArrPtrsCardWords(new_ptrs);++    words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + new_size;+    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words);+    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(new_size), 0);+    SET_HDR(dst, stg_MUT_ARR_PTRS_FROZEN_info, CCCS);+    StgMutArrPtrs_ptrs(dst) = new_ptrs;+    StgMutArrPtrs_size(dst) = new_size;++    dst_p   = dst + SIZEOF_StgMutArrPtrs;+    src     = src + SIZEOF_StgMutArrPtrs;+    src_end = src + WDS(old_ptrs);+    dst_end = dst_p + WDS(new_ptrs);++  while1:+    if (src != src_end) {+        W_[dst_p] = W_[src];+        dst_p = dst_p + WDS(1);+        src   = src   + WDS(1);+        goto while1;+    }++    W_[dst_p] = elem;+    dst_p = dst_p + WDS(1);++  while2:+    if (dst_p != dst_end) {+        W_[dst_p] = padElem;+        dst_p = dst_p + WDS(1);+        goto while2;+    }    ++    return (dst);+}+ insertArray(W_ index, gcptr elem, gcptr src) {     W_ words, old_ptrs, new_ptrs, new_size;     gcptr src_p, dst, dst_p, dst_end, ins_p;-                                                               -    again: MAYBE_GC(again); -             ++    again: MAYBE_GC(again);+     old_ptrs = StgMutArrPtrs_ptrs(src);     new_ptrs = old_ptrs + 1;     new_size = new_ptrs + mutArrPtrsCardWords(new_ptrs);      words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + new_size;-    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); +    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words);     TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(new_size), 0);-    SET_HDR(dst, stg_MUT_ARR_PTRS_FROZEN_info, CCCS);                                 +    SET_HDR(dst, stg_MUT_ARR_PTRS_FROZEN_info, CCCS);     StgMutArrPtrs_ptrs(dst) = new_ptrs;-    StgMutArrPtrs_size(dst) = new_size;   +    StgMutArrPtrs_size(dst) = new_size;      src_p   = src + SIZEOF_StgMutArrPtrs;-    dst_p   = dst + SIZEOF_StgMutArrPtrs;                   +    dst_p   = dst + SIZEOF_StgMutArrPtrs;     ins_p   = dst_p + WDS(index);-    dst_end = dst_p + WDS(new_ptrs);    +    dst_end = dst_p + WDS(new_ptrs);      W_[ins_p] = elem; @@ -101,14 +144,14 @@        src_p = src_p + WDS(1);        goto while1;     }-    +     dst_p = dst_p + WDS(1);    while2:     if (dst_p != dst_end){        W_[dst_p] = W_[src_p];        dst_p = dst_p + WDS(1);-       src_p = src_p + WDS(1);      +       src_p = src_p + WDS(1);        goto while2;     } @@ -119,24 +162,24 @@      W_ words, old_ptrs, new_ptrs, new_size;     gcptr src_p, src_end, dst, dst_p, dst_end, del_p;-                                                               -    again: MAYBE_GC(again); -             ++    again: MAYBE_GC(again);+     old_ptrs = StgMutArrPtrs_ptrs(src);     new_ptrs = old_ptrs - 1;     new_size = new_ptrs + mutArrPtrsCardWords(new_ptrs);      words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + new_size;-    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); +    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words);     TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(new_size), 0);-    SET_HDR(dst, stg_MUT_ARR_PTRS_FROZEN_info, CCCS);                                 +    SET_HDR(dst, stg_MUT_ARR_PTRS_FROZEN_info, CCCS);     StgMutArrPtrs_ptrs(dst) = new_ptrs;-    StgMutArrPtrs_size(dst) = new_size;   +    StgMutArrPtrs_size(dst) = new_size;      src_p   = src + SIZEOF_StgMutArrPtrs;-    dst_p   = dst + SIZEOF_StgMutArrPtrs;                   +    dst_p   = dst + SIZEOF_StgMutArrPtrs;     del_p   = src_p + WDS(index);-    src_end = src_p + WDS(old_ptrs);    +    src_end = src_p + WDS(old_ptrs);    while1:     if (src_p != del_p) {@@ -145,14 +188,14 @@        src_p = src_p + WDS(1);        goto while1;     }-    +     src_p = src_p + WDS(1);    while2:     if (src_p != src_end){        W_[dst_p] = W_[src_p];        dst_p = dst_p + WDS(1);-       src_p = src_p + WDS(1);      +       src_p = src_p + WDS(1);        goto while2;     } @@ -160,9 +203,9 @@ }  -     -    ++   

@@ -4,68 +4,109 @@ consSmallArray(gcptr elem, gcptr src) {     W_ words, old_size, new_size;     gcptr dst, dst_p, src_end;-                                                               -    again: MAYBE_GC(again); -             ++    again: MAYBE_GC(again);+     old_size = StgSmallMutArrPtrs_ptrs(src);     new_size = old_size + 1;      words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + new_size;-    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); +    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words);     TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(new_size), 0);-    SET_HDR(dst, stg_SMALL_MUT_ARR_PTRS_FROZEN_info, CCCS);                                 -    StgSmallMutArrPtrs_ptrs(dst) = new_size;                                -                        -    dst_p   = dst + SIZEOF_StgSmallMutArrPtrs;                   +    SET_HDR(dst, stg_SMALL_MUT_ARR_PTRS_FROZEN_info, CCCS);+    StgSmallMutArrPtrs_ptrs(dst) = new_size;++    dst_p   = dst + SIZEOF_StgSmallMutArrPtrs;     src     = src + SIZEOF_StgSmallMutArrPtrs;     src_end = src + WDS(old_size);      W_[dst_p] = elem;     dst_p = dst_p + WDS(1); -  while:                                                       -    if (src != src_end) {                                         -        W_[dst_p] = W_[src];                                 -        dst_p = dst_p + WDS(1);                                -        src   = src   + WDS(1);                                -        goto while;                                            -    }                                                          -                                                               +  while:+    if (src != src_end) {+        W_[dst_p] = W_[src];+        dst_p = dst_p + WDS(1);+        src   = src   + WDS(1);+        goto while;+    }+     return (dst); }  snocSmallArray(gcptr src, gcptr elem) {     W_ words, old_size, new_size;     gcptr dst, dst_p, src_end;-                                                               -    again: MAYBE_GC(again); -             ++    again: MAYBE_GC(again);+     old_size = StgSmallMutArrPtrs_ptrs(src);     new_size = old_size + 1;      words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + new_size;-    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); -    TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(new_size), 0); -    SET_HDR(dst, stg_SMALL_MUT_ARR_PTRS_FROZEN_info, CCCS);                                 -    StgSmallMutArrPtrs_ptrs(dst) = new_size;                                -                        -    dst_p   = dst + SIZEOF_StgSmallMutArrPtrs;                   +    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words);+    TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(new_size), 0);+    SET_HDR(dst, stg_SMALL_MUT_ARR_PTRS_FROZEN_info, CCCS);+    StgSmallMutArrPtrs_ptrs(dst) = new_size;++    dst_p   = dst + SIZEOF_StgSmallMutArrPtrs;     src     = src + SIZEOF_StgSmallMutArrPtrs;     src_end = src + WDS(old_size); -  while:                                                       -    if (src != src_end) {                                         -        W_[dst_p] = W_[src];                                 -        dst_p = dst_p + WDS(1);                                -        src   = src   + WDS(1);                                -        goto while;                                            +  while:+    if (src != src_end) {+        W_[dst_p] = W_[src];+        dst_p = dst_p + WDS(1);+        src   = src   + WDS(1);+        goto while;     }-    -    W_[dst_p] = elem;                                             -                                                               ++    W_[dst_p] = elem;+     return (dst); } +snocSmallArrayWithPadding(W_ padding, gcptr padElem, gcptr src, gcptr elem) {+    W_ words, old_size, new_size;+    gcptr dst, dst_p, src_end, dst_end;++    again: MAYBE_GC(again);++    old_size = StgSmallMutArrPtrs_ptrs(src);+    new_size = old_size + 1 + padding;++    words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + new_size;+    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words);+    TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(new_size), 0);+    SET_HDR(dst, stg_SMALL_MUT_ARR_PTRS_FROZEN_info, CCCS);+    StgSmallMutArrPtrs_ptrs(dst) = new_size;++    dst_p   = dst + SIZEOF_StgSmallMutArrPtrs;+    src     = src + SIZEOF_StgSmallMutArrPtrs;+    src_end = src + WDS(old_size);+    dst_end = dst_p + WDS(new_size);++  while1:+    if (src != src_end) {+        W_[dst_p] = W_[src];+        dst_p = dst_p + WDS(1);+        src   = src   + WDS(1);+        goto while1;+    }++    W_[dst_p] = elem;+    dst_p = dst_p + WDS(1);++  while2:+    if (dst_p != dst_end) {+        W_[dst_p] = padElem;+        dst_p = dst_p + WDS(1);+        goto while2;+    }++    return (dst);+}+ insertSmallArray(W_ index, gcptr elem, gcptr src) {     W_ words, size;     gcptr src_p, dst, dst_p, dst_end, ins_p;@@ -75,15 +116,15 @@     size = StgSmallMutArrPtrs_ptrs(src) + 1;      words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + size;-    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); +    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words);     TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(size), 0);     SET_HDR(dst, stg_SMALL_MUT_ARR_PTRS_FROZEN_info, CCCS);     StgSmallMutArrPtrs_ptrs(dst) = size;      src_p   = src + SIZEOF_StgSmallMutArrPtrs;-    dst_p   = dst + SIZEOF_StgSmallMutArrPtrs;                   +    dst_p   = dst + SIZEOF_StgSmallMutArrPtrs;     ins_p   = dst_p + WDS(index);-    dst_end = dst_p + WDS(size);    +    dst_end = dst_p + WDS(size);      W_[ins_p] = elem; @@ -94,14 +135,14 @@        src_p = src_p + WDS(1);        goto while1;     }-    +     dst_p = dst_p + WDS(1);    while2:     if (dst_p != dst_end){        W_[dst_p] = W_[src_p];        dst_p = dst_p + WDS(1);-       src_p = src_p + WDS(1);      +       src_p = src_p + WDS(1);        goto while2;     } @@ -118,15 +159,15 @@     new_size = old_size - 1;      words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + new_size;-    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); +    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words);     TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(new_size), 0);     SET_HDR(dst, stg_SMALL_MUT_ARR_PTRS_FROZEN_info, CCCS);     StgSmallMutArrPtrs_ptrs(dst) = new_size;      src_p   = src + SIZEOF_StgSmallMutArrPtrs;-    dst_p   = dst + SIZEOF_StgSmallMutArrPtrs;                   +    dst_p   = dst + SIZEOF_StgSmallMutArrPtrs;     del_p   = src_p + WDS(index);-    src_end = src_p + WDS(old_size);    +    src_end = src_p + WDS(old_size);    while1:     if (src_p != del_p) {@@ -135,14 +176,14 @@        src_p = src_p + WDS(1);        goto while1;     }-    +     src_p = src_p + WDS(1);    while2:     if (src_p != src_end){        W_[dst_p] = W_[src_p];        dst_p = dst_p + WDS(1);-       src_p = src_p + WDS(1);      +       src_p = src_p + WDS(1);        goto while2;     } @@ -150,9 +191,9 @@ }  -     -    ++   

@@ -0,0 +1,115 @@+{-# language RankNTypes, MagicHash, UnboxedTuples, BangPatterns,+    ScopedTypeVariables #-}++import GHC.Prim+import GHC.Types+import GHC.Prim.Array+import GHC.Prim.SmallArray++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.QuickCheck++runSTRep :: (forall s. State# s -> (# State# s, a #)) -> a+runSTRep f = case f realWorld# of (# _ , a #) -> a+{-# INLINE [0] runSTRep #-}++insList :: Int -> a -> [a] -> [a]+insList n a as = let (as1, as2) = splitAt n as in as1 ++ a:as2++delList :: Int -> [a] -> [a]+delList n as = case splitAt n as of+  (as1, _:as2) -> as1 ++ as2+  _            -> as++data A a = A (Array# a)++consA a (A arr) = A (consArray# a arr)+snocA (A arr) a = A (snocArray# arr a)+snocAPad (I# pad) padElem (A arr) a = A (snocArrayWithPadding# pad padElem arr a)+insertA (I# i) a (A arr) = A (insertArray# i a arr)+deleteA (I# i) (A arr)   = A (deleteArray# i arr)++toListA :: forall a. A a -> [a]+toListA (A arr) = go arr 0# where+    go arr i | isTrue# (i ==# sizeofArray# arr) = []+    go arr i = case indexArray# arr i of+        (# a #) -> a : go arr (i +# 1#)++fromListA :: [a] -> A a+fromListA xs = runSTRep $ \s -> let !(I# size) = length xs in+    case newArray# size undefined s of+        (# s, marr #) -> go xs 0# s where+            go (x:xs) i s = case writeArray# marr i x s of s -> go xs (i +# 1#) s+            go _      _ s = case unsafeFreezeArray# marr s of+                (# s , arr #) -> (# s, A arr #)++data SA a = SA (SmallArray# a)++consSA a (SA arr) = SA (consSmallArray# a arr)+snocSA (SA arr) a = SA (snocSmallArray# arr a)+snocSAPad (I# pad) padElem (SA arr) a = SA (snocSmallArrayWithPadding# pad padElem arr a)+insertSA (I# i) a (SA arr) = SA (insertSmallArray# i a arr)+deleteSA (I# i) (SA arr)   = SA (deleteSmallArray# i arr)++toListSA :: forall a. SA a -> [a]+toListSA (SA arr) = go arr 0# where+    go arr i | isTrue# (i ==# sizeofSmallArray# arr) = []+    go arr i = case indexSmallArray# arr i of+        (# a #) -> a : go arr (i +# 1#)++fromListSA :: [a] -> SA a+fromListSA xs = runSTRep $ \s -> let !(I# size) = length xs in+    case newSmallArray# size undefined s of+        (# s, marr #) -> go xs 0# s where+            go (x:xs) i s = case writeSmallArray# marr i x s of s -> go xs (i +# 1#) s+            go _      _ s = case unsafeFreezeSmallArray# marr s of+                (# s , arr #) -> (# s, SA arr #)++main :: IO ()+main = defaultMain $ testGroup "tests" [+  testGroup "smallArray" [+      testProperty "cons" $ \(xs :: [Int]) x ->+        (x:xs) == toListSA (consSA x (fromListSA xs))++    , testProperty "snoc" $ \(xs :: [Int]) x ->+        (xs ++ [x]) == toListSA (snocSA (fromListSA xs) x)++    , testProperty "snocWithPadding" $ \(xs :: [Int]) x ->+        forAll (choose (0, 10)) $ \pad ->+             (xs ++ [x] ++ replicate pad 0)+          == toListSA (snocSAPad pad 0 (fromListSA xs) x)++    , testProperty "insert" $ \(xs :: [Int]) x ->+        forAll (choose (0, length xs)) $ \n ->+          insList n x xs == toListSA (insertSA n x (fromListSA xs))++    , testProperty "delete" $ \(NonEmpty (xs :: [Int])) ->+        forAll (choose (0, length xs - 1)) $ \n ->+          delList n xs == toListSA (deleteSA n (fromListSA xs))+    ],++  testGroup "array" [+      testProperty "cons" $ \(xs :: [Int]) x ->+        (x:xs) == toListA (consA x (fromListA xs))++    , testProperty "snoc" $ \(xs :: [Int]) x ->+        (xs ++ [x]) == toListA (snocA (fromListA xs) x)++    , testProperty "snocWithPadding" $ \(xs :: [Int]) x ->+        forAll (choose (0, 10)) $ \pad ->+             (xs ++ [x] ++ replicate pad 0)+          == toListA (snocAPad pad 0 (fromListA xs) x)++    , testProperty "insert" $ \(xs :: [Int]) x ->+        forAll (choose (0, length xs)) $ \n ->+          insList n x xs == toListA (insertA n x (fromListA xs))++    , testProperty "delete" $ \(NonEmpty (xs :: [Int])) ->+        forAll (choose (0, length xs - 1)) $ \n ->+          delList n xs == toListA (deleteA n (fromListA xs))+    ]+  ]+++