cgPrimOp
) where
+#include "HsVersions.h"
+
+import ForeignCall ( CCallConv(CCallConv) )
import StgSyn ( StgLiveVars, StgArg )
+import CgForeignCall ( emitForeignCall' )
import CgBindery ( getVolatileRegs, getArgAmodes )
import CgMonad
import CgInfoTbls ( getConstrTag )
import CgUtils ( cmmOffsetW, cmmOffsetB, cmmLoadIndexW )
+import ForeignCall
import Cmm
-import CLabel ( mkMAP_FROZEN_infoLabel )
+import CLabel ( mkMAP_FROZEN_infoLabel, mkMAP_DIRTY_infoLabel,
+ mkDirty_MUT_VAR_Label, mkRtsCodeLabel )
import CmmUtils
import MachOp
import SMRep
import PrimOp ( PrimOp(..) )
import SMRep ( tablesNextToCode )
import Constants ( wORD_SIZE, wORD_SIZE_IN_BITS )
+import StaticFlags ( opt_Parallel )
import Outputable
-- ---------------------------------------------------------------------------
emitPrimOp [res] ParOp [arg] live
- = stmtC (CmmAssign res (CmmLit (mkIntCLit 1)))
+ = do
+ -- for now, just implement this in a C function
+ -- later, we might want to inline it.
+ vols <- getVolatileRegs live
+ emitForeignCall' PlayRisky
+ [(res,NoHint)]
+ (CmmForeignCall newspark CCallConv)
+ [(CmmReg (CmmGlobal BaseReg), PtrHint), (arg,PtrHint)]
+ (Just vols)
+ where
+ newspark = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("newSpark")))
emitPrimOp [res] ReadMutVarOp [mutv] live
= stmtC (CmmAssign res (cmmLoadIndexW mutv fixedHdrSize))
emitPrimOp [] WriteMutVarOp [mutv,var] live
- = stmtC (CmmStore (cmmOffsetW mutv fixedHdrSize) var)
-
-emitPrimOp [res] ForeignObjToAddrOp [fo] live
- = stmtC (CmmAssign res (cmmLoadIndexW fo fixedHdrSize))
-
-emitPrimOp [] WriteForeignObjOp [fo,addr] live
- = stmtC (CmmStore (cmmOffsetW fo fixedHdrSize) addr)
-
--- #define sizzeofByteArrayzh(r,a) \
+ = do
+ stmtC (CmmStore (cmmOffsetW mutv fixedHdrSize) var)
+ vols <- getVolatileRegs live
+ emitForeignCall' PlayRisky
+ [{-no results-}]
+ (CmmForeignCall (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
+ CCallConv)
+ [(CmmReg (CmmGlobal BaseReg), PtrHint), (mutv,PtrHint)]
+ (Just vols)
+
+-- #define sizzeofByteArrayzh(r,a) \
-- r = (((StgArrWords *)(a))->words * sizeof(W_))
emitPrimOp [res] SizeofByteArrayOp [arg] live
= stmtC $
CmmLit (mkIntCLit wORD_SIZE)
])
--- #define sizzeofMutableByteArrayzh(r,a) \
+-- #define sizzeofMutableByteArrayzh(r,a) \
-- r = (((StgArrWords *)(a))->words * sizeof(W_))
emitPrimOp [res] SizeofMutableByteArrayOp [arg] live
= emitPrimOp [res] SizeofByteArrayOp [arg] live
--- #define touchzh(o) /* nothing */
+-- #define touchzh(o) /* nothing */
emitPrimOp [] TouchOp [arg] live
= nopC
--- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
+-- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
emitPrimOp [res] ByteArrayContents_Char [arg] live
= stmtC (CmmAssign res (cmmOffsetB arg arrWordsHdrSize))
--- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
+-- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
emitPrimOp [res] StableNameToIntOp [arg] live
= stmtC (CmmAssign res (cmmLoadIndexW arg fixedHdrSize))
--- #define eqStableNamezh(r,sn1,sn2) \
+-- #define eqStableNamezh(r,sn1,sn2) \
-- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
emitPrimOp [res] EqStableNameOp [arg1,arg2] live
= stmtC (CmmAssign res (CmmMachOp mo_wordEq [
emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] live
= stmtC (CmmAssign res (CmmMachOp mo_wordEq [arg1,arg2]))
--- #define addrToHValuezh(r,a) r=(P_)a
+-- #define addrToHValuezh(r,a) r=(P_)a
emitPrimOp [res] AddrToHValueOp [arg] live
= stmtC (CmmAssign res arg)
--- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
+-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
emitPrimOp [res] DataToTagOp [arg] live
= stmtC (CmmAssign res (getConstrTag arg))
objects, even if they are in old space. When they become immutable,
they can be removed from this scavenge list. -}
--- #define unsafeFreezzeArrayzh(r,a)
+-- #define unsafeFreezzeArrayzh(r,a)
-- {
--- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info);
+-- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info);
-- r = a;
-- }
emitPrimOp [res] UnsafeFreezeArrayOp [arg] live
= stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
CmmAssign res arg ]
--- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
+-- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] live
= stmtC (CmmAssign res arg)
emitPrimOp [r] IndexArrayOp [obj,ix] live = doReadPtrArrayOp r obj ix
emitPrimOp [] WriteArrayOp [obj,ix,v] live = doWritePtrArrayOp obj ix v
--- IndexXXXoffForeignObj
-
-emitPrimOp res IndexOffForeignObjOp_Char args live = doIndexOffForeignObjOp (Just mo_u_8ToWord) I8 res args
-emitPrimOp res IndexOffForeignObjOp_WideChar args live = doIndexOffForeignObjOp (Just mo_u_32ToWord) I32 res args
-emitPrimOp res IndexOffForeignObjOp_Int args live = doIndexOffForeignObjOp Nothing wordRep res args
-emitPrimOp res IndexOffForeignObjOp_Word args live = doIndexOffForeignObjOp Nothing wordRep res args
-emitPrimOp res IndexOffForeignObjOp_Addr args live = doIndexOffForeignObjOp Nothing wordRep res args
-emitPrimOp res IndexOffForeignObjOp_Float args live = doIndexOffForeignObjOp Nothing F32 res args
-emitPrimOp res IndexOffForeignObjOp_Double args live = doIndexOffForeignObjOp Nothing F64 res args
-emitPrimOp res IndexOffForeignObjOp_StablePtr args live = doIndexOffForeignObjOp Nothing wordRep res args
-emitPrimOp res IndexOffForeignObjOp_Int8 args live = doIndexOffForeignObjOp (Just mo_s_8ToWord) I8 res args
-emitPrimOp res IndexOffForeignObjOp_Int16 args live = doIndexOffForeignObjOp (Just mo_s_16ToWord) I16 res args
-emitPrimOp res IndexOffForeignObjOp_Int32 args live = doIndexOffForeignObjOp (Just mo_s_32ToWord) I32 res args
-emitPrimOp res IndexOffForeignObjOp_Int64 args live = doIndexOffForeignObjOp Nothing I64 res args
-emitPrimOp res IndexOffForeignObjOp_Word8 args live = doIndexOffForeignObjOp (Just mo_u_8ToWord) I8 res args
-emitPrimOp res IndexOffForeignObjOp_Word16 args live = doIndexOffForeignObjOp (Just mo_u_16ToWord) I16 res args
-emitPrimOp res IndexOffForeignObjOp_Word32 args live = doIndexOffForeignObjOp (Just mo_u_32ToWord) I32 res args
-emitPrimOp res IndexOffForeignObjOp_Word64 args live = doIndexOffForeignObjOp Nothing I64 res args
-
-- IndexXXXoffAddr
emitPrimOp res IndexOffAddrOp_Char args live = doIndexOffAddrOp (Just mo_u_8ToWord) I8 res args
emitPrimOp res WriteOffAddrOp_Word args live = doWriteOffAddrOp Nothing wordRep res args
emitPrimOp res WriteOffAddrOp_Addr args live = doWriteOffAddrOp Nothing wordRep res args
emitPrimOp res WriteOffAddrOp_Float args live = doWriteOffAddrOp Nothing F32 res args
-emitPrimOp res WriteOffAddrOp_ForeignObj args live = doWriteOffAddrOp Nothing wordRep res args
emitPrimOp res WriteOffAddrOp_Double args live = doWriteOffAddrOp Nothing F64 res args
emitPrimOp res WriteOffAddrOp_StablePtr args live = doWriteOffAddrOp Nothing wordRep res args
emitPrimOp res WriteOffAddrOp_Int8 args live = doWriteOffAddrOp (Just mo_WordTo8) I8 res args
emitPrimOp [res] op args live
| Just prim <- callishOp op
= do vols <- getVolatileRegs live
- stmtC (CmmCall (CmmPrim prim) [(res,NoHint)]
- [(a,NoHint) | a<-args] (Just vols)) -- ToDo: hints?
+ emitForeignCall' PlayRisky
+ [(res,NoHint)]
+ (CmmPrim prim)
+ [(a,NoHint) | a<-args] -- ToDo: hints?
+ (Just vols)
| Just mop <- translateOp op
= let stmt = CmmAssign res (CmmMachOp mop args) in
nopOp Word2IntOp = True
nopOp Int2AddrOp = True
nopOp Addr2IntOp = True
+nopOp ChrOp = True -- Int# and Char# are rep'd the same
+nopOp OrdOp = True
nopOp _ = False
-- These PrimOps turn into double casts
translateOp AddrGtOp = Just mo_wordUGt
translateOp AddrLtOp = Just mo_wordULt
--- 32-bit unsigned ops
+-- Char# ops
-translateOp CharEqOp = Just (MO_Eq I32)
-translateOp CharNeOp = Just (MO_Ne I32)
-translateOp CharGeOp = Just (MO_U_Ge I32)
-translateOp CharLeOp = Just (MO_U_Le I32)
-translateOp CharGtOp = Just (MO_U_Gt I32)
-translateOp CharLtOp = Just (MO_U_Lt I32)
+translateOp CharEqOp = Just (MO_Eq wordRep)
+translateOp CharNeOp = Just (MO_Ne wordRep)
+translateOp CharGeOp = Just (MO_U_Ge wordRep)
+translateOp CharLeOp = Just (MO_U_Le wordRep)
+translateOp CharGtOp = Just (MO_U_Gt wordRep)
+translateOp CharLtOp = Just (MO_U_Lt wordRep)
-- Double ops
translateOp Float2DoubleOp = Just (MO_S_Conv F32 F64)
translateOp Double2FloatOp = Just (MO_S_Conv F64 F32)
-translateOp OrdOp = Just (MO_U_Conv I32 wordRep)
-translateOp ChrOp = Just (MO_U_Conv wordRep I32)
-
-- Word comparisons masquerading as more exotic things.
translateOp SameMutVarOp = Just mo_wordEq
translateOp SameMutableArrayOp = Just mo_wordEq
translateOp SameMutableByteArrayOp = Just mo_wordEq
translateOp SameTVarOp = Just mo_wordEq
-translateOp EqForeignObj = Just mo_wordEq
translateOp EqStablePtrOp = Just mo_wordEq
translateOp _ = Nothing
------------------------------------------------------------------------------
-- Helpers for translating various minor variants of array indexing.
-doIndexOffForeignObjOp maybe_post_read_cast rep [res] [addr,idx]
- = mkBasicIndexedRead 0 maybe_post_read_cast rep res
- (cmmLoadIndexW addr fixedHdrSize) idx
-doIndexOffForeignObjOp _ _ _ _
- = panic "CgPrimOp: doIndexOffForeignObjOp"
-
doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
= mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
doIndexOffAddrOp _ _ _ _
= panic "CgPrimOp: doWriteByteArrayOp"
doWritePtrArrayOp addr idx val
- = mkBasicIndexedWrite arrPtrsHdrSize Nothing wordRep addr idx val
+ = do stmtC (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
+ mkBasicIndexedWrite arrPtrsHdrSize Nothing wordRep addr idx val
mkBasicIndexedRead off Nothing read_rep res base idx
projects / ghc-hetmet.git / blobdiff