% -----------------------------------------------------------------------------
-% $Id: PrelException.lhs,v 1.12 2000/03/13 10:54:49 simonmar Exp $
+% $Id: PrelException.lhs,v 1.13 2000/03/16 17:27:13 simonmar Exp $
%
% (c) The GRAP/AQUA Project, Glasgow University, 1998
%
| AssertionFailed String -- Assertions
| DynException Dynamic -- Dynamic exceptions
| AsyncException AsyncException -- Externally generated errors
- | PutFullMVar -- Put on a full MVar
+ | PutFullMVar -- Put on a full MVar
+ | BlockedOnDeadMVar -- Blocking on a dead MVar
| NonTermination
data ArithException
showsPrec _ (AsyncException e) = shows e
showsPrec _ (DynException _err) = showString "unknown exception"
showsPrec _ (PutFullMVar) = showString "putMVar: full MVar"
+ showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
showsPrec _ (NonTermination) = showString "<<loop>>"
-- Primitives:
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.72 2000/01/22 18:00:03 simonmar Exp $
+ * $Id: GC.c,v 1.73 2000/03/16 17:27:12 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
#include "SchedAPI.h"
#include "Weak.h"
#include "StablePriv.h"
+#include "Prelude.h"
#if defined(GRAN) || defined(PAR)
# include "GranSimRts.h"
# include "ParallelRts.h"
*/
static nat evac_gen;
-/* WEAK POINTERS
+/* Weak pointers
*/
static StgWeak *old_weak_ptr_list; /* also pending finaliser list */
static rtsBool weak_done; /* all done for this pass */
+/* List of all threads during GC
+ */
+static StgTSO *old_all_threads;
+static StgTSO *resurrected_threads;
+
/* Flag indicating failure to evacuate an object to the desired
* generation.
*/
*/
bdescr *old_to_space;
+
/* Data used for allocation area sizing.
*/
lnat new_blocks; /* blocks allocated during this GC */
weak_ptr_list = NULL;
weak_done = rtsFalse;
+ /* The all_threads list is like the weak_ptr_list.
+ * See traverse_weak_ptr_list() for the details.
+ */
+ old_all_threads = all_threads;
+ all_threads = END_TSO_QUEUE;
+ resurrected_threads = END_TSO_QUEUE;
+
/* Mark the stable pointer table.
*/
markStablePtrTable(major_gc);
/* start any pending finalizers */
scheduleFinalizers(old_weak_ptr_list);
+ /* send exceptions to any threads which were about to die */
+ resurrectThreads(resurrected_threads);
+
/* check sanity after GC */
IF_DEBUG(sanity, checkSanity(N));
continue;
}
}
-
+
+ /* Now deal with the all_threads list, which behaves somewhat like
+ * the weak ptr list. If we discover any threads that are about to
+ * become garbage, we wake them up and administer an exception.
+ */
+ {
+ StgTSO *t, *tmp, *next, **prev;
+
+ prev = &old_all_threads;
+ for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
+
+ /* Threads which have finished or died get dropped from
+ * the list.
+ */
+ switch (t->whatNext) {
+ case ThreadKilled:
+ case ThreadComplete:
+ next = t->global_link;
+ *prev = next;
+ continue;
+ default:
+ }
+
+ /* Threads which have already been determined to be alive are
+ * moved onto the all_threads list.
+ */
+ (StgClosure *)tmp = isAlive((StgClosure *)t);
+ if (tmp != NULL) {
+ next = tmp->global_link;
+ tmp->global_link = all_threads;
+ all_threads = tmp;
+ *prev = next;
+ } else {
+ prev = &(t->global_link);
+ next = t->global_link;
+ }
+ }
+ }
+
/* If we didn't make any changes, then we can go round and kill all
* the dead weak pointers. The old_weak_ptr list is used as a list
* of pending finalizers later on.
for (w = old_weak_ptr_list; w; w = w->link) {
w->finalizer = evacuate(w->finalizer);
}
+
+ /* And resurrect any threads which were about to become garbage.
+ */
+ {
+ StgTSO *t, *tmp, *next;
+ for (t = old_all_threads; t != END_TSO_QUEUE; t = next) {
+ next = t->global_link;
+ (StgClosure *)tmp = evacuate((StgClosure *)t);
+ tmp->global_link = resurrected_threads;
+ resurrected_threads = tmp;
+ }
+ }
+
weak_done = rtsTrue;
}
isAlive(StgClosure *p)
{
const StgInfoTable *info;
+ nat size;
while (1) {
/* alive! */
return ((StgEvacuated *)p)->evacuee;
+ case BCO:
+ size = bco_sizeW((StgBCO*)p);
+ goto large;
+
+ case ARR_WORDS:
+ size = arr_words_sizeW((StgArrWords *)p);
+ goto large;
+
+ case MUT_ARR_PTRS:
+ case MUT_ARR_PTRS_FROZEN:
+ size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)p);
+ goto large;
+
+ case TSO:
+ if (((StgTSO *)p)->whatNext == ThreadRelocated) {
+ p = (StgClosure *)((StgTSO *)p)->link;
+ continue;
+ }
+
+ size = tso_sizeW((StgTSO *)p);
+ large:
+ if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)
+ && Bdescr((P_)p)->evacuated)
+ return p;
+ else
+ return NULL;
+
default:
/* dead. */
return NULL;
case IND_PERM:
case IND_OLDGEN:
case IND_OLDGEN_PERM:
- selectee = stgCast(StgInd *,selectee)->indirectee;
+ selectee = ((StgInd *)selectee)->indirectee;
goto selector_loop;
case CAF_ENTERED:
- selectee = stgCast(StgCAF *,selectee)->value;
+ selectee = ((StgCAF *)selectee)->value;
goto selector_loop;
case EVACUATED:
- selectee = stgCast(StgEvacuated*,selectee)->evacuee;
+ selectee = ((StgEvacuated *)selectee)->evacuee;
goto selector_loop;
case THUNK:
case PAP:
/* these are special - the payload is a copy of a chunk of stack,
tagging and all. */
- return copy(q,pap_sizeW(stgCast(StgPAP*,q)),step);
+ return copy(q,pap_sizeW((StgPAP *)q),step);
case EVACUATED:
/* Already evacuated, just return the forwarding address.
case ARR_WORDS:
{
- nat size = arr_words_sizeW(stgCast(StgArrWords*,q));
+ nat size = arr_words_sizeW((StgArrWords *)q);
if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
evacuate_large((P_)q, rtsFalse);
case MUT_ARR_PTRS:
case MUT_ARR_PTRS_FROZEN:
{
- nat size = mut_arr_ptrs_sizeW(stgCast(StgMutArrPtrs*,q));
+ nat size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)q);
if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
evacuate_large((P_)q, info->type == MUT_ARR_PTRS);
* srt field in the info table. That's ok, because we'll
* never dereference it.
*/
- srt = stgCast(StgClosure **,info->srt);
+ srt = (StgClosure **)(info->srt);
srt_end = srt + info->srt_len;
for (; srt < srt_end; srt++) {
/* Special-case to handle references to closures hiding out in DLLs, since
closure that's fixed at link-time, and no extra magic is required.
*/
#ifdef ENABLE_WIN32_DLL_SUPPORT
- if ( stgCast(unsigned long,*srt) & 0x1 ) {
+ if ( (unsigned long)(*srt) & 0x1 ) {
evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
} else {
evacuate(*srt);
case BCO:
{
- StgBCO* bco = stgCast(StgBCO*,p);
+ StgBCO* bco = (StgBCO *)p;
nat i;
for (i = 0; i < bco->n_ptrs; i++) {
bcoConstCPtr(bco,i) = evacuate(bcoConstCPtr(bco,i));
* evacuate the function pointer too...
*/
{
- StgPAP* pap = stgCast(StgPAP*,p);
+ StgPAP* pap = (StgPAP *)p;
pap->fun = evacuate(pap->fun);
scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
case ARR_WORDS:
/* nothing to follow */
- p += arr_words_sizeW(stgCast(StgArrWords*,p));
+ p += arr_words_sizeW((StgArrWords *)p);
break;
case MUT_ARR_PTRS:
if (! LOOKS_LIKE_GHC_INFO(q) ) {
#ifdef DEBUG
if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) { /* Is it a static closure? */
- ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
+ ASSERT(closure_STATIC((StgClosure *)q));
}
/* otherwise, must be a pointer into the allocation space. */
#endif
dbl_link_onto(bd, &step->scavenged_large_objects);
p = bd->start;
- info = get_itbl(stgCast(StgClosure*,p));
+ info = get_itbl((StgClosure *)p);
switch (info->type) {
case BCO:
{
- StgBCO* bco = stgCast(StgBCO*,p);
+ StgBCO* bco = (StgBCO *)p;
nat i;
evac_gen = saved_evac_gen;
for (i = 0; i < bco->n_ptrs; i++) {
enteredCAFs = caf->link;
ASSERT(get_itbl(caf)->type == CAF_ENTERED);
SET_INFO(caf,&CAF_UNENTERED_info);
- caf->value = stgCast(StgClosure*,0xdeadbeef);
- caf->link = stgCast(StgCAF*,0xdeadbeef);
+ caf->value = (StgClosure *)0xdeadbeef;
+ caf->link = (StgCAF *)0xdeadbeef;
}
enteredCAFs = END_CAF_LIST;
}
switch (get_itbl(update_frame)->type) {
case CATCH_FRAME:
- update_frame = stgCast(StgCatchFrame*,update_frame)->link;
+ update_frame = ((StgCatchFrame *)update_frame)->link;
break;
case UPDATE_FRAME:
break;
case SEQ_FRAME:
- update_frame = stgCast(StgSeqFrame*,update_frame)->link;
+ update_frame = ((StgSeqFrame *)update_frame)->link;
break;
case STOP_FRAME:
/* -----------------------------------------------------------------------------
- * $Id: Prelude.c,v 1.2 2000/03/14 14:34:47 sewardj Exp $
+ * $Id: Prelude.c,v 1.3 2000/03/16 17:27:13 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
const StgClosure *ind_stackOverflow_closure;
const StgClosure *ind_heapOverflow_closure;
const StgClosure *ind_PutFullMVar_static_closure;
+const StgClosure *ind_BlockedOnDeadMVar_static_closure;
const StgClosure *ind_NonTermination_static_closure;
const StgClosure *ind_mainIO_closure;
ind_True_static_closure = NULL; /* True_static_closure; */
ind_False_static_closure = NULL; /* False_static_closure; */
ind_PutFullMVar_static_closure = NULL; /* PutFullMVar_static_closure; */
+ ind_BlockedOnDeadMVar_static_closure = NULL; /* BlockedOnDeadMVar_static_closure; */
ind_NonTermination_static_closure = NULL; /* NonTermination_static_closure; */
ind_unpackCString_closure = NULL; /* unpackCString_closure; */
= ask("PrelBase_False_static_closure");
ind_PutFullMVar_static_closure
= ask("PrelException_PutFullMVar_static_closure");
+ ind_BlockedOnDeadMVar_static_closure
+ = ask("PrelException_BlockedOnDeadMVar_static_closure");
ind_NonTermination_static_closure
= ask("PrelException_NonTermination_static_closure");
/* -----------------------------------------------------------------------------
- * $Id: Prelude.h,v 1.4 2000/03/14 14:34:47 sewardj Exp $
+ * $Id: Prelude.h,v 1.5 2000/03/16 17:27:13 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
extern DLL_IMPORT const StgClosure PrelPack_unpackCString_closure;
extern DLL_IMPORT const StgClosure PrelException_stackOverflow_closure;
extern DLL_IMPORT const StgClosure PrelException_heapOverflow_closure;
+extern const StgClosure PrelMain_mainIO_closure;
+
extern DLL_IMPORT const StgClosure PrelException_PutFullMVar_static_closure;
+extern DLL_IMPORT const StgClosure PrelException_BlockedOnDeadMVar_static_closure;
extern DLL_IMPORT const StgClosure PrelException_NonTermination_static_closure;
-extern const StgClosure PrelMain_mainIO_closure;
extern DLL_IMPORT const StgInfoTable PrelBase_Czh_static_info;
extern DLL_IMPORT const StgInfoTable PrelBase_Izh_static_info;
#define stackOverflow_closure (&PrelException_stackOverflow_closure)
#define heapOverflow_closure (&PrelException_heapOverflow_closure)
#define PutFullMVar_closure (&PrelException_PutFullMVar_static_closure)
+#define BlockedOnDeadMVar_closure (&PrelException_BlockedOnDeadMVar_static_closure)
#define NonTermination_closure (&PrelException_NonTermination_static_closure)
#define Czh_static_info (&PrelBase_Czh_static_info)
#define Izh_static_info (&PrelBase_Izh_static_info)
extern const StgClosure *ind_stackOverflow_closure;
extern const StgClosure *ind_heapOverflow_closure;
extern const StgClosure *ind_PutFullMVar_static_closure;
+extern const StgClosure *ind_BlockedOnDeadMVar_static_closure;
extern const StgClosure *ind_NonTermination_static_closure;
extern const StgInfoTable *ind_Czh_static_info;
#define stackOverflow_closure ind_stackOverflow_closure
#define heapOverflow_closure ind_heapOverflow_closure
#define PutFullMVar_closure ind_PutFullMVar_static_closure
+#define BlockedOnDeadMVar_closure ind_BlockedOnDeadMVar_static_closure
#define NonTermination_closure ind_NonTermination_static_closure
#define Czh_static_info ind_Czh_static_info
#define Izh_static_info ind_Izh_static_info
/* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.52 2000/03/14 09:55:05 simonmar Exp $
+ * $Id: Schedule.c,v 1.53 2000/03/16 17:27:13 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
/* Thread queues.
* Locks required: sched_mutex.
*/
-
#if defined(GRAN)
StgTSO* ActiveTSO = NULL; /* for assigning system costs; GranSim-Light only */
StgTSO *run_queue_hds[MAX_PROC], *run_queue_tls[MAX_PROC];
StgTSO *blocked_queue_hds[MAX_PROC], *blocked_queue_tls[MAX_PROC];
StgTSO *ccalling_threadss[MAX_PROC];
+StgTSO *all_threadss[MAX_PROC];
#else /* !GRAN */
-//@cindex run_queue_hd
-//@cindex run_queue_tl
-//@cindex blocked_queue_hd
-//@cindex blocked_queue_tl
StgTSO *run_queue_hd, *run_queue_tl;
StgTSO *blocked_queue_hd, *blocked_queue_tl;
+/* Linked list of all threads.
+ * Used for detecting garbage collected threads.
+ */
+StgTSO *all_threads;
+
/* Threads suspended in _ccall_GC.
- * Locks required: sched_mutex.
*/
static StgTSO *suspended_ccalling_threads;
while (1) {
#endif
+ IF_DEBUG(scheduler, printAllThreads());
+
/* If we're interrupted (the user pressed ^C, or some other
* termination condition occurred), kill all the currently running
* threads.
size = MIN_STACK_WORDS + TSO_STRUCT_SIZEW;
}
- tso = (StgTSO *)allocate(size);
- TICK_ALLOC_TSO(size-sizeofW(StgTSO),0);
-
stack_size = size - TSO_STRUCT_SIZEW;
- // Hmm, this CCS_MAIN is not protected by a PROFILING cpp var;
+ tso = (StgTSO *)allocate(size);
+ TICK_ALLOC_TSO(size-TSO_STRUCT_SIZEW, 0);
+
SET_HDR(tso, &TSO_info, CCS_MAIN);
#if defined(GRAN)
SET_GRAN_HDR(tso, ThisPE);
tso->whatNext = ThreadEnterGHC;
/* tso->id needs to be unique. For now we use a heavyweight mutex to
- protect the increment operation on next_thread_id.
- In future, we could use an atomic increment instead.
- */
-
+ * protect the increment operation on next_thread_id.
+ * In future, we could use an atomic increment instead.
+ */
if (!have_lock) { ACQUIRE_LOCK(&sched_mutex); }
tso->id = next_thread_id++;
if (!have_lock) { RELEASE_LOCK(&sched_mutex); }
insertThread(tso, CurrentProc);
#else
/* In a non-GranSim setup the pushing of a TSO onto the runq is separated
- from its creation
- */
+ * from its creation
+ */
+#endif
+
+ /* Link the new thread on the global thread list.
+ */
+#if defined(GRAN)
+#error ToDo
+#else
+ tso->global_link = all_threads;
+ all_threads = tso;
#endif
#if defined(GRAN)
suspended_ccalling_threads = END_TSO_QUEUE;
main_threads = NULL;
+ all_threads = END_TSO_QUEUE;
context_switch = 0;
interrupted = 0;
barf("raiseAsync");
}
+/* -----------------------------------------------------------------------------
+ resurrectThreads is called after garbage collection on the list of
+ threads found to be garbage. Each of these threads will be woken
+ up and sent a signal: BlockedOnDeadMVar if the thread was blocked
+ on an MVar, or NonTermination if the thread was blocked on a Black
+ Hole.
+ -------------------------------------------------------------------------- */
+
+void
+resurrectThreads( StgTSO *threads )
+{
+ StgTSO *tso, *next;
+
+ for (tso = threads; tso != END_TSO_QUEUE; tso = next) {
+ next = tso->global_link;
+ tso->global_link = all_threads;
+ all_threads = tso;
+ IF_DEBUG(scheduler, sched_belch("resurrecting thread %d", tso->id));
+
+ switch (tso->why_blocked) {
+ case BlockedOnMVar:
+ case BlockedOnException:
+ raiseAsync(tso,(StgClosure *)BlockedOnDeadMVar_closure);
+ break;
+ case BlockedOnBlackHole:
+ raiseAsync(tso,(StgClosure *)NonTermination_closure);
+ break;
+ case NotBlocked:
+ barf("resurrectThreads: thread not blocked");
+ default:
+ barf("resurrectThreads: thread blocked in a strange way");
+ }
+ }
+}
+
//@node Debugging Routines, Index, Exception Handling Routines, Main scheduling code
//@subsection Debugging Routines
#ifdef DEBUG
-void printThreadBlockage(StgTSO *tso)
+void
+printThreadBlockage(StgTSO *tso)
{
switch (tso->why_blocked) {
case BlockedOnRead:
}
}
+void
+printThreadStatus(StgTSO *tso)
+{
+ switch (tso->whatNext) {
+ case ThreadKilled:
+ fprintf(stderr,"has been killed");
+ break;
+ case ThreadComplete:
+ fprintf(stderr,"has completed");
+ break;
+ default:
+ printThreadBlockage(tso);
+ }
+}
+
+void
+printAllThreads(void)
+{
+ StgTSO *t;
+
+ sched_belch("all threads:");
+ for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
+ fprintf(stderr, "\tthread %d is ", t->id);
+ printThreadStatus(t);
+ fprintf(stderr,"\n");
+ }
+}
+
/*
Print a whole blocking queue attached to node (debugging only).
*/
/* -----------------------------------------------------------------------------
- * $Id: Schedule.h,v 1.15 2000/01/14 14:06:48 hwloidl Exp $
+ * $Id: Schedule.h,v 1.16 2000/03/16 17:27:13 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
void initThread(StgTSO *tso, nat stack_size);
#endif
-// debugging only
-#ifdef DEBUG
-extern void printThreadBlockage(StgTSO *tso);
-#endif
-void print_bq (StgClosure *node);
-
//@node Scheduler Vars and Data Types, Some convenient macros, Scheduler Functions
//@subsection Scheduler Vars and Data Types
*/
extern StgTSO *run_queue_hd, *run_queue_tl;
extern StgTSO *blocked_queue_hd, *blocked_queue_tl;
+extern StgTSO *all_threads;
#ifdef SMP
//@cindex sched_mutex
void raiseAsync(StgTSO *tso, StgClosure *exception);
nat run_queue_len(void);
+void resurrectThreads( StgTSO * );
+
//@node Some convenient macros, Index, Scheduler Vars and Data Types
//@subsection Some convenient macros
+/* debugging only
+ */
+#ifdef DEBUG
+void printThreadBlockage(StgTSO *tso);
+void printThreadStatus(StgTSO *tso);
+void printAllThreads(void);
+#endif
+void print_bq (StgClosure *node);
+
/* -----------------------------------------------------------------------------
* Some convenient macros...
*/
projects / ghc-hetmet.git / commitdiff