import EnterCriticalSection;
import LeaveCriticalSection;
import ghczmprim_GHCziBool_False_closure;
+#if !defined(mingw32_HOST_OS)
+import sm_mutex;
+#endif
/*-----------------------------------------------------------------------------
Array Primitives
* round up to the nearest word for the size of the array.
*/
-newByteArrayzh_fast
+stg_newByteArrayzh
{
W_ words, payload_words, n, p;
- MAYBE_GC(NO_PTRS,newByteArrayzh_fast);
+ MAYBE_GC(NO_PTRS,stg_newByteArrayzh);
n = R1;
payload_words = ROUNDUP_BYTES_TO_WDS(n);
words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
- ("ptr" p) = foreign "C" allocateLocal(MyCapability() "ptr",words) [];
+ ("ptr" p) = foreign "C" allocate(MyCapability() "ptr",words) [];
TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
StgArrWords_words(p) = payload_words;
#define BA_ALIGN 16
#define BA_MASK (BA_ALIGN-1)
-newPinnedByteArrayzh_fast
+stg_newPinnedByteArrayzh
{
W_ words, bytes, payload_words, p;
- MAYBE_GC(NO_PTRS,newPinnedByteArrayzh_fast);
+ MAYBE_GC(NO_PTRS,stg_newPinnedByteArrayzh);
bytes = R1;
/* payload_words is what we will tell the profiler we had to allocate */
payload_words = ROUNDUP_BYTES_TO_WDS(bytes);
/* Now we convert to a number of words: */
words = ROUNDUP_BYTES_TO_WDS(bytes);
- ("ptr" p) = foreign "C" allocatePinned(words) [];
+ ("ptr" p) = foreign "C" allocatePinned(MyCapability() "ptr", words) [];
TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
/* Now we need to move p forward so that the payload is aligned
RET_P(p);
}
-newAlignedPinnedByteArrayzh_fast
+stg_newAlignedPinnedByteArrayzh
{
W_ words, bytes, payload_words, p, alignment;
- MAYBE_GC(NO_PTRS,newAlignedPinnedByteArrayzh_fast);
+ MAYBE_GC(NO_PTRS,stg_newAlignedPinnedByteArrayzh);
bytes = R1;
alignment = R2;
/* Now we convert to a number of words: */
words = ROUNDUP_BYTES_TO_WDS(bytes);
- ("ptr" p) = foreign "C" allocatePinned(words) [];
+ ("ptr" p) = foreign "C" allocatePinned(MyCapability() "ptr", words) [];
TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
/* Now we need to move p forward so that the payload is aligned
RET_P(p);
}
-newArrayzh_fast
+stg_newArrayzh
{
- W_ words, n, init, arr, p;
+ W_ words, n, init, arr, p, size;
/* Args: R1 = words, R2 = initialisation value */
n = R1;
- MAYBE_GC(R2_PTR,newArrayzh_fast);
-
- words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + n;
- ("ptr" arr) = foreign "C" allocateLocal(MyCapability() "ptr",words) [R2];
+ MAYBE_GC(R2_PTR,stg_newArrayzh);
+
+ // the mark area contains one byte for each 2^MUT_ARR_PTRS_CARD_BITS words
+ // in the array, making sure we round up, and then rounding up to a whole
+ // number of words.
+ size = n + mutArrPtrsCardWords(n);
+ words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size;
+ ("ptr" arr) = foreign "C" allocate(MyCapability() "ptr",words) [R2];
TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(n), 0);
SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, W_[CCCS]);
StgMutArrPtrs_ptrs(arr) = n;
+ StgMutArrPtrs_size(arr) = size;
// Initialise all elements of the the array with the value in R2
init = R2;
p = p + WDS(1);
goto for;
}
+ // Initialise the mark bits with 0
+ for2:
+ if (p < arr + WDS(size)) {
+ W_[p] = 0;
+ p = p + WDS(1);
+ goto for2;
+ }
RET_P(arr);
}
-unsafeThawArrayzh_fast
+stg_unsafeThawArrayzh
{
// SUBTLETY TO DO WITH THE OLD GEN MUTABLE LIST
//
// A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN
// normally doesn't. However, when we freeze a MUT_ARR_PTRS, we leave
// it on the mutable list for the GC to remove (removing something from
- // the mutable list is not easy, because the mut_list is only singly-linked).
+ // the mutable list is not easy).
//
// So that we can tell whether a MUT_ARR_PTRS_FROZEN is on the mutable list,
// when we freeze it we set the info ptr to be MUT_ARR_PTRS_FROZEN0
MutVar primitives
-------------------------------------------------------------------------- */
-newMutVarzh_fast
+stg_newMutVarzh
{
W_ mv;
/* Args: R1 = initialisation value */
- ALLOC_PRIM( SIZEOF_StgMutVar, R1_PTR, newMutVarzh_fast);
+ ALLOC_PRIM( SIZEOF_StgMutVar, R1_PTR, stg_newMutVarzh);
mv = Hp - SIZEOF_StgMutVar + WDS(1);
SET_HDR(mv,stg_MUT_VAR_DIRTY_info,W_[CCCS]);
RET_P(mv);
}
-atomicModifyMutVarzh_fast
+stg_atomicModifyMutVarzh
{
W_ mv, f, z, x, y, r, h;
/* Args: R1 :: MutVar#, R2 :: a -> (a,b) */
#define SIZE (THUNK_2_SIZE + THUNK_1_SIZE + THUNK_1_SIZE)
- HP_CHK_GEN_TICKY(SIZE, R1_PTR & R2_PTR, atomicModifyMutVarzh_fast);
+ HP_CHK_GEN_TICKY(SIZE, R1_PTR & R2_PTR, stg_atomicModifyMutVarzh);
mv = R1;
f = R2;
STRING(stg_weak_msg,"New weak pointer at %p\n")
-mkWeakzh_fast
+stg_mkWeakzh
{
/* R1 = key
R2 = value
R3 = stg_NO_FINALIZER_closure;
}
- ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR & R3_PTR, mkWeakzh_fast );
+ ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR & R3_PTR, stg_mkWeakzh );
w = Hp - SIZEOF_StgWeak + WDS(1);
SET_HDR(w, stg_WEAK_info, W_[CCCS]);
StgWeak_finalizer(w) = R3;
StgWeak_cfinalizer(w) = stg_NO_FINALIZER_closure;
+ ACQUIRE_LOCK(sm_mutex);
StgWeak_link(w) = W_[weak_ptr_list];
W_[weak_ptr_list] = w;
+ RELEASE_LOCK(sm_mutex);
IF_DEBUG(weak, foreign "C" debugBelch(stg_weak_msg,w) []);
RET_P(w);
}
-mkWeakForeignEnvzh_fast
+stg_mkWeakForeignEnvzh
{
/* R1 = key
R2 = value
flag = R5;
eptr = R6;
- ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR, mkWeakForeignEnvzh_fast );
+ ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR, stg_mkWeakForeignEnvzh );
w = Hp - SIZEOF_StgWeak + WDS(1);
SET_HDR(w, stg_WEAK_info, W_[CCCS]);
payload_words = 4;
words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
- ("ptr" p) = foreign "C" allocateLocal(MyCapability() "ptr", words) [];
+ ("ptr" p) = foreign "C" allocate(MyCapability() "ptr", words) [];
TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
StgWeak_finalizer(w) = stg_NO_FINALIZER_closure;
StgWeak_cfinalizer(w) = p;
+ ACQUIRE_LOCK(sm_mutex);
StgWeak_link(w) = W_[weak_ptr_list];
W_[weak_ptr_list] = w;
+ RELEASE_LOCK(sm_mutex);
IF_DEBUG(weak, foreign "C" debugBelch(stg_weak_msg,w) []);
RET_P(w);
}
-finalizzeWeakzh_fast
+stg_finalizzeWeakzh
{
/* R1 = weak ptr
*/
}
}
-deRefWeakzh_fast
+stg_deRefWeakzh
{
/* R1 = weak ptr */
W_ w, code, val;
Floating point operations.
-------------------------------------------------------------------------- */
-decodeFloatzuIntzh_fast
+stg_decodeFloatzuIntzh
{
W_ p;
F_ arg;
W_ mp_tmp1;
W_ mp_tmp_w;
- STK_CHK_GEN( WDS(2), NO_PTRS, decodeFloatzuIntzh_fast );
+ STK_CHK_GEN( WDS(2), NO_PTRS, stg_decodeFloatzuIntzh );
mp_tmp1 = Sp - WDS(1);
mp_tmp_w = Sp - WDS(2);
RET_NN(W_[mp_tmp1], W_[mp_tmp_w]);
}
-decodeDoublezu2Intzh_fast
+stg_decodeDoublezu2Intzh
{
D_ arg;
W_ p;
W_ mp_result1;
W_ mp_result2;
- STK_CHK_GEN( WDS(4), NO_PTRS, decodeDoublezu2Intzh_fast );
+ STK_CHK_GEN( WDS(4), NO_PTRS, stg_decodeDoublezu2Intzh );
mp_tmp1 = Sp - WDS(1);
mp_tmp2 = Sp - WDS(2);
* Concurrency primitives
* -------------------------------------------------------------------------- */
-forkzh_fast
+stg_forkzh
{
/* args: R1 = closure to spark */
- MAYBE_GC(R1_PTR, forkzh_fast);
+ MAYBE_GC(R1_PTR, stg_forkzh);
W_ closure;
W_ threadid;
closure "ptr") [];
/* start blocked if the current thread is blocked */
- StgTSO_flags(threadid) =
- StgTSO_flags(threadid) | (StgTSO_flags(CurrentTSO) &
- (TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32));
+ StgTSO_flags(threadid) = %lobits16(
+ TO_W_(StgTSO_flags(threadid)) |
+ TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
foreign "C" scheduleThread(MyCapability() "ptr", threadid "ptr") [];
RET_P(threadid);
}
-forkOnzh_fast
+stg_forkOnzh
{
/* args: R1 = cpu, R2 = closure to spark */
- MAYBE_GC(R2_PTR, forkOnzh_fast);
+ MAYBE_GC(R2_PTR, stg_forkOnzh);
W_ cpu;
W_ closure;
closure "ptr") [];
/* start blocked if the current thread is blocked */
- StgTSO_flags(threadid) =
- StgTSO_flags(threadid) | (StgTSO_flags(CurrentTSO) &
- (TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32));
+ StgTSO_flags(threadid) = %lobits16(
+ TO_W_(StgTSO_flags(threadid)) |
+ TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
foreign "C" scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr") [];
RET_P(threadid);
}
-yieldzh_fast
+stg_yieldzh
{
jump stg_yield_noregs;
}
-myThreadIdzh_fast
+stg_myThreadIdzh
{
/* no args. */
RET_P(CurrentTSO);
}
-labelThreadzh_fast
+stg_labelThreadzh
{
/* args:
R1 = ThreadId#
jump %ENTRY_CODE(Sp(0));
}
-isCurrentThreadBoundzh_fast
+stg_isCurrentThreadBoundzh
{
/* no args */
W_ r;
RET_N(r);
}
-threadStatuszh_fast
+stg_threadStatuszh
{
/* args: R1 :: ThreadId# */
W_ tso;
frame = Sp;
trec = StgTSO_trec(CurrentTSO);
- ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+ outer = StgTRecHeader_enclosing_trec(trec);
(r) = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") [];
if (r != 0) {
/* Succeeded (either first branch or second branch) */
frame = Sp;
trec = StgTSO_trec(CurrentTSO);
result = R1;
- ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+ outer = StgTRecHeader_enclosing_trec(trec);
if (outer == NO_TREC) {
/* First time back at the atomically frame -- pick up invariants */
W_ r, frame, trec, outer;
frame = Sp;
trec = StgTSO_trec(CurrentTSO);
- ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+ outer = StgTRecHeader_enclosing_trec(trec);
(r) = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") [];
if (r != 0) {
/* Commit succeeded */
// Primop definition ------------------------------------------------------------
-atomicallyzh_fast
+stg_atomicallyzh
{
W_ frame;
W_ old_trec;
W_ new_trec;
// stmStartTransaction may allocate
- MAYBE_GC (R1_PTR, atomicallyzh_fast);
+ MAYBE_GC (R1_PTR, stg_atomicallyzh);
/* Args: R1 = m :: STM a */
- STK_CHK_GEN(SIZEOF_StgAtomicallyFrame + WDS(1), R1_PTR, atomicallyzh_fast);
+ STK_CHK_GEN(SIZEOF_StgAtomicallyFrame + WDS(1), R1_PTR, stg_atomicallyzh);
old_trec = StgTSO_trec(CurrentTSO);
/* Nested transactions are not allowed; raise an exception */
if (old_trec != NO_TREC) {
R1 = base_ControlziExceptionziBase_nestedAtomically_closure;
- jump raisezh_fast;
+ jump stg_raisezh;
}
/* Set up the atomically frame */
}
-catchSTMzh_fast
+stg_catchSTMzh
{
W_ frame;
/* Args: R1 :: STM a */
/* Args: R2 :: Exception -> STM a */
- STK_CHK_GEN(SIZEOF_StgCatchSTMFrame + WDS(1), R1_PTR & R2_PTR, catchSTMzh_fast);
+ STK_CHK_GEN(SIZEOF_StgCatchSTMFrame + WDS(1), R1_PTR & R2_PTR, stg_catchSTMzh);
/* Set up the catch frame */
Sp = Sp - SIZEOF_StgCatchSTMFrame;
}
-catchRetryzh_fast
+stg_catchRetryzh
{
W_ frame;
W_ new_trec;
W_ trec;
// stmStartTransaction may allocate
- MAYBE_GC (R1_PTR & R2_PTR, catchRetryzh_fast);
+ MAYBE_GC (R1_PTR & R2_PTR, stg_catchRetryzh);
/* Args: R1 :: STM a */
/* Args: R2 :: STM a */
- STK_CHK_GEN(SIZEOF_StgCatchRetryFrame + WDS(1), R1_PTR & R2_PTR, catchRetryzh_fast);
+ STK_CHK_GEN(SIZEOF_StgCatchRetryFrame + WDS(1), R1_PTR & R2_PTR, stg_catchRetryzh);
/* Start a nested transaction within which to run the first code */
trec = StgTSO_trec(CurrentTSO);
}
-retryzh_fast
+stg_retryzh
{
W_ frame_type;
W_ frame;
W_ outer;
W_ r;
- MAYBE_GC (NO_PTRS, retryzh_fast); // STM operations may allocate
+ MAYBE_GC (NO_PTRS, stg_retryzh); // STM operations may allocate
// Find the enclosing ATOMICALLY_FRAME or CATCH_RETRY_FRAME
retry_pop_stack:
Sp = StgTSO_sp(CurrentTSO);
frame = Sp;
trec = StgTSO_trec(CurrentTSO);
- ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+ outer = StgTRecHeader_enclosing_trec(trec);
if (frame_type == CATCH_RETRY_FRAME) {
// The retry reaches a CATCH_RETRY_FRAME before the atomic frame
foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
trec = outer;
StgTSO_trec(CurrentTSO) = trec;
- ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+ outer = StgTRecHeader_enclosing_trec(trec);
}
ASSERT(outer == NO_TREC);
}
-checkzh_fast
+stg_checkzh
{
W_ trec, closure;
/* Args: R1 = invariant closure */
- MAYBE_GC (R1_PTR, checkzh_fast);
+ MAYBE_GC (R1_PTR, stg_checkzh);
trec = StgTSO_trec(CurrentTSO);
closure = R1;
}
-newTVarzh_fast
+stg_newTVarzh
{
W_ tv;
W_ new_value;
/* Args: R1 = initialisation value */
- MAYBE_GC (R1_PTR, newTVarzh_fast);
+ MAYBE_GC (R1_PTR, stg_newTVarzh);
new_value = R1;
("ptr" tv) = foreign "C" stmNewTVar(MyCapability() "ptr", new_value "ptr") [];
RET_P(tv);
}
-readTVarzh_fast
+stg_readTVarzh
{
W_ trec;
W_ tvar;
/* Args: R1 = TVar closure */
- MAYBE_GC (R1_PTR, readTVarzh_fast); // Call to stmReadTVar may allocate
+ MAYBE_GC (R1_PTR, stg_readTVarzh); // Call to stmReadTVar may allocate
trec = StgTSO_trec(CurrentTSO);
tvar = R1;
("ptr" result) = foreign "C" stmReadTVar(MyCapability() "ptr", trec "ptr", tvar "ptr") [];
RET_P(result);
}
-readTVarIOzh_fast
+stg_readTVarIOzh
{
W_ result;
RET_P(result);
}
-writeTVarzh_fast
+stg_writeTVarzh
{
W_ trec;
W_ tvar;
/* Args: R1 = TVar closure */
/* R2 = New value */
- MAYBE_GC (R1_PTR & R2_PTR, writeTVarzh_fast); // Call to stmWriteTVar may allocate
+ MAYBE_GC (R1_PTR & R2_PTR, stg_writeTVarzh); // Call to stmWriteTVar may allocate
trec = StgTSO_trec(CurrentTSO);
tvar = R1;
new_value = R2;
*
* -------------------------------------------------------------------------- */
-isEmptyMVarzh_fast
+stg_isEmptyMVarzh
{
/* args: R1 = MVar closure */
}
}
-newMVarzh_fast
+stg_newMVarzh
{
/* args: none */
W_ mvar;
- ALLOC_PRIM ( SIZEOF_StgMVar, NO_PTRS, newMVarzh_fast );
+ ALLOC_PRIM ( SIZEOF_StgMVar, NO_PTRS, stg_newMVarzh );
mvar = Hp - SIZEOF_StgMVar + WDS(1);
SET_HDR(mvar,stg_MVAR_DIRTY_info,W_[CCCS]);
StgTSO_sp(tso) = StgTSO_sp(tso) + WDS(3); \
lval = W_[StgTSO_sp(tso) - WDS(1)];
-takeMVarzh_fast
+stg_takeMVarzh
{
W_ mvar, val, info, tso;
tso = StgMVar_head(mvar);
PerformPut(tso,StgMVar_value(mvar));
- if (TO_W_(StgTSO_flags(tso)) & TSO_DIRTY == 0) {
+ if (TO_W_(StgTSO_dirty(tso)) == 0) {
foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
}
StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
}
-#if defined(THREADED_RTS)
unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
- SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
RET_P(val);
}
else
/* No further putMVars, MVar is now empty */
StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
-#if defined(THREADED_RTS)
unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
- SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
RET_P(val);
}
}
-tryTakeMVarzh_fast
+stg_tryTakeMVarzh
{
W_ mvar, val, info, tso;
/* actually perform the putMVar for the thread that we just woke up */
tso = StgMVar_head(mvar);
PerformPut(tso,StgMVar_value(mvar));
- if (TO_W_(StgTSO_flags(tso)) & TSO_DIRTY == 0) {
+ if (TO_W_(StgTSO_dirty(tso)) == 0) {
foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
}
if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
}
-#if defined(THREADED_RTS)
unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
- SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
}
else
{
/* No further putMVars, MVar is now empty */
StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
-#if defined(THREADED_RTS)
unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
- SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
}
RET_NP(1, val);
}
-putMVarzh_fast
+stg_putMVarzh
{
W_ mvar, val, info, tso;
/* actually perform the takeMVar */
tso = StgMVar_head(mvar);
PerformTake(tso, val);
- if (TO_W_(StgTSO_flags(tso)) & TSO_DIRTY == 0) {
+ if (TO_W_(StgTSO_dirty(tso)) == 0) {
foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
}
StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
}
-#if defined(THREADED_RTS)
unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
- SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
jump %ENTRY_CODE(Sp(0));
}
else
/* No further takes, the MVar is now full. */
StgMVar_value(mvar) = val;
-#if defined(THREADED_RTS)
unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
- SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
jump %ENTRY_CODE(Sp(0));
}
}
-tryPutMVarzh_fast
+stg_tryPutMVarzh
{
W_ mvar, info, tso;
/* actually perform the takeMVar */
tso = StgMVar_head(mvar);
PerformTake(tso, R2);
- if (TO_W_(StgTSO_flags(tso)) & TSO_DIRTY == 0) {
+ if (TO_W_(StgTSO_dirty(tso)) == 0) {
foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
}
StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
}
-#if defined(THREADED_RTS)
unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
- SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
}
else
{
/* No further takes, the MVar is now full. */
StgMVar_value(mvar) = R2;
-#if defined(THREADED_RTS)
unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
- SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
}
RET_N(1);
Stable pointer primitives
------------------------------------------------------------------------- */
-makeStableNamezh_fast
+stg_makeStableNamezh
{
W_ index, sn_obj;
- ALLOC_PRIM( SIZEOF_StgStableName, R1_PTR, makeStableNamezh_fast );
+ ALLOC_PRIM( SIZEOF_StgStableName, R1_PTR, stg_makeStableNamezh );
(index) = foreign "C" lookupStableName(R1 "ptr") [];
}
-makeStablePtrzh_fast
+stg_makeStablePtrzh
{
/* Args: R1 = a */
W_ sp;
- MAYBE_GC(R1_PTR, makeStablePtrzh_fast);
+ MAYBE_GC(R1_PTR, stg_makeStablePtrzh);
("ptr" sp) = foreign "C" getStablePtr(R1 "ptr") [];
RET_N(sp);
}
-deRefStablePtrzh_fast
+stg_deRefStablePtrzh
{
/* Args: R1 = the stable ptr */
W_ r, sp;
Bytecode object primitives
------------------------------------------------------------------------- */
-newBCOzh_fast
+stg_newBCOzh
{
/* R1 = instrs
R2 = literals
words = BYTES_TO_WDS(SIZEOF_StgBCO) + StgArrWords_words(bitmap_arr);
bytes = WDS(words);
- ALLOC_PRIM( bytes, R1_PTR&R2_PTR&R3_PTR&R5_PTR, newBCOzh_fast );
+ ALLOC_PRIM( bytes, R1_PTR&R2_PTR&R3_PTR&R5_PTR, stg_newBCOzh );
bco = Hp - bytes + WDS(1);
SET_HDR(bco, stg_BCO_info, W_[CCCS]);
}
-mkApUpd0zh_fast
+stg_mkApUpd0zh
{
// R1 = the BCO# for the AP
//
ASSERT(%INFO_TYPE(%GET_STD_INFO(R1)) == HALF_W_(BCO) &&
StgBCO_arity(R1) == HALF_W_(0));
- HP_CHK_GEN_TICKY(SIZEOF_StgAP, R1_PTR, mkApUpd0zh_fast);
+ HP_CHK_GEN_TICKY(SIZEOF_StgAP, R1_PTR, stg_mkApUpd0zh);
TICK_ALLOC_UP_THK(0, 0);
CCCS_ALLOC(SIZEOF_StgAP);
RET_P(ap);
}
-unpackClosurezh_fast
+stg_unpackClosurezh
{
/* args: R1 = closure to analyze */
// TODO: Consider the absence of ptrs or nonptrs as a special case ?
}}
out:
- W_ ptrs_arr_sz, nptrs_arr_sz;
+ W_ ptrs_arr_sz, ptrs_arr_cards, nptrs_arr_sz;
nptrs_arr_sz = SIZEOF_StgArrWords + WDS(nptrs);
- ptrs_arr_sz = SIZEOF_StgMutArrPtrs + WDS(ptrs);
+ ptrs_arr_cards = mutArrPtrsCardWords(ptrs);
+ ptrs_arr_sz = SIZEOF_StgMutArrPtrs + WDS(ptrs) + WDS(ptrs_arr_cards);
- ALLOC_PRIM (ptrs_arr_sz + nptrs_arr_sz, R1_PTR, unpackClosurezh_fast);
+ ALLOC_PRIM (ptrs_arr_sz + nptrs_arr_sz, R1_PTR, stg_unpackClosurezh);
W_ clos;
clos = UNTAG(R1);
SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, W_[CCCS]);
StgMutArrPtrs_ptrs(ptrs_arr) = ptrs;
+ StgMutArrPtrs_size(ptrs_arr) = ptrs + ptrs_arr_cards;
+
p = 0;
for:
if(p < ptrs) {
p = p + 1;
goto for;
}
+ /* We can leave the card table uninitialised, since the array is
+ allocated in the nursery. The GC will fill it in if/when the array
+ is promoted. */
SET_HDR(nptrs_arr, stg_ARR_WORDS_info, W_[CCCS]);
StgArrWords_words(nptrs_arr) = nptrs;
} \
W_[blocked_queue_tl] = tso;
-waitReadzh_fast
+stg_waitReadzh
{
/* args: R1 */
#ifdef THREADED_RTS
#endif
}
-waitWritezh_fast
+stg_waitWritezh
{
/* args: R1 */
#ifdef THREADED_RTS
}
-STRING(stg_delayzh_malloc_str, "delayzh_fast")
-delayzh_fast
+STRING(stg_delayzh_malloc_str, "stg_delayzh")
+stg_delayzh
{
#ifdef mingw32_HOST_OS
W_ ares;
#ifdef mingw32_HOST_OS
-STRING(stg_asyncReadzh_malloc_str, "asyncReadzh_fast")
-asyncReadzh_fast
+STRING(stg_asyncReadzh_malloc_str, "stg_asyncReadzh")
+stg_asyncReadzh
{
W_ ares;
CInt reqID;
#endif
}
-STRING(stg_asyncWritezh_malloc_str, "asyncWritezh_fast")
-asyncWritezh_fast
+STRING(stg_asyncWritezh_malloc_str, "stg_asyncWritezh")
+stg_asyncWritezh
{
W_ ares;
CInt reqID;
#endif
}
-STRING(stg_asyncDoProczh_malloc_str, "asyncDoProczh_fast")
-asyncDoProczh_fast
+STRING(stg_asyncDoProczh_malloc_str, "stg_asyncDoProczh")
+stg_asyncDoProczh
{
W_ ares;
CInt reqID;
}
#endif
-// noDuplicate# tries to ensure that none of the thunks under
-// evaluation by the current thread are also under evaluation by
-// another thread. It relies on *both* threads doing noDuplicate#;
-// the second one will get blocked if they are duplicating some work.
-noDuplicatezh_fast
+/* -----------------------------------------------------------------------------
+ * noDuplicate#
+ *
+ * noDuplicate# tries to ensure that none of the thunks under
+ * evaluation by the current thread are also under evaluation by
+ * another thread. It relies on *both* threads doing noDuplicate#;
+ * the second one will get blocked if they are duplicating some work.
+ *
+ * The idea is that noDuplicate# is used within unsafePerformIO to
+ * ensure that the IO operation is performed at most once.
+ * noDuplicate# calls threadPaused which acquires an exclusive lock on
+ * all the thunks currently under evaluation by the current thread.
+ *
+ * Consider the following scenario. There is a thunk A, whose
+ * evaluation requires evaluating thunk B, where thunk B is an
+ * unsafePerformIO. Two threads, 1 and 2, bother enter A. Thread 2
+ * is pre-empted before it enters B, and claims A by blackholing it
+ * (in threadPaused). Thread 1 now enters B, and calls noDuplicate#.
+ *
+ * thread 1 thread 2
+ * +-----------+ +---------------+
+ * | -------+-----> A <-------+------- |
+ * | update | BLACKHOLE | marked_update |
+ * +-----------+ +---------------+
+ * | | | |
+ * ... ...
+ * | | +---------------+
+ * +-----------+
+ * | ------+-----> B
+ * | update | BLACKHOLE
+ * +-----------+
+ *
+ * At this point: A is a blackhole, owned by thread 2. noDuplicate#
+ * calls threadPaused, which walks up the stack and
+ * - claims B on behalf of thread 1
+ * - then it reaches the update frame for A, which it sees is already
+ * a BLACKHOLE and is therefore owned by another thread. Since
+ * thread 1 is duplicating work, the computation up to the update
+ * frame for A is suspended, including thunk B.
+ * - thunk B, which is an unsafePerformIO, has now been reverted to
+ * an AP_STACK which could be duplicated - BAD!
+ * - The solution is as follows: before calling threadPaused, we
+ * leave a frame on the stack (stg_noDuplicate_info) that will call
+ * noDuplicate# again if the current computation is suspended and
+ * restarted.
+ *
+ * See the test program in concurrent/prog003 for a way to demonstrate
+ * this. It needs to be run with +RTS -N3 or greater, and the bug
+ * only manifests occasionally (once very 10 runs or so).
+ * -------------------------------------------------------------------------- */
+
+INFO_TABLE_RET(stg_noDuplicate, RET_SMALL)
+{
+ Sp_adj(1);
+ jump stg_noDuplicatezh;
+}
+
+stg_noDuplicatezh
{
+ STK_CHK_GEN( WDS(1), NO_PTRS, stg_noDuplicatezh );
+ // leave noDuplicate frame in case the current
+ // computation is suspended and restarted (see above).
+ Sp_adj(-1);
+ Sp(0) = stg_noDuplicate_info;
+
SAVE_THREAD_STATE();
ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
foreign "C" threadPaused (MyCapability() "ptr", CurrentTSO "ptr") [];
} else {
LOAD_THREAD_STATE();
ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
+ // remove the stg_noDuplicate frame if it is still there.
+ if (Sp(0) == stg_noDuplicate_info) {
+ Sp_adj(1);
+ }
jump %ENTRY_CODE(Sp(0));
}
}
-getApStackValzh_fast
+/* -----------------------------------------------------------------------------
+ Misc. primitives
+ -------------------------------------------------------------------------- */
+
+stg_getApStackValzh
{
W_ ap_stack, offset, val, ok;
RET_NP(ok,val);
}
-/* -----------------------------------------------------------------------------
- Misc. primitives
- -------------------------------------------------------------------------- */
-
// Write the cost center stack of the first argument on stderr; return
// the second. Possibly only makes sense for already evaluated
// things?
-traceCcszh_fast
+stg_traceCcszh
{
W_ ccs;
ENTER();
}
-getSparkzh_fast
+stg_getSparkzh
{
W_ spark;
}
#endif
}
+
+stg_traceEventzh
+{
+ W_ msg;
+ msg = R1;
+
+#if defined(TRACING) || defined(DEBUG)
+
+ foreign "C" traceUserMsg(MyCapability() "ptr", msg "ptr") [];
+
+#elif defined(DTRACE)
+
+ W_ enabled;
+
+ // We should go through the macro HASKELLEVENT_USER_MSG_ENABLED from
+ // RtsProbes.h, but that header file includes unistd.h, which doesn't
+ // work in Cmm
+ (enabled) = foreign "C" __dtrace_isenabled$HaskellEvent$user__msg$v1() [];
+ if (enabled != 0) {
+ foreign "C" dtraceUserMsgWrapper(MyCapability() "ptr", msg "ptr") [];
+ }
+
+#endif
+ jump %ENTRY_CODE(Sp(0));
+}
projects / ghc-hetmet.git / blobdiff