From c1f3fad183f553aa46ec9dea33999f387014fded Mon Sep 17 00:00:00 2001 From: stolz Date: Wed, 10 Apr 2002 11:43:49 +0000 Subject: [PATCH] [project @ 2002-04-10 11:43:43 by stolz] Two new scheduler-API primops: 1) GHC.Conc.forkProcess/forkProcess# :: IO Int This is a low-level call to fork() to replace Posix.forkProcess(). In a Concurrent Haskell setting, only the thread invoking forkProcess() is alive in the child process. Other threads will be GC'ed! This brings the RTS closer to pthreads, where a call to fork() doesn't clone any pthreads, either. The result is 0 for the child and the child's pid for the parent. The primop will barf() when used on mingw32, sorry. 2) GHC.Conc.labelThread/forkProcess# :: String -> IO () Useful for scheduler debugging: If the RTS is compiled with DEBUGging support, this primitive assigns a name to the current thread which will be used in debugging output (+RTS -D1). For larger applications, simply numbering threads is not sufficient. Notice: The Haskell side of this call is always available, but if you are not compiling with debugging support, the actual primop will turn into a no-op. --- ghc/compiler/prelude/primops.txt.pp | 14 +++++- ghc/includes/PrimOps.h | 5 ++- ghc/includes/TSO.h | 5 ++- ghc/rts/Linker.c | 4 +- ghc/rts/PrimOps.hc | 27 +++++++++++- ghc/rts/Schedule.c | 81 ++++++++++++++++++++++++++++++++++- ghc/rts/Schedule.h | 3 +- 7 files changed, 131 insertions(+), 8 deletions(-) diff --git a/ghc/compiler/prelude/primops.txt.pp b/ghc/compiler/prelude/primops.txt.pp index e73a6e2..2a58a75 100644 --- a/ghc/compiler/prelude/primops.txt.pp +++ b/ghc/compiler/prelude/primops.txt.pp @@ -1,5 +1,5 @@ ----------------------------------------------------------------------- --- $Id: primops.txt.pp,v 1.17 2002/03/27 12:35:44 simonmar Exp $ +-- $Id: primops.txt.pp,v 1.18 2002/04/10 11:43:43 stolz Exp $ -- -- Primitive Operations -- @@ -1417,6 +1417,12 @@ primop ForkOp "fork#" GenPrimOp has_side_effects = True out_of_line = True +primop ForkProcessOp "forkProcess#" GenPrimOp + State# RealWorld -> (# State# RealWorld, Int# #) + with + has_side_effects = True + out_of_line = True + primop KillThreadOp "killThread#" GenPrimOp ThreadId# -> a -> State# RealWorld -> State# RealWorld with @@ -1435,6 +1441,12 @@ primop MyThreadIdOp "myThreadId#" GenPrimOp with out_of_line = True +primop LabelThreadOp "labelThread#" GenPrimOp + Addr# -> State# RealWorld -> State# RealWorld + with + has_side_effects = True + out_of_line = True + ------------------------------------------------------------------------ section "Weak pointers" ------------------------------------------------------------------------ diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h index a853c67..7a7054c 100644 --- a/ghc/includes/PrimOps.h +++ b/ghc/includes/PrimOps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.h,v 1.92 2002/03/19 11:24:51 simonmar Exp $ + * $Id: PrimOps.h,v 1.93 2002/04/10 11:43:43 stolz Exp $ * * (c) The GHC Team, 1998-2000 * @@ -267,15 +267,18 @@ EXTFUN_RTS(deRefStablePtrzh_fast); -------------------------------------------------------------------------- */ EXTFUN_RTS(forkzh_fast); +EXTFUN_RTS(forkProcesszh_fast); EXTFUN_RTS(yieldzh_fast); EXTFUN_RTS(killThreadzh_fast); EXTFUN_RTS(seqzh_fast); EXTFUN_RTS(blockAsyncExceptionszh_fast); EXTFUN_RTS(unblockAsyncExceptionszh_fast); EXTFUN_RTS(myThreadIdzh_fast); +EXTFUN_RTS(labelThreadzh_fast); extern int cmp_thread(const StgTSO *tso1, const StgTSO *tso2); extern int rts_getThreadId(const StgTSO *tso); +extern void labelThread(StgTSO *tso, char *label); /* ----------------------------------------------------------------------------- diff --git a/ghc/includes/TSO.h b/ghc/includes/TSO.h index a6a1c93..06e8636 100644 --- a/ghc/includes/TSO.h +++ b/ghc/includes/TSO.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: TSO.h,v 1.25 2002/02/13 07:47:41 sof Exp $ + * $Id: TSO.h,v 1.26 2002/04/10 11:43:44 stolz Exp $ * * (c) The GHC Team, 1998-1999 * @@ -178,6 +178,9 @@ typedef struct StgTSO_ { StgTSOBlockInfo block_info; struct StgTSO_* blocked_exceptions; StgThreadID id; +#ifdef DEBUG + char* label; +#endif StgTSOTickyInfo ticky; StgTSOProfInfo prof; diff --git a/ghc/rts/Linker.c b/ghc/rts/Linker.c index 1dd4b0f..597da14 100644 --- a/ghc/rts/Linker.c +++ b/ghc/rts/Linker.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Linker.c,v 1.86 2002/04/01 11:18:18 panne Exp $ + * $Id: Linker.c,v 1.87 2002/04/10 11:43:45 stolz Exp $ * * (c) The GHC Team, 2000, 2001 * @@ -216,6 +216,7 @@ typedef struct _RtsSymbolVal { SymX(divExactIntegerzh_fast) \ SymX(divModIntegerzh_fast) \ SymX(forkzh_fast) \ + SymX(forkProcesszh_fast) \ SymX(freeHaskellFunctionPtr) \ SymX(freeStablePtr) \ SymX(gcdIntegerzh_fast) \ @@ -240,6 +241,7 @@ typedef struct _RtsSymbolVal { SymX(minusIntegerzh_fast) \ SymX(mkApUpd0zh_fast) \ SymX(myThreadIdzh_fast) \ + SymX(labelThreadzh_fast) \ SymX(newArrayzh_fast) \ SymX(newBCOzh_fast) \ SymX(newByteArrayzh_fast) \ diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc index b948f1f..d31e842 100644 --- a/ghc/rts/PrimOps.hc +++ b/ghc/rts/PrimOps.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.hc,v 1.94 2002/03/02 17:40:24 sof Exp $ + * $Id: PrimOps.hc,v 1.95 2002/04/10 11:43:45 stolz Exp $ * * (c) The GHC Team, 1998-2000 * @@ -1009,6 +1009,21 @@ FN_(forkzh_fast) FE_ } +FN_(forkProcesszh_fast) +{ + pid_t pid; + + FB_ + /* args: none */ + /* result: Pid */ + + R1.i = RET_STGCALL1(StgInt, forkProcess, CurrentTSO); + + JMP_(ENTRY_CODE(Sp[0])); + + FE_ +} + FN_(yieldzh_fast) { FB_ @@ -1024,7 +1039,15 @@ FN_(myThreadIdzh_fast) FE_ } - +FN_(labelThreadzh_fast) +{ + FB_ + /* args: R1.p = Addr# */ +#ifdef DEBUG + STGCALL2(labelThread,CurrentTSO,(char *)R1.p); +#endif + FE_ +} /* ----------------------------------------------------------------------------- diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c index 8a47443..edc13b0 100644 --- a/ghc/rts/Schedule.c +++ b/ghc/rts/Schedule.c @@ -1,5 +1,5 @@ /* --------------------------------------------------------------------------- - * $Id: Schedule.c,v 1.135 2002/04/01 11:18:19 panne Exp $ + * $Id: Schedule.c,v 1.136 2002/04/10 11:43:45 stolz Exp $ * * (c) The GHC Team, 1998-2000 * @@ -114,6 +114,13 @@ #include "OSThreads.h" #include "Task.h" +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#ifdef HAVE_UNISTD_H +#include +#endif + #include //@node Variables and Data structures, Prototypes, Includes, Main scheduling code @@ -429,6 +436,9 @@ schedule( void ) *prev = m->link; m->stat = Success; broadcastCondition(&m->wakeup); +#ifdef DEBUG + free(m->tso->label); +#endif break; case ThreadKilled: if (m->ret) *(m->ret) = NULL; @@ -439,6 +449,9 @@ schedule( void ) m->stat = Killed; } broadcastCondition(&m->wakeup); +#ifdef DEBUG + free(m->tso->label); +#endif break; default: break; @@ -458,6 +471,9 @@ schedule( void ) StgMainThread *m = main_threads; if (m->tso->what_next == ThreadComplete || m->tso->what_next == ThreadKilled) { +#ifdef DEBUG + free(m->tso->label); +#endif main_threads = main_threads->link; if (m->tso->what_next == ThreadComplete) { /* we finished successfully, fill in the return value */ @@ -1377,6 +1393,46 @@ schedule( void ) } /* --------------------------------------------------------------------------- + * Singleton fork(). Do not copy any running threads. + * ------------------------------------------------------------------------- */ + +StgInt forkProcess(StgTSO* tso) { + +#ifndef mingw32_TARGET_OS + pid_t pid; + StgTSO* t,*next; + + IF_DEBUG(scheduler,sched_belch("forking!")); + + pid = fork(); + if (pid) { /* parent */ + + /* just return the pid */ + + } else { /* child */ + /* wipe all other threads */ + run_queue_hd = tso; + tso->link = END_TSO_QUEUE; + + /* DO NOT TOUCH THE QUEUES directly because most of the code around + us is picky about finding the threat still in its queue when + handling the deleteThread() */ + + for (t = all_threads; t != END_TSO_QUEUE; t = next) { + next = t->link; + if (t->id != tso->id) { + deleteThread(t); + } + } + } + return pid; +#else /* mingw32 */ + barf("forkProcess#: primop not implemented for mingw32, sorry!"); + return -1; +#endif /* mingw32 */ +} + +/* --------------------------------------------------------------------------- * deleteAllThreads(): kill all the live threads. * * This is used when we catch a user interrupt (^C), before performing @@ -1550,6 +1606,24 @@ int rts_getThreadId(const StgTSO *tso) return tso->id; } +#ifdef DEBUG +void labelThread(StgTSO *tso, char *label) +{ + int len; + void *buf; + + /* Caveat: Once set, you can only set the thread name to "" */ + len = strlen(label)+1; + buf = realloc(tso->label,len); + if (buf == NULL) { + fprintf(stderr,"insufficient memory for labelThread!\n"); + free(tso->label); + } else + strncpy(buf,label,len); + tso->label = buf; +} +#endif /* DEBUG */ + /* --------------------------------------------------------------------------- Create a new thread. @@ -1624,6 +1698,10 @@ createThread_(nat size, rtsBool have_lock) #endif tso->what_next = ThreadEnterGHC; +#ifdef DEBUG + tso->label = NULL; +#endif + /* 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. @@ -3436,6 +3514,7 @@ printAllThreads(void) for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) { fprintf(stderr, "\tthread %d ", t->id); + if (t->label) fprintf(stderr,"[\"%s\"] ",t->label); printThreadStatus(t); fprintf(stderr,"\n"); } diff --git a/ghc/rts/Schedule.h b/ghc/rts/Schedule.h index 5b0e16b..376698e 100644 --- a/ghc/rts/Schedule.h +++ b/ghc/rts/Schedule.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Schedule.h,v 1.31 2002/03/12 13:57:12 simonmar Exp $ + * $Id: Schedule.h,v 1.32 2002/04/10 11:43:46 stolz Exp $ * * (c) The GHC Team 1998-1999 * @@ -135,6 +135,7 @@ extern nat rts_n_waiting_workers; extern nat rts_n_waiting_tasks; #endif +StgInt forkProcess(StgTSO *tso); /* Sigh, RTS-internal versions of waitThread(), scheduleThread(), and rts_evalIO() for the use by main() only. ToDo: better. */ -- 1.7.10.4