#include "PosixSource.h"
#include "Rts.h"
-#include "OSThreads.h"
#include "RtsAPI.h"
-#include "SchedAPI.h"
-#include "RtsFlags.h"
+#include "HsFFI.h"
+
#include "RtsUtils.h"
#include "Prelude.h"
#include "Schedule.h"
#include "Capability.h"
#include "Stable.h"
-
-#include <stdlib.h>
+#include "Weak.h"
/* ----------------------------------------------------------------------------
Building Haskell objects from C datatypes.
HaskellObj
rts_mkChar (Capability *cap, HsChar c)
{
- StgClosure *p = (StgClosure *)allocateLocal(cap, CONSTR_sizeW(0,1));
+ StgClosure *p = (StgClosure *)allocate(cap, CONSTR_sizeW(0,1));
SET_HDR(p, Czh_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)(StgWord)(StgChar)c;
return p;
HaskellObj
rts_mkInt (Capability *cap, HsInt i)
{
- StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, Izh_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)(StgInt)i;
return p;
HaskellObj
rts_mkInt8 (Capability *cap, HsInt8 i)
{
- StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, I8zh_con_info, CCS_SYSTEM);
/* Make sure we mask out the bits above the lowest 8 */
p->payload[0] = (StgClosure *)(StgInt)i;
HaskellObj
rts_mkInt16 (Capability *cap, HsInt16 i)
{
- StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, I16zh_con_info, CCS_SYSTEM);
/* Make sure we mask out the relevant bits */
p->payload[0] = (StgClosure *)(StgInt)i;
HaskellObj
rts_mkInt32 (Capability *cap, HsInt32 i)
{
- StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, I32zh_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)(StgInt)i;
return p;
}
-
-#ifdef sparc_HOST_ARCH
-/* The closures returned by allocateLocal are only guaranteed to be 32 bit
- aligned, because that's the size of pointers. SPARC v9 can't do
- misaligned loads/stores, so we have to write the 64bit word in chunks */
-
-HaskellObj
-rts_mkInt64 (Capability *cap, HsInt64 i_)
-{
- StgInt64 i = (StgInt64)i_;
- StgInt32 *tmp;
-
- StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
- SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
-
- tmp = (StgInt32*)&(p->payload[0]);
-
- tmp[0] = (StgInt32)((StgInt64)i >> 32);
- tmp[1] = (StgInt32)i; /* truncate high 32 bits */
-
- return p;
-}
-
-#else
-
HaskellObj
rts_mkInt64 (Capability *cap, HsInt64 i)
{
- llong *tmp;
- StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
+ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,2));
SET_HDR(p, I64zh_con_info, CCS_SYSTEM);
- tmp = (llong*)&(p->payload[0]);
- *tmp = (StgInt64)i;
+ ASSIGN_Int64((P_)&(p->payload[0]), i);
return p;
}
-#endif /* sparc_HOST_ARCH */
-
-
HaskellObj
rts_mkWord (Capability *cap, HsWord i)
{
- StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, Wzh_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)(StgWord)i;
return p;
rts_mkWord8 (Capability *cap, HsWord8 w)
{
/* see rts_mkInt* comments */
- StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, W8zh_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
return p;
rts_mkWord16 (Capability *cap, HsWord16 w)
{
/* see rts_mkInt* comments */
- StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, W16zh_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
return p;
rts_mkWord32 (Capability *cap, HsWord32 w)
{
/* see rts_mkInt* comments */
- StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, W32zh_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff);
return p;
}
-
-#ifdef sparc_HOST_ARCH
-/* The closures returned by allocateLocal are only guaranteed to be 32 bit
- aligned, because that's the size of pointers. SPARC v9 can't do
- misaligned loads/stores, so we have to write the 64bit word in chunks */
-
-HaskellObj
-rts_mkWord64 (Capability *cap, HsWord64 w_)
-{
- StgWord64 w = (StgWord64)w_;
- StgWord32 *tmp;
-
- StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
- /* see mk_Int8 comment */
- SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
-
- tmp = (StgWord32*)&(p->payload[0]);
-
- tmp[0] = (StgWord32)((StgWord64)w >> 32);
- tmp[1] = (StgWord32)w; /* truncate high 32 bits */
- return p;
-}
-
-#else
-
HaskellObj
rts_mkWord64 (Capability *cap, HsWord64 w)
{
- ullong *tmp;
-
- StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,2));
+ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,2));
/* see mk_Int8 comment */
SET_HDR(p, W64zh_con_info, CCS_SYSTEM);
- tmp = (ullong*)&(p->payload[0]);
- *tmp = (StgWord64)w;
+ ASSIGN_Word64((P_)&(p->payload[0]), w);
return p;
}
-#endif
-
HaskellObj
rts_mkFloat (Capability *cap, HsFloat f)
{
- StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,1));
+ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1));
SET_HDR(p, Fzh_con_info, CCS_SYSTEM);
ASSIGN_FLT((P_)p->payload, (StgFloat)f);
return p;
HaskellObj
rts_mkDouble (Capability *cap, HsDouble d)
{
- StgClosure *p = (StgClosure *)allocateLocal(cap,CONSTR_sizeW(0,sizeofW(StgDouble)));
+ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,sizeofW(StgDouble)));
SET_HDR(p, Dzh_con_info, CCS_SYSTEM);
ASSIGN_DBL((P_)p->payload, (StgDouble)d);
return p;
HaskellObj
rts_mkStablePtr (Capability *cap, HsStablePtr s)
{
- StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
+ StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
SET_HDR(p, StablePtr_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)s;
return p;
HaskellObj
rts_mkPtr (Capability *cap, HsPtr a)
{
- StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
+ StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
SET_HDR(p, Ptr_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)a;
return p;
HaskellObj
rts_mkFunPtr (Capability *cap, HsFunPtr a)
{
- StgClosure *p = (StgClosure *)allocateLocal(cap,sizeofW(StgHeader)+1);
+ StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1);
SET_HDR(p, FunPtr_con_info, CCS_SYSTEM);
p->payload[0] = (StgClosure *)a;
return p;
{
StgThunk *ap;
- ap = (StgThunk *)allocateLocal(cap,sizeofW(StgThunk) + 2);
+ ap = (StgThunk *)allocate(cap,sizeofW(StgThunk) + 2);
SET_HDR(ap, (StgInfoTable *)&stg_ap_2_upd_info, CCS_SYSTEM);
ap->payload[0] = f;
ap->payload[1] = arg;
return (HsInt32)(HsInt)(UNTAG_CLOSURE(p)->payload[0]);
}
-
-#ifdef sparc_HOST_ARCH
-/* The closures returned by allocateLocal are only guaranteed to be 32 bit
- aligned, because that's the size of pointers. SPARC v9 can't do
- misaligned loads/stores, so we have to read the 64bit word in chunks */
-
HsInt64
rts_getInt64 (HaskellObj p)
{
- HsInt32* tmp;
// See comment above:
// ASSERT(p->header.info == I64zh_con_info ||
// p->header.info == I64zh_static_info);
- tmp = (HsInt32*)&(UNTAG_CLOSURE(p)->payload[0]);
-
- HsInt64 i = (HsInt64)((HsInt64)(tmp[0]) << 32) | (HsInt64)tmp[1];
- return i;
+ return PK_Int64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
}
-#else
-
-HsInt64
-rts_getInt64 (HaskellObj p)
-{
- HsInt64* tmp;
- // See comment above:
- // ASSERT(p->header.info == I64zh_con_info ||
- // p->header.info == I64zh_static_info);
- tmp = (HsInt64*)&(UNTAG_CLOSURE(p)->payload[0]);
- return *tmp;
-}
-
-#endif /* sparc_HOST_ARCH */
-
-
HsWord
rts_getWord (HaskellObj p)
{
return (HsWord32)(HsWord)(UNTAG_CLOSURE(p)->payload[0]);
}
-
-#ifdef sparc_HOST_ARCH
-/* The closures returned by allocateLocal are only guaranteed to be 32 bit
- aligned, because that's the size of pointers. SPARC v9 can't do
- misaligned loads/stores, so we have to write the 64bit word in chunks */
-
-HsWord64
-rts_getWord64 (HaskellObj p)
-{
- HsInt32* tmp;
- // See comment above:
- // ASSERT(p->header.info == I64zh_con_info ||
- // p->header.info == I64zh_static_info);
- tmp = (HsInt32*)&(UNTAG_CLOSURE(p)->payload[0]);
-
- HsInt64 i = (HsWord64)((HsWord64)(tmp[0]) << 32) | (HsWord64)tmp[1];
- return i;
-}
-
-#else
-
HsWord64
rts_getWord64 (HaskellObj p)
{
- HsWord64* tmp;
// See comment above:
// ASSERT(p->header.info == W64zh_con_info ||
// p->header.info == W64zh_static_info);
- tmp = (HsWord64*)&(UNTAG_CLOSURE(p)->payload[0]);
- return *tmp;
+ return PK_Word64((P_)&(UNTAG_CLOSURE(p)->payload[0]));
}
-#endif
-
-
HsFloat
rts_getFloat (HaskellObj p)
{
createGenThread (Capability *cap, nat stack_size, StgClosure *closure)
{
StgTSO *t;
-#if defined(GRAN)
- t = createThread (cap, stack_size, NO_PRI);
-#else
t = createThread (cap, stack_size);
-#endif
pushClosure(t, (W_)closure);
pushClosure(t, (W_)&stg_enter_info);
return t;
createIOThread (Capability *cap, nat stack_size, StgClosure *closure)
{
StgTSO *t;
-#if defined(GRAN)
- t = createThread (cap, stack_size, NO_PRI);
-#else
t = createThread (cap, stack_size);
-#endif
pushClosure(t, (W_)&stg_noforceIO_info);
pushClosure(t, (W_)&stg_ap_v_info);
pushClosure(t, (W_)closure);
createStrictIOThread(Capability *cap, nat stack_size, StgClosure *closure)
{
StgTSO *t;
-#if defined(GRAN)
- t = createThread(cap, stack_size, NO_PRI);
-#else
t = createThread(cap, stack_size);
-#endif
pushClosure(t, (W_)&stg_forceIO_info);
pushClosure(t, (W_)&stg_ap_v_info);
pushClosure(t, (W_)closure);
Capability *cap;
Task *task;
- // ToDo: get rid of this lock in the common case. We could store
- // a free Task in thread-local storage, for example. That would
- // leave just one lock on the path into the RTS: cap->lock when
- // acquiring the Capability.
- ACQUIRE_LOCK(&sched_mutex);
+ if (running_finalizers) {
+ errorBelch("error: a C finalizer called back into Haskell.\n"
+ " This was previously allowed, but is disallowed in GHC 6.10.2 and later.\n"
+ " To create finalizers that may call back into Haskll, use\n"
+ " Foreign.Concurrent.newForeignPtr instead of Foreign.newForeignPtr.");
+ stg_exit(EXIT_FAILURE);
+ }
+
task = newBoundTask();
- RELEASE_LOCK(&sched_mutex);
cap = NULL;
waitForReturnCapability(&cap, task);
projects / ghc-hetmet.git / blobdiff