X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgPrimOp.hs;h=91aa3911f83a3fa84dec938eb36a3db655c77605;hb=91b07216be1cb09230b7d1b417899ddea8620ff3;hp=5c01903c8c79bb530b3161dd4bfe991a99d6f7d9;hpb=b61f70ce5ff947642c96b1ad980351691bb1e07a;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgPrimOp.hs b/ghc/compiler/codeGen/CgPrimOp.hs index 5c01903..91aa391 100644 --- a/ghc/compiler/codeGen/CgPrimOp.hs +++ b/ghc/compiler/codeGen/CgPrimOp.hs @@ -10,13 +10,15 @@ module CgPrimOp ( cgPrimOp ) where +import ForeignCall ( CCallConv(CCallConv) ) import StgSyn ( StgLiveVars, StgArg ) import CgBindery ( getVolatileRegs, getArgAmodes ) import CgMonad import CgInfoTbls ( getConstrTag ) import CgUtils ( cmmOffsetW, cmmOffsetB, cmmLoadIndexW ) import Cmm -import CLabel ( mkMAP_FROZEN_infoLabel ) +import CLabel ( mkMAP_FROZEN_infoLabel, mkMAP_DIRTY_infoLabel, + mkDirty_MUT_VAR_Label ) import CmmUtils import MachOp import SMRep @@ -113,15 +115,16 @@ 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 + stmtC (CmmCall (CmmForeignCall (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) + CCallConv) + [{-no results-}] + [(mutv,PtrHint)] + (Just vols)) + +-- #define sizzeofByteArrayzh(r,a) \ -- r = (((StgArrWords *)(a))->words * sizeof(W_)) emitPrimOp [res] SizeofByteArrayOp [arg] live = stmtC $ @@ -130,25 +133,25 @@ emitPrimOp [res] SizeofByteArrayOp [arg] live 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 [ @@ -160,11 +163,11 @@ emitPrimOp [res] EqStableNameOp [arg1,arg2] live 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)) @@ -173,16 +176,16 @@ emitPrimOp [res] DataToTagOp [arg] live 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) @@ -192,25 +195,6 @@ emitPrimOp [r] ReadArrayOp [obj,ix] live = doReadPtrArrayOp r obj ix 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 @@ -295,7 +279,6 @@ emitPrimOp res WriteOffAddrOp_Int args live = doWriteOffAddrOp Nothing wo 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 @@ -356,6 +339,8 @@ nopOp Int2WordOp = True 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 @@ -427,14 +412,14 @@ translateOp AddrLeOp = Just mo_wordULe 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 @@ -477,9 +462,6 @@ translateOp Float2IntOp = Just (MO_S_Conv F32 wordRep) 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 @@ -487,7 +469,6 @@ translateOp SameMVarOp = 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 @@ -528,12 +509,6 @@ callishOp _ = 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 _ _ _ _ @@ -559,7 +534,8 @@ doWriteByteArrayOp _ _ _ _ = 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