[project @ 2002-06-26 08:18:38 by stolz]

- Make TSO "stable" again: The thread label was changing the size of the
   TSO if you were building a debugging-RTS, leading to binary
   incompatibility. Now we map TSOs to strings using Hash.c.

- API change for labelThread: Label arbitrary threads.

ghc/compiler/prelude/primops.txt.pp

 -----------------------------------------------------------------------
--- $Id: primops.txt.pp,v 1.20 2002/06/18 13:58:24 simonpj Exp $
+-- $Id: primops.txt.pp,v 1.21 2002/06/26 08:18:38 stolz Exp $
 --
 -- Primitive Operations
 --
@@ -1442,7 +1442,7 @@ primop  MyThreadIdOp "myThreadId#" GenPrimOp
    out_of_line = True
 
 primop LabelThreadOp "labelThread#" GenPrimOp
-   Addr# -> State# RealWorld -> State# RealWorld
+   ThreadId# -> Addr# -> State# RealWorld -> State# RealWorld
    with
    has_side_effects = True
    out_of_line      = True

ghc/includes/TSO.h

 /* -----------------------------------------------------------------------------
- * $Id: TSO.h,v 1.26 2002/04/10 11:43:44 stolz Exp $
+ * $Id: TSO.h,v 1.27 2002/06/26 08:18:41 stolz Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -178,9 +178,6 @@ typedef struct StgTSO_ {
   StgTSOBlockInfo    block_info;
   struct StgTSO_*    blocked_exceptions;
   StgThreadID        id;
-#ifdef DEBUG
-  char*              label;
-#endif
 
   StgTSOTickyInfo    ticky; 
   StgTSOProfInfo     prof;

ghc/rts/PrimOps.hc

 /* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.98 2002/04/23 11:22:12 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.99 2002/06/26 08:18:41 stolz Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -1059,9 +1059,11 @@ FN_(myThreadIdzh_fast)
 FN_(labelThreadzh_fast)
 {
   FB_
-  /* args: R1.p = Addr# */
+  /* args: 
+	R1.p = ThreadId#
+	R2.p = Addr# */
 #ifdef DEBUG
-  STGCALL2(labelThread,CurrentTSO,(char *)R1.p);
+  STGCALL2(labelThread,(StgTSO *)R1.p,(char *)R2.p);
 #endif
   JMP_(ENTRY_CODE(Sp[0]));
   FE_

ghc/rts/RtsStartup.c

 /* -----------------------------------------------------------------------------
- * $Id: RtsStartup.c,v 1.63 2002/05/11 00:16:12 sof Exp $
+ * $Id: RtsStartup.c,v 1.64 2002/06/26 08:18:41 stolz Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -25,6 +25,7 @@
 #include "Prelude.h"		/* fixupRTStoPreludeRefs */
 #include "HsFFI.h"
 #include "Linker.h"
+#include "ThreadLabels.h"
 
 #if defined(RTS_GTK_FRONTPANEL)
 #include "FrontPanel.h"
@@ -156,6 +157,9 @@ startupHaskell(int argc, char *argv[], void (*init_root)(void))
     /* initialise the stable pointer table */
     initStablePtrTable();
 
+    /* initialise thread label table (tso->char*) */
+    initThreadLabelTable();
+
 #if defined(PROFILING) || defined(DEBUG)
     initProfiling1();
 #endif

ghc/rts/Schedule.c

 /* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.145 2002/06/19 20:45:15 sof Exp $
+ * $Id: Schedule.c,v 1.146 2002/06/26 08:18:42 stolz Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -96,6 +96,7 @@
 #include "Stats.h"
 #include "Itimer.h"
 #include "Prelude.h"
+#include "ThreadLabels.h"
 #ifdef PROFILING
 #include "Proftimer.h"
 #include "ProfHeap.h"
@@ -451,8 +452,7 @@ schedule( void )
 	  m->stat = Success;
 	  broadcastCondition(&m->wakeup);
 #ifdef DEBUG
-	  free(m->tso->label);
-	  m->tso->label = NULL;
+	  removeThreadLabel(m->tso);
 #endif
 	  break;
 	case ThreadKilled:
@@ -465,8 +465,7 @@ schedule( void )
 	  }
 	  broadcastCondition(&m->wakeup);
 #ifdef DEBUG
-	  free(m->tso->label);
-	  m->tso->label = NULL;
+	  removeThreadLabel(m->tso);
 #endif
 	  break;
 	default:
@@ -488,8 +487,7 @@ schedule( void )
       if (m->tso->what_next == ThreadComplete
 	  || m->tso->what_next == ThreadKilled) {
 #ifdef DEBUG
-	free(m->tso->label);
-	m->tso->label = NULL;
+	removeThreadLabel((StgWord)m->tso);
 #endif
 	main_threads = main_threads->link;
 	if (m->tso->what_next == ThreadComplete) {
@@ -1648,14 +1646,13 @@ void labelThread(StgTSO *tso, char *label)
 
   /* Caveat: Once set, you can only set the thread name to "" */
   len = strlen(label)+1;
-  buf = realloc(tso->label,len);
+  buf = malloc(len);
   if (buf == NULL) {
     fprintf(stderr,"insufficient memory for labelThread!\n");
-    free(tso->label);
-    tso->label = NULL;
   } else
     strncpy(buf,label,len);
-  tso->label = buf;
+  /* Update will free the old memory for us */
+  updateThreadLabel((StgWord)tso,buf);
 }
 #endif /* DEBUG */
 
@@ -1720,10 +1717,6 @@ createThread(nat size)
 #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.
@@ -3583,6 +3576,7 @@ void
 printAllThreads(void)
 {
   StgTSO *t;
+  void *label;
 
 # if defined(GRAN)
   char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN];
@@ -3601,8 +3595,9 @@ printAllThreads(void)
 # endif
 
   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);
+    fprintf(stderr, "\tthread %d @ %p ", t->id, (void *)t);
+    label = lookupThreadLabel((StgWord)t);
+    if (label) fprintf(stderr,"[\"%s\"] ",(char *)label);
     printThreadStatus(t);
     fprintf(stderr,"\n");
   }