X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgPrimOp.hs;fp=compiler%2FcodeGen%2FCgPrimOp.hs;h=c5a6644aba1c6822ccd8bed440755a6afaf68804;hp=fd440e913662b7ba15187bf36bc9f44859b8eb87;hb=9c23f06f3eb925dca063d5102b0ced4a9afe795e;hpb=a6cc4146630e34f2d69c5a0358a9133420f9102c diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index fd440e9..c5a6644 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -10,13 +10,17 @@ module CgPrimOp ( cgPrimOp ) where +import BasicTypes import ForeignCall import ClosureInfo import StgSyn import CgForeignCall import CgBindery import CgMonad +import CgHeapery import CgInfoTbls +import CgTicky +import CgProf import CgUtils import OldCmm import CLabel @@ -205,6 +209,19 @@ emitPrimOp [res] UnsafeFreezeArrayOp [arg] _ emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] _ = stmtC (CmmAssign (CmmLocal res) arg) +emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] live = + doCopyArrayOp src src_off dst dst_off n live +emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] live = + doCopyMutableArrayOp src src_off dst dst_off n live +emitPrimOp [res] CloneArrayOp [src,src_off,n] live = + emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live +emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] live = + emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live +emitPrimOp [res] FreezeArrayOp [src,src_off,n] live = + emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live +emitPrimOp [res] ThawArrayOp [src,src_off,n] live = + emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live + -- Reading/writing pointer arrays emitPrimOp [r] ReadArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix @@ -618,3 +635,198 @@ cmmLoadIndexOffExpr off rep base idx setInfo :: CmmExpr -> CmmExpr -> CmmStmt setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr +-- ---------------------------------------------------------------------------- +-- Copying pointer arrays + +-- | Takes a source 'Array#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code +doCopyArrayOp = emitCopyArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst = emitMemcpyCall + +-- | Takes a source 'MutableArray#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code +doCopyMutableArrayOp = emitCopyArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes live = + emitIfThenElse (cmmEqWord src dst) + (emitMemmoveCall dst_p src_p bytes live) + (emitMemcpyCall dst_p src_p bytes live) + +emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code) + -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars + -> Code +emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do + -- Assign the arguments to temporaries so the code generator can + -- calculate liveness for us. + src <- assignTemp_ src0 + src_off <- assignTemp_ src_off0 + dst <- assignTemp_ dst0 + dst_off <- assignTemp_ dst_off0 + n <- assignTemp_ n0 + + -- Set the dirty bit in the header. + stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + + dst_elems_p <- assignTemp $ cmmOffsetB dst arrPtrsHdrSize + dst_p <- assignTemp $ cmmOffsetExprW dst_elems_p dst_off + src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off + bytes <- assignTemp $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE)) + + copy src dst dst_p src_p bytes live + + -- The base address of the destination card table + dst_cards_p <- assignTemp $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst) + + emitSetCards dst_off dst_cards_p n live + +-- | 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 form the source array. +emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code +emitCloneArray info_p res_r src0 src_off0 n0 live = do + -- Assign the arguments to temporaries so the code generator can + -- calculate liveness for us. + src <- assignTemp_ src0 + src_off <- assignTemp_ src_off0 + n <- assignTemp_ n0 + + card_words <- assignTemp $ (n `cmmUShrWord` + (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))) + `cmmAddWord` CmmLit (mkIntCLit 1) + size <- assignTemp $ n `cmmAddWord` card_words + words <- assignTemp $ arrPtrsHdrSizeW `cmmAddWord` size + + arr_r <- newTemp bWord + emitAllocateCall arr_r myCapability words live + tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize) + (CmmLit $ mkIntCLit 0) + + let arr = CmmReg (CmmLocal arr_r) + emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCSAddr + stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE + + oFFSET_StgMutArrPtrs_ptrs)) n + stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE + + oFFSET_StgMutArrPtrs_size)) size + + dst_p <- assignTemp $ cmmOffsetB arr arrPtrsHdrSize + src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) + src_off + + emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) live + + emitMemsetCall (cmmOffsetExprW dst_p n) + (CmmLit (CmmInt (toInteger (1 :: Int)) W8)) + (card_words `cmmMulWord` wordSize) + live + stmtC $ CmmAssign (CmmLocal res_r) arr + where + arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize + + (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) + wordSize = CmmLit (mkIntCLit wORD_SIZE) + myCapability = CmmReg baseReg `cmmSubWord` + CmmLit (mkIntCLit oFFSET_Capability_r) + +-- | 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). Marks the relevant cards as dirty. +emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code +emitSetCards dst_start dst_cards_start n live = do + start_card <- assignTemp $ card dst_start + emitMemsetCall (dst_cards_start `cmmAddWord` start_card) + (CmmLit (CmmInt (toInteger (1 :: Int)) W8)) + ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card) + `cmmAddWord` CmmLit (mkIntCLit 1)) + live + where + -- Convert an element index to a card index + card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) + +-- | Emit a call to @memcpy@. +emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code +emitMemcpyCall dst src n live = do + vols <- getVolatileRegs live + emitForeignCall' PlayRisky + [{-no results-}] + (CmmCallee memcpy CCallConv) + [ (CmmHinted dst AddrHint) + , (CmmHinted src AddrHint) + , (CmmHinted n NoHint) + ] + (Just vols) + NoC_SRT -- No SRT b/c we do PlayRisky + CmmMayReturn + where + memcpy = CmmLit (CmmLabel (mkForeignLabel (fsLit "memcpy") Nothing + ForeignLabelInExternalPackage IsFunction)) + +-- | Emit a call to @memmove@. +emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code +emitMemmoveCall dst src n live = do + vols <- getVolatileRegs live + emitForeignCall' PlayRisky + [{-no results-}] + (CmmCallee memmove CCallConv) + [ (CmmHinted dst AddrHint) + , (CmmHinted src AddrHint) + , (CmmHinted n NoHint) + ] + (Just vols) + NoC_SRT -- No SRT b/c we do PlayRisky + CmmMayReturn + where + memmove = CmmLit (CmmLabel (mkForeignLabel (fsLit "memmove") Nothing + ForeignLabelInExternalPackage IsFunction)) + +-- | Emit a call to @memset@. The second argument must be of type +-- 'W8'. +emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code +emitMemsetCall dst c n live = do + vols <- getVolatileRegs live + emitForeignCall' PlayRisky + [{-no results-}] + (CmmCallee memset CCallConv) + [ (CmmHinted dst AddrHint) + , (CmmHinted c NoHint) + , (CmmHinted n NoHint) + ] + (Just vols) + NoC_SRT -- No SRT b/c we do PlayRisky + CmmMayReturn + where + memset = CmmLit (CmmLabel (mkForeignLabel (fsLit "memset") Nothing + ForeignLabelInExternalPackage IsFunction)) + +-- | Emit a call to @allocate@. +emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> StgLiveVars -> Code +emitAllocateCall res cap n live = do + vols <- getVolatileRegs live + emitForeignCall' PlayRisky + [CmmHinted res AddrHint] + (CmmCallee allocate CCallConv) + [ (CmmHinted cap AddrHint) + , (CmmHinted n NoHint) + ] + (Just vols) + NoC_SRT -- No SRT b/c we do PlayRisky + CmmMayReturn + where + allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing + ForeignLabelInExternalPackage IsFunction))