[project @ 2000-02-15 13:16:19 by sewardj]

Backend interop fixes:
-- Make Hugs use the same constructor tag numbering as GHC, viz, starting
   at zero.
-- Evaluator.c: when unwinding the stack on entering a constructor,
   return to the scheduler if a RET_{VEC_}{SMALL|BIG} is found on the
   stack.

ghc/interpreter/hugs.c

@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: hugs.c,v $
- * $Revision: 1.38 $
- * $Date: 2000/02/08 15:32:29 $
+ * $Revision: 1.39 $
+ * $Date: 2000/02/15 13:16:19 $
  * ------------------------------------------------------------------------*/
 
 #include <setjmp.h>
@@ -40,8 +40,6 @@ Bool showInstRes = FALSE;
 Bool multiInstRes = FALSE;
 #endif
 
-#define N_PRELUDE_SCRIPTS (combined ? 30 : 1)
-
 /* --------------------------------------------------------------------------
  * Local function prototypes:
  * ------------------------------------------------------------------------*/

ghc/interpreter/stg.c

@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: stg.c,v $
- * $Revision: 1.10 $
- * $Date: 1999/12/07 11:14:56 $
+ * $Revision: 1.11 $
+ * $Date: 2000/02/15 13:16:20 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -25,32 +25,40 @@
  * Utility functions
  * ------------------------------------------------------------------------*/
 
-void* stgConInfo( StgDiscr d )
+/* Make an info table for a constructor or tuple. */
+void* stgConInfo ( StgDiscr d )
 {
+    int tag;
     switch (whatIs(d)) {
-       case NAME:
+       case NAME: {
+          tag = cfunOf(d);
+          if (tag > 0) tag--;
           if (!name(d).itbl)
-             name(d).itbl = asmMkInfo(cfunOf(d),name(d).arity);
+             name(d).itbl = asmMkInfo(tag,name(d).arity);
           return name(d).itbl;
-       case TUPLE: 
+       }
+       case TUPLE: {
+          tag = 0;
           if (!tycon(d).itbl)
-             tycon(d).itbl = asmMkInfo(0,tupleOf(d));
+             tycon(d).itbl = asmMkInfo(tag,tupleOf(d));
           return tycon(d).itbl;
+       }
        default: 
           internal("stgConInfo");
     }
 }
 
-int stgDiscrTag( StgDiscr d )
+/* Return the tag for a constructor or tuple, starting at zero. */
+int stgDiscrTag ( StgDiscr d )
 {
+    int tag;
     switch (whatIs(d)) {
-    case NAME:
-            return cfunOf(d);
-    case TUPLE: 
-            return 0;
-    default: 
-            internal("stgDiscrTag");
+       case NAME:  tag = cfunOf(d); break;
+       case TUPLE: tag = 0;
+       default:    internal("stgDiscrTag");   
     }
+    if (tag > 0) tag--;
+    return tag;
 }
 
 /* --------------------------------------------------------------------------

ghc/interpreter/storage.c

@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.c,v $
- * $Revision: 1.42 $
- * $Date: 2000/02/08 17:50:46 $
+ * $Revision: 1.43 $
+ * $Date: 2000/02/15 13:16:20 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -1643,12 +1643,13 @@ String f; {                             /* of status for later restoration  */
 }
 
 Bool isPreludeScript() {                /* Test whether this is the Prelude*/
-    return (scriptHw==0);
+    return (scriptHw < N_PRELUDE_SCRIPTS /*==0*/ );
 }
 
 Bool moduleThisScript(m)                /* Test if given module is defined */
 Module m; {                             /* in current script file          */
-    return scriptHw<1 || m>=scripts[scriptHw-1].moduleHw;
+    return scriptHw < 1
+           || m>=scripts[scriptHw-1].moduleHw;
 }
 
 Module lastModule() {              /* Return module in current script file */

ghc/interpreter/storage.h

@@ -10,8 +10,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.h,v $
- * $Revision: 1.25 $
- * $Date: 2000/01/11 15:40:57 $
+ * $Revision: 1.26 $
+ * $Date: 2000/02/15 13:16:20 $
  * ------------------------------------------------------------------------*/
 
 /* --------------------------------------------------------------------------
@@ -545,6 +545,8 @@ extern void* lookupOExtraTabName ( char* sym );
 
 #define isPrelude(m) (m==modulePrelude)
 
+#define N_PRELUDE_SCRIPTS (combined ? 30 : 1)
+
 /* --------------------------------------------------------------------------
  * Type constructor names:
  * ------------------------------------------------------------------------*/

ghc/rts/Evaluator.c

@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Evaluator.c,v $
- * $Revision: 1.32 $
- * $Date: 2000/02/14 11:04:58 $
+ * $Revision: 1.33 $
+ * $Date: 2000/02/15 13:16:20 $
  * ---------------------------------------------------------------------------*/
 
 #include "Rts.h"
@@ -851,7 +851,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
                 {
                     int  tag       = BCO_INSTR_8;
                     StgWord offset = BCO_INSTR_16;
-                    if (constrTag(stgCast(StgClosure*,xStackPtr(0))) != tag) {
+                    if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
                         bciPtr += offset;
                     }
                     Continue;
@@ -1448,7 +1448,9 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
                 case RET_VEC_SMALL:
                 case RET_BIG:
                 case RET_VEC_BIG:
-		  //       barf("todo: RET_[VEC_]{BIG,SMALL}");
+                        cap->rCurrentTSO->whatNext = ThreadEnterGHC;
+                        xPushCPtr(obj);
+                        RETURN(ThreadYielding);
                 default:
                         belch("entered CONSTR with invalid continuation on stack");
                         IF_DEBUG(evaluator,

ghc/rts/StgCRun.c

 /* -----------------------------------------------------------------------------
- * $Id: StgCRun.c,v 1.10 2000/02/14 11:01:27 sewardj Exp $
+ * $Id: StgCRun.c,v 1.11 2000/02/15 13:16:20 sewardj Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -38,7 +38,7 @@
 
 static jmp_buf jmp_environment;
 
-#if 1
+#if 0
 
 extern StgThreadReturnCode StgRun(StgFunPtr f, StgRegTable *basereg)
 {