diff options
| author | Johan Tibell <johan.tibell@gmail.com> | 2014-03-23 12:06:56 +0100 |
|---|---|---|
| committer | Johan Tibell <johan.tibell@gmail.com> | 2014-03-29 11:24:07 +0100 |
| commit | 90329b6cc183b3cd05956ae6bdeb6ac6951549c2 (patch) | |
| tree | ba7d31656fe75fad2555c8a66b7ebd13dd9ebeb1 | |
| parent | 4c8edfd2c722504baaa6896d194fd3a8c3f9b652 (diff) | |
| download | haskell-90329b6cc183b3cd05956ae6bdeb6ac6951549c2.tar.gz | |
Add SmallArray# and SmallMutableArray# types
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, 1587 insertions, 61 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 7a9e32d270..407002f1c7 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -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, diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 5f2c4d86be..49143170c3 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -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)) )) ] diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs index a5a8c903c6..704c22db6a 100644 --- a/compiler/cmm/SMRep.lhs +++ b/compiler/cmm/SMRep.lhs @@ -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 diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index c29f47c7f4..06e17164dd 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -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) diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index b6bcf6912b..a02a5da616 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -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 diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index a688074b9e..bf88f1ccb3 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -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) diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 59afc897dc..a56248dcb9 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -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 diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index da30700bef..2c4ad4e3ce 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -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 diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 58612e2e48..6dfee5629a 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -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 diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 149633ffd0..5e9bddca88 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -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>" diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 0512607109..86f8d29229 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -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 ----------------------------------------------------- diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index bbe5aba119..789d121519 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -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} %************************************************************************ diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 553163b0af..10dd19d4bb 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -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 diff --git a/includes/Cmm.h b/includes/Cmm.h index 13e485f627..24bdda30c5 100644 --- a/includes/Cmm.h +++ b/includes/Cmm.h @@ -806,6 +806,10 @@ __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. */ @@ -890,4 +894,33 @@ __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 */ diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h index 88434d4e79..92b78de6f7 100644 --- a/includes/rts/storage/ClosureMacros.h +++ b/includes/rts/storage/ClosureMacros.h @@ -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: diff --git a/includes/rts/storage/ClosureTypes.h b/includes/rts/storage/ClosureTypes.h index 73a7311719..9bdddc4e0e 100644 --- a/includes/rts/storage/ClosureTypes.h +++ b/includes/rts/storage/ClosureTypes.h @@ -79,6 +79,10 @@ #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 */ diff --git a/includes/rts/storage/Closures.h b/includes/rts/storage/Closures.h index 27041287b9..8aed04e79c 100644 --- a/includes/rts/storage/Closures.h +++ b/includes/rts/storage/Closures.h @@ -158,6 +158,12 @@ typedef struct { typedef struct { StgHeader header; + StgWord ptrs; + StgClosure *payload[FLEXIBLE_ARRAY]; +} StgSmallMutArrPtrs; + +typedef struct { + StgHeader header; StgClosure *var; } StgMutVar; diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index 8be51fb036..944adac1fb 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -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); diff --git a/rts/CheckUnload.c b/rts/CheckUnload.c index 8692dea8bf..f1f454ceaf 100644 --- a/rts/CheckUnload.c +++ b/rts/CheckUnload.c @@ -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; diff --git a/rts/ClosureFlags.c b/rts/ClosureFlags.c index 020f28438a..c43437dc04 100644 --- a/rts/ClosureFlags.c +++ b/rts/ClosureFlags.c @@ -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 diff --git a/rts/LdvProfile.c b/rts/LdvProfile.c index d077f3caf7..4530969123 100644 --- a/rts/LdvProfile.c +++ b/rts/LdvProfile.c @@ -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: diff --git a/rts/Linker.c b/rts/Linker.c index fee6124965..9c73757a63 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -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) \ diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 2f697b43ce..df2119fc77 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -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 -------------------------------------------------------------------------- */ diff --git a/rts/Printer.c b/rts/Printer.c index ca9ca496b5..b7125d9980 100644 --- a/rts/Printer.c +++ b/rts/Printer.c @@ -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: { diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c index 6d78886e39..d21b14a26d 100644 --- a/rts/ProfHeap.c +++ b/rts/ProfHeap.c @@ -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; diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c index 973e03bd1a..bdfc831b94 100644 --- a/rts/RetainerProfile.c +++ b/rts/RetainerProfile.c @@ -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: diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm index 450b2d96c6..42ef39e134 100644 --- a/rts/StgMiscClosures.cmm +++ b/rts/StgMiscClosures.cmm @@ -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 ------------------------------------------------------------------------- */ diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c index e9973d3f8a..8ae72a96e0 100644 --- a/rts/sm/Compact.c +++ b/rts/sm/Compact.c @@ -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); diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c index 577edc38f5..4a550cdde5 100644 --- a/rts/sm/Evac.c +++ b/rts/sm/Evac.c @@ -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; diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c index 5b1e5d0fc8..c35444bbaa 100644 --- a/rts/sm/Scav.c +++ b/rts/sm/Scav.c @@ -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 index 0000000000..6902fe2db2 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/CopySmallArray.hs @@ -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 index 0000000000..86ad8a276c --- /dev/null +++ b/testsuite/tests/codeGen/should_run/CopySmallArray.stdout @@ -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 index 0000000000..7243fadb06 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.hs @@ -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 index 0000000000..122a125a8e --- /dev/null +++ b/testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.stdout @@ -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 index 0000000000..2e62709748 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/SizeOfSmallArray.hs @@ -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 index 0000000000..bf895d50ef --- /dev/null +++ b/testsuite/tests/codeGen/should_run/SizeOfSmallArray.stdout @@ -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] + diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T index bfe393d129..7604427a00 100644 --- a/testsuite/tests/codeGen/should_run/all.T +++ b/testsuite/tests/codeGen/should_run/all.T @@ -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, ['']) diff --git a/utils/deriveConstants/DeriveConstants.hs b/utils/deriveConstants/DeriveConstants.hs index 293fe65492..8c943f0584 100644 --- a/utils/deriveConstants/DeriveConstants.hs +++ b/utils/deriveConstants/DeriveConstants.hs @@ -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" diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index c9d0d9cc5e..aa64094add 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -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 |