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 ( ...@@ -56,6 +56,9 @@ module CLabel (
mkMAP_FROZEN_infoLabel, mkMAP_FROZEN_infoLabel,
mkMAP_FROZEN0_infoLabel, mkMAP_FROZEN0_infoLabel,
mkMAP_DIRTY_infoLabel, mkMAP_DIRTY_infoLabel,
mkSMAP_FROZEN_infoLabel,
mkSMAP_FROZEN0_infoLabel,
mkSMAP_DIRTY_infoLabel,
mkEMPTY_MVAR_infoLabel, mkEMPTY_MVAR_infoLabel,
mkArrWords_infoLabel, mkArrWords_infoLabel,
...@@ -405,7 +408,8 @@ mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel, ...@@ -405,7 +408,8 @@ mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,
mkMAP_FROZEN_infoLabel, mkMAP_FROZEN0_infoLabel, mkMAP_DIRTY_infoLabel, mkMAP_FROZEN_infoLabel, mkMAP_FROZEN0_infoLabel, mkMAP_DIRTY_infoLabel,
mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel, mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel,
mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel, 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 mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
mkSplitMarkerLabel = CmmLabel rtsPackageId (fsLit "__stg_split_marker") CmmCode mkSplitMarkerLabel = CmmLabel rtsPackageId (fsLit "__stg_split_marker") CmmCode
mkUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_upd_frame") CmmInfo mkUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_upd_frame") CmmInfo
...@@ -420,6 +424,9 @@ mkTopTickyCtrLabel = CmmLabel rtsPackageId (fsLit "top_ct") ...@@ -420,6 +424,9 @@ mkTopTickyCtrLabel = CmmLabel rtsPackageId (fsLit "top_ct")
mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmInfo mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmInfo
mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmEntry mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmEntry
mkArrWords_infoLabel = CmmLabel rtsPackageId (fsLit "stg_ARR_WORDS") CmmInfo 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, mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
......
...@@ -1334,7 +1334,7 @@ forkLabelledCode p = do ...@@ -1334,7 +1334,7 @@ forkLabelledCode p = do
initEnv :: DynFlags -> Env initEnv :: DynFlags -> Env
initEnv dflags = listToUFM [ initEnv dflags = listToUFM [
( fsLit "SIZEOF_StgHeader", ( 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", ( fsLit "SIZEOF_StgInfoTable",
VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) )) VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
] ]
......
...@@ -26,7 +26,7 @@ module SMRep ( ...@@ -26,7 +26,7 @@ module SMRep (
-- ** Construction -- ** Construction
mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep, mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep,
arrWordsRep, smallArrPtrsRep, arrWordsRep,
-- ** Predicates -- ** Predicates
isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon, isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon,
...@@ -34,8 +34,10 @@ module SMRep ( ...@@ -34,8 +34,10 @@ module SMRep (
-- ** Size-related things -- ** Size-related things
heapClosureSizeW, heapClosureSizeW,
fixedHdrSize, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize, fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize,
arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW, arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW,
smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW,
fixedHdrSize,
-- ** RTS closure types -- ** RTS closure types
rtsClosureType, rET_SMALL, rET_BIG, rtsClosureType, rET_SMALL, rET_BIG,
...@@ -158,6 +160,9 @@ data SMRep ...@@ -158,6 +160,9 @@ data SMRep
!WordOff -- # ptr words !WordOff -- # ptr words
!WordOff -- # card table words !WordOff -- # card table words
| SmallArrayPtrsRep
!WordOff -- # ptr words
| ArrayWordsRep | ArrayWordsRep
!WordOff -- # bytes expressed in words, rounded up !WordOff -- # bytes expressed in words, rounded up
...@@ -245,6 +250,9 @@ indStaticRep = HeapRep True 1 0 IndStatic ...@@ -245,6 +250,9 @@ indStaticRep = HeapRep True 1 0 IndStatic
arrPtrsRep :: DynFlags -> WordOff -> SMRep arrPtrsRep :: DynFlags -> WordOff -> SMRep
arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems) arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems)
smallArrPtrsRep :: WordOff -> SMRep
smallArrPtrsRep elems = SmallArrayPtrsRep elems
arrWordsRep :: DynFlags -> ByteOff -> SMRep arrWordsRep :: DynFlags -> ByteOff -> SMRep
arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes) arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes)
...@@ -286,9 +294,12 @@ isStaticNoCafCon _ = False ...@@ -286,9 +294,12 @@ isStaticNoCafCon _ = False
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Size-related things -- Size-related things
fixedHdrSize :: DynFlags -> ByteOff
fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags)
-- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h) -- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h)
fixedHdrSize :: DynFlags -> WordOff fixedHdrSizeW :: DynFlags -> WordOff
fixedHdrSize dflags = sTD_HDR_SIZE dflags + profHdrSize dflags fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags
-- | Size of the profiling part of a closure header -- | Size of the profiling part of a closure header
-- (StgProfHeader in includes/rts/storage/Closures.h) -- (StgProfHeader in includes/rts/storage/Closures.h)
...@@ -300,38 +311,58 @@ profHdrSize dflags ...@@ -300,38 +311,58 @@ profHdrSize dflags
-- | The garbage collector requires that every closure is at least as -- | The garbage collector requires that every closure is at least as
-- big as this. -- big as this.
minClosureSize :: DynFlags -> WordOff minClosureSize :: DynFlags -> WordOff
minClosureSize dflags = fixedHdrSize dflags + mIN_PAYLOAD_SIZE dflags minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags
arrWordsHdrSize :: DynFlags -> ByteOff arrWordsHdrSize :: DynFlags -> ByteOff
arrWordsHdrSize dflags arrWordsHdrSize dflags
= fixedHdrSize dflags * wORD_SIZE dflags + sIZEOF_StgArrWords_NoHdr dflags = fixedHdrSize dflags + sIZEOF_StgArrWords_NoHdr dflags
arrWordsHdrSizeW :: DynFlags -> WordOff arrWordsHdrSizeW :: DynFlags -> WordOff
arrWordsHdrSizeW dflags = arrWordsHdrSizeW dflags =
fixedHdrSize dflags + fixedHdrSizeW dflags +
(sIZEOF_StgArrWords_NoHdr dflags `quot` wORD_SIZE dflags) (sIZEOF_StgArrWords_NoHdr dflags `quot` wORD_SIZE dflags)
arrPtrsHdrSize :: DynFlags -> ByteOff arrPtrsHdrSize :: DynFlags -> ByteOff
arrPtrsHdrSize dflags arrPtrsHdrSize dflags
= fixedHdrSize dflags * wORD_SIZE dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags
arrPtrsHdrSizeW :: DynFlags -> WordOff arrPtrsHdrSizeW :: DynFlags -> WordOff
arrPtrsHdrSizeW dflags = arrPtrsHdrSizeW dflags =
fixedHdrSize dflags + fixedHdrSizeW dflags +
(sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE 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 -- Thunks have an extra header word on SMP, so the update doesn't
-- splat the payload. -- splat the payload.
thunkHdrSize :: DynFlags -> WordOff 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 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 :: DynFlags -> SMRep -> ByteOff
nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep) nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep)
nonHdrSizeW :: SMRep -> WordOff nonHdrSizeW :: SMRep -> WordOff
nonHdrSizeW (HeapRep _ p np _) = p + np nonHdrSizeW (HeapRep _ p np _) = p + np
nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct
nonHdrSizeW (SmallArrayPtrsRep elems) = elems
nonHdrSizeW (ArrayWordsRep words) = words nonHdrSizeW (ArrayWordsRep words) = words
nonHdrSizeW (StackRep bs) = length bs nonHdrSizeW (StackRep bs) = length bs
nonHdrSizeW (RTSRep _ rep) = nonHdrSizeW rep nonHdrSizeW (RTSRep _ rep) = nonHdrSizeW rep
...@@ -342,6 +373,8 @@ heapClosureSizeW dflags (HeapRep _ p np ty) ...@@ -342,6 +373,8 @@ heapClosureSizeW dflags (HeapRep _ p np ty)
= closureTypeHdrSize dflags ty + p + np = closureTypeHdrSize dflags ty + p + np
heapClosureSizeW dflags (ArrayPtrsRep elems ct) heapClosureSizeW dflags (ArrayPtrsRep elems ct)
= arrPtrsHdrSizeW dflags + elems + ct = arrPtrsHdrSizeW dflags + elems + ct
heapClosureSizeW dflags (SmallArrayPtrsRep elems)
= smallArrPtrsHdrSizeW dflags + elems
heapClosureSizeW dflags (ArrayWordsRep words) heapClosureSizeW dflags (ArrayWordsRep words)
= arrWordsHdrSizeW dflags + words = arrWordsHdrSizeW dflags + words
heapClosureSizeW _ _ = panic "SMRep.heapClosureSize" heapClosureSizeW _ _ = panic "SMRep.heapClosureSize"
...@@ -352,7 +385,7 @@ closureTypeHdrSize dflags ty = case ty of ...@@ -352,7 +385,7 @@ closureTypeHdrSize dflags ty = case ty of
ThunkSelector{} -> thunkHdrSize dflags ThunkSelector{} -> thunkHdrSize dflags
BlackHole{} -> thunkHdrSize dflags BlackHole{} -> thunkHdrSize dflags
IndStatic{} -> thunkHdrSize dflags IndStatic{} -> thunkHdrSize dflags
_ -> fixedHdrSize dflags _ -> fixedHdrSizeW dflags
-- All thunks use thunkHdrSize, even if they are non-updatable. -- All thunks use thunkHdrSize, even if they are non-updatable.
-- this is because we don't have separate closure types for -- this is because we don't have separate closure types for
-- updatable vs. non-updatable thunks, so the GC can't tell the -- updatable vs. non-updatable thunks, so the GC can't tell the
...@@ -472,6 +505,8 @@ instance Outputable SMRep where ...@@ -472,6 +505,8 @@ instance Outputable SMRep where
ppr (ArrayPtrsRep size _) = ptext (sLit "ArrayPtrsRep") <+> ppr size 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 (ArrayWordsRep words) = ptext (sLit "ArrayWordsRep") <+> ppr words
ppr (StackRep bs) = ptext (sLit "StackRep") <+> ppr bs ppr (StackRep bs) = ptext (sLit "StackRep") <+> ppr bs
......
...@@ -287,7 +287,7 @@ mkRhsClosure dflags bndr _cc _bi ...@@ -287,7 +287,7 @@ mkRhsClosure dflags bndr _cc _bi
maybe_offset = assocMaybe params_w_offsets (NonVoid selectee) maybe_offset = assocMaybe params_w_offsets (NonVoid selectee)
Just the_offset = maybe_offset Just the_offset = maybe_offset
offset_into_int = bytesToWordsRoundUp dflags the_offset offset_into_int = bytesToWordsRoundUp dflags the_offset
- fixedHdrSize dflags - fixedHdrSizeW dflags
---------- Note [Ap thunks] ------------------ ---------- Note [Ap thunks] ------------------
mkRhsClosure dflags bndr _cc _bi mkRhsClosure dflags bndr _cc _bi
...@@ -621,7 +621,7 @@ emitBlackHoleCode node = do ...@@ -621,7 +621,7 @@ emitBlackHoleCode node = do
-- work with profiling. -- work with profiling.
when eager_blackholing $ do when eager_blackholing $ do
emitStore (cmmOffsetW dflags node (fixedHdrSize dflags)) emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags))
(CmmReg (CmmGlobal CurrentTSO)) (CmmReg (CmmGlobal CurrentTSO))
emitPrimCall [] MO_WriteBarrier [] emitPrimCall [] MO_WriteBarrier []
emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo)) emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
...@@ -673,7 +673,7 @@ pushUpdateFrame lbl updatee body ...@@ -673,7 +673,7 @@ pushUpdateFrame lbl updatee body
updfr <- getUpdFrameOff updfr <- getUpdFrameOff
dflags <- getDynFlags dflags <- getDynFlags
let let
hdr = fixedHdrSize dflags * wORD_SIZE dflags hdr = fixedHdrSize dflags
frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags
-- --
emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee
...@@ -682,7 +682,7 @@ pushUpdateFrame lbl updatee body ...@@ -682,7 +682,7 @@ pushUpdateFrame lbl updatee body
emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode () emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()
emitUpdateFrame dflags frame lbl updatee = do emitUpdateFrame dflags frame lbl updatee = do
let let
hdr = fixedHdrSize dflags * wORD_SIZE dflags hdr = fixedHdrSize dflags
off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags
-- --
emitStore frame (mkLblExpr lbl) emitStore frame (mkLblExpr lbl)
......
...@@ -190,7 +190,7 @@ buildDynCon' dflags platform binder _ _cc con [arg] ...@@ -190,7 +190,7 @@ buildDynCon' dflags platform binder _ _cc con [arg]
, val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto... , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...
= do { let intlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE") = do { let intlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE")
val_int = fromIntegral val :: Int 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 closures consist of a header and one word payload
intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW
; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode
...@@ -204,7 +204,7 @@ buildDynCon' dflags platform binder _ _cc con [arg] ...@@ -204,7 +204,7 @@ buildDynCon' dflags platform binder _ _cc con [arg]
, val_int <= mAX_CHARLIKE dflags , val_int <= mAX_CHARLIKE dflags
, val_int >= mIN_CHARLIKE dflags , val_int >= mIN_CHARLIKE dflags
= do { let charlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_CHARLIKE") = 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 closures consist of a header and one word payload
charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW
; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode
......
...@@ -358,7 +358,7 @@ stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) ...@@ -358,7 +358,7 @@ stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags)
closureField :: DynFlags -> ByteOff -> ByteOff 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, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
stgSp = CmmReg sp stgSp = CmmReg sp
...@@ -405,6 +405,9 @@ add_shim dflags arg_ty expr ...@@ -405,6 +405,9 @@ add_shim dflags arg_ty expr
| tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
= cmmOffsetB dflags expr (arrPtrsHdrSize dflags) = cmmOffsetB dflags expr (arrPtrsHdrSize dflags)
| tycon == smallArrayPrimTyCon || tycon == smallMutableArrayPrimTyCon
= cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)
| tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
= cmmOffsetB dflags expr (arrWordsHdrSize dflags) = cmmOffsetB dflags expr (arrWordsHdrSize dflags)
......
...@@ -404,7 +404,7 @@ mkVirtHeapOffsets dflags is_thunk things ...@@ -404,7 +404,7 @@ mkVirtHeapOffsets dflags is_thunk things
) )
where where
hdr_words | is_thunk = thunkHdrSize dflags hdr_words | is_thunk = thunkHdrSize dflags
| otherwise = fixedHdrSize dflags | otherwise = fixedHdrSizeW dflags
hdr_bytes = wordsToBytes dflags hdr_words hdr_bytes = wordsToBytes dflags hdr_words
non_void_things = filterOut (isVoidRep . fst) things non_void_things = filterOut (isVoidRep . fst) things
......
----------------------------------------------------------------------------- ----------------------------------------------------------------------------
-- --
-- Stg to C--: primitive operations -- Stg to C--: primitive operations
-- --
...@@ -139,7 +139,14 @@ shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n _))] ...@@ -139,7 +139,14 @@ shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n _))]
shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n _)), init] shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n _)), init]
| wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = | 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 shouldInlinePrimOp _ CopyArrayOp
[src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
...@@ -173,6 +180,31 @@ shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n _))] ...@@ -173,6 +180,31 @@ shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n _))]
| wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags = | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) 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 shouldInlinePrimOp dflags primop args
| primOpOutOfLine primop = Nothing | primOpOutOfLine primop = Nothing
| otherwise = Just $ \ regs -> emitPrimOp dflags regs primop args | otherwise = Just $ \ regs -> emitPrimOp dflags regs primop args
...@@ -298,10 +330,10 @@ emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg] ...@@ -298,10 +330,10 @@ emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg]
= emitAssign (CmmLocal res) curCCS = emitAssign (CmmLocal res) curCCS
emitPrimOp dflags [res] ReadMutVarOp [mutv] 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] emitPrimOp dflags [] WriteMutVarOp [mutv,var]
= do emitStore (cmmOffsetW dflags mutv (fixedHdrSize dflags)) var = do emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var
emitCCall emitCCall
[{-no results-}] [{-no results-}]
(CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
...@@ -310,7 +342,7 @@ emitPrimOp dflags [] WriteMutVarOp [mutv,var] ...@@ -310,7 +342,7 @@ emitPrimOp dflags [] WriteMutVarOp [mutv,var]
-- #define sizzeofByteArrayzh(r,a) \ -- #define sizzeofByteArrayzh(r,a) \
-- r = ((StgArrWords *)(a))->bytes -- r = ((StgArrWords *)(a))->bytes
emitPrimOp dflags [res] SizeofByteArrayOp [arg] 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) \ -- #define sizzeofMutableByteArrayzh(r,a) \
-- r = ((StgArrWords *)(a))->bytes -- r = ((StgArrWords *)(a))->bytes
...@@ -328,14 +360,14 @@ emitPrimOp dflags [res] ByteArrayContents_Char [arg] ...@@ -328,14 +360,14 @@ emitPrimOp dflags [res] ByteArrayContents_Char [arg]
-- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
emitPrimOp dflags [res] StableNameToIntOp [arg] 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) \ -- #define eqStableNamezh(r,sn1,sn2) \
-- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] emitPrimOp dflags [res] EqStableNameOp [arg1,arg2]
= emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [ = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [
cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags), cmmLoadIndexW dflags arg1 (fixedHdrSizeW dflags) (bWord dflags),
cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags) cmmLoadIndexW dflags arg2 (fixedHdrSizeW dflags) (bWord dflags)
]) ])
...@@ -369,6 +401,10 @@ emitPrimOp _ [res] UnsafeFreezeArrayArrayOp [arg] ...@@ -369,6 +401,10 @@ emitPrimOp _ [res] UnsafeFreezeArrayArrayOp [arg]
= emit $ catAGraphs = emit $ catAGraphs
[ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN0_infoLabel)), [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN0_infoLabel)),
mkAssign (CmmLocal res) arg ] 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) -- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
emitPrimOp _ [res] UnsafeFreezeByteArrayOp [arg] emitPrimOp _ [res] UnsafeFreezeByteArrayOp [arg]
...@@ -391,8 +427,14 @@ emitPrimOp _ [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] = doWritePt ...@@ -391,8 +427,14 @@ emitPrimOp _ [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] = doWritePt
emitPrimOp _ [] WriteArrayArrayOp_ArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v emitPrimOp _ [] WriteArrayArrayOp_ArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v
emitPrimOp _ [] WriteArrayArrayOp_MutableArrayArray [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] 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] SizeofMutableArrayOp [arg]
= emitPrimOp dflags [res] SizeofArrayOp [arg] = emitPrimOp dflags [res] SizeofArrayOp [arg]
emitPrimOp dflags [res] SizeofArrayArrayOp [arg] emitPrimOp dflags [res] SizeofArrayArrayOp [arg]
...@@ -400,6 +442,13 @@ emitPrimOp dflags [res] SizeofArrayArrayOp [arg] ...@@ -400,6 +442,13 @@ emitPrimOp dflags [res] SizeofArrayArrayOp [arg]
emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg] emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg]
= emitPrimOp dflags [res] SizeofArrayOp [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 -- IndexXXXoffAddr
emitPrimOp dflags res IndexOffAddrOp_Char args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args 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) ...@@ -1060,6 +1109,7 @@ translateOp dflags SameMVarOp = Just (mo_wordEq dflags)
translateOp dflags SameMutableArrayOp = Just (mo_wordEq dflags) translateOp dflags SameMutableArrayOp = Just (mo_wordEq dflags)
translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags) translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags)
translateOp dflags SameMutableArrayArrayOp= 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 SameTVarOp = Just (mo_wordEq dflags)
translateOp dflags EqStablePtrOp = Just (mo_wordEq dflags) translateOp dflags EqStablePtrOp = Just (mo_wordEq dflags)
...@@ -1196,7 +1246,7 @@ doWritePtrArrayOp addr idx val ...@@ -1196,7 +1246,7 @@ doWritePtrArrayOp addr idx val
loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr
loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags) 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 mkBasicIndexedRead :: ByteOff -- Initial offset in bytes
-> Maybe MachOp -- Optional result cast -> Maybe MachOp -- Optional result cast
...@@ -1471,7 +1521,7 @@ doNewByteArrayOp res_r n = do ...@@ -1471,7 +1521,7 @@ doNewByteArrayOp res_r n = do
(mkIntExpr dflags (nonHdrSize dflags rep)) (mkIntExpr dflags (nonHdrSize dflags rep))
(zeroExpr dflags) (zeroExpr dflags)
let hdr_size = wordsToBytes dflags (fixedHdrSize dflags) let hdr_size = fixedHdrSize dflags
base <- allocHeapClosure rep info_ptr curCCS base <- allocHeapClosure rep info_ptr curCCS
[ (mkIntExpr dflags n, [ (mkIntExpr dflags n,
...@@ -1571,34 +1621,30 @@ doSetByteArrayOp ba off len c ...@@ -1571,34 +1621,30 @@ doSetByteArrayOp ba off len c
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
-- Allocating arrays -- Allocating arrays
-- | Takes a register to return the newly allocated array in, the size -- | Allocate a new array.
-- of the new array, and an initial value for the elements. Allocates doNewArrayOp :: CmmFormal -- ^ return register
-- a new 'MutableArray#'. -> SMRep -- ^ representation of the array
doNewArrayOp :: CmmFormal -> WordOff -> CmmExpr -> FCode () -> CLabel -- ^ info pointer
doNewArrayOp res_r n init = do -> [(CmmExpr, ByteOff)] -- ^ header payload
-> WordOff -- ^ array size
-> CmmExpr -- ^ initial element