[project @ 2005-04-22 09:32:39 by simonmar]

SMP: the rest of the changes to support safe thunk entry & updates.  I
thought the compiler changes were independent, but I ended up breaking
the HEAD, so I'll have to commit the rest.  non-SMP compilation should
not be affected.

ghc/includes/ClosureMacros.h

@@ -161,23 +161,28 @@
 
 /* -----------------------------------------------------------------------------
    How to get hold of the static link field for a static closure.
-   
-   Note that we have to use (*cast(T*,&e)) instead of cast(T,e)
-   because C won't let us take the address of a casted
-   expression. Huh?
    -------------------------------------------------------------------------- */
 
-#define STATIC_LINK(info,p)						\
-   (*(StgClosure**)(&((p)->payload[info->layout.payload.ptrs +		\
-					info->layout.payload.nptrs])))
-
-/* These macros are optimised versions of the above for certain
- * closure types.  They *must* be equivalent to the generic
- * STATIC_LINK.
- */
-#define FUN_STATIC_LINK(p)   ((p)->payload[0])
-#define THUNK_STATIC_LINK(p) ((p)->payload[1])
-#define IND_STATIC_LINK(p)   ((p)->payload[1])
+/* These are hard-coded. */
+#define FUN_STATIC_LINK(p)   (&(p)->payload[0])
+#define THUNK_STATIC_LINK(p) (&(p)->payload[1])
+#define IND_STATIC_LINK(p)   (&(p)->payload[1])
+
+INLINE_HEADER StgClosure **
+STATIC_LINK(const StgInfoTable *info, StgClosure *p)
+{ 
+    switch (info->type) {
+    case THUNK_STATIC:
+	return THUNK_STATIC_LINK(p);
+    case FUN_STATIC:
+	return FUN_STATIC_LINK(p);
+    case IND_STATIC:
+	return IND_STATIC_LINK(p);
+    default:
+	return &(p)->payload[info->layout.payload.ptrs +
+			     info->layout.payload.nptrs];
+    }
+}
 
 #define STATIC_LINK2(info,p)							\
    (*(StgClosure**)(&((p)->payload[info->layout.payload.ptrs +			\

ghc/includes/Closures.h

@@ -34,6 +34,17 @@ typedef struct {
   StgWord procs; /* bitmask indicating on which PEs this closure resides */
 } StgGranHeader;
 
+/* -----------------------------------------------------------------------------
+   The SMP header
+
+   In SMP mode, we have an extra word of padding in a thunk's header.
+   (Note: thunks only; other closures do not have this padding word).
+   -------------------------------------------------------------------------- */
+
+typedef struct {
+    StgWord pad;
+} StgSMPThunkHeader;
+
 /* -----------------------------------------------------------------------------
    The full fixed-size closure header
 
@@ -42,15 +53,35 @@ typedef struct {
    -------------------------------------------------------------------------- */
 
 typedef struct {
-	const struct _StgInfoTable* info;
+    const struct _StgInfoTable* info;
 #ifdef PROFILING
-	StgProfHeader         prof;
+    StgProfHeader         prof;
 #endif
 #ifdef GRAN
-	StgGranHeader         gran;
+    StgGranHeader         gran;
 #endif
 } StgHeader;
 
+/*
+ * In SMP mode, a thunk has a padding word to take the updated value.
+ * This is so that the update doesn't overwrite the payload, so we can
+ * avoid needing to lock the thunk during entry and update.
+ *
+ * Note: this doesn't apply to THUNK_STATICs, which have no payload.
+ */
+typedef struct {
+    const struct _StgInfoTable* info;
+#ifdef PROFILING
+    StgProfHeader         prof;
+#endif
+#ifdef GRAN
+    StgGranHeader         gran;
+#endif
+#ifdef SMP
+    StgSMPThunkHeader     smp;
+#endif
+} StgThunkHeader;
+
 /* -----------------------------------------------------------------------------
    Closure Types
 
@@ -67,7 +98,12 @@ struct StgClosure_ {
 };
 
 typedef struct {
-    StgHeader   header;
+    StgThunkHeader  header;
+    struct StgClosure_ *payload[FLEXIBLE_ARRAY];
+} StgThunk;
+
+typedef struct {
+    StgThunkHeader   header;
     StgClosure *selectee;
 } StgSelector;
 
@@ -79,11 +115,16 @@ typedef struct {
     StgClosure *payload[FLEXIBLE_ARRAY];
 } StgPAP;
 
-/* AP closures have the same layout, for convenience */
-typedef StgPAP StgAP;
+typedef struct {
+    StgThunkHeader   header;
+    StgHalfWord arity;		/* zero if it is an AP */
+    StgHalfWord n_args;
+    StgClosure *fun;		/* really points to a fun */
+    StgClosure *payload[FLEXIBLE_ARRAY];
+} StgAP;
 
 typedef struct {
-    StgHeader   header;
+    StgThunkHeader   header;
     StgWord     size;                    /* number of words in payload */
     StgClosure *fun;
     StgClosure *payload[FLEXIBLE_ARRAY]; /* contains a chunk of *stack* */

ghc/includes/Cmm.h

@@ -324,6 +324,26 @@
         jump stg_gc_gen_hp;				\
    }
 
+/* -----------------------------------------------------------------------------
+   Closure headers
+   -------------------------------------------------------------------------- */
+
+/*
+ * This is really ugly, since we don't do the rest of StgHeader this
+ * way.  The problem is that values from DerivedConstants.h cannot be 
+ * dependent on the way (SMP, PROF etc.).  For SIZEOF_StgHeader we get
+ * the value from GHC, but it seems like too much trouble to do that
+ * for StgThunkHeader.
+ */
+#ifdef SMP
+#define SIZEOF_StgThunkHeader SIZEOF_StgHeader+SIZEOF_StgSMPThunkHeader
+#else
+#define SIZEOF_StgThunkHeader SIZEOF_StgHeader
+#endif
+
+#define StgThunk_payload(__ptr__,__ix__) \
+    W_[__ptr__+SIZEOF_StgThunkHeader+ WDS(__ix__)]
+
 /* -----------------------------------------------------------------------------
    Closures
    -------------------------------------------------------------------------- */

ghc/includes/StgTypes.h

@@ -48,7 +48,6 @@ typedef unsigned char            StgWord8;
 typedef signed   short           StgInt16;
 typedef unsigned short           StgWord16;
 
-
 #if SIZEOF_UNSIGNED_INT == 4
 typedef signed   int             StgInt32;
 typedef unsigned int             StgWord32;

ghc/includes/Storage.h

@@ -255,6 +255,9 @@ extern rtsBool keepCAFs;
 INLINE_HEADER StgOffset PAP_sizeW   ( nat n_args )
 { return sizeofW(StgPAP) + n_args; }
 
+INLINE_HEADER StgOffset AP_sizeW   ( nat n_args )
+{ return sizeofW(StgAP) + n_args; }
+
 INLINE_HEADER StgOffset AP_STACK_sizeW ( nat size )
 { return sizeofW(StgAP_STACK) + size; }
 
@@ -276,9 +279,17 @@ INLINE_HEADER StgOffset sizeW_fromITBL( const StgInfoTable* itbl )
        + sizeofW(StgPtr)  * itbl->layout.payload.ptrs 
        + sizeofW(StgWord) * itbl->layout.payload.nptrs; }
 
+INLINE_HEADER StgOffset thunk_sizeW_fromITBL( const StgInfoTable* itbl ) 
+{ return sizeofW(StgThunk) 
+       + sizeofW(StgPtr)  * itbl->layout.payload.ptrs 
+       + sizeofW(StgWord) * itbl->layout.payload.nptrs; }
+
 INLINE_HEADER StgOffset ap_stack_sizeW( StgAP_STACK* x )
 { return AP_STACK_sizeW(x->size); }
 
+INLINE_HEADER StgOffset ap_sizeW( StgAP* x )
+{ return AP_sizeW(x->n_args); }
+
 INLINE_HEADER StgOffset pap_sizeW( StgPAP* x )
 { return PAP_sizeW(x->n_args); }
 

ghc/includes/mkDerivedConstants.c

@@ -232,6 +232,8 @@ main(int argc, char *argv[])
     struct_field_("StgHeader_ccs",  StgHeader, prof.ccs);
     struct_field_("StgHeader_ldvw", StgHeader, prof.hp.ldvw);
 
+    struct_size(StgSMPThunkHeader);
+
     closure_payload(StgClosure,payload);
 
     struct_field(StgEntCounter, allocs);

ghc/rts/GC.c

@@ -1721,9 +1721,11 @@ loop:
   case FUN_1_0:
   case FUN_0_1:
   case CONSTR_1_0:
+    return copy(q,sizeofW(StgHeader)+1,stp);
+
   case THUNK_1_0:
   case THUNK_0_1:
-    return copy(q,sizeofW(StgHeader)+1,stp);
+    return copy(q,sizeofW(StgThunk)+1,stp);
 
   case THUNK_1_1:
   case THUNK_0_2:
@@ -1735,7 +1737,7 @@ loop:
       stp = bd->step;
     }
 #endif
-    return copy(q,sizeofW(StgHeader)+2,stp);
+    return copy(q,sizeofW(StgThunk)+2,stp);
 
   case FUN_1_1:
   case FUN_0_2:
@@ -1801,16 +1803,16 @@ loop:
 
   case THUNK_STATIC:
     if (info->srt_bitmap != 0 && major_gc && 
-	THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
-      THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
+	*THUNK_STATIC_LINK((StgClosure *)q) == NULL) {
+      *THUNK_STATIC_LINK((StgClosure *)q) = static_objects;
       static_objects = (StgClosure *)q;
     }
     return q;
 
   case FUN_STATIC:
     if (info->srt_bitmap != 0 && major_gc && 
-	FUN_STATIC_LINK((StgClosure *)q) == NULL) {
-      FUN_STATIC_LINK((StgClosure *)q) = static_objects;
+	*FUN_STATIC_LINK((StgClosure *)q) == NULL) {
+      *FUN_STATIC_LINK((StgClosure *)q) = static_objects;
       static_objects = (StgClosure *)q;
     }
     return q;
@@ -1822,15 +1824,15 @@ loop:
      */
     if (major_gc
 	  && ((StgIndStatic *)q)->saved_info == NULL
- 	  && IND_STATIC_LINK((StgClosure *)q) == NULL) {
-	IND_STATIC_LINK((StgClosure *)q) = static_objects;
+ 	  && *IND_STATIC_LINK((StgClosure *)q) == NULL) {
+	*IND_STATIC_LINK((StgClosure *)q) = static_objects;
 	static_objects = (StgClosure *)q;
     }
     return q;
 
   case CONSTR_STATIC:
-    if (major_gc && STATIC_LINK(info,(StgClosure *)q) == NULL) {
-      STATIC_LINK(info,(StgClosure *)q) = static_objects;
+    if (major_gc && *STATIC_LINK(info,(StgClosure *)q) == NULL) {
+      *STATIC_LINK(info,(StgClosure *)q) = static_objects;
       static_objects = (StgClosure *)q;
     }
     return q;
@@ -1859,9 +1861,11 @@ loop:
     barf("evacuate: stack frame at %p\n", q);
 
   case PAP:
-  case AP:
       return copy(q,pap_sizeW((StgPAP*)q),stp);
 
+  case AP:
+      return copy(q,ap_sizeW((StgAP*)q),stp);
+
   case AP_STACK:
       return copy(q,ap_stack_sizeW((StgAP_STACK*)q),stp);
 
@@ -2343,15 +2347,6 @@ scavenge_fun_srt(const StgInfoTable *info)
     scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
 }
 
-STATIC_INLINE void
-scavenge_ret_srt(const StgInfoTable *info)
-{
-    StgRetInfoTable *ret_info;
-
-    ret_info = itbl_to_ret_itbl(info);
-    scavenge_srt((StgClosure **)GET_SRT(ret_info), ret_info->i.srt_bitmap);
-}
-
 /* -----------------------------------------------------------------------------
    Scavenge a TSO.
    -------------------------------------------------------------------------- */
@@ -2424,18 +2419,15 @@ scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
 }
 
 STATIC_INLINE StgPtr
-scavenge_PAP (StgPAP *pap)
+scavenge_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
 {
     StgPtr p;
-    StgWord bitmap, size;
+    StgWord bitmap;
     StgFunInfoTable *fun_info;
-
-    pap->fun = evacuate(pap->fun);
-    fun_info = get_fun_itbl(pap->fun);
+    
+    fun_info = get_fun_itbl(fun);
     ASSERT(fun_info->i.type != PAP);
-
-    p = (StgPtr)pap->payload;
-    size = pap->n_args;
+    p = (StgPtr)payload;
 
     switch (fun_info->f.fun_type) {
     case ARG_GEN:
@@ -2446,13 +2438,12 @@ scavenge_PAP (StgPAP *pap)
 	p += size;
 	break;
     case ARG_BCO:
-	scavenge_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun), size);
+	scavenge_large_bitmap((StgPtr)payload, BCO_BITMAP(fun), size);
 	p += size;
 	break;
     default:
 	bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
     small_bitmap:
-	size = pap->n_args;
 	while (size > 0) {
 	    if ((bitmap & 1) == 0) {
 		*p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
@@ -2466,6 +2457,20 @@ scavenge_PAP (StgPAP *pap)
     return p;
 }
 
+STATIC_INLINE StgPtr
+scavenge_PAP (StgPAP *pap)
+{
+    pap->fun = evacuate(pap->fun);
+    return scavenge_PAP_payload (pap->fun, pap->payload, pap->n_args);
+}
+
+STATIC_INLINE StgPtr
+scavenge_AP (StgAP *ap)
+{
+    ap->fun = evacuate(ap->fun);
+    return scavenge_PAP_payload (ap->fun, ap->payload, ap->n_args);
+}
+
 /* -----------------------------------------------------------------------------
    Scavenge a given step until there are no more objects in this step
    to scavenge.
@@ -2535,6 +2540,11 @@ scavenge(step *stp)
 
     case THUNK_2_0:
 	scavenge_thunk_srt(info);
+	((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
+	((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
+	p += sizeofW(StgThunk) + 2;
+	break;
+
     case CONSTR_2_0:
 	((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
 	((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
@@ -2543,8 +2553,8 @@ scavenge(step *stp)
 	
     case THUNK_1_0:
 	scavenge_thunk_srt(info);
-	((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
-	p += sizeofW(StgHeader) + 1;
+	((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
+	p += sizeofW(StgThunk) + 1;
 	break;
 	
     case FUN_1_0:
@@ -2556,7 +2566,7 @@ scavenge(step *stp)
 	
     case THUNK_0_1:
 	scavenge_thunk_srt(info);
-	p += sizeofW(StgHeader) + 1;
+	p += sizeofW(StgThunk) + 1;
 	break;
 	
     case FUN_0_1:
@@ -2567,7 +2577,7 @@ scavenge(step *stp)
 	
     case THUNK_0_2:
 	scavenge_thunk_srt(info);
-	p += sizeofW(StgHeader) + 2;
+	p += sizeofW(StgThunk) + 2;
 	break;
 	
     case FUN_0_2:
@@ -2578,8 +2588,8 @@ scavenge(step *stp)
 	
     case THUNK_1_1:
 	scavenge_thunk_srt(info);
-	((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
-	p += sizeofW(StgHeader) + 2;
+	((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
+	p += sizeofW(StgThunk) + 2;
 	break;
 
     case FUN_1_1:
@@ -2594,8 +2604,17 @@ scavenge(step *stp)
 	goto gen_obj;
 
     case THUNK:
+    {
+	StgPtr end;
+
 	scavenge_thunk_srt(info);
-	// fall through 
+	end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
+	for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
+	    *p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
+	}
+	p += info->layout.payload.nptrs;
+	break;
+    }
 	
     gen_obj:
     case CONSTR:
@@ -2680,10 +2699,13 @@ scavenge(step *stp)
     }
 
     case PAP:
-    case AP:
 	p = scavenge_PAP((StgPAP *)p);
 	break;
 
+    case AP:
+	p = scavenge_AP((StgAP *)p);
+	break;
+
     case ARR_WORDS:
 	// nothing to follow 
 	p += arr_words_sizeW((StgArrWords *)p);
@@ -2914,6 +2936,10 @@ linear_scan:
 
 	case THUNK_2_0:
 	    scavenge_thunk_srt(info);
+	    ((StgThunk *)p)->payload[1] = evacuate(((StgThunk *)p)->payload[1]);
+	    ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
+	    break;
+
 	case CONSTR_2_0:
 	    ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
 	    ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
@@ -2928,6 +2954,9 @@ linear_scan:
 	case THUNK_1_0:
 	case THUNK_1_1:
 	    scavenge_thunk_srt(info);
+	    ((StgThunk *)p)->payload[0] = evacuate(((StgThunk *)p)->payload[0]);
+	    break;
+
 	case CONSTR_1_0:
 	case CONSTR_1_1:
 	    ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
@@ -2952,8 +2981,16 @@ linear_scan:
 	    goto gen_obj;
 
 	case THUNK:
+	{
+	    StgPtr end;
+	    
 	    scavenge_thunk_srt(info);
-	    // fall through 
+	    end = (P_)((StgThunk *)p)->payload + info->layout.payload.ptrs;
+	    for (p = (P_)((StgThunk *)p)->payload; p < end; p++) {
+		*p = (StgWord)(StgPtr)evacuate((StgClosure *)*p);
+	    }
+	    break;
+	}
 	
 	gen_obj:
 	case CONSTR:
@@ -3023,9 +3060,12 @@ linear_scan:
 	}
 
 	case PAP:
-	case AP:
 	    scavenge_PAP((StgPAP *)p);
 	    break;
+
+	case AP:
+	    scavenge_AP((StgAP *)p);
+	    break;
       
 	case MUT_ARR_PTRS:
 	    // follow everything 
@@ -3254,18 +3294,28 @@ scavenge_one(StgPtr p)
 	break;
     }
 
-    case FUN:
-    case FUN_1_0:			// hardly worth specialising these guys
-    case FUN_0_1:
-    case FUN_1_1:
-    case FUN_0_2:
-    case FUN_2_0:
     case THUNK:
     case THUNK_1_0:
     case THUNK_0_1:
     case THUNK_1_1:
     case THUNK_0_2:
     case THUNK_2_0:
+    {
+	StgPtr q, end;
+	
+	end = (StgPtr)((StgThunk *)p)->payload + info->layout.payload.ptrs;
+	for (q = (StgPtr)((StgThunk *)p)->payload; q < end; q++) {
+	    *q = (StgWord)(StgPtr)evacuate((StgClosure *)*q);
+	}
+	break;
+    }
+
+    case FUN:
+    case FUN_1_0:			// hardly worth specialising these guys
+    case FUN_0_1:
+    case FUN_1_1:
+    case FUN_0_2:
+    case FUN_2_0:
     case CONSTR:
     case CONSTR_1_0:
     case CONSTR_0_1:
@@ -3316,6 +3366,9 @@ scavenge_one(StgPtr p)
     }
 
     case PAP:
+	p = scavenge_AP((StgAP *)p);
+	break;
+
     case AP:
 	p = scavenge_PAP((StgPAP *)p);
 	break;
@@ -3582,8 +3635,8 @@ scavenge_static(void)
     /* Take this object *off* the static_objects list,
      * and put it on the scavenged_static_objects list.
      */
-    static_objects = STATIC_LINK(info,p);
-    STATIC_LINK(info,p) = scavenged_static_objects;
+    static_objects = *STATIC_LINK(info,p);
+    *STATIC_LINK(info,p) = scavenged_static_objects;
     scavenged_static_objects = p;
     
     switch (info -> type) {
@@ -3852,8 +3905,8 @@ zero_static_object_list(StgClosure* first_static)
 
   for (p = first_static; p != END_OF_STATIC_LIST; p = link) {
     info = get_itbl(p);
-    link = STATIC_LINK(info, p);
-    STATIC_LINK(info,p) = NULL;
+    link = *STATIC_LINK(info, p);
+    *STATIC_LINK(info,p) = NULL;
   }
 }
 

ghc/rts/GCCompact.c

@@ -110,20 +110,22 @@ STATIC_INLINE nat
 obj_sizeW( StgClosure *p, StgInfoTable *info )
 {
     switch (info->type) {
+    case THUNK_0_1:
+    case THUNK_1_0:
+	return sizeofW(StgThunk) + 1;
     case FUN_0_1:
     case CONSTR_0_1:
     case FUN_1_0:
     case CONSTR_1_0:
-    case THUNK_0_1:
-    case THUNK_1_0:
 	return sizeofW(StgHeader) + 1;
     case THUNK_0_2:
+    case THUNK_1_1:
+    case THUNK_2_0:
+	return sizeofW(StgThunk) + 2;
     case FUN_0_2:
     case CONSTR_0_2:
-    case THUNK_1_1:
     case FUN_1_1:
     case CONSTR_1_1:
-    case THUNK_2_0:
     case FUN_2_0:
     case CONSTR_2_0:
 	return sizeofW(StgHeader) + 2;
@@ -171,17 +173,17 @@ thread_static( StgClosure* p )
       
     case IND_STATIC:
 	thread((StgPtr)&((StgInd *)p)->indirectee);
-	p = IND_STATIC_LINK(p);
+	p = *IND_STATIC_LINK(p);
 	continue;
       
     case THUNK_STATIC:
-	p = THUNK_STATIC_LINK(p);
+	p = *THUNK_STATIC_LINK(p);
 	continue;
     case FUN_STATIC:
-	p = FUN_STATIC_LINK(p);
+	p = *FUN_STATIC_LINK(p);
 	continue;
     case CONSTR_STATIC:
-	p = STATIC_LINK(info,p);
+	p = *STATIC_LINK(info,p);
 	continue;
       
     default:
@@ -366,17 +368,16 @@ thread_stack(StgPtr p, StgPtr stack_end)
 }
 
 STATIC_INLINE StgPtr
-thread_PAP (StgPAP *pap)
+thread_PAP_payload (StgClosure *fun, StgClosure **payload, StgWord size)
 {
     StgPtr p;
-    StgWord bitmap, size;
+    StgWord bitmap;
     StgFunInfoTable *fun_info;
-    
-    fun_info = itbl_to_fun_itbl(get_threaded_info((StgPtr)pap->fun));
+
+    fun_info = itbl_to_fun_itbl(get_threaded_info((StgPtr)fun));
     ASSERT(fun_info->i.type != PAP);
 
-    p = (StgPtr)pap->payload;
-    size = pap->n_args;
+    p = (StgPtr)payload;