Commit 90329b6c authored by tibbe's avatar tibbe

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.
parent 4c8edfd2
......@@ -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,
......
......@@ -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)) ))
]
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
-----------------------------------------------------------------------------
----------------------------------------------------------------------------
--
-- 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
......
......@@ -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
......
......@@ -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>"
......
......@@ -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
-----------------------------------------------------
......
......@@ -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