Implement appendArray# (external) primop

3 files changed, 82 insertions, 0 deletions

diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index 59f31faf57..d8d5232a2a 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -1246,6 +1246,14 @@ primop  ThawArrayOp "thawArray#" GenPrimOp
   has_side_effects = True
   can_fail         = True
 
+primop AppendArrays "appendArrays#" GenPrimOp
+  Array# a -> Array# a -> Array# a
+  {Concatenate two arrays by @memcpy@ing them into a new array.}
+  with
+  out_of_line      = True
+  has_side_effects = True
+  can_fail         = True
+
 primop CasArrayOp  "casArray#" GenPrimOp
    MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #)
    {Given an array, an offset, the expected old value, and
@@ -1437,6 +1445,14 @@ primop  ThawSmallArrayOp "thawSmallArray#" GenPrimOp
   has_side_effects = True
   can_fail         = True
 
+primop AppendSmallArrays "appendSmallArrays#" GenPrimOp
+  SmallArray# a -> SmallArray# a -> SmallArray# a
+  {Concatenate two arrays by @memcpy@ing them into a new array.}
+  with
+  out_of_line      = True
+  has_side_effects = True
+  can_fail         = True
+
 primop CasSmallArrayOp  "casSmallArray#" GenPrimOp
    SmallMutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #)
    {Unsafe, machine-level atomic compare and swap on an element within an array.
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 4c69537733..0923852729 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -219,6 +219,8 @@ emitPrimOp dflags primop = case primop of
       -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
     _ -> PrimopCmmEmit_External
 
+  AppendArrays -> const PrimopCmmEmit_External
+
   NewSmallArrayOp -> \case
     [(CmmLit (CmmInt n w)), init]
       | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
@@ -264,6 +266,8 @@ emitPrimOp dflags primop = case primop of
       -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
     _ -> PrimopCmmEmit_External
 
+  AppendSmallArrays -> const PrimopCmmEmit_External
+
 -- First we handle various awkward cases specially.
 
   ParOp -> \[arg] -> opIntoRegs $ \[res] -> do
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index a13dae6774..b343624872 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -343,6 +343,40 @@ stg_thawArrayzh ( gcptr src, W_ offset, W_ n )
     cloneArray(stg_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
 }
 
+stg_appendArrayszh( gcptr src1, gcptr src2 )
+{
+    W_ words, n1, n2, nDest, size1, size2;
+    gcptr dst, dst_p, src1_p, src2_p;
+
+    again: MAYBE_GC(again);
+
+    n1 = StgMutArrPtrs_ptrs(src1);
+    n2 = StgMutArrPtrs_ptrs(src2);
+    nDest = n1 + n2;
+
+    size1 = n1 + mutArrPtrsCardWords(n1);
+    size2 = n2 + mutArrPtrsCardWords(n2);
+    sizeDest = nDest + mutArrPtrsCardWords(nDest);
+
+    words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + sizeDest;
+
+    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words);
+    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(sizeDest), 0);
+
+    SET_HDR(dst, stg_MUT_ARR_PTRS_FROZEN_CLEAN_info, CCCS);
+    StgMutArrPtrs_ptrs(dst) = nDest;
+    StgMutArrPtrs_size(dst) = sizeDest;
+
+    dst_p = dst + SIZEOF_StgMutArrPtrs;
+    src1_p = src1 + SIZEOF_StgMutArrPtrs;
+    src2_p = src2 + SIZEOF_StgMutArrPtrs;
+
+    prim %memcpy(dst_p, src1_p, WDS(n1), SIZEOF_W);
+    prim %memcpy(dst_p + WDS(n1), src2_p, WDS(n2), SIZEOF_W);
+
+    return (dst);
+}
+
 // RRN: Uses the ticketed approach; see casMutVar
 stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
 /* MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, Any a #) */
@@ -478,6 +512,34 @@ stg_thawSmallArrayzh ( gcptr src, W_ offset, W_ n )
     cloneSmallArray(stg_SMALL_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
 }
 
+stg_appendSmallArrayszh( gcptr src1, gcptr src2 )
+{
+    W_ words, n1, n2, nDest;
+    gcptr dst, dst_p, src1_p, src2_p;
+
+    again: MAYBE_GC(again);
+
+    n1 = StgSmallMutArrPtrs_ptrs(src1);
+    n2 = StgSmallMutArrPtrs_ptrs(src2);
+    nDest = n1 + n2;
+    words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + nDest;
+
+    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words);
+    TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(nDest), 0);
+
+    SET_HDR(dst, stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN_info, CCCS);                                  \
+    StgSmallMutArrPtrs_ptrs(dst) = nDest;
+
+    dst_p = dst + SIZEOF_StgSmallMutArrPtrs;
+    src1_p = src1 + SIZEOF_StgSmallMutArrPtrs;
+    src2_p = src2 + SIZEOF_StgSmallMutArrPtrs;
+
+    prim %memcpy(dst_p, src1_p, WDS(n1), SIZEOF_W);
+    prim %memcpy(dst_p + WDS(n1), src2_p, WDS(n2), SIZEOF_W);
+
+    return (dst);
+}
+
 // Concurrent GC write barrier for pointer array copies
 //
 // hdr_size in bytes. dst_off in words, n in words.