projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
change dirty_MUT_VAR() to use recordMutableCap()
[ghc-hetmet.git] / ghc / compiler / codeGen / CgPrimOp.hs
diff --git a/ghc/compiler/codeGen/CgPrimOp.hs b/ghc/compiler/codeGen/CgPrimOp.hs
index db01ee8..c1264be 100644 (file)
--- a/ghc/compiler/codeGen/CgPrimOp.hs
+++ b/ghc/compiler/codeGen/CgPrimOp.hs
@@ -10,19 +10,25 @@ module CgPrimOp (
    cgPrimOp
  ) where
 
+#include "HsVersions.h"
+
+import ForeignCall     ( CCallConv(CCallConv) )
 import StgSyn          ( StgLiveVars, StgArg )
 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
 
 -- ---------------------------------------------------------------------------
@@ -107,19 +113,30 @@ emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] live
 
 
 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
+    stmtC (CmmCall (CmmForeignCall newspark CCallConv) [(res,NoHint)]
+               [(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)
+   = do
+       stmtC (CmmStore (cmmOffsetW mutv fixedHdrSize) var)
+       vols <- getVolatileRegs live
+       stmtC (CmmCall (CmmForeignCall (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
+                               CCallConv) 
+                       [{-no results-}]
+                       [(CmmReg (CmmGlobal BaseReg), PtrHint),
+                        (mutv,PtrHint)]
+                       (Just vols))
 
 --  #define sizzeofByteArrayzh(r,a) \
 --     r = (((StgArrWords *)(a))->words * sizeof(W_))
@@ -192,25 +209,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 +293,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 +353,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 +426,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 +476,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 +483,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 +523,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 +548,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
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)