Make array copy primops inline

2 files changed, 228 insertions, 3 deletions

diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index fd440e9136..c5a6644aba 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))
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 922d330b26..4df7c77914 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -20,7 +20,7 @@ module CgUtils (
         emitRODataLits, mkRODataLits,
         emitIf, emitIfThenElse,
 	emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
-	assignTemp, newTemp,
+	assignTemp, assignTemp_, newTemp,
 	emitSimultaneously,
 	emitSwitch, emitLitSwitch,
 	tagToClosure,
@@ -29,7 +29,7 @@ module CgUtils (
 	activeStgRegs, fixStgRegisters,
 
 	cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
-        cmmUGtWord,
+        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
 	cmmOffsetExprW, cmmOffsetExprB,
 	cmmRegOffW, cmmRegOffB,
 	cmmLabelOffW, cmmLabelOffB,
@@ -180,8 +180,10 @@ cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
 cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
 cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
 --cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
---cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
+cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
+cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2]
 cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
+cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2]
 
 cmmNegate :: CmmExpr -> CmmExpr
 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
@@ -587,6 +589,9 @@ mkByteStringCLit bytes
 --
 -------------------------------------------------------------------------
 
+-- | If the expression is trivial, return it.  Otherwise, assign the
+-- expression to a temporary register and return an expression
+-- referring to this register.
 assignTemp :: CmmExpr -> FCode CmmExpr
 -- For a non-trivial expression, e, create a local
 -- variable and assign the expression to it
@@ -596,6 +601,14 @@ assignTemp e
 			    ; stmtC (CmmAssign (CmmLocal reg) e)
 			    ; return (CmmReg (CmmLocal reg)) }
 
+-- | Assign the expression to a temporary register and return an
+-- expression referring to this register.
+assignTemp_ :: CmmExpr -> FCode CmmExpr
+assignTemp_ e = do
+    reg <- newTemp (cmmExprType e)
+    stmtC (CmmAssign (CmmLocal reg) e)
+    return (CmmReg (CmmLocal reg))
+
 newTemp :: CmmType -> FCode LocalReg
 newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }