Add array copy/clone primops

5 files changed, 171 insertions, 2 deletions

diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 49f7a97a61..bf9d477e1f 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -626,6 +626,55 @@ primop  UnsafeThawArrayOp  "unsafeThawArray#" GenPrimOp
    out_of_line = True
    has_side_effects = True
 
+primop  CopyArrayOp "copyArray#" GenPrimOp
+  Array# a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s
+  {Copy a range of the Array# to the specified region in the MutableArray#.
+   Both arrays must fully contain the specified ranges, but this is not checked.
+   The two arrays must not be the same array in different states, but this is not checked either.}
+  with
+  out_of_line = True
+  has_side_effects = True
+
+primop  CopyMutableArrayOp "copyMutableArray#" GenPrimOp
+  MutableArray# s a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s
+  {Copy a range of the first MutableArray# to the specified region in the second MutableArray#.
+   Both arrays must fully contain the specified ranges, but this is not checked.}
+  with
+  out_of_line = True
+  has_side_effects = True
+
+primop  CloneArrayOp "cloneArray#" GenPrimOp
+  Array# a -> Int# -> Int# -> Array# a
+  {Return a newly allocated Array# with the specified subrange of the provided Array#. 
+   The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.}
+  with
+  out_of_line = True
+  has_side_effects = True
+
+primop  CloneMutableArrayOp "cloneMutableArray#" GenPrimOp
+  MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
+  {Return a newly allocated Array# with the specified subrange of the provided Array#.
+   The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.}
+  with
+  out_of_line = True
+  has_side_effects = True
+
+primop  FreezeArrayOp "freezeArray#" GenPrimOp
+  MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, Array# a #)
+  {Return a newly allocated Array# with the specified subrange of the provided MutableArray#.
+   The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.}
+  with
+  out_of_line = True
+  has_side_effects = True
+
+primop  ThawArrayOp "thawArray#" GenPrimOp
+  Array# a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
+  {Return a newly allocated Array# with the specified subrange of the provided MutableArray#.
+   The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.}
+  with
+  out_of_line = True
+  has_side_effects = True
+
 ------------------------------------------------------------------------
 section "Byte Arrays"
 	{Operations on {\tt ByteArray\#}. A {\tt ByteArray\#} is a just a region of
diff --git a/includes/Cmm.h b/includes/Cmm.h
index 0ba14fbff6..641faa216e 100644
--- a/includes/Cmm.h
+++ b/includes/Cmm.h
@@ -464,8 +464,10 @@
 #define StgFunInfoExtra_bitmap(i)     StgFunInfoExtraFwd_bitmap(i)
 #endif
 
-#define mutArrPtrsCardWords(n) \
-    ROUNDUP_BYTES_TO_WDS(((n) + (1 << MUT_ARR_PTRS_CARD_BITS) - 1) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrCardMask ((1 << MUT_ARR_PTRS_CARD_BITS) - 1)
+#define mutArrPtrCardDown(i) ((i) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrCardUp(i)   (((i) + mutArrCardMask) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrsCardWords(n) ROUNDUP_BYTES_TO_WDS(mutArrPtrCardUp(n))
 
 #if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG))
 #define OVERWRITING_CLOSURE(c) foreign "C" overwritingClosure(c "ptr")
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index ed0bf655e1..3851f08d19 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -380,6 +380,12 @@ RTS_FUN_DECL(stg_newByteArrayzh);
 RTS_FUN_DECL(stg_newPinnedByteArrayzh);
 RTS_FUN_DECL(stg_newAlignedPinnedByteArrayzh);
 RTS_FUN_DECL(stg_newArrayzh);
+RTS_FUN_DECL(stg_copyArrayzh);
+RTS_FUN_DECL(stg_copyMutableArrayzh);
+RTS_FUN_DECL(stg_cloneArrayzh);
+RTS_FUN_DECL(stg_cloneMutableArrayzh);
+RTS_FUN_DECL(stg_freezzeArrayzh);
+RTS_FUN_DECL(stg_thawArrayzh);
 
 RTS_FUN_DECL(stg_newMutVarzh);
 RTS_FUN_DECL(stg_atomicModifyMutVarzh);
diff --git a/rts/Linker.c b/rts/Linker.c
index 28ba9a0aa9..6b52be6d66 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -826,6 +826,12 @@ typedef struct _RtsSymbolVal {
       SymI_HasProto(stg_myThreadIdzh)                   \
       SymI_HasProto(stg_labelThreadzh)                  \
       SymI_HasProto(stg_newArrayzh)                     \
+      SymI_HasProto(stg_copyArrayzh)                    \
+      SymI_HasProto(stg_copyMutableArrayzh)             \
+      SymI_HasProto(stg_cloneArrayzh)                   \
+      SymI_HasProto(stg_cloneMutableArrayzh)            \
+      SymI_HasProto(stg_freezzeArrayzh)                 \
+      SymI_HasProto(stg_thawArrayzh)                    \
       SymI_HasProto(stg_newBCOzh)                       \
       SymI_HasProto(stg_newByteArrayzh)                 \
       SymI_HasProto_redirect(newCAF, newDynCAF)         \
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 5c9cfb75ad..791ee96449 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -212,6 +212,112 @@ stg_unsafeThawArrayzh
   }
 }
 
+#define COPY_CARDS(src_start, src_cards_start, dst_start, dst_cards_start, n, copy) \
+  if (src_start & mutArrCardMask == dst_start & mutArrCardMask) { \
+    foreign "C" copy(dst_cards_start + mutArrPtrCardUp(dst_start), src_cards_start + mutArrPtrCardUp(src_start), mutArrPtrCardDown(n)); \
+    \
+    I8[dst_cards_start + mutArrPtrCardDown(dst_start)] = I8[dst_cards_start + mutArrPtrCardDown(dst_start)]     | I8[src_cards_start + mutArrPtrCardDown(src_start)]; \
+    I8[dst_cards_start + mutArrPtrCardUp(n)]           = I8[dst_cards_start + mutArrPtrCardUp(dst_start + n)] | I8[src_cards_start + mutArrPtrCardUp(src_start + n)]; \
+  } else { \
+    foreign "C" memset(dst_cards_start "ptr", 1, mutArrPtrCardDown(n)); \
+  }
+
+stg_copyArrayzh
+{
+  W_ bytes, n, src, dst, src_start, dst_start, src_start_ptr, dst_start_ptr;
+  W_ src_cards_start, dst_cards_start;
+
+  src = R1;
+  src_start = R2;
+  dst = R3;
+  dst_start = R4;
+  n = R5;
+  MAYBE_GC(R1_PTR & R3_PTR, stg_copyArrayzh);
+
+  bytes = WDS(n);
+
+  src_start_ptr = src + SIZEOF_StgMutArrPtrs + WDS(src_start);
+  dst_start_ptr = dst + SIZEOF_StgMutArrPtrs + WDS(dst_start);
+
+  // Copy data (we assume the arrays aren't overlapping since they're of different types)
+  foreign "C" memcpy(dst_start_ptr "ptr", src_start_ptr "ptr", bytes);
+
+  // The base address of both source and destination card tables
+  src_cards_start = src + SIZEOF_StgMutArrPtrs + WDS(StgMutArrPtrs_ptrs(src));
+  dst_cards_start = dst + SIZEOF_StgMutArrPtrs + WDS(StgMutArrPtrs_ptrs(dst));
+
+  COPY_CARDS(src_start, src_cards_start, dst_start, dst_cards_start, n, memcpy);
+
+  jump %ENTRY_CODE(Sp(0));
+}
+
+stg_copyMutableArrayzh
+{
+  W_ bytes, n, src, dst, src_start, dst_start, src_start_ptr, dst_start_ptr;
+  W_ src_cards_start, dst_cards_start;
+
+  src = R1;
+  src_start = R2;
+  dst = R3;
+  dst_start = R4;
+  n = R5;
+  MAYBE_GC(R1_PTR & R3_PTR, stg_copyMutableArrayzh);
+
+  bytes = WDS(n);
+
+  src_start_ptr = src + SIZEOF_StgMutArrPtrs + WDS(src_start);
+  dst_start_ptr = dst + SIZEOF_StgMutArrPtrs + WDS(dst_start);
+
+  src_cards_start = src + SIZEOF_StgMutArrPtrs + WDS(StgMutArrPtrs_ptrs(src));
+  dst_cards_start = dst + SIZEOF_StgMutArrPtrs + WDS(StgMutArrPtrs_ptrs(dst));
+
+  // The only time the memory might overlap is when the two arrays we were provided are the same array!
+  if (src == dst) {
+    foreign "C" memmove(dst_start_ptr "ptr", src_start_ptr "ptr", bytes);
+    COPY_CARDS(src_start, src_cards_start, dst_start, dst_cards_start, n, memmove);
+  } else {
+    foreign "C" memcpy(dst_start_ptr "ptr", src_start_ptr "ptr", bytes);
+    COPY_CARDS(src_start, src_cards_start, dst_start, dst_cards_start, n, memcpy);
+  }
+
+  jump %ENTRY_CODE(Sp(0));
+}
+
+#define ARRAY_CLONE(name, type) \
+  name \
+  { \
+    W_ src, src_off, words, n, init, arr, src_p, dst_p, size; \
+    \
+    src = R1; \
+    src_off = R2; \
+    n = R3; \
+    \
+    MAYBE_GC(R1_PTR, name); \
+    \
+    size = n + mutArrPtrsCardWords(n); \
+    words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size; \
+    ("ptr" arr) = foreign "C" allocate(MyCapability() "ptr", words) [R2]; \
+    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(n), 0); \
+    \
+    SET_HDR(arr, type, W_[CCCS]); \
+    StgMutArrPtrs_ptrs(arr) = n; \
+    StgMutArrPtrs_size(arr) = size; \
+    \
+    dst_p = arr + SIZEOF_StgMutArrPtrs; \
+    src_p = src + SIZEOF_StgMutArrPtrs + WDS(src_off); \
+    \
+    foreign "C" memcpy(dst_p "ptr", src_p "ptr", WDS(n)); \
+    \
+    foreign "C" memset(dst_p + WDS(n), 0, WDS(mutArrPtrsCardWords(n))); \
+    RET_P(arr); \
+  }
+
+ARRAY_CLONE(stg_cloneArrayzh, stg_MUT_ARR_PTRS_FROZEN0_info)
+ARRAY_CLONE(stg_cloneMutableArrayzh, stg_MUT_ARR_PTRS_DIRTY_info)
+ARRAY_CLONE(stg_freezzeArrayzh, stg_MUT_ARR_PTRS_FROZEN0_info)
+ARRAY_CLONE(stg_thawArrayzh, stg_MUT_ARR_PTRS_DIRTY_info)
+
+
 /* -----------------------------------------------------------------------------
    MutVar primitives
    -------------------------------------------------------------------------- */