[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.

diff --git a/ghc/compiler/prelude/primops.txt.pp b/ghc/compiler/prelude/primops.txt.pp
index e73a6e2..2a58a75 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 <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 */
@@ -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 (file)
--- 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. */