[project @ 1999-12-06 16:25:23 by sewardj]

Remove Hugs' special treatment of tuples, and instead have them as
just another Tycon.  This is to make interworking with GHC simpler.

Put tuple entries in the Tycon table.  Modify isTycon, isTuple, tupleOf,
mkTuple and whatIs so that client code doesn't see any difference.
Add allocTupleTycon to manufacture tuple Tycon entries as startup.

diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c
index 2ffd55a..c47ca21 100644 (file)
--- a/ghc/interpreter/codegen.c
+++ b/ghc/interpreter/codegen.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: codegen.c,v $
- * $Revision: 1.12 $
- * $Date: 1999/11/29 18:59:25 $
+ * $Revision: 1.13 $
+ * $Date: 1999/12/06 16:25:23 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -476,14 +476,12 @@ static Void alloc( AsmBCO bco, StgVar v )
                    itblNames[nItblNames++] = textToStr(name(con).text);
                 } else
                 if (isTuple(con)) {
-                   char* cc = malloc(10);
-                   assert(cc);
+                   char cc[20];
                    sprintf(cc, "Tuple%d", tupleOf(con) );
                    itblNames[nItblNames++] = vv;
                    itblNames[nItblNames++] = cc;
                 } else
                 assert ( /* cant identify constructor name */ 0 );
-
                 setPos(v,asmAllocCONSTR(bco, vv));
             }
             break;
@@ -745,7 +743,7 @@ Void cgBinds( List binds )
     }
 
     for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
-      //printf("endTop %s\n", maybeName(hd(b)));
+       //printStg( stdout, hd(b) ); printf( "\n\n");
        endTop(hd(b));
     }
 

diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c
index 8aad0eb..f5c69a1 100644 (file)
--- a/ghc/interpreter/hugs.c
+++ b/ghc/interpreter/hugs.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: hugs.c,v $
- * $Revision: 1.28 $
- * $Date: 1999/12/03 17:01:20 $
+ * $Revision: 1.29 $
+ * $Date: 1999/12/06 16:25:24 $
  * ------------------------------------------------------------------------*/
 
 #include <setjmp.h>
@@ -306,7 +306,20 @@ String argv[]; {
 
    namesUpto = numScripts = 0;
 
-   for (i=1; i<argc; ++i) {            /* process command line arguments  */
+   /* Pre-scan flags to see if -c or +c is present.  This needs to
+      precede adding the stack entry for Prelude.  On the other hand,
+      that stack entry needs to be made before the cmd line args are
+      properly examined.  Hence the following pre-scan of them.
+   */
+   for (i=1; i < argc; ++i) {
+      if (strcmp(argv[i], "--")==0) break;
+      if (strcmp(argv[i], "-c")==0) combined = FALSE;
+      if (strcmp(argv[i], "+c")==0) combined = TRUE;
+   }
+
+   addStackEntry("Prelude");
+
+   for (i=1; i < argc; ++i) {            /* process command line arguments  */
         if (strcmp(argv[i], "--")==0) break;
         if (strcmp(argv[i],"+")==0 && i+1<argc) {
             if (proj) {
@@ -321,8 +334,6 @@ String argv[]; {
         }
     }
 
-   addStackEntry("Prelude");
-
 #if DEBUG
     { 
        char exe_name[N_INSTALLDIR + 6];
@@ -586,7 +597,8 @@ String s; {                             /* return FALSE if none found.     */
                                   "You can't enable/disable combined"
                                   " operation inside Hugs\n" );
                        } else {
-                          combined = state;
+                         /* don't do anything, since pre-scan of args
+                             will have got it already */
                        }
                        return TRUE;
 

diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c
index b7def70..d7d9bdb 100644 (file)
--- a/ghc/interpreter/link.c
+++ b/ghc/interpreter/link.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: link.c,v $
- * $Revision: 1.19 $
- * $Date: 1999/12/03 17:56:04 $
+ * $Revision: 1.20 $
+ * $Date: 1999/12/06 16:25:25 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -474,6 +474,7 @@ Void linkPreludeNames(void) {           /* Hook to names defined in Prelude */
 
 Void linkControl(what)
 Int what; {
+    Int i;
     switch (what) {
         case RESET   :
         case MARK    : 
@@ -484,6 +485,10 @@ Int what; {
                        modulePrelude = newModule(textPrelude);
                        setCurrModule(modulePrelude);
 
+                       for(i=0; i<NUM_TUPLES; ++i) {
+                           allocTupleTycon(i);
+                       }
+
                        typeArrow = addPrimTycon(findText("(->)"),
                                                 pair(STAR,pair(STAR,STAR)),
                                                 2,DATATYPE,NIL);

diff --git a/ghc/interpreter/runnofib b/ghc/interpreter/runnofib
index 3aeca64..38cc5be 100644 (file)
--- a/ghc/interpreter/runnofib
+++ b/ghc/interpreter/runnofib
@@ -19,20 +19,20 @@ fi
 
 if [ -f $NROOT/$1/$2/$2.stdin ]
 then 
-echo "$HUGZ/hugs -Q -P$NROOT/$1/$2 Main -- $3 $4 $5 $6 $7 $8 $9"
+echo "$HUGZ/hugs -Q -c -P$NROOT/$1/$2 Main -- $3 $4 $5 $6 $7 $8 $9"
 echo "     < $NROOT/$1/$2/$2.stdin 2> /dev/null"
 echo "     > $TMPFILE"
 else
-echo "$HUGZ/hugs -Q -P$NROOT/$1/$2 Main -- $3 $4 $5 $6 $7 $8 $9"
+echo "$HUGZ/hugs -Q -c -P$NROOT/$1/$2 Main -- $3 $4 $5 $6 $7 $8 $9"
 echo "     < /dev/null 2> /dev/null"
 echo "     > $TMPFILE"
 fi
 
 if [ -f $NROOT/$1/$2/$2.stdin ]
 then 
-$HUGZ/hugs -Q -P$NROOT/$1/$2 Main -- $3 $4 $5 $6 $7 $8 $9 < $NROOT/$1/$2/$2.stdin 2> /dev/null > $TMPFILE
+$HUGZ/hugs -Q -c -P$NROOT/$1/$2 Main -- $3 $4 $5 $6 $7 $8 $9 < $NROOT/$1/$2/$2.stdin 2> /dev/null > $TMPFILE
 else
-$HUGZ/hugs -Q -P$NROOT/$1/$2 Main -- $3 $4 $5 $6 $7 $8 $9 < /dev/null  2> /dev/null > $TMPFILE
+$HUGZ/hugs -Q -c -P$NROOT/$1/$2 Main -- $3 $4 $5 $6 $7 $8 $9 < /dev/null  2> /dev/null > $TMPFILE
 fi
 
 if [ $? -ne 0 ]; then

diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c
index a050959..1ee4eb8 100644 (file)
--- a/ghc/interpreter/storage.c
+++ b/ghc/interpreter/storage.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.c,v $
- * $Revision: 1.21 $
- * $Date: 1999/12/03 17:01:23 $
+ * $Revision: 1.22 $
+ * $Date: 1999/12/06 16:25:25 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -466,6 +466,7 @@ Text t; {
     tycon(tyconHw).what          = NIL;
     tycon(tyconHw).conToTag      = NIL;
     tycon(tyconHw).tagToCon      = NIL;
+    tycon(tyconHw).tuple         = -1;
     tycon(tyconHw).mod           = currentModule;
     module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons);
     tycon(tyconHw).nextTyconHash = tyconHash[h];
@@ -496,7 +497,7 @@ Tycon tc; {
 
 static Void local hashTycon(tc)         /* Insert Tycon into hash table    */
 Tycon tc; {
-   assert(isTycon(tc));
+   assert(isTycon(tc) || isTuple(tc));
    if (1) {
      Text  t = tycon(tc).text;
      Int   h = tHash(t);
@@ -590,6 +591,35 @@ Tycon tup; {
     return findText(buf);
 }
 
+Tycon mkTuple ( Int n )
+{
+   Int i;
+   if (n >= NUM_TUPLES)
+      internal("mkTuple: request for tuple of unsupported size");
+   for (i = TYCMIN; i < tyconHw; i++)
+      if (tycon(i).tuple == n) return i;
+   internal("mkTuple: request for non-existent tuple");
+}
+
+Void allocTupleTycon ( Int n )
+{
+   Int   i;
+   char  buf[20];
+   Kind  k;
+   Tycon t;
+   for (i = TYCMIN; i < tyconHw; i++)
+      if (tycon(i).tuple == n) return;
+   sprintf(buf,"Tuple%d",n);
+   //t = addPrimTycon(findText(buf),simpleKind(n),n, DATATYPE,NIL);
+
+   k = STAR;
+   for (i = 0; i < n; i++) k = ap(STAR,k);
+   t = newTycon(findText(buf));
+   tycon(t).kind = k;
+   tycon(t).tuple = n;
+   tycon(t).what = DATATYPE;
+}
+
 /* --------------------------------------------------------------------------
  * Name storage:
  *
@@ -1818,7 +1848,7 @@ register Cell c; {
                                         else            return CLASS;}
                     else                if (c>=INSTMIN) return INSTANCE;
                                         else            return NAME;}
-    else            if (c>=MODMIN)     {if (c>=TYCMIN)  return TYCON;
+    else            if (c>=MODMIN)     {if (c>=TYCMIN)  return isTuple(c) ? TUPLE : TYCON;
                                         else            return MODULE;}
                     else                if (c>=OFFMIN)  return OFFSET;
 #if TREX

diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h
index 36bb320..a81ec69 100644 (file)
--- a/ghc/interpreter/storage.h
+++ b/ghc/interpreter/storage.h
@@ -10,8 +10,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.h,v $
- * $Revision: 1.16 $
- * $Date: 1999/12/03 17:01:25 $
+ * $Revision: 1.17 $
+ * $Date: 1999/12/06 16:25:27 $
  * ------------------------------------------------------------------------*/
 
 /* --------------------------------------------------------------------------
@@ -355,6 +355,9 @@ extern  Ptr             cptrOf          Args((Cell));
  * ------------------------------------------------------------------------*/
 
 #define TUPMIN       201
+
+#if 0
+#error xyzzy
 #if TREX
 #define isTuple(c)   (TUPMIN<=(c) && (c)<EXTMIN)
 #else
@@ -362,6 +365,8 @@ extern  Ptr             cptrOf          Args((Cell));
 #endif
 #define mkTuple(n)   (TUPMIN+(n))
 #define tupleOf(n)   ((Int)((n)-TUPMIN))
+#endif
+
 extern Text ghcTupleText Args((Tycon));
 
 
@@ -483,14 +488,20 @@ extern DLSect    lookupDLSect Args((void*));
  * ------------------------------------------------------------------------*/
 
 #define TYCMIN       (MODMIN+NUM_MODULE)
-#define isTycon(c)   (TYCMIN<=(c) && (c)<NAMEMIN)
-#define mkTycon(n)   (TCMIN+(n))
+#define isTycon(c)   (TYCMIN<=(c) && (c)<NAMEMIN && tabTycon[(c)-TYCMIN].tuple==-1)
 #define tycon(n)     tabTycon[(n)-TYCMIN]
 
+#define isTuple(c)   (TYCMIN<=(c) && (c)<NAMEMIN && tabTycon[(c)-TYCMIN].tuple>=0)
+#define tupleOf(n)   (tabTycon[(n)-TYCMIN].tuple)
+extern Tycon mkTuple ( Int );
+extern Void allocTupleTycon ( Int );
+
+
 struct strTycon {
     Text   text;
     Int    line;
     Module mod;                         /* module that defines it          */
+    Int    tuple;                      /* tuple number, or -1 if not tuple */
     Int    arity;
     Kind   kind;                        /* kind (includes arity) of Tycon  */
     Cell   what;                        /* DATATYPE/SYNONYM/RESTRICTSYN... */

diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c
index 0fb0439..392472b 100644 (file)
--- a/ghc/interpreter/translate.c
+++ b/ghc/interpreter/translate.c
@@ -10,8 +10,8 @@
  * included in the distribution.
  *
  * $RCSfile: translate.c,v $
- * $Revision: 1.21 $
- * $Date: 1999/12/03 17:01:26 $
+ * $Revision: 1.22 $
+ * $Date: 1999/12/06 16:25:27 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -1006,7 +1006,6 @@ Void implementForeignExport ( Name n )
     }
 }
 
-// ToDo: figure out how to set inlineMe for these (non-Name) things
 Void implementTuple(size)
 Int size; {
     if (size > 0) {

diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c
index 9c625e9..12c0458 100644 (file)
--- a/ghc/interpreter/type.c
+++ b/ghc/interpreter/type.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: type.c,v $
- * $Revision: 1.17 $
- * $Date: 1999/11/29 18:59:34 $
+ * $Revision: 1.18 $
+ * $Date: 1999/12/06 16:25:28 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -2765,7 +2765,7 @@ Void typeChecker(what)
 Int what; {
     switch (what) {
         case RESET   : tcMode       = EXPRESSION;
-+                     daSccs       = NIL;
+                      daSccs       = NIL;
                        preds        = NIL;
                        pendingBtyvs = NIL;
                        daSccs       = NIL;