Commit c1f3fad1 authored by stolz's avatar stolz

[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.
parent 3fd1d833
-----------------------------------------------------------------------
-- $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"
------------------------------------------------------------------------
......
/* -----------------------------------------------------------------------------
* $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);
/* -----------------------------------------------------------------------------
......
/* -----------------------------------------------------------------------------
* $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;
......
/* -----------------------------------------------------------------------------
* $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) \
......
/* -----------------------------------------------------------------------------
* $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_
}
/* -----------------------------------------------------------------------------
......
/* ---------------------------------------------------------------------------
* $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 <sys/types.h>
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#include <stdarg.h>
//@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 */
......@@ -1376,6 +1392,46 @@ schedule( void )
belch("== Leaving schedule() after having received Finish"));
}
/* ---------------------------------------------------------------------------
* 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.
*
......@@ -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");
}
......
/* -----------------------------------------------------------------------------
* $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. */
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment