X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmPrim.hs;h=e6dbcec7f90a2ed14377919422fa6c4c1ca992ee;hb=8b3bfb2ec41fd0e807a8f6e7a823795eafca1dcb;hp=8298b68deea5f608f310ed2cc29f7f4cb44cc7ca;hpb=5892af0e08fdb890b5a0b9a64346d9f7773a6ed8;p=ghc-hetmet.git diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 8298b68..e6dbcec 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -17,10 +17,15 @@ import StgCmmForeign import StgCmmEnv import StgCmmMonad import StgCmmUtils +import StgCmmTicky +import StgCmmHeap +import StgCmmProf -import MkZipCfgCmm +import BasicTypes +import MkGraph import StgSyn -import Cmm +import CmmDecl +import CmmExpr import Type ( Type, tyConAppTyCon ) import TyCon import CLabel @@ -28,6 +33,7 @@ import CmmUtils import PrimOp import SMRep import Constants +import Module import FastString import Outputable @@ -82,7 +88,7 @@ cgOpApp (StgPrimOp primop) args res_ty | primOpOutOfLine primop = do { cmm_args <- getNonVoidArgAmodes args ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) - ; emitCall PrimOp fun cmm_args } + ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args } | ReturnsPrim VoidRep <- result_info = do cgPrimOp [] primop args @@ -110,6 +116,11 @@ cgOpApp (StgPrimOp primop) args res_ty where result_info = getPrimOpResultInfo primop +cgOpApp (StgPrimCallOp primcall) args _res_ty + = do { cmm_args <- getNonVoidArgAmodes args + ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) + ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args } + --------------------------------------------------- cgPrimOp :: [LocalReg] -- where to put the results -> PrimOp -- the op @@ -196,7 +207,7 @@ emitPrimOp [res] ParOp [arg] -- later, we might want to inline it. emitCCall [(res,NoHint)] - (CmmLit (CmmLabel (mkRtsCodeLabel (sLit "newSpark")))) + (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] emitPrimOp [res] ReadMutVarOp [mutv] @@ -211,23 +222,20 @@ emitPrimOp [] WriteMutVarOp [mutv,var] [(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)] -- #define sizzeofByteArrayzh(r,a) \ --- r = (((StgArrWords *)(a))->words * sizeof(W_)) +-- r = ((StgArrWords *)(a))->bytes emitPrimOp [res] SizeofByteArrayOp [arg] = emit $ - mkAssign (CmmLocal res) (CmmMachOp mo_wordMul [ - cmmLoadIndexW arg fixedHdrSize bWord, - CmmLit (mkIntCLit wORD_SIZE) - ]) + mkAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord) -- #define sizzeofMutableByteArrayzh(r,a) \ --- r = (((StgArrWords *)(a))->words * sizeof(W_)) +-- r = ((StgArrWords *)(a))->bytes emitPrimOp [res] SizeofMutableByteArrayOp [arg] = emitPrimOp [res] SizeofByteArrayOp [arg] -- #define touchzh(o) /* nothing */ -emitPrimOp [] TouchOp [_arg] - = nopC +emitPrimOp res@[] TouchOp args@[_arg] + = do emitPrimCall res MO_Touch args -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) emitPrimOp [res] ByteArrayContents_Char [arg] @@ -277,12 +285,32 @@ emitPrimOp [res] UnsafeFreezeArrayOp [arg] emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] = emit (mkAssign (CmmLocal res) arg) +-- Copying pointer arrays + +emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] = + doCopyArrayOp src src_off dst dst_off n +emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] = + doCopyMutableArrayOp src src_off dst dst_off n +emitPrimOp [res] CloneArrayOp [src,src_off,n] = + emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n +emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] = + emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n +emitPrimOp [res] FreezeArrayOp [src,src_off,n] = + emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n +emitPrimOp [res] ThawArrayOp [src,src_off,n] = + emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n + -- Reading/writing pointer arrays emitPrimOp [r] ReadArrayOp [obj,ix] = doReadPtrArrayOp r obj ix emitPrimOp [r] IndexArrayOp [obj,ix] = doReadPtrArrayOp r obj ix emitPrimOp [] WriteArrayOp [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp [res] SizeofArrayOp [arg] + = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize + oFFSET_StgMutArrPtrs_ptrs) bWord) +emitPrimOp [res] SizeofMutableArrayOp [arg] + = emitPrimOp [res] SizeofArrayOp [arg] + -- IndexXXXoffAddr emitPrimOp res IndexOffAddrOp_Char args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args @@ -407,9 +435,9 @@ emitPrimOp [res] op [arg] = emit (mkAssign (CmmLocal res) $ CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]]) -emitPrimOp [res] op args +emitPrimOp r@[res] op args | Just prim <- callishOp op - = do emitPrimCall res prim args + = do emitPrimCall r prim args | Just mop <- translateOp op = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in @@ -630,8 +658,21 @@ doWriteByteArrayOp _ _ _ doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () doWritePtrArrayOp addr idx val - = do emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - mkBasicIndexedWrite arrPtrsHdrSize Nothing addr idx val + = do mkBasicIndexedWrite arrPtrsHdrSize Nothing addr idx val + emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + -- the write barrier. We must write a byte into the mark table: + -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] + emit $ mkStore ( + cmmOffsetExpr + (cmmOffsetExprW (cmmOffsetB addr arrPtrsHdrSize) + (loadArrPtrsSize addr)) + (CmmMachOp mo_wordUShr [idx, + CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)]) + ) (CmmLit (CmmInt 1 W8)) + +loadArrPtrsSize :: CmmExpr -> CmmExpr +loadArrPtrsSize addr = CmmLoad (cmmOffsetB addr off) bWord + where off = fixedHdrSize*wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType -> LocalReg -> CmmExpr -> CmmExpr -> FCode () @@ -662,3 +703,193 @@ cmmLoadIndexOffExpr off ty base idx setInfo :: CmmExpr -> CmmExpr -> CmmAGraph setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr +-- ---------------------------------------------------------------------------- +-- Copying pointer arrays + +-- EZY: This code has an unusually high amount of assignTemp calls, seen +-- nowhere else in the code generator. This is mostly because these +-- "primitive" ops result in a surprisingly large amount of code. It +-- will likely be worthwhile to optimize what is emitted here, so that +-- our optimization passes don't waste time repeatedly optimizing the +-- same bits of code. + +-- More closely imitates 'assignTemp' from the old code generator, which +-- returns a CmmExpr rather than a LocalReg. +assignTempE :: CmmExpr -> FCode CmmExpr +assignTempE e = do + t <- assignTemp e + return (CmmReg (CmmLocal t)) + +-- | 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 + -> FCode () +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 + -> FCode () +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 = do + [moveCall, cpyCall] <- forkAlts [ + getCode $ emitMemmoveCall dst_p src_p bytes, + getCode $ emitMemcpyCall dst_p src_p bytes + ] + emit $ mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall + +emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode ()) + -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do + -- Passed as arguments (be careful) + src <- assignTempE src0 + src_off <- assignTempE src_off0 + dst <- assignTempE dst0 + dst_off <- assignTempE dst_off0 + n <- assignTempE n0 + + -- Set the dirty bit in the header. + emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + + dst_elems_p <- assignTempE $ cmmOffsetB dst arrPtrsHdrSize + dst_p <- assignTempE $ cmmOffsetExprW dst_elems_p dst_off + src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off + bytes <- assignTempE $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE)) + + copy src dst dst_p src_p bytes + + -- The base address of the destination card table + dst_cards_p <- assignTempE $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst) + + emitSetCards dst_off dst_cards_p n + +-- | 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 + -> FCode () +emitCloneArray info_p res_r src0 src_off0 n0 = do + -- Passed as arguments (be careful) + src <- assignTempE src0 + src_off <- assignTempE src_off0 + n <- assignTempE n0 + + card_words <- assignTempE $ (n `cmmUShrWord` + (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))) + `cmmAddWord` CmmLit (mkIntCLit 1) + size <- assignTempE $ n `cmmAddWord` card_words + words <- assignTempE $ arrPtrsHdrSizeW `cmmAddWord` size + + arr_r <- newTemp bWord + emitAllocateCall arr_r myCapability words + tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize) + (CmmLit $ mkIntCLit 0) + + let arr = CmmReg (CmmLocal arr_r) + emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCSAddr + emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE + + oFFSET_StgMutArrPtrs_ptrs)) n + emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE + + oFFSET_StgMutArrPtrs_size)) size + + dst_p <- assignTempE $ cmmOffsetB arr arrPtrsHdrSize + src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) + src_off + + emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) + + emitMemsetCall (cmmOffsetExprW dst_p n) + (CmmLit (mkIntCLit 1)) + (card_words `cmmMulWord` wordSize) + emit $ mkAssign (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 -> FCode () +emitSetCards dst_start dst_cards_start n = do + start_card <- assignTempE $ card dst_start + emitMemsetCall (dst_cards_start `cmmAddWord` start_card) + (CmmLit (mkIntCLit 1)) + ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card) + `cmmAddWord` CmmLit (mkIntCLit 1)) + 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 -> FCode () +emitMemcpyCall dst src n = do + emitCCall + [ {-no results-} ] + memcpy + [ (dst, AddrHint) + , (src, AddrHint) + , (n, NoHint) + ] + where + memcpy = CmmLit (CmmLabel (mkForeignLabel (fsLit "memcpy") Nothing + ForeignLabelInExternalPackage IsFunction)) + +-- | Emit a call to @memmove@. +emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitMemmoveCall dst src n = do + emitCCall + [ {- no results -} ] + memmove + [ (dst, AddrHint) + , (src, AddrHint) + , (n, NoHint) + ] + where + memmove = CmmLit (CmmLabel (mkForeignLabel (fsLit "memmove") Nothing + ForeignLabelInExternalPackage IsFunction)) + +-- | Emit a call to @memset@. The second argument must fit inside an +-- unsigned char. +emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitMemsetCall dst c n = do + emitCCall + [ {- no results -} ] + memset + [ (dst, AddrHint) + , (c, NoHint) + , (n, NoHint) + ] + where + memset = CmmLit (CmmLabel (mkForeignLabel (fsLit "memset") Nothing + ForeignLabelInExternalPackage IsFunction)) + +-- | Emit a call to @allocate@. +emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> FCode () +emitAllocateCall res cap n = do + emitCCall + [ (res, AddrHint) ] + allocate + [ (cap, AddrHint) + , (n, NoHint) + ] + where + allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing + ForeignLabelInExternalPackage IsFunction))