Fix segfault in array copy primops on 32-bit

[ghc-hetmet.git] / compiler / codeGen / StgCmmPrim.hs

diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 96467fe..afe0c39 100644 (file)
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -18,9 +18,10 @@ import StgCmmEnv
 import StgCmmMonad
 import StgCmmUtils
 
-import MkZipCfgCmm
+import MkGraph
 import StgSyn
-import Cmm
+import CmmDecl
+import CmmExpr
 import Type    ( Type, tyConAppTyCon )
 import TyCon
 import CLabel
@@ -28,6 +29,7 @@ import CmmUtils
 import PrimOp
 import SMRep
 import Constants
+import Module
 import FastString
 import Outputable
 
@@ -66,7 +68,9 @@ cgOpApp (StgFCallOp fcall _) stg_args res_ty
 
 cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty 
   = ASSERT(isEnumerationTyCon tycon)
-    do { amode <- getArgAmode arg
+    do { args' <- getNonVoidArgAmodes [arg]
+        ; let amode = case args' of [amode] -> amode
+                                    _ -> panic "TagToEnumOp had void arg"
        ; emitReturn [tagToClosure tycon amode] }
    where
          -- If you're reading this code in the attempt to figure
@@ -79,8 +83,8 @@ cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty
 cgOpApp (StgPrimOp primop) args res_ty
   | primOpOutOfLine primop
   = do { cmm_args <- getNonVoidArgAmodes args
-       ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
-       ; emitCall fun cmm_args }
+        ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
+        ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args }
 
   | ReturnsPrim VoidRep <- result_info
   = do cgPrimOp [] primop args 
@@ -108,6 +112,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
@@ -194,7 +203,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]
@@ -209,23 +218,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]
@@ -281,6 +287,11 @@ 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
@@ -405,9 +416,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
@@ -628,8 +639,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 ()