-- -----------------------------------------------------------------------------
-- For certain types passed to foreign calls, we adjust the actual
--- value passed to the call. Two main cases: for ForeignObj# we pass
--- the pointer inside the ForeignObj# closure, and for ByteArray#/Array# we
--- pass the address of the actual array, not the address of the heap object.
+-- value passed to the call. For ByteArray#/Array# we pass the
+-- address of the actual array, not the address of the heap object.
shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
shimForeignCallArg arg expr
- | tycon == foreignObjPrimTyCon
- = cmmLoadIndexW expr fixedHdrSize
-
| tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
= cmmOffsetB expr arrPtrsHdrSize
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) \
-- r = (((StgArrWords *)(a))->words * sizeof(W_))
emitPrimOp [res] SizeofByteArrayOp [arg] live
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
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 _ _ _ _
dsCCall lbl args may_gc result_ty
= mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
- boxResult [] id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
+ boxResult id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
newUnique `thenDs` \ uniq ->
let
target = StaticTarget lbl
\begin{code}
-boxResult :: [Id]
- -> ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
+boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
-> Maybe Id
-> Type
-> DsM (Type, CoreExpr -> CoreExpr)
-- the result type will be
-- State# RealWorld -> (# State# RealWorld #)
-boxResult arg_ids augment mbTopCon result_ty
+boxResult augment mbTopCon result_ty
= case tcSplitTyConApp_maybe result_ty of
-- This split absolutely has to be a tcSplit, because we must
-- see the IO type; and it's a newtype which is transparent to splitTyConApp.
let
work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars
- -- These are the ids we pass to boxResult, which are used to decide
- -- whether to touch# an argument after the call (used to keep
- -- ForeignObj#s live across a 'safe' foreign import).
- maybe_arg_ids | unsafe_call fcall = work_arg_ids
- | otherwise = []
-
forDotnet =
case fcall of
DNCall{} -> True
in
augmentResultDs `thenDs` \ augment ->
topConDs `thenDs` \ topCon ->
- boxResult maybe_arg_ids augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
+ boxResult augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
newUnique `thenDs` \ ccall_uniq ->
newUnique `thenDs` \ work_uniq ->
stableNamePrimTyCon, mkStableNamePrimTy,
bcoPrimTyCon, bcoPrimTy,
weakPrimTyCon, mkWeakPrimTy,
- foreignObjPrimTyCon, foreignObjPrimTy,
threadIdPrimTyCon, threadIdPrimTy,
int32PrimTyCon, int32PrimTy,
, intPrimTyCon
, int32PrimTyCon
, int64PrimTyCon
- , foreignObjPrimTyCon
, bcoPrimTyCon
, weakPrimTyCon
, mutableArrayPrimTyCon
tVarPrimTyConName = mkPrimTc FSLIT("TVar#") tVarPrimTyConKey tVarPrimTyCon
stablePtrPrimTyConName = mkPrimTc FSLIT("StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon
stableNamePrimTyConName = mkPrimTc FSLIT("StableName#") stableNamePrimTyConKey stableNamePrimTyCon
-foreignObjPrimTyConName = mkPrimTc FSLIT("ForeignObj#") foreignObjPrimTyConKey foreignObjPrimTyCon
bcoPrimTyConName = mkPrimTc FSLIT("BCO#") bcoPrimTyConKey bcoPrimTyCon
weakPrimTyConName = mkPrimTc FSLIT("Weak#") weakPrimTyConKey weakPrimTyCon
threadIdPrimTyConName = mkPrimTc FSLIT("ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon
%************************************************************************
%* *
-\subsection[TysPrim-foreign-objs]{The ``foreign object'' type}
-%* *
-%************************************************************************
-
-A Foreign Object is just a boxed, unlifted, Addr#. They're needed
-because finalisers (weak pointers) can't watch Addr#s, they can only
-watch heap-resident objects.
-
-We can't use a lifted Addr# (such as Addr) because race conditions
-could bite us. For example, if the program deconstructed the Addr
-before passing its contents to a ccall, and a weak pointer was
-watching the Addr, the weak pointer might deduce that the Addr was
-dead before it really was.
-
-\begin{code}
-foreignObjPrimTy = mkTyConTy foreignObjPrimTyCon
-foreignObjPrimTyCon = pcPrimTyCon0 foreignObjPrimTyConName PtrRep
-\end{code}
-
-%************************************************************************
-%* *
\subsection[TysPrim-BCOs]{The ``bytecode object'' type}
%* *
%************************************************************************
-----------------------------------------------------------------------
--- $Id: primops.txt.pp,v 1.35 2005/03/07 15:16:41 simonmar Exp $
+-- $Id: primops.txt.pp,v 1.36 2005/07/25 14:12:48 simonmar Exp $
--
-- Primitive Operations
--
-> Int\#}; otherwise it has type {\tt ByteArr\# -> Int\# ->
Int32\#}. This approach confines the necessary {\tt
\#if}-defs to this file; no conditional compilation is needed
- in the files that expose these primops, namely
- \texttt{lib/std/PrelStorable.lhs},
- \texttt{hslibs/lang/ArrayBase.hs}, and (in deprecated
- fashion) in \texttt{hslibs/lang/ForeignObj.lhs} and
- \texttt{hslibs/lang/Addr.lhs}.
+ in the files that expose these primops.
Finally, there are strongly deprecated primops for coercing
between {\tt Addr\#}, the primitive type of machine
Addr# -> Int# -> Addr# -> State# s -> State# s
with has_side_effects = True
-primop WriteOffAddrOp_ForeignObj "writeForeignObjOffAddr#" GenPrimOp
- Addr# -> Int# -> ForeignObj# -> State# s -> State# s
- with has_side_effects = True
-
primop WriteOffAddrOp_Float "writeFloatOffAddr#" GenPrimOp
Addr# -> Int# -> Float# -> State# s -> State# s
with has_side_effects = True
with has_side_effects = True
------------------------------------------------------------------------
-section "ForeignObj#"
- {Operations on ForeignObj\#. The indexing operations are
- all deprecated.}
-------------------------------------------------------------------------
-
-primop MkForeignObjOp "mkForeignObj#" GenPrimOp
- Addr# -> State# RealWorld -> (# State# RealWorld, ForeignObj# #)
- with
- has_side_effects = True
- out_of_line = True
-
-primop WriteForeignObjOp "writeForeignObj#" GenPrimOp
- ForeignObj# -> Addr# -> State# s -> State# s
- with
- has_side_effects = True
-
-primop ForeignObjToAddrOp "foreignObjToAddr#" GenPrimOp
- ForeignObj# -> Addr#
-
-primop TouchOp "touch#" GenPrimOp
- o -> State# RealWorld -> State# RealWorld
- with
- has_side_effects = True
-
-primop EqForeignObj "eqForeignObj#" GenPrimOp
- ForeignObj# -> ForeignObj# -> Bool
- with commutable = True
-
-primop IndexOffForeignObjOp_Char "indexCharOffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> Char#
- {Read 8-bit character; offset in bytes.}
-
-primop IndexOffForeignObjOp_WideChar "indexWideCharOffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> Char#
- {Read 31-bit character; offset in 4-byte words.}
-
-primop IndexOffForeignObjOp_Int "indexIntOffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> Int#
-
-primop IndexOffForeignObjOp_Word "indexWordOffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> Word#
-
-primop IndexOffForeignObjOp_Addr "indexAddrOffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> Addr#
-
-primop IndexOffForeignObjOp_Float "indexFloatOffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> Float#
-
-primop IndexOffForeignObjOp_Double "indexDoubleOffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> Double#
-
-primop IndexOffForeignObjOp_StablePtr "indexStablePtrOffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> StablePtr# a
-
-primop IndexOffForeignObjOp_Int8 "indexInt8OffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> Int#
-
-primop IndexOffForeignObjOp_Int16 "indexInt16OffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> Int#
-
-primop IndexOffForeignObjOp_Int32 "indexInt32OffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> INT32
-
-primop IndexOffForeignObjOp_Int64 "indexInt64OffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> INT64
-
-primop IndexOffForeignObjOp_Word8 "indexWord8OffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> Word#
-
-primop IndexOffForeignObjOp_Word16 "indexWord16OffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> Word#
-
-primop IndexOffForeignObjOp_Word32 "indexWord32OffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> WORD32
-
-primop IndexOffForeignObjOp_Word64 "indexWord64OffForeignObj#" GenPrimOp
- ForeignObj# -> Int# -> WORD64
-
-
-
-------------------------------------------------------------------------
section "Mutable variables"
{Operations on MutVar\#s, which behave like single-element mutable arrays.}
------------------------------------------------------------------------
has_side_effects = True
out_of_line = True
+primop TouchOp "touch#" GenPrimOp
+ o -> State# RealWorld -> State# RealWorld
+ with
+ has_side_effects = True
+
------------------------------------------------------------------------
section "Stable pointers and names"
------------------------------------------------------------------------
#define MUT_ARR_PTRS_FROZEN 53
#define MUT_VAR 54
#define WEAK 55
-#define FOREIGN 56
-#define STABLE_NAME 57
-#define TSO 58
-#define BLOCKED_FETCH 69
-#define FETCH_ME 60
-#define FETCH_ME_BQ 61
-#define RBH 62
-#define EVACUATED 63
-#define REMOTE_REF 64
-#define TVAR_WAIT_QUEUE 65
-#define TVAR 66
-#define TREC_CHUNK 67
-#define TREC_HEADER 68
-#define ATOMICALLY_FRAME 79
-#define CATCH_RETRY_FRAME 70
-#define CATCH_STM_FRAME 71
-#define N_CLOSURE_TYPES 72
+#define STABLE_NAME 56
+#define TSO 57
+#define BLOCKED_FETCH 68
+#define FETCH_ME 69
+#define FETCH_ME_BQ 60
+#define RBH 61
+#define EVACUATED 62
+#define REMOTE_REF 63
+#define TVAR_WAIT_QUEUE 64
+#define TVAR 65
+#define TREC_CHUNK 66
+#define TREC_HEADER 67
+#define ATOMICALLY_FRAME 78
+#define CATCH_RETRY_FRAME 79
+#define CATCH_STM_FRAME 70
+#define N_CLOSURE_TYPES 71
#endif /* CLOSURETYPES_H */
StgHeader header;
} StgRetry;
-typedef struct _StgForeignObj {
- StgHeader header;
- StgAddr data; /* pointer to data in non-haskell-land */
-} StgForeignObj;
-
typedef struct _StgStableName {
StgHeader header;
StgWord sn;
#endif
RTS_FUN_INFO(stg_BCO_info);
RTS_INFO(stg_EVACUATED_info);
-RTS_INFO(stg_FOREIGN_info);
RTS_INFO(stg_WEAK_info);
RTS_INFO(stg_DEAD_WEAK_info);
RTS_INFO(stg_STABLE_NAME_info);
#endif
RTS_ENTRY(stg_BCO_entry);
RTS_ENTRY(stg_EVACUATED_entry);
-RTS_ENTRY(stg_FOREIGN_entry);
RTS_ENTRY(stg_WEAK_entry);
RTS_ENTRY(stg_DEAD_WEAK_entry);
RTS_ENTRY(stg_STABLE_NAME_entry);
RTS_FUN(finalizzeWeakzh_fast);
RTS_FUN(deRefWeakzh_fast);
-RTS_FUN(mkForeignObjzh_fast);
-
RTS_FUN(newBCOzh_fast);
RTS_FUN(mkApUpd0zh_fast);
closure_field(StgCatchRetryFrame, alt_code);
closure_field(StgCatchRetryFrame, first_code_trec);
- closure_size(StgForeignObj);
- closure_field(StgForeignObj,data);
-
closure_size(StgWeak);
closure_field(StgWeak,link);
closure_field(StgWeak,key);
/* MUT_ARR_PTRS_FROZEN = */ (_HNF| _NS| _UPT ),
/* MUT_VAR = */ (_HNF| _NS| _MUT|_UPT ),
/* WEAK = */ (_HNF| _NS| _UPT ),
-/* FOREIGN = */ (_HNF| _NS| _UPT ),
/* STABLE_NAME = */ (_HNF| _NS| _UPT ),
/* TSO = */ (_HNF| _NS| _MUT|_UPT ),
/* BLOCKED_FETCH = */ (_HNF| _NS| _MUT|_UPT ),
/* CATCH_STM_FRAME = */ ( _BTM )
};
-#if N_CLOSURE_TYPES != 72
+#if N_CLOSURE_TYPES != 71
#error Closure types changed: update ClosureFlags.c!
#endif
break;
case WEAK:
- case FOREIGN:
case STABLE_NAME:
case MVAR:
case MUT_VAR:
case WEAK:
case MUT_VAR:
- case FOREIGN:
case BCO:
case STABLE_NAME:
size = sizeW_fromITBL(info);
#if !defined(PAR)
-#define Maybe_ForeignObj SymX(mkForeignObjzh_fast)
-
#define Maybe_Stable_Names SymX(mkWeakzh_fast) \
SymX(makeStableNamezh_fast) \
SymX(finalizzeWeakzh_fast)
#else
/* These are not available in GUM!!! -- HWL */
-#define Maybe_ForeignObj
#define Maybe_Stable_Names
#endif
#endif
#define RTS_SYMBOLS \
- Maybe_ForeignObj \
Maybe_Stable_Names \
Sym(StgReturn) \
SymX(stg_enter_info) \
}
/* -----------------------------------------------------------------------------
- Foreign Object Primitives
- -------------------------------------------------------------------------- */
-
-mkForeignObjzh_fast
-{
- /* R1 = ptr to foreign object,
- */
- W_ result;
-
- ALLOC_PRIM( SIZEOF_StgForeignObj, NO_PTRS, mkForeignObjzh_fast);
-
- result = Hp - SIZEOF_StgForeignObj + WDS(1);
- SET_HDR(result,stg_FOREIGN_info,W_[CCCS]);
- StgForeignObj_data(result) = R1;
-
- /* returns (# s#, ForeignObj# #) */
- RET_P(result);
-}
-
-/* -----------------------------------------------------------------------------
Weak Pointer Primitives
-------------------------------------------------------------------------- */
/* ToDo: chase 'link' ? */
break;
- case FOREIGN:
- debugBelch("FOREIGN(");
- printPtr((StgPtr)( ((StgForeignObj*)obj)->data ));
- debugBelch(")\n");
- break;
-
case STABLE_NAME:
debugBelch("STABLE_NAME(%ld)\n", ((StgStableName*)obj)->sn);
break;
, "MUT_VAR"
, "WEAK"
- , "FOREIGN"
, "TSO"
case MVAR:
case WEAK:
- case FOREIGN:
case STABLE_NAME:
case MUT_VAR:
prim = rtsTrue;
// layout.payload.ptrs, no SRT
case CONSTR:
- case FOREIGN:
case STABLE_NAME:
case BCO:
case CONSTR_STATIC:
return;
case CONSTR:
- case FOREIGN:
case STABLE_NAME:
case BCO:
case CONSTR_STATIC:
case CONSTR_STATIC:
case FUN_STATIC:
// misc
- case FOREIGN:
case STABLE_NAME:
case BCO:
case ARR_WORDS:
case IND_PERM:
case IND_OLDGEN:
case IND_OLDGEN_PERM:
- case FOREIGN:
case BCO:
case STABLE_NAME:
return sizeW_fromITBL(info);
#endif
case BLACKHOLE:
case CAF_BLACKHOLE:
- case FOREIGN:
case STABLE_NAME:
case MUT_VAR:
case CONSTR_INTLIKE:
CLOSURE(stg_NO_FINALIZER_closure,stg_NO_FINALIZER);
/* ----------------------------------------------------------------------------
- Foreign Objects are unlifted and therefore never entered.
- ------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_FOREIGN,0,1,FOREIGN,"FOREIGN","FOREIGN")
-{ foreign "C" barf("FOREIGN object entered!"); }
-
-/* ----------------------------------------------------------------------------
Stable Names are unlifted too.
------------------------------------------------------------------------- */
projects / ghc-hetmet.git / commitdiff