Add SmallArray# and SmallMutableArray# types
authorJohan Tibell <johan.tibell@gmail.com>
Sun, 23 Mar 2014 11:06:56 +0000 (12:06 +0100)
committerJohan Tibell <johan.tibell@gmail.com>
Sat, 29 Mar 2014 10:24:07 +0000 (11:24 +0100)
These array types are smaller than Array# and MutableArray# and are
faster when the array size is small, as they don't have the overhead
of a card table. Having no card table reduces the closure size with 2
words in the typical small array case and leads to less work when
updating or GC:ing the array.

Reduces both the runtime and memory allocation by 8.8% on my insert
benchmark for the HashMap type in the unordered-containers package,
which makes use of lots of small arrays. With tuned GC settings
(i.e. `+RTS -A6M`) the runtime reduction is 15%.

Fixes #8923.

39 files changed:
compiler/cmm/CLabel.hs
compiler/cmm/CmmParse.y
compiler/cmm/SMRep.lhs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmCon.hs
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmPrim.hs
compiler/ghci/ByteCodeGen.lhs
compiler/ghci/RtClosureInspect.hs
compiler/prelude/PrelNames.lhs
compiler/prelude/TysPrim.lhs
compiler/prelude/primops.txt.pp
includes/Cmm.h
includes/rts/storage/ClosureMacros.h
includes/rts/storage/ClosureTypes.h
includes/rts/storage/Closures.h
includes/stg/MiscClosures.h
rts/CheckUnload.c
rts/ClosureFlags.c
rts/LdvProfile.c
rts/Linker.c
rts/PrimOps.cmm
rts/Printer.c
rts/ProfHeap.c
rts/RetainerProfile.c
rts/StgMiscClosures.cmm
rts/sm/Compact.c
rts/sm/Evac.c
rts/sm/Scav.c
testsuite/tests/codeGen/should_run/CopySmallArray.hs [new file with mode: 0644]
testsuite/tests/codeGen/should_run/CopySmallArray.stdout [new file with mode: 0644]
testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.hs [new file with mode: 0644]
testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.stdout [new file with mode: 0644]
testsuite/tests/codeGen/should_run/SizeOfSmallArray.hs [new file with mode: 0644]
testsuite/tests/codeGen/should_run/SizeOfSmallArray.stdout [new file with mode: 0644]
testsuite/tests/codeGen/should_run/all.T
utils/deriveConstants/DeriveConstants.hs
utils/genprimopcode/Main.hs

index 7a9e32d..407002f 100644 (file)
@@ -56,6 +56,9 @@ module CLabel (
         mkMAP_FROZEN_infoLabel,
         mkMAP_FROZEN0_infoLabel,
         mkMAP_DIRTY_infoLabel,
+        mkSMAP_FROZEN_infoLabel,
+        mkSMAP_FROZEN0_infoLabel,
+        mkSMAP_DIRTY_infoLabel,
         mkEMPTY_MVAR_infoLabel,
         mkArrWords_infoLabel,
 
@@ -405,7 +408,8 @@ mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,
     mkMAP_FROZEN_infoLabel, mkMAP_FROZEN0_infoLabel, mkMAP_DIRTY_infoLabel,
     mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel,
     mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel,
-    mkArrWords_infoLabel :: CLabel
+    mkArrWords_infoLabel, mkSMAP_FROZEN_infoLabel, mkSMAP_FROZEN0_infoLabel,
+    mkSMAP_DIRTY_infoLabel :: CLabel
 mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
 mkSplitMarkerLabel              = CmmLabel rtsPackageId (fsLit "__stg_split_marker")    CmmCode
 mkUpdInfoLabel                  = CmmLabel rtsPackageId (fsLit "stg_upd_frame")         CmmInfo
@@ -420,6 +424,9 @@ mkTopTickyCtrLabel              = CmmLabel rtsPackageId (fsLit "top_ct")
 mkCAFBlackHoleInfoTableLabel    = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE")     CmmInfo
 mkCAFBlackHoleEntryLabel        = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE")     CmmEntry
 mkArrWords_infoLabel            = CmmLabel rtsPackageId (fsLit "stg_ARR_WORDS")         CmmInfo
+mkSMAP_FROZEN_infoLabel         = CmmLabel rtsPackageId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo
+mkSMAP_FROZEN0_infoLabel        = CmmLabel rtsPackageId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo
+mkSMAP_DIRTY_infoLabel          = CmmLabel rtsPackageId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
 
 -----
 mkCmmInfoLabel,   mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
index 5f2c4d8..4914317 100644 (file)
@@ -1334,7 +1334,7 @@ forkLabelledCode p = do
 initEnv :: DynFlags -> Env
 initEnv dflags = listToUFM [
   ( fsLit "SIZEOF_StgHeader",
-    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE dflags)) (wordWidth dflags)) )),
+    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),
   ( fsLit "SIZEOF_StgInfoTable",
     VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
   ]
index a5a8c90..704c22d 100644 (file)
@@ -26,7 +26,7 @@ module SMRep (
 
         -- ** Construction
         mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep,
-        arrWordsRep,
+        smallArrPtrsRep, arrWordsRep,
 
         -- ** Predicates
         isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon,
@@ -34,8 +34,10 @@ module SMRep (
 
         -- ** Size-related things
         heapClosureSizeW,
-        fixedHdrSize, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize,
+        fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize,
         arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW,
+        smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW,
+        fixedHdrSize,
 
         -- ** RTS closure types
         rtsClosureType, rET_SMALL, rET_BIG,
@@ -158,6 +160,9 @@ data SMRep
         !WordOff        -- # ptr words
         !WordOff        -- # card table words
 
+  | SmallArrayPtrsRep
+        !WordOff        -- # ptr words
+
   | ArrayWordsRep
         !WordOff        -- # bytes expressed in words, rounded up
 
@@ -245,6 +250,9 @@ indStaticRep = HeapRep True 1 0 IndStatic
 arrPtrsRep :: DynFlags -> WordOff -> SMRep
 arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems)
 
+smallArrPtrsRep :: WordOff -> SMRep
+smallArrPtrsRep elems = SmallArrayPtrsRep elems
+
 arrWordsRep :: DynFlags -> ByteOff -> SMRep
 arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes)
 
@@ -286,9 +294,12 @@ isStaticNoCafCon _                           = False
 -----------------------------------------------------------------------------
 -- Size-related things
 
+fixedHdrSize :: DynFlags -> ByteOff
+fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags)
+
 -- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h)
-fixedHdrSize :: DynFlags -> WordOff
-fixedHdrSize dflags = sTD_HDR_SIZE dflags + profHdrSize dflags
+fixedHdrSizeW :: DynFlags -> WordOff
+fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags
 
 -- | Size of the profiling part of a closure header
 -- (StgProfHeader in includes/rts/storage/Closures.h)
@@ -300,38 +311,58 @@ profHdrSize dflags
 -- | The garbage collector requires that every closure is at least as
 --   big as this.
 minClosureSize :: DynFlags -> WordOff
-minClosureSize dflags = fixedHdrSize dflags + mIN_PAYLOAD_SIZE dflags
+minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags
 
 arrWordsHdrSize :: DynFlags -> ByteOff
 arrWordsHdrSize dflags
- = fixedHdrSize dflags * wORD_SIZE dflags + sIZEOF_StgArrWords_NoHdr dflags
+ = fixedHdrSize dflags + sIZEOF_StgArrWords_NoHdr dflags
 
 arrWordsHdrSizeW :: DynFlags -> WordOff
 arrWordsHdrSizeW dflags =
-    fixedHdrSize dflags +
+    fixedHdrSizeW dflags +
     (sIZEOF_StgArrWords_NoHdr dflags `quot` wORD_SIZE dflags)
 
 arrPtrsHdrSize :: DynFlags -> ByteOff
 arrPtrsHdrSize dflags
- = fixedHdrSize dflags * wORD_SIZE dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags
+ = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags
 
 arrPtrsHdrSizeW :: DynFlags -> WordOff
 arrPtrsHdrSizeW dflags =
-    fixedHdrSize dflags +
+    fixedHdrSizeW dflags +
     (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)
 
+smallArrPtrsHdrSize :: DynFlags -> ByteOff
+smallArrPtrsHdrSize dflags
+ = fixedHdrSize dflags + sIZEOF_StgSmallMutArrPtrs_NoHdr dflags
+
+smallArrPtrsHdrSizeW :: DynFlags -> WordOff
+smallArrPtrsHdrSizeW dflags =
+    fixedHdrSizeW dflags +
+    (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)
+
 -- Thunks have an extra header word on SMP, so the update doesn't
 -- splat the payload.
 thunkHdrSize :: DynFlags -> WordOff
-thunkHdrSize dflags = fixedHdrSize dflags + smp_hdr
+thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr
         where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags
 
+hdrSize :: DynFlags -> SMRep -> ByteOff
+hdrSize dflags rep = wordsToBytes dflags (hdrSizeW dflags rep)
+
+hdrSizeW :: DynFlags -> SMRep -> WordOff
+hdrSizeW dflags (HeapRep _ _ _ ty)    = closureTypeHdrSize dflags ty
+hdrSizeW dflags (ArrayPtrsRep _ _)    = arrPtrsHdrSizeW dflags
+hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags
+hdrSizeW dflags (ArrayWordsRep _)     = arrWordsHdrSizeW dflags
+hdrSizeW _ _                          = panic "SMRep.hdrSizeW"
+
 nonHdrSize :: DynFlags -> SMRep -> ByteOff
 nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep)
 
 nonHdrSizeW :: SMRep -> WordOff
 nonHdrSizeW (HeapRep _ p np _) = p + np
 nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct
+nonHdrSizeW (SmallArrayPtrsRep elems) = elems
 nonHdrSizeW (ArrayWordsRep words) = words
 nonHdrSizeW (StackRep bs)      = length bs
 nonHdrSizeW (RTSRep _ rep)     = nonHdrSizeW rep
@@ -342,6 +373,8 @@ heapClosureSizeW dflags (HeapRep _ p np ty)
  = closureTypeHdrSize dflags ty + p + np
 heapClosureSizeW dflags (ArrayPtrsRep elems ct)
  = arrPtrsHdrSizeW dflags + elems + ct
+heapClosureSizeW dflags (SmallArrayPtrsRep elems)
+ = smallArrPtrsHdrSizeW dflags + elems
 heapClosureSizeW dflags (ArrayWordsRep words)
  = arrWordsHdrSizeW dflags + words
 heapClosureSizeW _ _ = panic "SMRep.heapClosureSize"
@@ -352,7 +385,7 @@ closureTypeHdrSize dflags ty = case ty of
                   ThunkSelector{} -> thunkHdrSize dflags
                   BlackHole{}     -> thunkHdrSize dflags
                   IndStatic{}     -> thunkHdrSize dflags
-                  _               -> fixedHdrSize dflags
+                  _               -> fixedHdrSizeW dflags
         -- All thunks use thunkHdrSize, even if they are non-updatable.
         -- this is because we don't have separate closure types for
         -- updatable vs. non-updatable thunks, so the GC can't tell the
@@ -472,6 +505,8 @@ instance Outputable SMRep where
 
    ppr (ArrayPtrsRep size _) = ptext (sLit "ArrayPtrsRep") <+> ppr size
 
+   ppr (SmallArrayPtrsRep size) = ptext (sLit "SmallArrayPtrsRep") <+> ppr size
+
    ppr (ArrayWordsRep words) = ptext (sLit "ArrayWordsRep") <+> ppr words
 
    ppr (StackRep bs) = ptext (sLit "StackRep") <+> ppr bs
index c29f47c..06e1716 100644 (file)
@@ -287,7 +287,7 @@ mkRhsClosure    dflags bndr _cc _bi
     maybe_offset          = assocMaybe params_w_offsets (NonVoid selectee)
     Just the_offset       = maybe_offset
     offset_into_int       = bytesToWordsRoundUp dflags the_offset
-                             - fixedHdrSize dflags
+                             - fixedHdrSizeW dflags
 
 ---------- Note [Ap thunks] ------------------
 mkRhsClosure    dflags bndr _cc _bi
@@ -621,7 +621,7 @@ emitBlackHoleCode node = do
              -- work with profiling.
 
   when eager_blackholing $ do
-    emitStore (cmmOffsetW dflags node (fixedHdrSize dflags))
+    emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags))
                   (CmmReg (CmmGlobal CurrentTSO))
     emitPrimCall [] MO_WriteBarrier []
     emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
@@ -673,7 +673,7 @@ pushUpdateFrame lbl updatee body
        updfr  <- getUpdFrameOff
        dflags <- getDynFlags
        let
-           hdr         = fixedHdrSize dflags * wORD_SIZE dflags
+           hdr         = fixedHdrSize dflags
            frame       = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags
        --
        emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee
@@ -682,7 +682,7 @@ pushUpdateFrame lbl updatee body
 emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()
 emitUpdateFrame dflags frame lbl updatee = do
   let
-           hdr         = fixedHdrSize dflags * wORD_SIZE dflags
+           hdr         = fixedHdrSize dflags
            off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags
   --
   emitStore frame (mkLblExpr lbl)
index b6bcf69..a02a5da 100644 (file)
@@ -190,7 +190,7 @@ buildDynCon' dflags platform binder _ _cc con [arg]
   , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...
   = do  { let intlike_lbl   = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE")
               val_int = fromIntegral val :: Int
-              offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1)
+              offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1)
                 -- INTLIKE closures consist of a header and one word payload
               intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW
         ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode
@@ -204,7 +204,7 @@ buildDynCon' dflags platform binder _ _cc con [arg]
   , val_int <= mAX_CHARLIKE dflags
   , val_int >= mIN_CHARLIKE dflags
   = do  { let charlike_lbl   = mkCmmClosureLabel rtsPackageId (fsLit "stg_CHARLIKE")
-              offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1)
+              offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1)
                 -- CHARLIKE closures consist of a header and one word payload
               charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW
         ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode
index a688074..bf88f1c 100644 (file)
@@ -358,7 +358,7 @@ stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)
 
 
 closureField :: DynFlags -> ByteOff -> ByteOff
-closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE dflags
+closureField dflags off = off + fixedHdrSize dflags
 
 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
 stgSp             = CmmReg sp
@@ -405,6 +405,9 @@ add_shim dflags arg_ty expr
   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
   = cmmOffsetB dflags expr (arrPtrsHdrSize dflags)
 
+  | tycon == smallArrayPrimTyCon || tycon == smallMutableArrayPrimTyCon
+  = cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)
+
   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
   = cmmOffsetB dflags expr (arrWordsHdrSize dflags)
 
index 59afc89..a56248d 100644 (file)
@@ -404,7 +404,7 @@ mkVirtHeapOffsets dflags is_thunk things
     )
   where
     hdr_words | is_thunk   = thunkHdrSize dflags
-              | otherwise  = fixedHdrSize dflags
+              | otherwise  = fixedHdrSizeW dflags
     hdr_bytes = wordsToBytes dflags hdr_words
 
     non_void_things    = filterOut (isVoidRep . fst)  things
index da30700..2c4ad4e 100644 (file)
@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+----------------------------------------------------------------------------
 --
 -- Stg to C--: primitive operations
 --
@@ -139,7 +139,14 @@ shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n _))]
 
 shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n _)), init]
   | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
-      Just $ \ [res] -> doNewArrayOp res (fromInteger n) init
+      Just $ \ [res] ->
+      doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel
+      [ (mkIntExpr dflags (fromInteger n),
+         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)
+      , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),
+         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)
+      ]
+      (fromInteger n) init
 
 shouldInlinePrimOp _ CopyArrayOp
     [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
@@ -173,6 +180,31 @@ shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n _))]
   | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
       Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
 
+shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n _)), init]
+  | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+      Just $ \ [res] ->
+      doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel
+      [ (mkIntExpr dflags (fromInteger n),
+         fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)
+      ]
+      (fromInteger n) init
+
+shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n _))]
+  | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n _))]
+  | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n _))]
+  | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n _))]
+  | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
+
 shouldInlinePrimOp dflags primop args
   | primOpOutOfLine primop = Nothing
   | otherwise = Just $ \ regs -> emitPrimOp dflags regs primop args
@@ -298,10 +330,10 @@ emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg]
    = emitAssign (CmmLocal res) curCCS
 
 emitPrimOp dflags [res] ReadMutVarOp [mutv]
-   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSize dflags) (gcWord dflags))
+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))
 
 emitPrimOp dflags [] WriteMutVarOp [mutv,var]
-   = do emitStore (cmmOffsetW dflags mutv (fixedHdrSize dflags)) var
+   = do emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var
         emitCCall
                 [{-no results-}]
                 (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
@@ -310,7 +342,7 @@ emitPrimOp dflags [] WriteMutVarOp [mutv,var]
 --  #define sizzeofByteArrayzh(r,a) \
 --     r = ((StgArrWords *)(a))->bytes
 emitPrimOp dflags [res] SizeofByteArrayOp [arg]
-   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags))
+   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
 
 --  #define sizzeofMutableByteArrayzh(r,a) \
 --      r = ((StgArrWords *)(a))->bytes
@@ -328,14 +360,14 @@ emitPrimOp dflags [res] ByteArrayContents_Char [arg]
 
 --  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 emitPrimOp dflags [res] StableNameToIntOp [arg]
-   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags))
+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
 
 --  #define eqStableNamezh(r,sn1,sn2)                                   \
 --    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 emitPrimOp dflags [res] EqStableNameOp [arg1,arg2]
    = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [
-                                   cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags),
-                                   cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags)
+                                   cmmLoadIndexW dflags arg1 (fixedHdrSizeW dflags) (bWord dflags),
+                                   cmmLoadIndexW dflags arg2 (fixedHdrSizeW dflags) (bWord dflags)
                          ])
 
 
@@ -369,6 +401,10 @@ emitPrimOp _      [res] UnsafeFreezeArrayArrayOp [arg]
    = emit $ catAGraphs
    [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN0_infoLabel)),
      mkAssign (CmmLocal res) arg ]
+emitPrimOp _      [res] UnsafeFreezeSmallArrayOp [arg]
+   = emit $ catAGraphs
+   [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN0_infoLabel)),
+     mkAssign (CmmLocal res) arg ]
 
 --  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)
 emitPrimOp _      [res] UnsafeFreezeByteArrayOp [arg]
@@ -391,8 +427,14 @@ emitPrimOp _      []  WriteArrayArrayOp_MutableByteArray  [obj,ix,v] = doWritePt
 emitPrimOp _      []  WriteArrayArrayOp_ArrayArray        [obj,ix,v] = doWritePtrArrayOp obj ix v
 emitPrimOp _      []  WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v
 
+emitPrimOp _      [res] ReadSmallArrayOp  [obj,ix] = doReadSmallPtrArrayOp res obj ix
+emitPrimOp _      [res] IndexSmallArrayOp [obj,ix] = doReadSmallPtrArrayOp res obj ix
+emitPrimOp _      []  WriteSmallArrayOp [obj,ix,v] = doWriteSmallPtrArrayOp obj ix v
+
+-- Getting the size of pointer arrays
+
 emitPrimOp dflags [res] SizeofArrayOp [arg]
-   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) (bWord dflags))
+   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags + oFFSET_StgMutArrPtrs_ptrs dflags) (bWord dflags))
 emitPrimOp dflags [res] SizeofMutableArrayOp [arg]
    = emitPrimOp dflags [res] SizeofArrayOp [arg]
 emitPrimOp dflags [res] SizeofArrayArrayOp [arg]
@@ -400,6 +442,13 @@ emitPrimOp dflags [res] SizeofArrayArrayOp [arg]
 emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg]
    = emitPrimOp dflags [res] SizeofArrayOp [arg]
 
+emitPrimOp dflags [res] SizeofSmallArrayOp [arg] =
+    emit $ mkAssign (CmmLocal res)
+    (cmmLoadIndexW dflags arg
+     (fixedHdrSizeW dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags) (bWord dflags))
+emitPrimOp dflags [res] SizeofSmallMutableArrayOp [arg] =
+    emitPrimOp dflags [res] SizeofSmallArrayOp [arg]
+
 -- IndexXXXoffAddr
 
 emitPrimOp dflags res IndexOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args
@@ -1060,6 +1109,7 @@ translateOp dflags SameMVarOp             = Just (mo_wordEq dflags)
 translateOp dflags SameMutableArrayOp     = Just (mo_wordEq dflags)
 translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags)
 translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags)
+translateOp dflags SameSmallMutableArrayOp= Just (mo_wordEq dflags)
 translateOp dflags SameTVarOp             = Just (mo_wordEq dflags)
 translateOp dflags EqStablePtrOp          = Just (mo_wordEq dflags)
 
@@ -1196,7 +1246,7 @@ doWritePtrArrayOp addr idx val
 
 loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr
 loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)
- where off = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgMutArrPtrs_ptrs dflags
+ where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags
 
 mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes
                    -> Maybe MachOp -- Optional result cast
@@ -1471,7 +1521,7 @@ doNewByteArrayOp res_r n = do
         (mkIntExpr dflags (nonHdrSize dflags rep))
         (zeroExpr dflags)
 
-    let hdr_size = wordsToBytes dflags (fixedHdrSize dflags)
+    let hdr_size = fixedHdrSize dflags
 
     base <- allocHeapClosure rep info_ptr curCCS
                      [ (mkIntExpr dflags n,
@@ -1571,34 +1621,30 @@ doSetByteArrayOp ba off len c
 -- ----------------------------------------------------------------------------
 -- Allocating arrays
 
--- | Takes a register to return the newly allocated array in, the size
--- of the new array, and an initial value for the elements. Allocates
--- a new 'MutableArray#'.
-doNewArrayOp :: CmmFormal -> WordOff -> CmmExpr -> FCode ()
-doNewArrayOp res_r n init = do
+-- | Allocate a new array.
+doNewArrayOp :: CmmFormal             -- ^ return register
+             -> SMRep                 -- ^ representation of the array
+             -> CLabel                -- ^ info pointer
+             -> [(CmmExpr, ByteOff)]  -- ^ header payload
+             -> WordOff               -- ^ array size
+             -> CmmExpr               -- ^ initial element
+             -> FCode ()
+doNewArrayOp res_r rep info payload n init = do
     dflags <- getDynFlags
 
-    let info_ptr = mkLblExpr mkMAP_DIRTY_infoLabel
-        rep = arrPtrsRep dflags n
+    let info_ptr = mkLblExpr info
 
-    tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags))
+    tickyAllocPrim (mkIntExpr dflags (hdrSize dflags rep))
         (mkIntExpr dflags (nonHdrSize dflags rep))
         (zeroExpr dflags)
 
-    let hdr_size = wordsToBytes dflags (fixedHdrSize dflags)
-
-    base <- allocHeapClosure rep info_ptr curCCS
-                     [ (mkIntExpr dflags n,
-                        hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)
-                     , (mkIntExpr dflags (nonHdrSizeW rep),
-                        hdr_size + oFFSET_StgMutArrPtrs_size dflags)
-                     ]
+    base <- allocHeapClosure rep info_ptr curCCS payload
 
     arr <- CmmLocal `fmap` newTemp (bWord dflags)
     emit $ mkAssign arr base
 
     -- Initialise all elements of the the array
-    p <- assignTemp $ cmmOffsetB dflags (CmmReg arr) (arrPtrsHdrSize dflags)
+    p <- assignTemp $ cmmOffsetB dflags (CmmReg arr) (hdrSize dflags rep)
     for <- newLabelC
     emitLabel for
     let loopBody =
@@ -1608,7 +1654,7 @@ doNewArrayOp res_r n init = do
     emit =<< mkCmmIfThen
         (cmmULtWord dflags (CmmReg (CmmLocal p))
          (cmmOffsetW dflags (CmmReg arr)
-          (arrPtrsHdrSizeW dflags + n)))
+          (hdrSizeW dflags rep + n)))
         (catAGraphs loopBody)
 
     emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
@@ -1717,7 +1763,7 @@ emitCloneArray info_p res_r src src_off n = do
         (mkIntExpr dflags (nonHdrSize dflags rep))
         (zeroExpr dflags)
 
-    let hdr_size = wordsToBytes dflags (fixedHdrSize dflags)
+    let hdr_size = fixedHdrSize dflags
 
     base <- allocHeapClosure rep info_ptr curCCS
                      [ (mkIntExpr dflags n,
@@ -1740,6 +1786,43 @@ emitCloneArray info_p res_r src src_off n = do
 
     emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
 
+-- | Takes an info table label, a register to return the newly
+-- allocated array in, a source array, an offset in the source array,
+-- and the number of elements to copy. Allocates a new array and
+-- initializes it from the source array.
+emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff
+                    -> FCode ()
+emitCloneSmallArray info_p res_r src src_off n = do
+    dflags <- getDynFlags
+
+    let info_ptr = mkLblExpr info_p
+        rep = smallArrPtrsRep n
+
+    tickyAllocPrim (mkIntExpr dflags (smallArrPtrsHdrSize dflags))
+        (mkIntExpr dflags (nonHdrSize dflags rep))
+        (zeroExpr dflags)
+
+    let hdr_size = fixedHdrSize dflags
+
+    base <- allocHeapClosure rep info_ptr curCCS
+                     [ (mkIntExpr dflags n,
+                        hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)
+                     ]
+
+    arr <- CmmLocal `fmap` newTemp (bWord dflags)
+    emit $ mkAssign arr base
+
+    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)
+             (smallArrPtrsHdrSize dflags)
+    src_p <- assignTempE $ cmmOffsetExprW dflags src
+             (cmmAddWord dflags
+              (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off)
+
+    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))
+        (mkIntExpr dflags (wORD_SIZE dflags))
+
+    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
+
 -- | Takes and offset in the destination array, the base address of
 -- the card table, and the number of elements affected (*not* the
 -- number of cards). The number of elements may not be zero.
@@ -1762,6 +1845,31 @@ cardCmm :: DynFlags -> CmmExpr -> CmmExpr
 cardCmm dflags i =
     cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags))
 
+------------------------------------------------------------------------------
+-- SmallArray PrimOp implementations
+
+doReadSmallPtrArrayOp :: LocalReg
+                      -> CmmExpr
+                      -> CmmExpr
+                      -> FCode ()
+doReadSmallPtrArrayOp res addr idx = do
+    dflags <- getDynFlags
+    mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr
+        (gcWord dflags) idx
+
+doWriteSmallPtrArrayOp :: CmmExpr
+                       -> CmmExpr
+                       -> CmmExpr
+                       -> FCode ()
+doWriteSmallPtrArrayOp addr idx val = do
+    dflags <- getDynFlags
+    let ty = cmmExprType dflags val
+    mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val
+    emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))
+
+------------------------------------------------------------------------------
+-- Helpers for emitting function calls
+
 -- | Emit a call to @memcpy@.
 emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 emitMemcpyCall dst src n align = do
index 58612e2..6dfee56 100644 (file)
@@ -933,6 +933,11 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
                              code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a
                              return ((code,AddrRep):rest)
 
+                     | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
+                       -> do rest <- pargs (d + fromIntegral addr_sizeW) az
+                             code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a
+                             return ((code,AddrRep):rest)
+
                      | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
                        -> do rest <- pargs (d + fromIntegral addr_sizeW) az
                              code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
index 149633f..5e9bddc 100644 (file)
@@ -513,8 +513,10 @@ repPrim t = rep where
     | t == threadIdPrimTyCon         = text "<ThreadId>"
     | t == weakPrimTyCon             = text "<Weak>"
     | t == arrayPrimTyCon            = text "<array>"
+    | t == smallArrayPrimTyCon       = text "<smallArray>"
     | t == byteArrayPrimTyCon        = text "<bytearray>"
     | t == mutableArrayPrimTyCon     = text "<mutableArray>"
+    | t == smallMutableArrayPrimTyCon = text "<smallMutableArray>"
     | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>"
     | t == mutVarPrimTyCon           = text "<mutVar>"
     | t == mVarPrimTyCon             = text "<mVar>"
index 0512607..86f8d29 100644 (file)
@@ -1304,7 +1304,8 @@ addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, byteA
     mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, mutableByteArrayPrimTyConKey,
     orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey,
     realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey,
-    anyTyConKey, eqTyConKey :: Unique
+    anyTyConKey, eqTyConKey, smallArrayPrimTyConKey,
+    smallMutableArrayPrimTyConKey :: Unique
 addrPrimTyConKey                        = mkPreludeTyConUnique  1
 arrayPrimTyConKey                       = mkPreludeTyConUnique  3
 boolTyConKey                            = mkPreludeTyConUnique  4
@@ -1494,6 +1495,9 @@ proxyPrimTyConKey = mkPreludeTyConUnique 176
 specTyConKey :: Unique
 specTyConKey = mkPreludeTyConUnique 177
 
+smallArrayPrimTyConKey        = mkPreludeTyConUnique  178
+smallMutableArrayPrimTyConKey = mkPreludeTyConUnique  179
+
 ---------------- Template Haskell -------------------
 --      USES TyConUniques 200-299
 -----------------------------------------------------
index bbe5aba..789d121 100644 (file)
@@ -54,9 +54,11 @@ module TysPrim(
        arrayPrimTyCon, mkArrayPrimTy, 
        byteArrayPrimTyCon,     byteArrayPrimTy,
        arrayArrayPrimTyCon, mkArrayArrayPrimTy, 
+       smallArrayPrimTyCon, mkSmallArrayPrimTy,
        mutableArrayPrimTyCon, mkMutableArrayPrimTy,
        mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy,
        mutableArrayArrayPrimTyCon, mkMutableArrayArrayPrimTy,
+       smallMutableArrayPrimTyCon, mkSmallMutableArrayPrimTy,
        mutVarPrimTyCon, mkMutVarPrimTy,
 
        mVarPrimTyCon,                  mkMVarPrimTy,   
@@ -111,6 +113,7 @@ primTyCons
     , arrayPrimTyCon
     , byteArrayPrimTyCon
     , arrayArrayPrimTyCon
+    , smallArrayPrimTyCon
     , charPrimTyCon
     , doublePrimTyCon
     , floatPrimTyCon
@@ -122,6 +125,7 @@ primTyCons
     , mutableArrayPrimTyCon
     , mutableByteArrayPrimTyCon
     , mutableArrayArrayPrimTyCon
+    , smallMutableArrayPrimTyCon
     , mVarPrimTyCon
     , tVarPrimTyCon
     , mutVarPrimTyCon
@@ -156,7 +160,7 @@ mkPrimTc fs unique tycon
                  (ATyCon tycon)        -- Relevant TyCon
                  UserSyntax            -- None are built-in syntax
 
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, voidPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, voidPrimTyConName :: Name
 charPrimTyConName            = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
 intPrimTyConName             = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon
 int32PrimTyConName           = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
@@ -176,9 +180,11 @@ realWorldTyConName            = mkPrimTc (fsLit "RealWorld") realWorldTyConKey r
 arrayPrimTyConName           = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon
 byteArrayPrimTyConName       = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon
 arrayArrayPrimTyConName          = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon
+smallArrayPrimTyConName       = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon
 mutableArrayPrimTyConName     = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon
 mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon
 mutableArrayArrayPrimTyConName= mkPrimTc (fsLit "MutableArrayArray#") mutableArrayArrayPrimTyConKey mutableArrayArrayPrimTyCon
+smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon
 mutVarPrimTyConName          = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon
 mVarPrimTyConName            = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon
 tVarPrimTyConName            = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon
@@ -538,13 +544,16 @@ defined in \tr{TysWiredIn.lhs}, not here.
 
 \begin{code}
 arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon,
-    byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon :: TyCon
+    byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon,
+    smallArrayPrimTyCon, smallMutableArrayPrimTyCon :: TyCon
 arrayPrimTyCon             = pcPrimTyCon arrayPrimTyConName             [Representational] PtrRep
 mutableArrayPrimTyCon      = pcPrimTyCon  mutableArrayPrimTyConName     [Nominal, Representational] PtrRep
 mutableByteArrayPrimTyCon  = pcPrimTyCon mutableByteArrayPrimTyConName  [Nominal] PtrRep
 byteArrayPrimTyCon         = pcPrimTyCon0 byteArrayPrimTyConName        PtrRep
 arrayArrayPrimTyCon        = pcPrimTyCon0 arrayArrayPrimTyConName       PtrRep
 mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] PtrRep
+smallArrayPrimTyCon        = pcPrimTyCon smallArrayPrimTyConName        [Representational] PtrRep
+smallMutableArrayPrimTyCon = pcPrimTyCon smallMutableArrayPrimTyConName [Nominal, Representational] PtrRep
 
 mkArrayPrimTy :: Type -> Type
 mkArrayPrimTy elt          = TyConApp arrayPrimTyCon [elt]
@@ -552,12 +561,16 @@ byteArrayPrimTy :: Type
 byteArrayPrimTy                    = mkTyConTy byteArrayPrimTyCon
 mkArrayArrayPrimTy :: Type
 mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon
+mkSmallArrayPrimTy :: Type -> Type
+mkSmallArrayPrimTy elt = TyConApp smallArrayPrimTyCon [elt]
 mkMutableArrayPrimTy :: Type -> Type -> Type
 mkMutableArrayPrimTy s elt  = TyConApp mutableArrayPrimTyCon [s, elt]
 mkMutableByteArrayPrimTy :: Type -> Type
 mkMutableByteArrayPrimTy s  = TyConApp mutableByteArrayPrimTyCon [s]
 mkMutableArrayArrayPrimTy :: Type -> Type
 mkMutableArrayArrayPrimTy s = TyConApp mutableArrayArrayPrimTyCon [s]
+mkSmallMutableArrayPrimTy :: Type -> Type -> Type
+mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [s, elt]
 \end{code}
 
 %************************************************************************
index 553163b..10dd19d 100644 (file)
@@ -796,7 +796,7 @@ primop  CloneArrayOp "cloneArray#" GenPrimOp
   with
   out_of_line      = True
   has_side_effects = True
-  code_size = { primOpCodeSizeForeignCall + 4 }
+  can_fail         = True
 
 primop  CloneMutableArrayOp "cloneMutableArray#" GenPrimOp
   MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
@@ -807,7 +807,7 @@ primop  CloneMutableArrayOp "cloneMutableArray#" GenPrimOp
   with
   out_of_line      = True
   has_side_effects = True
-  code_size = { primOpCodeSizeForeignCall + 4 }
+  can_fail         = True
 
 primop  FreezeArrayOp "freezeArray#" GenPrimOp
   MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, Array# a #)
@@ -818,7 +818,7 @@ primop  FreezeArrayOp "freezeArray#" GenPrimOp
   with
   out_of_line      = True
   has_side_effects = True
-  code_size = { primOpCodeSizeForeignCall + 4 }
+  can_fail         = True
 
 primop  ThawArrayOp "thawArray#" GenPrimOp
   Array# a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
@@ -829,7 +829,7 @@ primop  ThawArrayOp "thawArray#" GenPrimOp
   with
   out_of_line      = True
   has_side_effects = True
-  code_size = { primOpCodeSizeForeignCall + 4 }
+  can_fail         = True
 
 primop CasArrayOp  "casArray#" GenPrimOp
    MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #)
@@ -840,6 +840,154 @@ primop CasArrayOp  "casArray#" GenPrimOp
 
 
 ------------------------------------------------------------------------
+section "Small Arrays"
+
+       {Operations on {\tt SmallArray\#}. A {\tt SmallArray\#} works
+         just like an {\tt Array\#}, except that its implementation is
+         optimized for small arrays (i.e. no more than 128 elements.)}
+
+------------------------------------------------------------------------
+
+primtype SmallArray# a
+
+primtype SmallMutableArray# s a
+
+primop  NewSmallArrayOp "newSmallArray#" GenPrimOp
+   Int# -> a -> State# s -> (# State# s, SmallMutableArray# s a #)
+   {Create a new mutable array with the specified number of elements,
+    in the specified state thread,
+    with each element containing the specified initial value.}
+   with
+   out_of_line = True
+   has_side_effects = True
+
+primop  SameSmallMutableArrayOp "sameSmallMutableArray#" GenPrimOp
+   SmallMutableArray# s a -> SmallMutableArray# s a -> Int#
+
+primop  ReadSmallArrayOp "readSmallArray#" GenPrimOp
+   SmallMutableArray# s a -> Int# -> State# s -> (# State# s, a #)
+   {Read from specified index of mutable array. Result is not yet evaluated.}
+   with
+   has_side_effects = True
+   can_fail         = True
+
+primop  WriteSmallArrayOp "writeSmallArray#" GenPrimOp
+   SmallMutableArray# s a -> Int# -> a -> State# s -> State# s
+   {Write to specified index of mutable array.}
+   with
+   has_side_effects = True
+   can_fail         = True
+
+primop  SizeofSmallArrayOp "sizeofSmallArray#" GenPrimOp
+   SmallArray# a -> Int#
+   {Return the number of elements in the array.}
+
+primop  SizeofSmallMutableArrayOp "sizeofSmallMutableArray#" GenPrimOp
+   SmallMutableArray# s a -> Int#
+   {Return the number of elements in the array.}
+
+primop  IndexSmallArrayOp "indexSmallArray#" GenPrimOp
+   SmallArray# a -> Int# -> (# a #)
+   {Read from specified index of immutable array. Result is packaged into
+    an unboxed singleton; the result itself is not yet evaluated.}
+   with
+   can_fail         = True
+
+primop  UnsafeFreezeSmallArrayOp "unsafeFreezeSmallArray#" GenPrimOp
+   SmallMutableArray# s a -> State# s -> (# State# s, SmallArray# a #)
+   {Make a mutable array immutable, without copying.}
+   with
+   has_side_effects = True
+
+primop  UnsafeThawSmallArrayOp  "unsafeThawSmallArray#" GenPrimOp
+   SmallArray# a -> State# s -> (# State# s, SmallMutableArray# s a #)
+   {Make an immutable array mutable, without copying.}
+   with
+   out_of_line = True
+   has_side_effects = True
+
+-- The code_size is only correct for the case when the copy family of
+-- primops aren't inlined. It would be nice to keep track of both.
+
+primop  CopySmallArrayOp "copySmallArray#" GenPrimOp
+  SmallArray# a -> Int# -> SmallMutableArray# s a -> Int# -> Int# -> State# s -> State# s
+  {Given a source array, an offset into the source array, a
+   destination array, an offset into the destination array, and a
+   number of elements to copy, copy the elements from the source array
+   to the destination array. 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
+  can_fail         = True
+
+primop  CopySmallMutableArrayOp "copySmallMutableArray#" GenPrimOp
+  SmallMutableArray# s a -> Int# -> SmallMutableArray# s a -> Int# -> Int# -> State# s -> State# s
+  {Given a source array, an offset into the source array, a
+   destination array, an offset into the destination array, and a
+   number of elements to copy, copy the elements from the source array
+   to the destination array. The source and destination arrays can
+   refer to the same array. Both arrays must fully contain the
+   specified ranges, but this is not checked.}
+  with
+  out_of_line      = True
+  has_side_effects = True
+  can_fail         = True
+
+primop  CloneSmallArrayOp "cloneSmallArray#" GenPrimOp
+  SmallArray# a -> Int# -> Int# -> SmallArray# a
+  {Given a source array, an offset into the source array, and a number
+   of elements to copy, create a new array with the elements from the
+   source array. The provided array must fully contain the specified
+   range, but this is not checked.}
+  with
+  out_of_line      = True
+  has_side_effects = True
+  can_fail         = True
+
+primop  CloneSmallMutableArrayOp "cloneSmallMutableArray#" GenPrimOp
+  SmallMutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a #)
+  {Given a source array, an offset into the source array, and a number
+   of elements to copy, create a new array with the elements from the
+   source array. The provided array must fully contain the specified
+   range, but this is not checked.}
+  with
+  out_of_line      = True
+  has_side_effects = True
+  can_fail         = True
+
+primop  FreezeSmallArrayOp "freezeSmallArray#" GenPrimOp
+  SmallMutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, SmallArray# a #)
+  {Given a source array, an offset into the source array, and a number
+   of elements to copy, create a new array with the elements from the
+   source array. The provided array must fully contain the specified
+   range, but this is not checked.}
+  with
+  out_of_line      = True
+  has_side_effects = True
+  can_fail         = True
+
+primop  ThawSmallArrayOp "thawSmallArray#" GenPrimOp
+  SmallArray# a -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a #)
+  {Given a source array, an offset into the source array, and a number
+   of elements to copy, create a new array with the elements from the
+   source array. The provided array must fully contain the specified
+   range, but this is not checked.}
+  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.}
+   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
          raw memory in the garbage-collected heap, which is not
index 13e485f..24bdda3 100644 (file)
       __gen = TO_W_(bdescr_gen_no(__bd));                       \
       if (__gen > 0) { recordMutableCap(__p, __gen); }
 
+/* -----------------------------------------------------------------------------
+   Arrays
+   -------------------------------------------------------------------------- */
+
 /* Complete function body for the clone family of (mutable) array ops.
    Defined as a macro to avoid function call overhead or code
    duplication. */
     __cards = __end_card - __start_card + 1;                   \
     prim %memset((dst_cards_p) + __start_card, 1, __cards, 1);
 
+/* Complete function body for the clone family of small (mutable)
+   array ops. Defined as a macro to avoid function call overhead or
+   code duplication. */
+#define cloneSmallArray(info, src, offset, n)                  \
+    W_ words, size;                                            \
+    gcptr dst, dst_p, src_p;                                   \
+                                                               \
+    again: MAYBE_GC(again);                                    \
+                                                               \
+    words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + n;       \
+    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \
+    TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0);     \
+                                                               \
+    SET_HDR(dst, info, CCCS);                                  \
+    StgSmallMutArrPtrs_ptrs(dst) = n;                          \
+                                                               \
+    dst_p = dst + SIZEOF_StgSmallMutArrPtrs;                   \
+    src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(offset);     \
+  while:                                                       \
+    if (n != 0) {                                              \
+        n = n - 1;                                             \
+        W_[dst_p] = W_[src_p];                                 \
+        dst_p = dst_p + WDS(1);                                \
+        src_p = src_p + WDS(1);                                \
+        goto while;                                            \
+    }                                                          \
+                                                               \
+    return (dst);
+
 #endif /* CMM_H */
index 88434d4..92b78de 100644 (file)
@@ -326,6 +326,10 @@ EXTERN_INLINE StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x );
 EXTERN_INLINE StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x )
 { return sizeofW(StgMutArrPtrs) + x->size; }
 
+EXTERN_INLINE StgOffset small_mut_arr_ptrs_sizeW( StgSmallMutArrPtrs* x );
+EXTERN_INLINE StgOffset small_mut_arr_ptrs_sizeW( StgSmallMutArrPtrs* x )
+{ return sizeofW(StgSmallMutArrPtrs) + x->ptrs; }
+
 EXTERN_INLINE StgWord stack_sizeW ( StgStack *stack );
 EXTERN_INLINE StgWord stack_sizeW ( StgStack *stack )
 { return sizeofW(StgStack) + stack->stack_size; }
@@ -378,6 +382,11 @@ closure_sizeW_ (StgClosure *p, StgInfoTable *info)
     case MUT_ARR_PTRS_FROZEN:
     case MUT_ARR_PTRS_FROZEN0:
        return mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+    case SMALL_MUT_ARR_PTRS_CLEAN:
+    case SMALL_MUT_ARR_PTRS_DIRTY:
+    case SMALL_MUT_ARR_PTRS_FROZEN:
+    case SMALL_MUT_ARR_PTRS_FROZEN0:
+       return small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs*)p);
     case TSO:
         return sizeofW(StgTSO);
     case STACK:
index 73a7311..9bdddc4 100644 (file)
 #define CATCH_RETRY_FRAME       58
 #define CATCH_STM_FRAME         59
 #define WHITEHOLE               60
-#define N_CLOSURE_TYPES         61
+#define SMALL_MUT_ARR_PTRS_CLEAN      61
+#define SMALL_MUT_ARR_PTRS_DIRTY      62
+#define SMALL_MUT_ARR_PTRS_FROZEN0    63
+#define SMALL_MUT_ARR_PTRS_FROZEN     64
+#define N_CLOSURE_TYPES         65
 
 #endif /* RTS_STORAGE_CLOSURETYPES_H */
index 2704128..8aed04e 100644 (file)
@@ -158,6 +158,12 @@ typedef struct {
 
 typedef struct {
     StgHeader   header;
+    StgWord     ptrs;
+    StgClosure *payload[FLEXIBLE_ARRAY];
+} StgSmallMutArrPtrs;
+
+typedef struct {
+    StgHeader   header;
     StgClosure *var;
 } StgMutVar;
 
index 8be51fb..944adac 100644 (file)
@@ -112,6 +112,10 @@ RTS_ENTRY(stg_MUT_ARR_PTRS_CLEAN);
 RTS_ENTRY(stg_MUT_ARR_PTRS_DIRTY);
 RTS_ENTRY(stg_MUT_ARR_PTRS_FROZEN);
 RTS_ENTRY(stg_MUT_ARR_PTRS_FROZEN0);
+RTS_ENTRY(stg_SMALL_MUT_ARR_PTRS_CLEAN);
+RTS_ENTRY(stg_SMALL_MUT_ARR_PTRS_DIRTY);
+RTS_ENTRY(stg_SMALL_MUT_ARR_PTRS_FROZEN);
+RTS_ENTRY(stg_SMALL_MUT_ARR_PTRS_FROZEN0);
 RTS_ENTRY(stg_MUT_VAR_CLEAN);
 RTS_ENTRY(stg_MUT_VAR_DIRTY);
 RTS_ENTRY(stg_END_TSO_QUEUE);
@@ -352,6 +356,16 @@ RTS_FUN_DECL(stg_cloneMutableArrayzh);
 RTS_FUN_DECL(stg_freezzeArrayzh);
 RTS_FUN_DECL(stg_thawArrayzh);
 
+RTS_FUN_DECL(stg_newSmallArrayzh);
+RTS_FUN_DECL(stg_unsafeThawSmallArrayzh);
+RTS_FUN_DECL(stg_cloneSmallArrayzh);
+RTS_FUN_DECL(stg_cloneSmallMutableArrayzh);
+RTS_FUN_DECL(stg_freezzeSmallArrayzh);
+RTS_FUN_DECL(stg_thawSmallArrayzh);
+RTS_FUN_DECL(stg_copySmallArrayzh);
+RTS_FUN_DECL(stg_copySmallMutableArrayzh);
+RTS_FUN_DECL(stg_casSmallArrayzh);
+
 RTS_FUN_DECL(stg_newMutVarzh);
 RTS_FUN_DECL(stg_atomicModifyMutVarzh);
 RTS_FUN_DECL(stg_casMutVarzh);
index 8692dea..f1f454c 100644 (file)
@@ -198,6 +198,14 @@ static void searchHeapBlocks (HashTable *addrs, bdescr *bd)
                prim = rtsTrue;
                size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)p);
                break;
+
+           case SMALL_MUT_ARR_PTRS_CLEAN:
+           case SMALL_MUT_ARR_PTRS_DIRTY:
+           case SMALL_MUT_ARR_PTRS_FROZEN:
+           case SMALL_MUT_ARR_PTRS_FROZEN0:
+               prim = rtsTrue;
+               size = small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs *)p);
+               break;
                
            case TSO:
                prim = rtsTrue;
index 020f284..c43437d 100644 (file)
@@ -81,9 +81,13 @@ StgWord16 closure_flags[] = {
  [ATOMICALLY_FRAME]     =  (     _BTM                                  ),
  [CATCH_RETRY_FRAME]    =  (     _BTM                                  ),
  [CATCH_STM_FRAME]      =  (     _BTM                                  ),
- [WHITEHOLE]            =  ( 0                                         )
+ [WHITEHOLE]            =  ( 0                                         ),
+ [SMALL_MUT_ARR_PTRS_CLEAN]   =  (_HNF|     _NS|         _MUT|_UPT           ),
+ [SMALL_MUT_ARR_PTRS_DIRTY]   =  (_HNF|     _NS|         _MUT|_UPT           ),
+ [SMALL_MUT_ARR_PTRS_FROZEN0] =  (_HNF|     _NS|         _MUT|_UPT           ),
+ [SMALL_MUT_ARR_PTRS_FROZEN]  =  (_HNF|     _NS|              _UPT           )
 };
 
-#if N_CLOSURE_TYPES != 61
+#if N_CLOSURE_TYPES != 65
 #error Closure types changed: update ClosureFlags.c!
 #endif
index d077f3c..4530969 100644 (file)
@@ -68,6 +68,10 @@ processHeapClosureForDead( StgClosure *c )
     case MUT_ARR_PTRS_DIRTY:
     case MUT_ARR_PTRS_FROZEN:
     case MUT_ARR_PTRS_FROZEN0:
+    case SMALL_MUT_ARR_PTRS_CLEAN:
+    case SMALL_MUT_ARR_PTRS_DIRTY:
+    case SMALL_MUT_ARR_PTRS_FROZEN:
+    case SMALL_MUT_ARR_PTRS_FROZEN0:
     case ARR_WORDS:
     case WEAK:
     case MUT_VAR_CLEAN:
index fee6124..9c73757 100644 (file)
@@ -1168,6 +1168,15 @@ typedef struct _RtsSymbolVal {
       SymI_HasProto(stg_thawArrayzh)                                    \
       SymI_HasProto(stg_newArrayArrayzh)                                \
       SymI_HasProto(stg_casArrayzh)                                     \
+      SymI_HasProto(stg_newSmallArrayzh)                                \
+      SymI_HasProto(stg_unsafeThawSmallArrayzh)                         \
+      SymI_HasProto(stg_cloneSmallArrayzh)                              \
+      SymI_HasProto(stg_cloneSmallMutableArrayzh)                       \
+      SymI_HasProto(stg_freezzeSmallArrayzh)                            \
+      SymI_HasProto(stg_thawSmallArrayzh)                               \
+      SymI_HasProto(stg_copySmallArrayzh)                               \
+      SymI_HasProto(stg_copySmallMutableArrayzh)                        \
+      SymI_HasProto(stg_casSmallArrayzh)                                \
       SymI_HasProto(stg_newBCOzh)                                       \
       SymI_HasProto(stg_newByteArrayzh)                                 \
       SymI_HasProto(stg_casIntArrayzh)                                  \
index 2f697b4..df2119f 100644 (file)
@@ -322,6 +322,124 @@ stg_newArrayArrayzh ( W_ n /* words */ )
 
 
 /* -----------------------------------------------------------------------------
+   SmallArray primitives
+   -------------------------------------------------------------------------- */
+
+stg_newSmallArrayzh ( W_ n /* words */, gcptr init )
+{
+    W_ words, size, p;
+    gcptr arr;
+
+    again: MAYBE_GC(again);
+
+    words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + n;
+    ("ptr" arr) = ccall allocate(MyCapability() "ptr",words);
+    TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0);
+
+    SET_HDR(arr, stg_SMALL_MUT_ARR_PTRS_DIRTY_info, CCCS);
+    StgSmallMutArrPtrs_ptrs(arr) = n;
+
+    // Initialise all elements of the the array with the value in R2
+    p = arr + SIZEOF_StgSmallMutArrPtrs;
+  for:
+    if (p < arr + SIZEOF_StgSmallMutArrPtrs + WDS(n)) {
+        W_[p] = init;
+        p = p + WDS(1);
+        goto for;
+    }
+
+    return (arr);
+}
+
+stg_unsafeThawSmallArrayzh ( gcptr arr )
+{
+    // See stg_unsafeThawArrayzh
+    if (StgHeader_info(arr) != stg_SMALL_MUT_ARR_PTRS_FROZEN0_info) {
+        SET_INFO(arr, stg_SMALL_MUT_ARR_PTRS_DIRTY_info);
+        recordMutable(arr);
+        // must be done after SET_INFO, because it ASSERTs closure_MUTABLE()
+        return (arr);
+    } else {
+        SET_INFO(arr, stg_SMALL_MUT_ARR_PTRS_DIRTY_info);
+        return (arr);
+    }
+}
+
+stg_cloneSmallArrayzh ( gcptr src, W_ offset, W_ n )
+{
+    cloneSmallArray(stg_SMALL_MUT_ARR_PTRS_FROZEN_info, src, offset, n)
+}
+
+stg_cloneSmallMutableArrayzh ( gcptr src, W_ offset, W_ n )
+{
+    cloneSmallArray(stg_SMALL_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
+}
+
+// We have to escape the "z" in the name.
+stg_freezzeSmallArrayzh ( gcptr src, W_ offset, W_ n )
+{
+    cloneSmallArray(stg_SMALL_MUT_ARR_PTRS_FROZEN_info, src, offset, n)
+}
+
+stg_thawSmallArrayzh ( gcptr src, W_ offset, W_ n )
+{
+    cloneSmallArray(stg_SMALL_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
+}
+
+stg_copySmallArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n)
+{
+    W_ dst_p, src_p, bytes;
+
+    SET_INFO(dst, stg_SMALL_MUT_ARR_PTRS_DIRTY_info);
+
+    dst_p = dst + SIZEOF_StgSmallMutArrPtrs + WDS(dst_off);
+    src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(src_off);
+    bytes = WDS(n);
+    prim %memcpy(dst_p, src_p, bytes, WDS(1));
+
+    return ();
+}
+
+stg_copySmallMutableArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n)
+{
+    W_ dst_p, src_p, bytes;
+
+    SET_INFO(dst, stg_SMALL_MUT_ARR_PTRS_DIRTY_info);
+
+    dst_p = dst + SIZEOF_StgSmallMutArrPtrs + WDS(dst_off);
+    src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(src_off);
+    bytes = WDS(n);
+    if (src == dst) {
+        prim %memmove(dst_p, src_p, bytes, WDS(1));
+    } else {
+        prim %memcpy(dst_p, src_p, bytes, WDS(1));
+    }
+
+    return ();
+}
+
+// RRN: Uses the ticketed approach; see casMutVar
+stg_casSmallArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
+/* SmallMutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, Any a #) */
+{
+    gcptr h;
+    W_ p, len;
+
+    p = arr + SIZEOF_StgSmallMutArrPtrs + WDS(ind);
+    (h) = ccall cas(p, old, new);
+
+    if (h != old) {
+        // Failure, return what was there instead of 'old':
+        return (1,h);
+    } else {
+        // Compare and Swap Succeeded:
+        SET_HDR(arr, stg_SMALL_MUT_ARR_PTRS_DIRTY_info, CCCS);
+        return (0,new);
+    }
+}
+
+
+/* -----------------------------------------------------------------------------
    MutVar primitives
    -------------------------------------------------------------------------- */
 
index ca9ca49..b7125d9 100644 (file)
@@ -322,6 +322,21 @@ printClosure( StgClosure *obj )
        debugBelch("MUT_ARR_PTRS_FROZEN(size=%" FMT_Word ")\n", (W_)((StgMutArrPtrs *)obj)->ptrs);
        break;
 
+    case SMALL_MUT_ARR_PTRS_CLEAN:
+       debugBelch("SMALL_MUT_ARR_PTRS_CLEAN(size=%" FMT_Word ")\n",
+                   (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
+       break;
+
+    case SMALL_MUT_ARR_PTRS_DIRTY:
+       debugBelch("SMALL_MUT_ARR_PTRS_DIRTY(size=%" FMT_Word ")\n",
+                   (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
+       break;
+
+    case SMALL_MUT_ARR_PTRS_FROZEN:
+       debugBelch("SMALL_MUT_ARR_PTRS_FROZEN(size=%" FMT_Word ")\n",
+                   (W_)((StgSmallMutArrPtrs *)obj)->ptrs);
+       break;
+
     case MVAR_CLEAN:
     case MVAR_DIRTY:
         {
index 6d78886..d21b14a 100644 (file)
@@ -1025,6 +1025,14 @@ heapCensusChain( Census *census, bdescr *bd )
                prim = rtsTrue;
                size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)p);
                break;
+
+           case SMALL_MUT_ARR_PTRS_CLEAN:
+           case SMALL_MUT_ARR_PTRS_DIRTY:
+           case SMALL_MUT_ARR_PTRS_FROZEN:
+           case SMALL_MUT_ARR_PTRS_FROZEN0:
+               prim = rtsTrue;
+               size = small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs *)p);
+               break;
                
            case TSO:
                prim = rtsTrue;
index 973e03b..bdfc831 100644 (file)
@@ -531,6 +531,18 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
            return;
        break;
 
+       // StgMutArrPtr.ptrs, no SRT
+    case SMALL_MUT_ARR_PTRS_CLEAN:
+    case SMALL_MUT_ARR_PTRS_DIRTY:
+    case SMALL_MUT_ARR_PTRS_FROZEN:
+    case SMALL_MUT_ARR_PTRS_FROZEN0:
+       init_ptrs(&se.info, ((StgSmallMutArrPtrs *)c)->ptrs,
+                 (StgPtr)(((StgSmallMutArrPtrs *)c)->payload));
+       *first_child = find_ptrs(&se.info);
+       if (*first_child == NULL)
+           return;
+       break;
+
     // layout.payload.ptrs, SRT
     case FUN:           // *c is a heap object.
     case FUN_2_0:
index 450b2d9..42ef39e 100644 (file)
@@ -604,6 +604,18 @@ INFO_TABLE(stg_MUT_ARR_PTRS_FROZEN, 0, 0, MUT_ARR_PTRS_FROZEN, "MUT_ARR_PTRS_FRO
 INFO_TABLE(stg_MUT_ARR_PTRS_FROZEN0, 0, 0, MUT_ARR_PTRS_FROZEN0, "MUT_ARR_PTRS_FROZEN0", "MUT_ARR_PTRS_FROZEN0")
 { foreign "C" barf("MUT_ARR_PTRS_FROZEN0 object entered!") never returns; }
 
+INFO_TABLE(stg_SMALL_MUT_ARR_PTRS_CLEAN, 0, 0, SMALL_MUT_ARR_PTRS_CLEAN, "SMALL_MUT_ARR_PTRS_CLEAN", "SMALL_MUT_ARR_PTRS_CLEAN")
+{ foreign "C" barf("SMALL_MUT_ARR_PTRS_CLEAN object entered!") never returns; }
+
+INFO_TABLE(stg_SMALL_MUT_ARR_PTRS_DIRTY, 0, 0, SMALL_MUT_ARR_PTRS_DIRTY, "SMALL_MUT_ARR_PTRS_DIRTY", "SMALL_MUT_ARR_PTRS_DIRTY")
+{ foreign "C" barf("SMALL_MUT_ARR_PTRS_DIRTY object entered!") never returns; }
+
+INFO_TABLE(stg_SMALL_MUT_ARR_PTRS_FROZEN, 0, 0, SMALL_MUT_ARR_PTRS_FROZEN, "SMALL_MUT_ARR_PTRS_FROZEN", "SMALL_MUT_ARR_PTRS_FROZEN")
+{ foreign "C" barf("SMALL_MUT_ARR_PTRS_FROZEN object entered!") never returns; }
+
+INFO_TABLE(stg_SMALL_MUT_ARR_PTRS_FROZEN0, 0, 0, SMALL_MUT_ARR_PTRS_FROZEN0, "SMALL_MUT_ARR_PTRS_FROZEN0", "SMALL_MUT_ARR_PTRS_FROZEN0")
+{ foreign "C" barf("SMALL_MUT_ARR_PTRS_FROZEN0 object entered!") never returns; }
+
 /* ----------------------------------------------------------------------------
    Mutable Variables
    ------------------------------------------------------------------------- */
index e9973d3..8ae72a9 100644 (file)
@@ -495,6 +495,21 @@ update_fwd_large( bdescr *bd )
           continue;
       }
 
+    case SMALL_MUT_ARR_PTRS_CLEAN:
+    case SMALL_MUT_ARR_PTRS_DIRTY:
+    case SMALL_MUT_ARR_PTRS_FROZEN:
+    case SMALL_MUT_ARR_PTRS_FROZEN0:
+      // follow everything 
+      {
+          StgSmallMutArrPtrs *a;
+
+          a = (StgSmallMutArrPtrs*)p;
+          for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
+              thread((StgClosure **)p);
+          }
+          continue;
+      }
+
     case STACK:
     {
         StgStack *stack = (StgStack*)p;
@@ -680,6 +695,22 @@ thread_obj (StgInfoTable *info, StgPtr p)
 
        return (StgPtr)a + mut_arr_ptrs_sizeW(a);
     }
+
+    case SMALL_MUT_ARR_PTRS_CLEAN:
+    case SMALL_MUT_ARR_PTRS_DIRTY:
+    case SMALL_MUT_ARR_PTRS_FROZEN:
+    case SMALL_MUT_ARR_PTRS_FROZEN0:
+       // follow everything 
+    {
+        StgSmallMutArrPtrs *a;
+
+        a = (StgSmallMutArrPtrs *)p;
+       for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) {
+           thread((StgClosure **)p);
+       }
+
+       return (StgPtr)a + small_mut_arr_ptrs_sizeW(a);
+    }
     
     case TSO:
        return thread_TSO((StgTSO *)p);
index 577edc3..4a550cd 100644 (file)
@@ -716,6 +716,14 @@ loop:
       copy(p,info,q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),gen_no);
       return;
 
+  case SMALL_MUT_ARR_PTRS_CLEAN:
+  case SMALL_MUT_ARR_PTRS_DIRTY:
+  case SMALL_MUT_ARR_PTRS_FROZEN:
+  case SMALL_MUT_ARR_PTRS_FROZEN0:
+      // just copy the block 
+      copy(p,info,q,small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs *)q),gen_no);
+      return;
+
   case TSO:
       copy(p,info,q,sizeofW(StgTSO),gen_no);
       return;
index 5b1e5d0..c35444b 100644 (file)
@@ -661,6 +661,54 @@ scavenge_block (bdescr *bd)
        break;
     }
 
+    case SMALL_MUT_ARR_PTRS_CLEAN:
+    case SMALL_MUT_ARR_PTRS_DIRTY:
+        // follow everything
+    {
+        StgPtr next;
+
+        // We don't eagerly promote objects pointed to by a mutable
+        // array, but if we find the array only points to objects in
+        // the same or an older generation, we mark it "clean" and
+        // avoid traversing it during minor GCs.
+        gct->eager_promotion = rtsFalse;
+        next = p + small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs*)p);
+        for (p = (P_)((StgSmallMutArrPtrs *)p)->payload; p < next; p++) {
+            evacuate((StgClosure **)p);
+        }
+        gct->eager_promotion = saved_eager_promotion;
+
+        if (gct->failed_to_evac) {
+            ((StgClosure *)q)->header.info = &stg_SMALL_MUT_ARR_PTRS_DIRTY_info;
+        } else {
+            ((StgClosure *)q)->header.info = &stg_SMALL_MUT_ARR_PTRS_CLEAN_info;
+        }
+
+        gct->failed_to_evac = rtsTrue; // always put it on the mutable list.
+        break;
+    }
+
+    case SMALL_MUT_ARR_PTRS_FROZEN:
+    case SMALL_MUT_ARR_PTRS_FROZEN0:
+        // follow everything
+    {
+        StgPtr next;
+
+        next = p + small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs*)p);
+        for (p = (P_)((StgSmallMutArrPtrs *)p)->payload; p < next; p++) {
+            evacuate((StgClosure **)p);
+        }
+
+        // If we're going to put this object on the mutable list, then
+        // set its info ptr to SMALL_MUT_ARR_PTRS_FROZEN0 to indicate that.
+        if (gct->failed_to_evac) {
+            ((StgClosure *)q)->header.info = &stg_SMALL_MUT_ARR_PTRS_FROZEN0_info;
+        } else {
+            ((StgClosure *)q)->header.info = &stg_SMALL_MUT_ARR_PTRS_FROZEN_info;
+        }
+        break;
+    }
+
     case TSO:
     { 
         scavengeTSO((StgTSO *)p);
@@ -1016,6 +1064,56 @@ scavenge_mark_stack(void)
            break;
        }
 
+        case SMALL_MUT_ARR_PTRS_CLEAN:
+        case SMALL_MUT_ARR_PTRS_DIRTY:
+            // follow everything
+        {
+            StgPtr next;
+            rtsBool saved_eager;
+
+            // We don't eagerly promote objects pointed to by a mutable
+            // array, but if we find the array only points to objects in
+            // the same or an older generation, we mark it "clean" and
+            // avoid traversing it during minor GCs.
+            saved_eager = gct->eager_promotion;
+            gct->eager_promotion = rtsFalse;
+            next = p + small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs*)p);
+            for (p = (P_)((StgSmallMutArrPtrs *)p)->payload; p < next; p++) {
+                evacuate((StgClosure **)p);
+            }
+            gct->eager_promotion = saved_eager;
+
+            if (gct->failed_to_evac) {
+                ((StgClosure *)q)->header.info = &stg_SMALL_MUT_ARR_PTRS_DIRTY_info;
+            } else {
+                ((StgClosure *)q)->header.info = &stg_SMALL_MUT_ARR_PTRS_CLEAN_info;
+            }
+
+            gct->failed_to_evac = rtsTrue; // mutable anyhow.
+            break;
+        }
+
+        case SMALL_MUT_ARR_PTRS_FROZEN:
+        case SMALL_MUT_ARR_PTRS_FROZEN0:
+            // follow everything
+        {
+            StgPtr next, q = p;
+           
+            next = p + small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs*)p);
+            for (p = (P_)((StgSmallMutArrPtrs *)p)->payload; p < next; p++) {
+                evacuate((StgClosure **)p);
+            }
+
+            // If we're going to put this object on the mutable list, then
+            // set its info ptr to SMALL_MUT_ARR_PTRS_FROZEN0 to indicate that.
+            if (gct->failed_to_evac) {
+                ((StgClosure *)q)->header.info = &stg_SMALL_MUT_ARR_PTRS_FROZEN0_info;
+            } else {
+                ((StgClosure *)q)->header.info = &stg_SMALL_MUT_ARR_PTRS_FROZEN_info;
+            }
+            break;
+        }
+
        case TSO:
        { 
             scavengeTSO((StgTSO*)p);
@@ -1281,6 +1379,56 @@ scavenge_one(StgPtr p)
        break;
     }
 
+    case SMALL_MUT_ARR_PTRS_CLEAN:
+    case SMALL_MUT_ARR_PTRS_DIRTY:
+    {
+        StgPtr next, q;
+        rtsBool saved_eager;
+
+        // We don't eagerly promote objects pointed to by a mutable
+        // array, but if we find the array only points to objects in
+        // the same or an older generation, we mark it "clean" and
+        // avoid traversing it during minor GCs.
+        saved_eager = gct->eager_promotion;
+        gct->eager_promotion = rtsFalse;
+        q = p;
+        next = p + small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs*)p);
+        for (p = (P_)((StgSmallMutArrPtrs *)p)->payload; p < next; p++) {
+            evacuate((StgClosure **)p);
+        }
+        gct->eager_promotion = saved_eager;
+
+        if (gct->failed_to_evac) {
+            ((StgClosure *)q)->header.info = &stg_SMALL_MUT_ARR_PTRS_DIRTY_info;
+        } else {
+            ((StgClosure *)q)->header.info = &stg_SMALL_MUT_ARR_PTRS_CLEAN_info;
+        }
+
+        gct->failed_to_evac = rtsTrue;
+        break;
+    }
+
+    case SMALL_MUT_ARR_PTRS_FROZEN:
+    case SMALL_MUT_ARR_PTRS_FROZEN0:
+    {
+        // follow everything
+        StgPtr next, q=p;
+     
+        next = p + small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs*)p);
+        for (p = (P_)((StgSmallMutArrPtrs *)p)->payload; p < next; p++) {
+            evacuate((StgClosure **)p);
+        }
+
+        // If we're going to put this object on the mutable list, then
+        // set its info ptr to SMALL_MUT_ARR_PTRS_FROZEN0 to indicate that.
+        if (gct->failed_to_evac) {
+            ((StgClosure *)q)->header.info = &stg_SMALL_MUT_ARR_PTRS_FROZEN0_info;
+        } else {
+            ((StgClosure *)q)->header.info = &stg_SMALL_MUT_ARR_PTRS_FROZEN_info;
+        }
+        break;
+    }
+
     case TSO:
     {
        scavengeTSO((StgTSO*)p);
diff --git a/testsuite/tests/codeGen/should_run/CopySmallArray.hs b/testsuite/tests/codeGen/should_run/CopySmallArray.hs
new file mode 100644 (file)
index 0000000..6902fe2
--- /dev/null
@@ -0,0 +1,300 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+-- !!! simple tests of copying/cloning primitive arrays
+--
+
+module Main ( main ) where
+
+import GHC.Exts hiding (IsList(..))
+import GHC.Prim
+import GHC.ST
+
+main :: IO ()
+main = putStr
+       (test_copyArray
+        ++ "\n" ++ test_copyMutableArray
+        ++ "\n" ++ test_copyMutableArrayOverlap
+        ++ "\n" ++ test_cloneArray
+        ++ "\n" ++ test_cloneArrayStatic
+        ++ "\n" ++ test_cloneMutableArray
+        ++ "\n" ++ test_cloneMutableArrayEmpty
+        ++ "\n" ++ test_cloneMutableArrayStatic
+        ++ "\n" ++ test_freezeArray
+        ++ "\n" ++ test_freezeArrayStatic
+        ++ "\n" ++ test_thawArray
+        ++ "\n" ++ test_thawArrayStatic
+        ++ "\n"
+       )
+
+------------------------------------------------------------------------
+-- Constants
+
+-- All allocated arrays are of this size
+len :: Int
+len = 130
+
+-- We copy these many elements
+copied :: Int
+copied = len - 2
+
+copiedStatic :: Int
+copiedStatic = 16
+{-# INLINE copiedStatic #-}  -- to make sure optimization triggers
+
+------------------------------------------------------------------------
+-- copySmallArray#
+
+-- Copy a slice of the source array into a destination array and check
+-- that the copy succeeded.
+test_copyArray :: String
+test_copyArray =
+    let dst = runST $ do
+            src <- newArray len 0
+            fill src 0 len
+            src <- unsafeFreezeArray src
+            dst <- newArray len (-1)
+            -- Leave the first and last element untouched
+            copyArray src 1 dst 1 copied
+            unsafeFreezeArray dst
+    in shows (toList dst len) "\n"
+
+------------------------------------------------------------------------
+-- copySmallMutableArray#
+
+-- Copy a slice of the source array into a destination array and check
+-- that the copy succeeded.
+test_copyMutableArray :: String
+test_copyMutableArray =
+    let dst = runST $ do
+            src <- newArray len 0
+            fill src 0 len
+            dst <- newArray len (-1)
+            -- Leave the first and last element untouched
+            copyMutableArray src 1 dst 1 copied
+            unsafeFreezeArray dst
+    in shows (toList dst len) "\n"
+
+-- Perform a copy where the source and destination part overlap.
+test_copyMutableArrayOverlap :: String
+test_copyMutableArrayOverlap =
+    let arr = runST $ do
+            marr <- fromList inp
+            -- Overlap of two elements
+            copyMutableArray marr 5 marr 7 8
+            unsafeFreezeArray marr
+    in shows (toList arr (length inp)) "\n"
+  where
+     -- This case was known to fail at some point.
+     inp = [0,169,196,9,16,25,36,16,25,81,100,121,144,169,196]
+
+------------------------------------------------------------------------
+-- cloneSmallArray#
+
+-- Clone a slice of the source array into a destination array and
+-- check that the clone succeeded.
+test_cloneArray :: String
+test_cloneArray =
+    let dst = runST $ do
+            src <- newArray len 0
+            fill src 0 len
+            src <- unsafeFreezeArray src
+            -- Don't include the first and last element.
+            return $! cloneArray src 1 copied
+    in shows (toList dst copied) "\n"
+
+--  Check that the static-size optimization works.
+test_cloneArrayStatic :: String
+test_cloneArrayStatic =
+    let dst = runST $ do
+            src <- newArray len 0
+            fill src 0 len
+            src <- unsafeFreezeArray src
+            -- Don't include the first and last element.
+            return $! cloneArray src 1 copiedStatic
+    in shows (toList dst copiedStatic) "\n"
+
+------------------------------------------------------------------------
+-- cloneMutableSmallArray#
+
+-- Clone a slice of the source array into a destination array and
+-- check that the clone succeeded.
+test_cloneMutableArray :: String
+test_cloneMutableArray =
+    let dst = runST $ do
+            src <- newArray len 0
+            fill src 0 len
+            -- Don't include the first and last element.
+            dst <- cloneMutableArray src 1 copied
+            unsafeFreezeArray dst
+    in shows (toList dst copied) "\n"
+
+-- Check that zero-length clones work.
+test_cloneMutableArrayEmpty :: String
+test_cloneMutableArrayEmpty =
+    let dst = runST $ do
+            src <- newArray len 0
+            dst <- cloneMutableArray src 0 0
+            unsafeFreezeArray dst
+    in shows (toList dst 0) "\n"
+
+--  Check that the static-size optimization works.
+test_cloneMutableArrayStatic :: String
+test_cloneMutableArrayStatic =
+    let dst = runST $ do
+            src <- newArray len 0
+            fill src 0 len
+            -- Don't include the first and last element.
+            dst <- cloneMutableArray src 1 copiedStatic
+            unsafeFreezeArray dst
+    in shows (toList dst copiedStatic) "\n"
+
+------------------------------------------------------------------------
+-- freezeSmallArray#
+
+-- Clone a slice of the source array into a destination array and
+-- check that the clone succeeded.
+test_freezeArray :: String
+test_freezeArray =
+    let dst = runST $ do
+            src <- newArray len 0
+            fill src 0 len
+            -- Don't include the first and last element.
+            freezeArray src 1 copied
+    in shows (toList dst copied) "\n"
+
+--  Check that the static-size optimization works.
+test_freezeArrayStatic :: String
+test_freezeArrayStatic =
+    let dst = runST $ do
+            src <- newArray len 0
+            fill src 0 len
+            -- Don't include the first and last element.
+            freezeArray src 1 copiedStatic
+    in shows (toList dst copiedStatic) "\n"
+
+------------------------------------------------------------------------
+-- thawSmallArray#
+
+-- Clone a slice of the source array into a destination array and
+-- check that the clone succeeded.
+test_thawArray :: String
+test_thawArray =
+    let dst = runST $ do
+            src <- newArray len 0
+            fill src 0 len
+            src <- unsafeFreezeArray src
+            -- Don't include the first and last element.
+            dst <- thawArray src 1 copied
+            unsafeFreezeArray dst
+    in shows (toList dst copied) "\n"
+
+--  Check that the static-size optimization works.
+test_thawArrayStatic :: String
+test_thawArrayStatic =
+    let dst = runST $ do
+            src <- newArray len 0
+            fill src 0 len
+            src <- unsafeFreezeArray src
+            -- Don't include the first and last element.
+            dst <- thawArray src 1 copiedStatic
+            unsafeFreezeArray dst
+    in shows (toList dst copiedStatic) "\n"
+
+------------------------------------------------------------------------
+-- Test helpers
+
+-- Initialize the elements of this array, starting at the given
+-- offset.  The last parameter specifies the number of elements to
+-- initialize.  Element at index @i@ takes the value @i*i@ (i.e. the
+-- first actually modified element will take value @off*off@).
+fill :: MArray s Int -> Int -> Int -> ST s ()
+fill marr off count = go 0
+  where
+    go i
+        | i >= count = return ()
+        | otherwise = writeArray marr (off + i) (i*i) >> go (i + 1)
+
+fromList :: [Int] -> ST s (MArray s Int)
+fromList xs0 = do
+    marr <- newArray (length xs0) bottomElem
+    let go [] i = i `seq` return marr
+        go (x:xs) i = writeArray marr i x >> go xs (i + 1)
+    go xs0 0
+  where
+    bottomElem = error "undefined element"
+
+------------------------------------------------------------------------
+-- Convenience wrappers for SmallArray# and MutableSmallArray#
+
+data Array a = Array { unArray :: SmallArray# a }
+data MArray s a = MArray { unMArray :: SmallMutableArray# s a }
+
+newArray :: Int -> a -> ST s (MArray s a)
+newArray (I# n#) a = ST $ \s# -> case newSmallArray# n# a s# of
+    (# s2#, marr# #) -> (# s2#, MArray marr# #)
+
+indexArray :: Array a -> Int -> a
+indexArray arr i@(I# i#)
+  | i < 0 || i >= len =
+      error $ "bounds error, offset " ++ show i ++ ", length " ++ show len
+  | otherwise = case indexSmallArray# (unArray arr) i# of
+      (# a #) -> a
+  where len = lengthArray arr
+
+writeArray :: MArray s a -> Int -> a -> ST s ()
+writeArray marr i@(I# i#) a
+  | i < 0 || i >= len =
+      error $ "bounds error, offset " ++ show i ++ ", length " ++ show len
+  | otherwise = ST $ \ s# ->
+    case writeSmallArray# (unMArray marr) i# a s# of
+        s2# -> (# s2#, () #)
+  where len = lengthMArray marr
+
+lengthArray :: Array a -> Int
+lengthArray arr = I# (sizeofSmallArray# (unArray arr))
+
+lengthMArray :: MArray s a -> Int
+lengthMArray marr = I# (sizeofSmallMutableArray# (unMArray marr))
+
+unsafeFreezeArray :: MArray s a -> ST s (Array a)
+unsafeFreezeArray marr = ST $ \ s# ->
+    case unsafeFreezeSmallArray# (unMArray marr) s# of
+        (# s2#, arr# #) -> (# s2#, Array arr# #)
+
+copyArray :: Array a -> Int -> MArray s a -> Int -> Int -> ST s ()
+copyArray src (I# six#) dst (I# dix#) (I# n#) = ST $ \ s# ->
+    case copySmallArray# (unArray src) six# (unMArray dst) dix# n# s# of
+        s2# -> (# s2#, () #)
+
+copyMutableArray :: MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
+copyMutableArray src (I# six#) dst (I# dix#) (I# n#) = ST $ \ s# ->
+    case copySmallMutableArray# (unMArray src) six# (unMArray dst) dix# n# s# of
+        s2# -> (# s2#, () #)
+
+cloneArray :: Array a -> Int -> Int -> Array a
+cloneArray src (I# six#) (I# n#) = Array (cloneSmallArray# (unArray src) six# n#)
+{-# INLINE cloneArray #-}  -- to make sure optimization triggers
+
+cloneMutableArray :: MArray s a -> Int -> Int -> ST s (MArray s a)
+cloneMutableArray src (I# six#) (I# n#) = ST $ \ s# ->
+    case cloneSmallMutableArray# (unMArray src) six# n# s# of
+        (# s2#, marr# #) -> (# s2#, MArray marr# #)
+{-# INLINE cloneMutableArray #-}  -- to make sure optimization triggers
+
+freezeArray :: MArray s a -> Int -> Int -> ST s (Array a)
+freezeArray src (I# six#) (I# n#) = ST $ \ s# ->
+    case freezeSmallArray# (unMArray src) six# n# s# of
+        (# s2#, arr# #) -> (# s2#, Array arr# #)
+{-# INLINE freezeArray #-}  -- to make sure optimization triggers
+
+thawArray :: Array a -> Int -> Int -> ST s (MArray s a)
+thawArray src (I# six#) (I# n#) = ST $ \ s# ->
+    case thawSmallArray# (unArray src) six# n# s# of
+        (# s2#, marr# #) -> (# s2#, MArray marr# #)
+{-# INLINE thawArray #-}  -- to make sure optimization triggers
+
+toList :: Array a -> Int -> [a]
+toList arr n = go 0
+  where
+    go i | i >= n = []
+         | otherwise = indexArray arr i : go (i+1)
diff --git a/testsuite/tests/codeGen/should_run/CopySmallArray.stdout b/testsuite/tests/codeGen/should_run/CopySmallArray.stdout
new file mode 100644 (file)
index 0000000..86ad8a2
--- /dev/null
@@ -0,0 +1,24 @@
+[-1,1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384,-1]
+
+[-1,1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384,-1]
+
+[0,169,196,9,16,25,36,25,36,16,25,81,100,121,144]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384]
+
+[]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256]
+
diff --git a/testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.hs b/testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.hs
new file mode 100644 (file)
index 0000000..7243fad
--- /dev/null
@@ -0,0 +1,387 @@
+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, MagicHash,
+             UnboxedTuples #-}
+
+-- !!! stress tests of copying/cloning primitive arrays
+
+-- Note: You can run this test manually with an argument (i.e.
+-- ./CopySmallArrayStressTest 10000) if you want to run the stress
+-- test for longer.
+
+{-
+Test strategy
+=============
+
+We create an array of arrays of integers. Repeatedly we then either
+
+* allocate a new array in place of an old, or
+
+* copy a random segment of an array into another array (which might be
+  the source array).
+
+By running this process long enough we hope to trigger any bugs
+related to garbage collection or edge cases.
+
+We only test copySmallMutableArray# and cloneSmallArray# as they are
+representative of all the primops.
+-}
+
+module Main ( main ) where
+
+import Debug.Trace (trace)
+
+import Control.Exception (assert)
+import Control.Monad
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Class
+import GHC.Exts hiding (IsList(..))
+import GHC.ST hiding (liftST)
+import Prelude hiding (length, read)
+import qualified Prelude as P
+import qualified Prelude as P
+import System.Environment
+import System.Random
+
+main :: IO ()
+main = do
+    args <- getArgs
+    -- Number of copies to perform
+    let numMods = case args of
+            [] -> 100
+            [n] -> P.read n :: Int
+    putStr (test_copyMutableArray numMods ++ "\n" ++
+            test_cloneMutableArray numMods ++ "\n"
+           )
+
+-- Number of arrays
+numArrays :: Int
+numArrays = 100
+
+-- Maxmimum length of a sub-array
+maxLen :: Int
+maxLen = 1024
+
+-- Create an array of arrays, with each sub-array having random length
+-- and content.
+setup :: Rng s (MArray s (MArray s Int))
+setup = do
+    len <- rnd (1, numArrays)
+    marr <- liftST $ new_ len
+    let go i
+            | i >= len = return ()
+            | otherwise = do
+                n <- rnd (1, maxLen)
+                subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]]
+                liftST $ write marr i subarr
+                go (i+1)
+    go 0
+    return marr
+
+-- Replace one of the sub-arrays with a newly allocated array.
+allocate :: MArray s (MArray s Int) -> Rng s ()
+allocate marr = do
+    ix <- rnd (0, length marr - 1)
+    n <- rnd (1, maxLen)
+    subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]]
+    liftST $ write marr ix subarr
+
+type CopyFunction s a =
+    MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
+
+-- Copy a random segment of an array onto another array, using the
+-- supplied copy function.
+copy :: MArray s (MArray s a) -> CopyFunction s a
+     -> Rng s (Int, Int, Int, Int, Int)
+copy marr f = do
+    six <- rnd (0, length marr - 1)
+    dix <- rnd (0, length marr - 1)
+    src <- liftST $ read marr six
+    dst <- liftST $ read marr dix
+    let srcLen = length src
+    srcOff <- rnd (0, srcLen - 1)
+    let dstLen = length dst
+    dstOff <- rnd (0, dstLen - 1)
+    n <- rnd (0, min (srcLen - srcOff) (dstLen - dstOff))
+    liftST $ f src srcOff dst dstOff n
+    return (six, dix, srcOff, dstOff, n)
+
+type CloneFunction s a = MArray s a -> Int -> Int -> ST s (MArray s a)
+
+-- Clone a random segment of an array, replacing another array, using
+-- the supplied clone function.
+clone :: MArray s (MArray s a) -> CloneFunction s a
+      -> Rng s (Int, Int, Int, Int)
+clone marr f = do
+    six <- rnd (0, length marr - 1)
+    dix <- rnd (0, length marr - 1)
+    src <- liftST $ read marr six
+    let srcLen = length src
+    -- N.B. The array length might be zero if we previously cloned
+    -- zero elements from some array.
+    srcOff <- rnd (0, max 0 (srcLen - 1))
+    n <- rnd (0, srcLen - srcOff)
+    dst <- liftST $ f src srcOff n
+    liftST $ write marr dix dst
+    return (six, dix, srcOff, n)
+
+------------------------------------------------------------------------
+-- copySmallMutableArray#
+
+-- Copy a slice of the source array into a destination array and check
+-- that the copy succeeded.
+test_copyMutableArray :: Int -> String
+test_copyMutableArray numMods = runST $ run $ do
+    marr <- local setup
+    marrRef <- setup
+    let go i
+            | i >= numMods = return "test_copyMutableArray: OK"
+            | otherwise = do
+                -- Either allocate or copy
+                alloc <- rnd (True, False)
+                if alloc then doAlloc else doCopy
+                go (i+1)
+
+        doAlloc = do
+            local $ allocate marr
+            allocate marrRef
+
+        doCopy = do
+            inp <- liftST $ asList marr
+            _ <- local $ copy marr copyMArray
+            (six, dix, srcOff, dstOff, n) <- copy marrRef copyMArraySlow
+            el <- liftST $ asList marr
+            elRef <- liftST $ asList marrRef
+            when (el /= elRef) $
+                fail inp el elRef six dix srcOff dstOff n
+    go 0
+  where
+    fail inp el elRef six dix srcOff dstOff n =
+        error $ "test_copyMutableArray: FAIL\n"
+        ++ "   Input: " ++ unlinesShow inp
+        ++ "    Copy: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: "
+        ++ show srcOff ++ " dstOff: " ++ show dstOff ++ " n: " ++ show n ++ "\n"
+        ++ "Expected: " ++ unlinesShow elRef
+        ++ "  Actual: " ++ unlinesShow el
+
+asList :: MArray s (MArray s a) -> ST s [[a]]
+asList marr = toListM =<< mapArrayM toListM marr
+
+unlinesShow :: Show a => [a] -> String
+unlinesShow =  concatMap (\ x -> show x ++ "\n")
+
+------------------------------------------------------------------------
+-- cloneSmallMutableArray#
+
+-- Copy a slice of the source array into a destination array and check
+-- that the copy succeeded.
+test_cloneMutableArray :: Int -> String
+test_cloneMutableArray numMods = runST $ run $ do
+    marr <- local setup
+    marrRef <- setup
+    let go i
+            | i >= numMods = return "test_cloneMutableArray: OK"
+            | otherwise = do
+                -- Either allocate or clone
+                alloc <- rnd (True, False)
+                if alloc then doAlloc else doClone
+                go (i+1)
+
+        doAlloc = do
+            local $ allocate marr
+            allocate marrRef
+
+        doClone = do
+            inp <- liftST $ asList marr
+            _ <- local $ clone marr cloneMArray
+            (six, dix, srcOff, n) <- clone marrRef cloneMArraySlow
+            el <- liftST $ asList marr
+            elRef <- liftST $ asList marrRef
+            when (el /= elRef) $
+                fail inp el elRef six dix srcOff n
+    go 0
+  where
+    fail inp el elRef six dix srcOff n =
+        error $ "test_cloneMutableArray: FAIL\n"
+        ++ "   Input: " ++ unlinesShow inp
+        ++ "   Clone: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: "
+        ++ show srcOff ++ " n: " ++ show n ++ "\n"
+        ++ "Expected: " ++ unlinesShow elRef
+        ++ "  Actual: " ++ unlinesShow el
+
+------------------------------------------------------------------------
+-- Convenience wrappers for SmallArray# and SmallMutableArray#
+
+data Array a = Array
+    { unArray :: SmallArray# a
+    , lengthA :: {-# UNPACK #-} !Int}
+
+data MArray s a = MArray
+    { unMArray :: SmallMutableArray# s a
+    , lengthM :: {-# UNPACK #-} !Int}
+
+class IArray a where
+    length :: a -> Int
+instance IArray (Array a) where
+    length = lengthA
+instance IArray (MArray s a) where
+    length = lengthM
+
+instance Eq a => Eq (Array a) where
+    arr1 == arr2 = toList arr1 == toList arr2
+
+new :: Int -> a -> ST s (MArray s a)
+new n@(I# n#) a =
+    assert (n >= 0) $
+    ST $ \s# -> case newSmallArray# n# a s# of
+        (# s2#, marr# #) -> (# s2#, MArray marr# n #)
+
+new_ :: Int -> ST s (MArray s a)
+new_ n = new n (error "Undefined element")
+
+write :: MArray s a -> Int -> a -> ST s ()
+write marr i@(I# i#) a =
+    assert (i >= 0) $
+    assert (i < length marr) $
+    ST $ \ s# ->
+    case writeSmallArray# (unMArray marr) i# a s# of
+        s2# -> (# s2#, () #)
+
+read :: MArray s a -> Int -> ST s a
+read marr i@(I# i#) =
+    assert (i >= 0) $
+    assert (i < length marr) $
+    ST $ \ s# ->
+    readSmallArray# (unMArray marr) i# s#
+
+index :: Array a -> Int -> a
+index arr i@(I# i#) =
+    assert (i >= 0) $
+    assert (i < length arr) $
+    case indexSmallArray# (unArray arr) i# of
+        (# a #) -> a
+
+unsafeFreeze :: MArray s a -> ST s (Array a)
+unsafeFreeze marr = ST $ \ s# ->
+    case unsafeFreezeSmallArray# (unMArray marr) s# of
+        (# s2#, arr# #) -> (# s2#, Array arr# (length marr) #)
+
+toList :: Array a -> [a]
+toList arr = go 0
+  where
+    go i | i >= length arr = []
+         | otherwise = index arr i : go (i+1)
+
+fromList :: [e] -> ST s (MArray s e)
+fromList es = do
+    marr <- new_ n
+    let go !_ [] = return ()
+        go i (x:xs) = write marr i x >> go (i+1) xs
+    go 0 es
+    return marr
+  where
+    n = P.length es
+
+mapArrayM :: (a -> ST s b) -> MArray s a -> ST s (MArray s b)
+mapArrayM f src = do
+    dst <- new_ n
+    let go i
+            | i >= n = return dst
+            | otherwise = do
+                el <- read src i
+                el' <- f el
+                write dst i el'
+                go (i+1)
+    go 0
+  where
+    n = length src
+
+toListM :: MArray s e -> ST s [e]
+toListM marr =
+    sequence [read marr i | i <- [0..(length marr)-1]]
+
+------------------------------------------------------------------------
+-- Wrappers around copy/clone primops
+
+copyMArray :: MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
+copyMArray src six@(I# six#) dst dix@(I# dix#) n@(I# n#) =
+    assert (six >= 0) $
+    assert (six + n <= length src) $
+    assert (dix >= 0) $
+    assert (dix + n <= length dst) $
+    ST $ \ s# ->
+    case copySmallMutableArray# (unMArray src) six# (unMArray dst) dix# n# s# of
+        s2# -> (# s2#, () #)
+
+cloneMArray :: MArray s a -> Int -> Int -> ST s (MArray s a)
+cloneMArray marr off@(I# off#) n@(I# n#) =
+    assert (off >= 0) $
+    assert (off + n <= length marr) $
+    ST $ \ s# ->
+    case cloneSmallMutableArray# (unMArray marr) off# n# s# of
+        (# s2#, marr2 #) -> (# s2#, MArray marr2 n #)
+
+------------------------------------------------------------------------
+-- Manual versions of copy/clone primops.  Used to validate the
+-- primops
+
+copyMArraySlow :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()
+copyMArraySlow !src !six !dst !dix n =
+    assert (six >= 0) $
+    assert (six + n <= length src) $
+    assert (dix >= 0) $
+    assert (dix + n <= length dst) $
+       if six < dix
+       then goB (six+n-1) (dix+n-1) 0  -- Copy backwards
+       else goF six dix 0  -- Copy forwards
+  where
+    goF !i !j c
+        | c >= n = return ()
+        | otherwise = do b <- read src i
+                         write dst j b
+                         goF (i+1) (j+1) (c+1)
+    goB !i !j c
+        | c >= n = return ()
+        | otherwise = do b <- read src i
+                         write dst j b
+                         goB (i-1) (j-1) (c+1)
+
+cloneMArraySlow :: MArray s a -> Int -> Int -> ST s (MArray s a)
+cloneMArraySlow !marr !off n =
+    assert (off >= 0) $
+    assert (off + n <= length marr) $ do
+        marr2 <- new_ n
+        let go !i !j c
+                | c >= n = return marr2
+                | otherwise = do
+                    b <- read marr i
+                    write marr2 j b
+                    go (i+1) (j+1) (c+1)
+        go off 0 0
+
+------------------------------------------------------------------------
+-- Utilities for simplifying RNG passing
+
+newtype Rng s a = Rng { unRng :: StateT StdGen (ST s) a }
+                deriving Monad
+
+-- Same as 'randomR', but using the RNG state kept in the 'Rng' monad.
+rnd :: Random a => (a, a) -> Rng s a
+rnd r = Rng $ do
+    g <- get
+    let (x, g') = randomR r g
+    put g'
+    return x
+
+-- Run a sub-computation without affecting the RNG state.
+local :: Rng s a -> Rng s a
+local m = Rng $ do
+    g <- get
+    x <- unRng m
+    put g
+    return x
+
+liftST :: ST s a -> Rng s a
+liftST m = Rng $ lift m
+
+run :: Rng s a -> ST s a
+run = flip evalStateT (mkStdGen 13) . unRng
+
diff --git a/testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.stdout b/testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.stdout
new file mode 100644 (file)
index 0000000..122a125
--- /dev/null
@@ -0,0 +1,2 @@
+test_copyMutableArray: OK
+test_cloneMutableArray: OK
diff --git a/testsuite/tests/codeGen/should_run/SizeOfSmallArray.hs b/testsuite/tests/codeGen/should_run/SizeOfSmallArray.hs
new file mode 100644 (file)
index 0000000..2e62709
--- /dev/null
@@ -0,0 +1,32 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+module Main ( main ) where
+
+import GHC.Exts
+import GHC.Prim
+import GHC.ST
+
+main = putStr
+       (test_sizeofArray
+        ++ "\n" ++ test_sizeofMutableArray
+        ++ "\n"
+       )
+
+test_sizeofArray :: String
+test_sizeofArray = flip shows "\n" $ runST $ ST $ \ s# -> go 0 [] s#
+  where
+    go i@(I# i#) acc s#
+        | i < 1000 = case newSmallArray# i# 0 s# of
+            (# s2#, marr# #) -> case unsafeFreezeSmallArray# marr# s2# of
+                (# s3#, arr# #) -> case sizeofSmallArray# arr# of
+                    j# -> go (i+1) ((I# j#):acc) s3#
+        | otherwise = (# s#, reverse acc #)
+
+test_sizeofMutableArray :: String
+test_sizeofMutableArray = flip shows "\n" $ runST $ ST $ \ s# -> go 0 [] s#
+  where
+    go i@(I# i#) acc s#
+        | i < 1000 = case newSmallArray# i# 0 s# of
+            (# s2#, marr# #) -> case sizeofSmallMutableArray# marr# of
+                    j# -> go (i+1) ((I# j#):acc) s2#
+        | otherwise = (# s#, reverse acc #)
diff --git a/testsuite/tests/codeGen/should_run/SizeOfSmallArray.stdout b/testsuite/tests/codeGen/should_run/SizeOfSmallArray.stdout
new file mode 100644 (file)
index 0000000..bf895d5
--- /dev/null
@@ -0,0 +1,4 @@
+[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,256,257,258,259,260,261,262,263,264,265,266,267,268,269,270,271,272,273,274,275,276,277,278,279,280,281,282,283,284,285,286,287,288,289,290,291,292,293,294,295,296,297,298,299,300,301,302,303,304,305,306,307,308,309,310,311,312,313,314,315,316,317,318,319,320,321,322,323,324,325,326,327,328,329,330,331,332,333,334,335,336,337,338,339,340,341,342,343,344,345,346,347,348,349,350,351,352,353,354,355,356,357,358,359,360,361,362,363,364,365,366,367,368,369,370,371,372,373,374,375,376,377,378,379,380,381,382,383,384,385,386,387,388,389,390,391,392,393,394,395,396,397,398,399,400,401,402,403,404,405,406,407,408,409,410,411,412,413,414,415,416,417,418,419,420,421,422,423,424,425,426,427,428,429,430,431,432,433,434,435,436,437,438,439,440,441,442,443,444,445,446,447,448,449,450,451,452,453,454,455,456,457,458,459,460,461,462,463,464,465,466,467,468,469,470,471,472,473,474,475,476,477,478,479,480,481,482,483,484,485,486,487,488,489,490,491,492,493,494,495,496,497,498,499,500,501,502,503,504,505,506,507,508,509,510,511,512,513,514,515,516,517,518,519,520,521,522,523,524,525,526,527,528,529,530,531,532,533,534,535,536,537,538,539,540,541,542,543,544,545,546,547,548,549,550,551,552,553,554,555,556,557,558,559,560,561,562,563,564,565,566,567,568,569,570,571,572,573,574,575,576,577,578,579,580,581,582,583,584,585,586,587,588,589,590,591,592,593,594,595,596,597,598,599,600,601,602,603,604,605,606,607,608,609,610,611,612,613,614,615,616,617,618,619,620,621,622,623,624,625,626,627,628,629,630,631,632,633,634,635,636,637,638,639,640,641,642,643,644,645,646,647,648,649,650,651,652,653,654,655,656,657,658,659,660,661,662,663,664,665,666,667,668,669,670,671,672,673,674,675,676,677,678,679,680,681,682,683,684,685,686,687,688,689,690,691,692,693,694,695,696,697,698,699,700,701,702,703,704,705,706,707,708,709,710,711,712,713,714,715,716,717,718,719,720,721,722,723,724,725,726,727,728,729,730,731,732,733,734,735,736,737,738,739,740,741,742,743,744,745,746,747,748,749,750,751,752,753,754,755,756,757,758,759,760,761,762,763,764,765,766,767,768,769,770,771,772,773,774,775,776,777,778,779,780,781,782,783,784,785,786,787,788,789,790,791,792,793,794,795,796,797,798,799,800,801,802,803,804,805,806,807,808,809,810,811,812,813,814,815,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830,831,832,833,834,835,836,837,838,839,840,841,842,843,844,845,846,847,848,849,850,851,852,853,854,855,856,857,858,859,860,861,862,863,864,865,866,867,868,869,870,871,872,873,874,875,876,877,878,879,880,881,882,883,884,885,886,887,888,889,890,891,892,893,894,895,896,897,898,899,900,901,902,903,904,905,906,907,908,909,910,911,912,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927,928,929,930,931,932,933,934,935,936,937,938,939,940,941,942,943,944,945,946,947,948,949,950,951,952,953,954,955,956,957,958,959,960,961,962,963,964,965,966,967,968,969,970,971,972,973,974,975,976,977,978,979,980,981,982,983,984,985,986,987,988,989,990,991,992,993,994,995,996,997,998,999]
+
+[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,256,257,258,259,260,261,262,263,264,265,266,267,268,269,270,271,272,273,274,275,276,277,278,279,280,281,282,283,284,285,286,287,288,289,290,291,292,293,294,295,296,297,298,299,300,301,302,303,304,305,306,307,308,309,310,311,312,313,314,315,316,317,318,319,320,321,322,323,324,325,326,327,328,329,330,331,332,333,334,335,336,337,338,339,340,341,342,343,344,345,346,347,348,349,350,351,352,353,354,355,356,357,358,359,360,361,362,363,364,365,366,367,368,369,370,371,372,373,374,375,376,377,378,379,380,381,382,383,384,385,386,387,388,389,390,391,392,393,394,395,396,397,398,399,400,401,402,403,404,405,406,407,408,409,410,411,412,413,414,415,416,417,418,419,420,421,422,423,424,425,426,427,428,429,430,431,432,433,434,435,436,437,438,439,440,441,442,443,444,445,446,447,448,449,450,451,452,453,454,455,456,457,458,459,460,461,462,463,464,465,466,467,468,469,470,471,472,473,474,475,476,477,478,479,480,481,482,483,484,485,486,487,488,489,490,491,492,493,494,495,496,497,498,499,500,501,502,503,504,505,506,507,508,509,510,511,512,513,514,515,516,517,518,519,520,521,522,523,524,525,526,527,528,529,530,531,532,533,534,535,536,537,538,539,540,541,542,543,544,545,546,547,548,549,550,551,552,553,554,555,556,557,558,559,560,561,562,563,564,565,566,567,568,569,570,571,572,573,574,575,576,577,578,579,580,581,582,583,584,585,586,587,588,589,590,591,592,593,594,595,596,597,598,599,600,601,602,603,604,605,606,607,608,609,610,611,612,613,614,615,616,617,618,619,620,621,622,623,624,625,626,627,628,629,630,631,632,633,634,635,636,637,638,639,640,641,642,643,644,645,646,647,648,649,650,651,652,653,654,655,656,657,658,659,660,661,662,663,664,665,666,667,668,669,670,671,672,673,674,675,676,677,678,679,680,681,682,683,684,685,686,687,688,689,690,691,692,693,694,695,696,697,698,699,700,701,702,703,704,705,706,707,708,709,710,711,712,713,714,715,716,717,718,719,720,721,722,723,724,725,726,727,728,729,730,731,732,733,734,735,736,737,738,739,740,741,742,743,744,745,746,747,748,749,750,751,752,753,754,755,756,757,758,759,760,761,762,763,764,765,766,767,768,769,770,771,772,773,774,775,776,777,778,779,780,781,782,783,784,785,786,787,788,789,790,791,792,793,794,795,796,797,798,799,800,801,802,803,804,805,806,807,808,809,810,811,812,813,814,815,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830,831,832,833,834,835,836,837,838,839,840,841,842,843,844,845,846,847,848,849,850,851,852,853,854,855,856,857,858,859,860,861,862,863,864,865,866,867,868,869,870,871,872,873,874,875,876,877,878,879,880,881,882,883,884,885,886,887,888,889,890,891,892,893,894,895,896,897,898,899,900,901,902,903,904,905,906,907,908,909,910,911,912,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927,928,929,930,931,932,933,934,935,936,937,938,939,940,941,942,943,944,945,946,947,948,949,950,951,952,953,954,955,956,957,958,959,960,961,962,963,964,965,966,967,968,969,970,971,972,973,974,975,976,977,978,979,980,981,982,983,984,985,986,987,988,989,990,991,992,993,994,995,996,997,998,999]
+
index bfe393d..7604427 100644 (file)
@@ -118,3 +118,6 @@ test('T8256', reqlib('vector'), compile_and_run, [''])
 test('T6084',normal, compile_and_run, ['-O2'])
 test('StaticArraySize', normal, compile_and_run, ['-O2'])
 test('StaticByteArraySize', normal, compile_and_run, ['-O2'])
+test('CopySmallArray', normal, compile_and_run, [''])
+test('CopySmallArrayStressTest', normal, compile_and_run, [''])
+test('SizeOfSmallArray', normal, compile_and_run, [''])
index 293fe65..8c943f0 100644 (file)
@@ -391,6 +391,9 @@ wanteds = concat
           ,closureField Both "StgMutArrPtrs" "ptrs"
           ,closureField Both "StgMutArrPtrs" "size"
 
+          ,closureSize  Both "StgSmallMutArrPtrs"
+          ,closureField Both "StgSmallMutArrPtrs" "ptrs"
+
           ,closureSize    Both "StgArrWords"
           ,closureField   Both "StgArrWords" "bytes"
           ,closurePayload C    "StgArrWords" "payload"
index c9d0d9c..aa64094 100644 (file)
@@ -893,10 +893,13 @@ ppType (TyApp (TyCon "MutVar#") [x,y])          = "mkMutVarPrimTy " ++ ppType x
 ppType (TyApp (TyCon "MutableArray#") [x,y])    = "mkMutableArrayPrimTy " ++ ppType x
                                                    ++ " " ++ ppType y
 ppType (TyApp (TyCon "MutableArrayArray#") [x]) = "mkMutableArrayArrayPrimTy " ++ ppType x
+ppType (TyApp (TyCon "SmallMutableArray#") [x,y]) = "mkSmallMutableArrayPrimTy " ++ ppType x
+                                                    ++ " " ++ ppType y
 ppType (TyApp (TyCon "MutableByteArray#") [x])  = "mkMutableByteArrayPrimTy " 
                                                    ++ ppType x
 ppType (TyApp (TyCon "Array#") [x])             = "mkArrayPrimTy " ++ ppType x
 ppType (TyApp (TyCon "ArrayArray#") [])         = "mkArrayArrayPrimTy"
+ppType (TyApp (TyCon "SmallArray#") [x])        = "mkSmallArrayPrimTy " ++ ppType x
 
 
 ppType (TyApp (TyCon "Weak#")       [x]) = "mkWeakPrimTy " ++ ppType x