[project @ 1999-11-08 15:30:32 by sewardj]

Make Hugs evaluator work with new register table arrangements
arising from Simon's SMP work.

diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c
index 0d96391..74cd9e5 100644 (file)
--- a/ghc/rts/Assembler.c
+++ b/ghc/rts/Assembler.c
@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Assembler.c,v $
- * $Revision: 1.13 $
- * $Date: 1999/11/01 18:19:40 $
+ * $Revision: 1.14 $
+ * $Date: 1999/11/08 15:30:32 $
  *
  * This module provides functions to construct BCOs and other closures
  * required by the bytecode compiler.
@@ -49,9 +49,10 @@
 #include "Bytecodes.h"
 #include "Printer.h"
 #include "Disassembler.h"
-#include "Evaluator.h"
 #include "StgMiscClosures.h"
 #include "Storage.h"
+#include "Schedule.h"
+#include "Evaluator.h"
 
 #define INSIDE_ASSEMBLER_C
 #include "Assembler.h"

diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c
index e8cc683..87e5616 100644 (file)
--- a/ghc/rts/Evaluator.c
+++ b/ghc/rts/Evaluator.c
@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Evaluator.c,v $
- * $Revision: 1.24 $
- * $Date: 1999/11/01 18:19:41 $
+ * $Revision: 1.25 $
+ * $Date: 1999/11/08 15:30:33 $
  * ---------------------------------------------------------------------------*/
 
 #include "Rts.h"
@@ -255,35 +255,6 @@ void setRtsFlags( int x )
     }
 }
 
-/* --------------------------------------------------------------------------
- * RTS Hooks
- *
- * ToDo: figure out why these are being used and crush them!
- * ------------------------------------------------------------------------*/
-#if 0
-void OnExitHook (void)
-{
-}
-void StackOverflowHook (unsigned long stack_size)
-{
-    fprintf(stderr,"Stack Overflow\n");
-    exit(1);
-}
-void OutOfHeapHook (unsigned long request_size, unsigned long heap_size)
-{
-    fprintf(stderr,"Out Of Heap\n");
-    exit(1);
-}
-void MallocFailHook (unsigned long request_size /* in bytes */, char *msg)
-{
-    fprintf(stderr,"Malloc Fail\n");
-    exit(1);
-}
-void defaultsHook (void)
-{
-    /* do nothing */
-}
-#endif
 
 /* --------------------------------------------------------------------------
  * Entering-objects and bytecode interpreter part of evaluator
@@ -313,13 +284,14 @@ void defaultsHook (void)
 
 /* Forward decls ... */
 static        void* enterBCO_primop1 ( int );
-static        void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */, StgBCO** );
+static        void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */, 
+                                       StgBCO**, Capability* );
 static inline void PopUpdateFrame ( StgClosure* obj );
 static inline void PopCatchFrame  ( void );
 static inline void PopSeqFrame    ( void );
 static inline void PopStopFrame( StgClosure* obj );
 static inline void PushTaggedRealWorld( void );
-static inline void PushTaggedInteger  ( mpz_ptr );
+/* static inline void PushTaggedInteger  ( mpz_ptr ); */
 static inline StgPtr grabHpUpd( nat size );
 static inline StgPtr grabHpNonUpd( nat size );
 static        StgClosure* raiseAnError   ( StgClosure* errObj );
@@ -341,19 +313,27 @@ void      SloppifyIntegerEnd ( StgPtr );
 
 
 
+#define gSp     MainRegTable.rSp
+#define gSu     MainRegTable.rSu
+#define gSpLim  MainRegTable.rSpLim
+
+
 /* Macros to save/load local state. */
 #ifdef DEBUG
-#define SSS { tSp=Sp = xSp; tSu=Su = xSu; tSpLim=SpLim = xSpLim; }
-#define LLL { tSp=xSp = Sp; tSu=xSu = Su; tSpLim=xSpLim = SpLim; }
+#define SSS { tSp=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; }
+#define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; }
 #else
-#define SSS { Sp = xSp; Su = xSu; SpLim = xSpLim; }
-#define LLL { xSp = Sp; xSu = Su; xSpLim = SpLim; }
+#define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; }
+#define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; }
 #endif
 
-#define RETURN(vvv) {                                         \
-           StgThreadReturnCode retVal=(vvv); SSS;             \
-           /* SaveThreadState() is done by the scheduler. */  \
-           return retVal;                                     \
+#define RETURN(vvv) {                                          \
+           StgThreadReturnCode retVal=(vvv);                   \
+          SSS;                                                 \
+           cap->rCurrentTSO->sp    = gSp;                      \
+           cap->rCurrentTSO->su    = gSu;                      \
+           cap->rCurrentTSO->splim = gSpLim;                   \
+           return retVal;                                      \
         }
 
 
@@ -365,7 +345,7 @@ void      SloppifyIntegerEnd ( StgPtr );
    the macros, in particular xPopTagged*, do not make the tag
    sanity checks that their non-x cousins do, and (2) some of
    the macros depend critically on the semantics of C comma
-   expressions to work properly
+   expressions to work properly.
 */
 #define xPushPtr(ppp)           { xSp--; *xSp=(StgWord)(ppp); }
 #define xPopPtr()               ((StgPtr)(*xSp++))
@@ -427,6 +407,16 @@ void      SloppifyIntegerEnd ( StgPtr );
                                  PK_DBL(xSp-sizeofW(StgDouble))))
 
 
+#define xPushUpdateFrame(target, xSp_offset)                      \
+{                                                                 \
+   StgUpdateFrame *__frame;                                       \
+   __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1;          \
+   SET_INFO(__frame, (StgInfoTable *)&Upd_frame_info);            \
+   __frame->link = xSu;                                           \
+   __frame->updatee = (StgClosure *)(target);                     \
+   xSu = __frame;                                                 \
+}
+
 #define xPopUpdateFrame(ooo)                                      \
 {                                                                 \
     /* NB: doesn't assume that Sp == Su */                        \
@@ -450,7 +440,12 @@ void      SloppifyIntegerEnd ( StgPtr );
 #define PC (bciPtr - &(bcoInstr(bco,0)))
 
 
-StgThreadReturnCode enter( StgClosure* obj0 )
+/* State on entry to enter():
+ *    - current thread  is in cap->rCurrentTSO;
+ *    - allocation area is in cap->rCurrentNursery & cap->rNursery
+ */
+
+StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
 {
    /* use of register here is primarily to make it clear to compilers
       that these entities are non-aliasable.
@@ -462,12 +457,16 @@ StgThreadReturnCode enter( StgClosure* obj0 )
              char             eCount; /* enter counter, for context switching */
 
 #ifdef DEBUG
-    /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
     StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
 #endif
-    /* LoadThreadState() is done by the scheduler. */
+
+    gSp    = cap->rCurrentTSO->sp;
+    gSu    = cap->rCurrentTSO->su;
+    gSpLim = cap->rCurrentTSO->splim;
+
 #ifdef DEBUG
-    tSp = Sp; tSu = Su; tSpLim = SpLim;
+    /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
+    tSp = gSp; tSu = gSu; tSpLim = gSpLim;
 #endif
 
     obj    = obj0;
@@ -482,9 +481,9 @@ StgThreadReturnCode enter( StgClosure* obj0 )
     enterLoop:
 
 #ifdef DEBUG
-    assert(Sp == tSp);
-    assert(Su == tSu);
-    assert(SpLim == tSpLim);
+    assert(gSp == tSp);
+    assert(gSu == tSu);
+    assert(gSpLim == tSpLim);
     IF_DEBUG(evaluator,
              SSS;
              enterCountI++;
@@ -494,7 +493,7 @@ StgThreadReturnCode enter( StgClosure* obj0 )
              fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
              fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
              fprintf(stderr, "\n" );
-             printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu);
+             printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu);
              fprintf(stderr, "\n\n");
              LLL;
             );
@@ -558,7 +557,7 @@ StgThreadReturnCode enter( StgClosure* obj0 )
 
             LoopTopLabel
 
-            ASSERT(PC < bco->n_instrs);
+            ASSERT((StgWord)(PC) < bco->n_instrs);
             IF_DEBUG(evaluator,
             fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
                     SSS;
@@ -566,7 +565,7 @@ StgThreadReturnCode enter( StgClosure* obj0 )
                     if (0) { int i;
                     fprintf(stderr,"\n");
                       for (i = 8; i >= 0; i--) 
-                         fprintf(stderr, "%d  %p\n", i, (StgPtr)(*(Sp+i)));
+                         fprintf(stderr, "%d  %p\n", i, (StgPtr)(*(gSp+i)));
                       }
                     fprintf(stderr,"\n");
                     LLL;
@@ -1167,7 +1166,7 @@ StgThreadReturnCode enter( StgClosure* obj0 )
                     pc_saved = PC; 
                     bco_tmp  = bco;
                     SSS;
-                    p        = enterBCO_primop2 ( i, &trc, &bco_tmp ); 
+                    p        = enterBCO_primop2 ( i, &trc, &bco_tmp, cap ); 
                     LLL;
                     bco      = bco_tmp;
                     bciPtr   = &(bcoInstr(bco,pc_saved));
@@ -1307,7 +1306,7 @@ StgThreadReturnCode enter( StgClosure* obj0 )
             if (caf->mut_link == NULL) { 
                SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL; 
             }
-            SSS; PUSH_UPD_FRAME(bh,0); LLL;
+            xPushUpdateFrame(bh,0);
             xSp -= sizeofW(StgUpdateFrame);
             caf->link = enteredCAFs;
             enteredCAFs = caf;
@@ -1328,8 +1327,8 @@ StgThreadReturnCode enter( StgClosure* obj0 )
            /*was StgBlackHole* */
             StgBlockingQueue* bh = (StgBlockingQueue*)obj;
             /* Put ourselves on the blocking queue for this black hole and block */
-            CurrentTSO->link = bh->blocking_queue;
-            bh->blocking_queue = CurrentTSO;
+            cap->rCurrentTSO->link = bh->blocking_queue;
+            bh->blocking_queue = cap->rCurrentTSO;
             xPushCPtr(obj); /* code to restart with */
             barf("enter: CAF_BLACKHOLE unexpected!");
             RETURN(ThreadBlocked);
@@ -1344,7 +1343,7 @@ StgThreadReturnCode enter( StgClosure* obj0 )
             }
             /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME 
                and insert an indirection immediately  */
-            SSS; PUSH_UPD_FRAME(ap,0); LLL;
+            xPushUpdateFrame(ap,0);
             xSp -= sizeofW(StgUpdateFrame);
             while (--i >= 0) {
                 xPushWord(payloadWord(ap,i));
@@ -1418,7 +1417,8 @@ StgThreadReturnCode enter( StgClosure* obj0 )
                                  fprintf(stderr, "hit a STOP_FRAME\n");
                                  printObj(obj);
                                  fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
-                                 printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu);
+                                 printStack(xSp,cap->rCurrentTSO->stack
+                                                + cap->rCurrentTSO->stack_size,xSu);
                                  LLL;
                                  );
                         SSS; PopStopFrame(obj); LLL;
@@ -1459,7 +1459,7 @@ StgThreadReturnCode enter( StgClosure* obj0 )
             //fprintf(stderr, "entering unknown closure -- yielding to sched\n"); 
             //printObj(obj);
             //LLL;
-            CurrentTSO->whatNext = ThreadEnterGHC;
+            cap->rCurrentTSO->whatNext = ThreadEnterGHC;
             xPushCPtr(obj); /* code to restart with */
             RETURN(ThreadYielding);
         }
@@ -1505,7 +1505,8 @@ StgThreadReturnCode enter( StgClosure* obj0 )
 #undef xPushTaggedDouble
 #undef xTaggedStackDouble
 #undef xPopTaggedDouble
-
+#undef xPopUpdateFrame
+#undef xPushUpdateFrame
 
 
 /* --------------------------------------------------------------------------
@@ -1513,56 +1514,56 @@ StgThreadReturnCode enter( StgClosure* obj0 )
  * ------------------------------------------------------------------------*/
 
 static inline void            PushTag            ( StackTag    t ) 
-   { *(--Sp) = t; }
+   { *(--gSp) = t; }
        inline void            PushPtr            ( StgPtr      x ) 
-   { *(--stgCast(StgPtr*,Sp))  = x; }
+   { *(--stgCast(StgPtr*,gSp))  = x; }
 static inline void            PushCPtr           ( StgClosure* x ) 
-   { *(--stgCast(StgClosure**,Sp)) = x; }
+   { *(--stgCast(StgClosure**,gSp)) = x; }
 static inline void            PushInt            ( StgInt      x ) 
-   { *(--stgCast(StgInt*,Sp))  = x; }
+   { *(--stgCast(StgInt*,gSp))  = x; }
 static inline void            PushWord           ( StgWord     x ) 
-   { *(--stgCast(StgWord*,Sp)) = x; }
+   { *(--stgCast(StgWord*,gSp)) = x; }
                                                      
                                                  
 static inline void            checkTag           ( StackTag t1, StackTag t2 ) 
    { ASSERT(t1 == t2);}
 static inline void            PopTag             ( StackTag t ) 
-   { checkTag(t,*(Sp++));    }
+   { checkTag(t,*(gSp++));    }
        inline StgPtr          PopPtr             ( void )       
-   { return *stgCast(StgPtr*,Sp)++; }
+   { return *stgCast(StgPtr*,gSp)++; }
 static inline StgClosure*     PopCPtr            ( void )       
-   { return *stgCast(StgClosure**,Sp)++; }
+   { return *stgCast(StgClosure**,gSp)++; }
 static inline StgInt          PopInt             ( void )       
-   { return *stgCast(StgInt*,Sp)++;  }
+   { return *stgCast(StgInt*,gSp)++;  }
 static inline StgWord         PopWord            ( void )       
-   { return *stgCast(StgWord*,Sp)++; }
+   { return *stgCast(StgWord*,gSp)++; }
 
 static inline StgPtr          stackPtr           ( StgStackOffset i ) 
-   { return *stgCast(StgPtr*, Sp+i); }
+   { return *stgCast(StgPtr*, gSp+i); }
 static inline StgInt          stackInt           ( StgStackOffset i ) 
-   { return *stgCast(StgInt*, Sp+i); }
+   { return *stgCast(StgInt*, gSp+i); }
 static inline StgWord         stackWord          ( StgStackOffset i ) 
-   { return *stgCast(StgWord*,Sp+i); }
+   { return *stgCast(StgWord*,gSp+i); }
                               
 static inline void            setStackWord       ( StgStackOffset i, StgWord w ) 
-   { Sp[i] = w; }
+   { gSp[i] = w; }
 
 static inline void            PushTaggedRealWorld( void            ) 
    { PushTag(REALWORLD_TAG);  }
        inline void            PushTaggedInt      ( StgInt        x ) 
-   { Sp -= sizeofW(StgInt);        *Sp = x;          PushTag(INT_TAG);    }
+   { gSp -= sizeofW(StgInt);        *gSp = x;          PushTag(INT_TAG);    }
        inline void            PushTaggedWord     ( StgWord       x ) 
-   { Sp -= sizeofW(StgWord);       *Sp = x;          PushTag(WORD_TAG);   }
+   { gSp -= sizeofW(StgWord);       *gSp = x;          PushTag(WORD_TAG);   }
        inline void            PushTaggedAddr     ( StgAddr       x ) 
-   { Sp -= sizeofW(StgAddr);       *Sp = (W_)x;      PushTag(ADDR_TAG);   }
+   { gSp -= sizeofW(StgAddr);       *gSp = (W_)x;      PushTag(ADDR_TAG);   }
        inline void            PushTaggedChar     ( StgChar       x ) 
-   { Sp -= sizeofW(StgChar);         *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
+   { gSp -= sizeofW(StgChar);         *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
        inline void            PushTaggedFloat    ( StgFloat      x ) 
-   { Sp -= sizeofW(StgFloat);      ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG);  }
+   { gSp -= sizeofW(StgFloat);      ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG);  }
        inline void            PushTaggedDouble   ( StgDouble     x ) 
-   { Sp -= sizeofW(StgDouble);     ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
+   { gSp -= sizeofW(StgDouble);     ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
        inline void            PushTaggedStablePtr   ( StgStablePtr  x ) 
-   { Sp -= sizeofW(StgStablePtr);  *Sp = x;          PushTag(STABLE_TAG); }
+   { gSp -= sizeofW(StgStablePtr);  *gSp = x;          PushTag(STABLE_TAG); }
 static inline void            PushTaggedBool     ( int           x ) 
    { PushTaggedInt(x); }
 
@@ -1571,43 +1572,43 @@ static inline void            PushTaggedBool     ( int           x )
 static inline void            PopTaggedRealWorld ( void ) 
    { PopTag(REALWORLD_TAG); }
        inline StgInt          PopTaggedInt       ( void ) 
-   { StgInt    r; PopTag(INT_TAG);     r = *stgCast(StgInt*,  Sp);      
-     Sp += sizeofW(StgInt);        return r;}
+   { StgInt    r; PopTag(INT_TAG);     r = *stgCast(StgInt*,  gSp);      
+     gSp += sizeofW(StgInt);        return r;}
        inline StgWord         PopTaggedWord      ( void ) 
-   { StgWord   r; PopTag(WORD_TAG);    r = *stgCast(StgWord*, Sp);      
-     Sp += sizeofW(StgWord);       return r;}
+   { StgWord   r; PopTag(WORD_TAG);    r = *stgCast(StgWord*, gSp);      
+     gSp += sizeofW(StgWord);       return r;}
        inline StgAddr         PopTaggedAddr      ( void ) 
-   { StgAddr   r; PopTag(ADDR_TAG);    r = *stgCast(StgAddr*, Sp);      
-     Sp += sizeofW(StgAddr);       return r;}
+   { StgAddr   r; PopTag(ADDR_TAG);    r = *stgCast(StgAddr*, gSp);      
+     gSp += sizeofW(StgAddr);       return r;}
        inline StgChar         PopTaggedChar      ( void ) 
-   { StgChar   r; PopTag(CHAR_TAG);    r = stgCast(StgChar, *Sp);       
-     Sp += sizeofW(StgChar);       return r;}
+   { StgChar   r; PopTag(CHAR_TAG);    r = stgCast(StgChar, *gSp);       
+     gSp += sizeofW(StgChar);       return r;}
        inline StgFloat        PopTaggedFloat     ( void ) 
-   { StgFloat  r; PopTag(FLOAT_TAG);   r = PK_FLT(Sp);                  
-     Sp += sizeofW(StgFloat);      return r;}
+   { StgFloat  r; PopTag(FLOAT_TAG);   r = PK_FLT(gSp);                  
+     gSp += sizeofW(StgFloat);      return r;}
        inline StgDouble       PopTaggedDouble    ( void ) 
-   { StgDouble r; PopTag(DOUBLE_TAG);  r = PK_DBL(Sp);                  
-     Sp += sizeofW(StgDouble);     return r;}
+   { StgDouble r; PopTag(DOUBLE_TAG);  r = PK_DBL(gSp);                  
+     gSp += sizeofW(StgDouble);     return r;}
        inline StgStablePtr    PopTaggedStablePtr    ( void ) 
-   { StgInt    r; PopTag(STABLE_TAG);  r = *stgCast(StgStablePtr*, Sp); 
-     Sp += sizeofW(StgStablePtr);  return r;}
+   { StgInt    r; PopTag(STABLE_TAG);  r = *stgCast(StgStablePtr*, gSp); 
+     gSp += sizeofW(StgStablePtr);  return r;}
 
 
 
 static inline StgInt          taggedStackInt     ( StgStackOffset i ) 
-   { checkTag(INT_TAG,Sp[i]);     return *stgCast(StgInt*,         Sp+1+i); }
+   { checkTag(INT_TAG,gSp[i]);     return *stgCast(StgInt*,         gSp+1+i); }
 static inline StgWord         taggedStackWord    ( StgStackOffset i ) 
-   { checkTag(WORD_TAG,Sp[i]);    return *stgCast(StgWord*,        Sp+1+i); }
+   { checkTag(WORD_TAG,gSp[i]);    return *stgCast(StgWord*,        gSp+1+i); }
 static inline StgAddr         taggedStackAddr    ( StgStackOffset i ) 
-   { checkTag(ADDR_TAG,Sp[i]);    return *stgCast(StgAddr*,        Sp+1+i); }
+   { checkTag(ADDR_TAG,gSp[i]);    return *stgCast(StgAddr*,        gSp+1+i); }
 static inline StgChar         taggedStackChar    ( StgStackOffset i ) 
-   { checkTag(CHAR_TAG,Sp[i]);    return stgCast(StgChar, *(Sp+1+i))   ; }
+   { checkTag(CHAR_TAG,gSp[i]);    return stgCast(StgChar, *(gSp+1+i))   ; }
 static inline StgFloat        taggedStackFloat   ( StgStackOffset i ) 
-   { checkTag(FLOAT_TAG,Sp[i]);   return PK_FLT(Sp+1+i); }
+   { checkTag(FLOAT_TAG,gSp[i]);   return PK_FLT(gSp+1+i); }
 static inline StgDouble       taggedStackDouble  ( StgStackOffset i ) 
-   { checkTag(DOUBLE_TAG,Sp[i]);  return PK_DBL(Sp+1+i); }
+   { checkTag(DOUBLE_TAG,gSp[i]);  return PK_DBL(gSp+1+i); }
 static inline StgStablePtr    taggedStackStable  ( StgStackOffset i ) 
-   { checkTag(STABLE_TAG,Sp[i]);  return *stgCast(StgStablePtr*,   Sp+1+i); }
+   { checkTag(STABLE_TAG,gSp[i]);  return *stgCast(StgStablePtr*,   gSp+1+i); }
 
 
 /* --------------------------------------------------------------------------
@@ -1648,105 +1649,105 @@ static inline StgPtr grabHpNonUpd( nat size )
  * o Stop frames
  * ------------------------------------------------------------------------*/
 
-static inline void PopUpdateFrame( StgClosure* obj )
+static inline void PopUpdateFrame ( StgClosure* obj )
 {
-    /* NB: doesn't assume that Sp == Su */
+    /* NB: doesn't assume that gSp == gSu */
     IF_DEBUG(evaluator,
              fprintf(stderr,  "Updating ");
-             printPtr(stgCast(StgPtr,Su->updatee)); 
+             printPtr(stgCast(StgPtr,gSu->updatee)); 
              fprintf(stderr,  " with ");
              printObj(obj);
-             fprintf(stderr,"Sp = %p\tSu = %p\n\n", Sp, Su);
+             fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
              );
 #ifdef EAGER_BLACKHOLING
 #warn  LAZY_BLACKHOLING is default for StgHugs
 #error Dont know if EAGER_BLACKHOLING works in StgHugs
-    ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE
-           || get_itbl(Su->updatee)->type == SE_BLACKHOLE
-           || get_itbl(Su->updatee)->type == CAF_BLACKHOLE
-           || get_itbl(Su->updatee)->type == SE_CAF_BLACKHOLE
+    ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
+           || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
+           || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
+           || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
            );
 #endif /* EAGER_BLACKHOLING */
-    UPD_IND(Su->updatee,obj);
-    Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
-    Su = Su->link;
+    UPD_IND(gSu->updatee,obj);
+    gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
+    gSu = gSu->link;
 }
 
-static inline void PopStopFrame( StgClosure* obj )
+static inline void PopStopFrame ( StgClosure* obj )
 {
-    /* Move Su just off the end of the stack, we're about to spam the
+    /* Move gSu just off the end of the stack, we're about to gSpam the
      * STOP_FRAME with the return value.
      */
-    Su = stgCast(StgUpdateFrame*,Sp+1);  
-    *stgCast(StgClosure**,Sp) = obj;
+    gSu = stgCast(StgUpdateFrame*,gSp+1);  
+    *stgCast(StgClosure**,gSp) = obj;
 }
 
-static inline void PushCatchFrame( StgClosure* handler )
+static inline void PushCatchFrame ( StgClosure* handler )
 {
     StgCatchFrame* fp;
     /* ToDo: stack check! */
-    Sp -= sizeofW(StgCatchFrame);
-    fp = stgCast(StgCatchFrame*,Sp);
+    gSp -= sizeofW(StgCatchFrame);
+    fp = stgCast(StgCatchFrame*,gSp);
     SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
     fp->handler         = handler;
-    fp->link            = Su;
-    Su = stgCast(StgUpdateFrame*,fp);
+    fp->link            = gSu;
+    gSu = stgCast(StgUpdateFrame*,fp);
 }
 
-static inline void PopCatchFrame( void )
+static inline void PopCatchFrame ( void )
 {
-    /* NB: doesn't assume that Sp == Su */
+    /* NB: doesn't assume that gSp == gSu */
     /* fprintf(stderr,"Popping catch frame\n"); */
-    Sp = stgCast(StgStackPtr,Su) + sizeofW(StgCatchFrame);
-    Su = stgCast(StgCatchFrame*,Su)->link;             
+    gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
+    gSu = stgCast(StgCatchFrame*,gSu)->link;           
 }
 
-static inline void PushSeqFrame( void )
+static inline void PushSeqFrame ( void )
 {
     StgSeqFrame* fp;
     /* ToDo: stack check! */
-    Sp -= sizeofW(StgSeqFrame);
-    fp = stgCast(StgSeqFrame*,Sp);
+    gSp -= sizeofW(StgSeqFrame);
+    fp = stgCast(StgSeqFrame*,gSp);
     SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
-    fp->link = Su;
-    Su = stgCast(StgUpdateFrame*,fp);
+    fp->link = gSu;
+    gSu = stgCast(StgUpdateFrame*,fp);
 }
 
-static inline void PopSeqFrame( void )
+static inline void PopSeqFrame ( void )
 {
-    /* NB: doesn't assume that Sp == Su */
-    Sp = stgCast(StgStackPtr,Su) + sizeofW(StgSeqFrame);
-    Su = stgCast(StgSeqFrame*,Su)->link;               
+    /* NB: doesn't assume that gSp == gSu */
+    gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
+    gSu = stgCast(StgSeqFrame*,gSu)->link;             
 }
 
-static inline StgClosure* raiseAnError( StgClosure* errObj )
+static inline StgClosure* raiseAnError ( StgClosure* errObj )
 {
     StgClosure *raise_closure;
 
     /* This closure represents the expression 'raise# E' where E
      * is the exception raised.  It is used to overwrite all the
-     * thunks which are currently under evaluataion.
+     * thunks which are currently under evaluation.
      */
     raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1);
     raise_closure->header.info = &raise_info;
-    raise_closure->payload[0] = R1.cl;
+    raise_closure->payload[0] = 0xdeadbeef; /*R1.cl;*/
 
     while (1) {
-        switch (get_itbl(Su)->type) {
+        switch (get_itbl(gSu)->type) {
         case UPDATE_FRAME:
-                UPD_IND(Su->updatee,raise_closure);
-                Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
-                Su = Su->link;
+                UPD_IND(gSu->updatee,raise_closure);
+                gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
+                gSu = gSu->link;
                 break;
         case SEQ_FRAME:
                 PopSeqFrame();
                 break;
         case CATCH_FRAME:  /* found it! */
             {
-                StgCatchFrame* fp = stgCast(StgCatchFrame*,Su);
+                StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
                 StgClosure *handler = fp->handler;
-                Su = fp->link; 
-                Sp += sizeofW(StgCatchFrame); /* Pop */
+                gSu = fp->link; 
+                gSp += sizeofW(StgCatchFrame); /* Pop */
                 PushCPtr(errObj);
                 return handler;
            }
@@ -2202,29 +2203,29 @@ void SloppifyIntegerEnd ( StgPtr arr0 )
 }
 
 
-void myStackCheck ( void )
+void myStackCheck ( Capability* cap )
 {
-   //StgPtr sp = (StgPtr)Sp;
-   StgPtr su = (StgPtr)Su;
-   //fprintf(stderr, "myStackCheck\n");
-   if (!(SpLim <= Sp && Sp <= stgCast(StgPtr,Su))) {
-      fprintf(stderr, "myStackCheck: invalid initial Sp/Su \n" );
+   /* fprintf(stderr, "myStackCheck\n"); */
+   if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
+      fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
       assert(0);
    }
    while (1) {
-      if (!(su >= CurrentTSO->stack && su <= CurrentTSO->stack + CurrentTSO->stack_size)) {
-         fprintf ( stderr, "myStackCheck: su out of stack\n" );
+      if (!(gSu >= cap->rCurrentTSO->stack 
+            && gSu <= cap->rCurrentTSO->stack 
+               + cap->rCurrentTSO->stack_size)) {
+         fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
          assert(0);
       }
-      switch (get_itbl(stgCast(StgClosure*,su))->type) {
+      switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
       case CATCH_FRAME:
-         su = (StgPtr) ((StgCatchFrame*)(su))->link;
+         gSu = (StgPtr) ((StgCatchFrame*)(gSu))->link;
          break;
       case UPDATE_FRAME:
-         su = (StgPtr) ((StgUpdateFrame*)(su))->link;
+         gSu = (StgPtr) ((StgUpdateFrame*)(gSu))->link;
          break;
       case SEQ_FRAME:
-         su = (StgPtr) ((StgSeqFrame*)(su))->link;
+         gSu = (StgPtr) ((StgSeqFrame*)(gSu))->link;
          break;
       case STOP_FRAME:
          goto postloop;
@@ -2638,7 +2639,8 @@ static void* enterBCO_primop1 ( int primop1code )
 */
 static void* enterBCO_primop2 ( int primop2code, 
                                 int* /*StgThreadReturnCode* */ return2,
-                                StgBCO** bco )
+                                StgBCO** bco,
+                                Capability* cap )
 {
         switch (primop2code) {
         case i_raise:  /* raise#{err} */
@@ -2757,7 +2759,7 @@ static void* enterBCO_primop2 ( int primop2code,
                 break; 
             }
 
-        /* Most of these generate alignment warnings on Sparcs and similar architectures.
+        /* Most of these generate alignment warnings on gSparcs and similar architectures.
          * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
          */
         case i_indexCharArray:   
@@ -2935,7 +2937,7 @@ static void* enterBCO_primop2 ( int primop2code,
             {
                 StgTSO* tso = stgCast(StgTSO*,PopPtr());
                 deleteThread(tso);
-                if (tso == CurrentTSO) { /* suicide */
+                if (tso == cap->rCurrentTSO) { /* suicide */
                     *return2 = ThreadFinished;
                     return (void*)(1+(NULL));
                 }
@@ -2974,12 +2976,12 @@ off the stack.
                  */
                 if (GET_INFO(mvar) != &FULL_MVAR_info) {
                     if (mvar->head == EndTSOQueue) {
-                        mvar->head = CurrentTSO;
+                        mvar->head = cap->rCurrentTSO;
                     } else {
-                        mvar->tail->link = CurrentTSO;
+                        mvar->tail->link = cap->rCurrentTSO;
                     }
-                    CurrentTSO->link = EndTSOQueue;
-                    mvar->tail = CurrentTSO;
+                    cap->rCurrentTSO->link = EndTSOQueue;
+                    mvar->tail = cap->rCurrentTSO;
 
                     /* Hack, hack, hack.
                      * When we block, we push a restart closure
@@ -3071,7 +3073,7 @@ off the stack.
                 char cc = (primop2code == i_ccall_stdcall_Id ||
                            primop2code == i_ccall_stdcall_IO)
                           ? 's' : 'c';
-                r = ccall(descriptor,funPtr,bco,cc);
+                r = ccall(descriptor,funPtr,bco,cc,cap);
                 if (r == 0) break;
                 if (r == 1) 
                    return makeErrorCall(
@@ -3091,11 +3093,11 @@ off the stack.
  * ccall support code:
  *   marshall moves args from C stack to Haskell stack
  *   unmarshall moves args from Haskell stack to C stack
- *   argSize calculates how much space you need on the C stack
+ *   argSize calculates how much gSpace you need on the C stack
  * ---------------------------------------------------------------------------*/
 
 /* Pop arguments off the C stack and Push them onto the Hugs stack.
- * Used when preparing for C calling Haskell or in response to
+ * Used when preparing for C calling Haskell or in regSponse to
  *  Haskell calling C.
  */
 nat marshall(char arg_ty, void* arg)
@@ -3147,7 +3149,7 @@ nat marshall(char arg_ty, void* arg)
 }
 
 /* Pop arguments off the Hugs stack and Push them onto the C stack.
- * Used when preparing for Haskell calling C or in response to
+ * Used when preparing for Haskell calling C or in regSponse to
  * C calling Haskell.
  */
 nat unmarshall(char res_ty, void* res)

diff --git a/ghc/rts/Evaluator.h b/ghc/rts/Evaluator.h
index 3e4cf0d..a6e46f7 100644 (file)
--- a/ghc/rts/Evaluator.h
+++ b/ghc/rts/Evaluator.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Evaluator.h,v 1.5 1999/10/22 15:58:25 sewardj Exp $
+ * $Id: Evaluator.h,v 1.6 1999/11/08 15:30:37 sewardj Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -26,7 +26,7 @@
  * 
  * ------------------------------------------------------------------------*/
 
-extern StgThreadReturnCode enter        ( StgClosurePtr obj );
+extern StgThreadReturnCode enter ( Capability* cap, StgClosurePtr obj );
 
 extern nat marshall   ( char arg_ty, void* arg );
 extern nat unmarshall ( char res_ty, void* res );

diff --git a/ghc/rts/ForeignCall.c b/ghc/rts/ForeignCall.c
index 5bf75ad..17eb97a 100644 (file)
--- a/ghc/rts/ForeignCall.c
+++ b/ghc/rts/ForeignCall.c
@@ -1,6 +1,6 @@
 
 /* -----------------------------------------------------------------------------
- * $Id: ForeignCall.c,v 1.10 1999/10/26 17:27:30 sewardj Exp $
+ * $Id: ForeignCall.c,v 1.11 1999/11/08 15:30:37 sewardj Exp $
  *
  * (c) The GHC Team 1994-1999.
  *
@@ -13,6 +13,7 @@
 
 #include "RtsUtils.h"    /* barf :-) */
 #include "Assembler.h"   /* for CFun stuff */
+#include "Schedule.h"
 #include "Evaluator.h"
 #include "ForeignCall.h"
 
@@ -227,7 +228,8 @@ static void universal_call_c_generic
 int ccall ( CFunDescriptor*  d, 
             void             (*fun)(void), 
             StgBCO**         bco,
-            char             cc
+            char             cc,
+            Capability*      cap
           )
 {
    double         arg_vec [31];
@@ -235,6 +237,7 @@ int ccall ( CFunDescriptor*  d,
    unsigned int*  p;
    int            i;
    unsigned long  ul;
+   unsigned int   token;
 
    if (sizeof(int) != 4 || sizeof(double) != 8 || sizeof(float) != 4
        || (sizeof(void*) != 4 && sizeof(void*) != 8)
@@ -311,7 +314,10 @@ int ccall ( CFunDescriptor*  d,
    }
  
    PushPtr((StgPtr)(*bco));
-   SaveThreadState();
+   cap->rCurrentTSO->sp    = MainRegTable.rSp;
+   cap->rCurrentTSO->su    = MainRegTable.rSu;
+   cap->rCurrentTSO->splim = MainRegTable.rSpLim;
+   token = suspendThread(cap);
 
 #if i386_TARGET_ARCH
    if (cc == 'c')
@@ -325,7 +331,11 @@ int ccall ( CFunDescriptor*  d,
    universal_call_c_generic ( 
       d->num_args, (void*)arg_vec, argd_vec, fun );
 #endif
-   LoadThreadState();
+
+   cap = resumeThread(token);
+   MainRegTable.rSp    = cap->rCurrentTSO->sp;
+   MainRegTable.rSu    = cap->rCurrentTSO->su;
+   MainRegTable.rSpLim = cap->rCurrentTSO->splim;
    *bco=(StgBCO*)PopPtr();
 
    /* INT, WORD, ADDR, STABLE don't need to do a word-size check

diff --git a/ghc/rts/ForeignCall.h b/ghc/rts/ForeignCall.h
index 5bff124..0a962b5 100644 (file)
--- a/ghc/rts/ForeignCall.h
+++ b/ghc/rts/ForeignCall.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: ForeignCall.h,v 1.7 1999/10/26 17:27:30 sewardj Exp $
+ * $Id: ForeignCall.h,v 1.8 1999/11/08 15:30:39 sewardj Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -12,7 +12,8 @@ typedef int StablePtr;
 extern int ccall ( CFunDescriptor* descriptor, 
                    void            (*fun)(void), 
                    StgBCO**        bco,
-                   char            callconv
+                   char            callconv,
+                   Capability*     cap
                  );
 
 extern StgAddr createAdjThunk ( StgStablePtr stableptr,

diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c
index fb6749a..e614ae7 100644 (file)
--- a/ghc/rts/Schedule.c
+++ b/ghc/rts/Schedule.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.29 1999/11/02 17:19:16 simonmar Exp $
+ * $Id: Schedule.c,v 1.30 1999/11/08 15:30:39 sewardj Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -149,7 +149,7 @@ void            addToBlockedQueue ( StgTSO *tso );
 
 static void     schedule          ( void );
 static void     initThread        ( StgTSO *tso, nat stack_size );
-static void     interruptStgRts   ( void );
+       void     interruptStgRts   ( void );
 
 #ifdef SMP
 pthread_mutex_t sched_mutex       = PTHREAD_MUTEX_INITIALIZER;
@@ -278,17 +278,13 @@ schedule( void )
       break;
     case ThreadEnterHugs:
 #ifdef INTERPRETER
-      {  
-       IF_DEBUG(scheduler,belch("schedule: entering Hugs"));     
-       LoadThreadState();
-       /* CHECK_SENSIBLE_REGS(); */
-       {
-         StgClosure* c = (StgClosure *)Sp[0];
-         Sp += 1;
-         ret = enter(c);
-       }       
-       SaveThreadState();
-       break;
+      {
+         StgClosure* c;
+        IF_DEBUG(scheduler,belch("schedule: entering Hugs"));    
+        c = (StgClosure *)(cap->rCurrentTSO->sp[0]);
+        cap->rCurrentTSO->sp += 1;
+        ret = enter(cap,c);
+         break;
       }
 #else
       barf("Panic: entered a BCO but no bytecode interpreter in this build");