[project @ 2000-04-06 14:23:55 by sewardj]

Align Hugs' constructor-building with that of GHC.  Always pass dictionaries
to the constructor function, even if they are ignored.  Generate a
constructor function which expects dictionaries.  And ignore dictionaries
in constructor types when desugaring patterns containing them.

diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c
index 4ab3144..ac85831 100644 (file)
--- a/ghc/interpreter/compiler.c
+++ b/ghc/interpreter/compiler.c
@@ -11,8 +11,8 @@
  * included in the distribution.
  *
  * $RCSfile: compiler.c,v $
- * $Revision: 1.25 $
- * $Date: 2000/03/24 14:32:03 $
+ * $Revision: 1.26 $
+ * $Date: 2000/04/06 14:23:55 $
  * ------------------------------------------------------------------------*/
 
 #include "hugsbasictypes.h"
@@ -847,7 +847,7 @@ List lds; {
                          }
 
         case DICTVAR   : /* shouldn't really occur */
-                         assert(0); /* so let's test for it then! ADR */
+         //assert(0); /* so let's test for it then! ADR */
         case VARIDCELL :
         case VAROPCELL : return addEqn(pat,expr,lds);
 
@@ -865,10 +865,15 @@ List lds; {
                          /* intentional fall-thru */
         case TUPLE     : {   List ps = getArgs(pat);
 
+                             /* get rid of leading dictionaries in args */
+                             if (isName(c) && isCfun(c)) {
+                                Int i = numQualifiers(name(c).type);
+                                for (; i > 0; i--) ps = tl(ps);
+                             }
+
                              if (nonNull(ps)) {
                                  Cell nv, sel;
                                  Int  i;
-
                                  if (isVar(expr) || isName(expr))
                                      nv  = expr;
                                  else {

diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c
index e82660a..39e68ea 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.64 $
- * $Date: 2000/04/06 00:01:27 $
+ * $Revision: 1.65 $
+ * $Date: 2000/04/06 14:23:55 $
  * ------------------------------------------------------------------------*/
 
 #include "hugsbasictypes.h"
@@ -523,7 +523,7 @@ static Bool debugStorageExtra = FALSE;
             newTab[i].inUse = FALSE;                                    \
             newTab[i].nextFree = i-1+TAB_BASE_ADDR;                     \
          }                                                              \
-         if (debugStorageExtra)                                         \
+         if (0 && debugStorageExtra)                                    \
             fprintf(stderr, "Expanding " #type_name                     \
                             "table to size %d\n", newSz );              \
          newTab[tab_size].nextFree = TAB_BASE_ADDR-1;                   \
@@ -1532,6 +1532,15 @@ List getAllKnownTyconsAndClasses ( void )
    return xs;
 }
 
+Int numQualifiers ( Type t )
+{
+   if (isPolyType(t)) t = monotypeOf(t);
+   if (isQualType(t)) 
+       return length ( fst(snd(t)) ); else
+       return 0;
+}
+
+
 /* Purely for debugging. */
 void locateSymbolByName ( Text t )
 {
@@ -2013,7 +2022,7 @@ Void garbageCollect()     {             /* Run garbage collector ...       */
     everybody(GCDONE);
 
 #if defined(DEBUG_STORAGE) || defined(DEBUG_STORAGE_EXTRA)
-    fprintf(stderr, "\n--- GC recovered %d\n",recovered );
+    /* fprintf(stderr, "\n--- GC recovered %d\n",recovered ); */
 #endif
 
     /* can only return if freeList is nonempty on return. */

diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h
index 8fc200f..e05bfb2 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.40 $
- * $Date: 2000/04/05 16:57:18 $
+ * $Revision: 1.41 $
+ * $Date: 2000/04/06 14:23:55 $
  * ------------------------------------------------------------------------*/
 
 #define DEBUG_STORAGE               /* a moderate level of sanity checking */
@@ -688,11 +688,11 @@ struct strTycon {
 extern struct strTycon* tabTycon;
 extern Int              tabTyconSz;
 
-extern Tycon newTycon     ( Text );
-extern Tycon findTycon    ( Text );
-extern Tycon addTycon     ( Tycon );
+extern Tycon newTycon      ( Text );
+extern Tycon findTycon     ( Text );
+extern Tycon addTycon      ( Tycon );
 extern Tycon findQualTycon ( Cell );
-extern Tycon addPrimTycon ( Text,Kind,Int,Cell,Cell );
+extern Tycon addPrimTycon  ( Text,Kind,Int,Cell,Cell );
 
 #define isSynonym(h)    (isTycon(h) && tycon(h).what==SYNONYM)
 #define isQualType(t)  (isPair(t) && fst(t)==QUAL)
@@ -705,6 +705,9 @@ extern Tycon addPrimTycon ( Text,Kind,Int,Cell,Cell );
 
 extern Tycon findQualTyconWithoutConsultingExportList ( QualId q );
 
+extern Int numQualifiers   ( Type );
+
+
 /* --------------------------------------------------------------------------
  * Globally defined name values:
  * ------------------------------------------------------------------------*/

diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c
index 54b01b9..eee6260 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.31 $
- * $Date: 2000/04/05 10:25:09 $
+ * $Revision: 1.32 $
+ * $Date: 2000/04/06 14:23:55 $
  * ------------------------------------------------------------------------*/
 
 #include "hugsbasictypes.h"
@@ -454,11 +454,15 @@ Void stgDefn( Name n, Int arity, Cell e )
 Void implementCfun(c,scs)               /* Build implementation for constr */
 Name c;                                 /* fun c.  scs lists integers (1..)*/
 List scs; {                             /* in incr order of strict fields. */
-    Int a = name(c).arity;
+    Int  a  = name(c).arity;               /* arity, not incl dictionaries */
+    Int  ad = numQualifiers(name(c).type);   /* the number of dictionaries */
+    Type t  = name(c).type;
 
-    if (a > 0) {
+    /* a+ad is total arity for this fn */
+    if (a+ad > 0) {
         StgVar  vcurr, e1, v, vsi;
         List    args  = makeArgs(a);
+        List    argsd = makeArgs(ad);
         StgVar  v0    = mkStgVar(mkStgCon(c,args),NIL);
         List    binds = singleton(v0);
 
@@ -470,7 +474,7 @@ List scs; {                             /* in incr order of strict fields. */
         }
         binds = rev(binds);
         e1    = mkStgLet(binds,vcurr);
-        v     = mkStgVar(mkStgLambda(args,e1),NIL);
+        v     = mkStgVar(mkStgLambda(dupOnto(argsd,args),e1),NIL);
         name(c).stgVar = v;
     } else {
         StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);

diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c
index 063e469..eb2d2d9 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.33 $
- * $Date: 2000/04/06 00:01:27 $
+ * $Revision: 1.34 $
+ * $Date: 2000/04/06 14:23:55 $
  * ------------------------------------------------------------------------*/
 
 #include "hugsbasictypes.h"
@@ -800,7 +800,7 @@ Cell e; {                               /* requires polymorphism, qualified*/
         for (; nonNull(predsAre); predsAre=tl(predsAre)) {
             evs = cons(assumeEvid(hd(predsAre),typeOff),evs);
         }
-        if (!isName(h) || !isCfun(h)) {
+        /* we now _always_ do this: if (!isName(h) || !isCfun(h)) */ {
             h = applyToArgs(h,rev(evs));
         }
     }