X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Ftype.c;h=eb2d2d9f4050187ddd5ee6ad8a28b82fec06e00f;hb=f016aea1357b8ce5a4f3cd866b32761cfd25f841;hp=726c14f48f20358f8cc989d14ab25275c180f001;hpb=59c9a5828f3d060aabafc7e00f8ee6a17e1c51ab;p=ghc-hetmet.git

diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c
index 726c14f..eb2d2d9 100644
--- a/ghc/interpreter/type.c
+++ b/ghc/interpreter/type.c
@@ -9,17 +9,15 @@
  * included in the distribution.
  *
  * $RCSfile: type.c,v $
- * $Revision: 1.15 $
- * $Date: 1999/11/19 15:42:08 $
+ * $Revision: 1.34 $
+ * $Date: 2000/04/06 14:23:55 $
  * ------------------------------------------------------------------------*/
 
-#include "prelude.h"
+#include "hugsbasictypes.h"
 #include "storage.h"
-#include "backend.h"
 #include "connect.h"
-#include "link.h"
 #include "errors.h"
-#include "subst.h"
+
 #include "Assembler.h" /* for AsmCTypes */
 
 /*#define DEBUG_TYPES*/
@@ -28,87 +26,82 @@
 /*#define DEBUG_SELS*/
 /*#define DEBUG_DEPENDS*/
 /*#define DEBUG_DERIVING*/
-/*#define DEBUG_CODE*/
-
-Bool catchAmbigs       = FALSE;         /* TRUE => functions with ambig.   */
-                                        /*         types produce error     */
-
 
 /* --------------------------------------------------------------------------
  * Local function prototypes:
  * ------------------------------------------------------------------------*/
 
-static Void   local emptyAssumption   Args((Void));
-static Void   local enterBindings     Args((Void));
-static Void   local leaveBindings     Args((Void));
-static Int    local defType           Args((Cell));
-static Type   local useType           Args((Cell));
-static Void   local markAssumList     Args((List));
-static Cell   local findAssum         Args((Text));
-static Pair   local findInAssumList   Args((Text,List));
-static List   local intsIntersect     Args((List,List));
-static List   local genvarAllAss      Args((List));
-static List   local genvarAnyAss      Args((List));
-static Int    local newVarsBind       Args((Cell));
-static Void   local newDefnBind       Args((Cell,Type));
-
-static Void   local enterPendingBtyvs Args((Void));
-static Void   local leavePendingBtyvs Args((Void));
-static Cell   local patBtyvs          Args((Cell));
-static Void   local doneBtyvs         Args((Int));
-static Void   local enterSkolVars     Args((Void));
-static Void   local leaveSkolVars     Args((Int,Type,Int,Int));
-
-static Void   local typeError         Args((Int,Cell,Cell,String,Type,Int));
-static Void   local reportTypeError   Args((Int,Cell,Cell,String,Type,Type));
-static Void   local cantEstablish     Args((Int,String,Cell,Type,List));
-static Void   local tooGeneral        Args((Int,Cell,Type,Type));
-
-static Cell   local typeExpr          Args((Int,Cell));
-
-static Cell   local typeAp            Args((Int,Cell));
-static Type   local typeExpected      Args((Int,String,Cell,Type,Int,Int,Bool));
-static Void   local typeAlt           Args((String,Cell,Cell,Type,Int,Int));
-static Int    local funcType          Args((Int));
-static Void   local typeCase          Args((Int,Int,Cell));
-static Void   local typeComp          Args((Int,Type,Cell,List));
-static Cell   local typeMonadComp     Args((Int,Cell));
-static Void   local typeDo            Args((Int,Cell));
-static Void   local typeConFlds       Args((Int,Cell));
-static Void   local typeUpdFlds       Args((Int,Cell));
+static Void   local emptyAssumption   ( Void );
+static Void   local enterBindings     ( Void );
+static Void   local leaveBindings     ( Void );
+static Int    local defType           ( Cell );
+static Type   local useType           ( Cell );
+static Void   local markAssumList     ( List );
+static Cell   local findAssum         ( Text );
+static Pair   local findInAssumList   ( Text,List );
+static List   local intsIntersect     ( List,List );
+static List   local genvarAllAss      ( List );
+static List   local genvarAnyAss      ( List );
+static Int    local newVarsBind       ( Cell );
+static Void   local newDefnBind       ( Cell,Type );
+
+static Void   local enterPendingBtyvs ( Void );
+static Void   local leavePendingBtyvs ( Void );
+static Cell   local patBtyvs          ( Cell );
+static Void   local doneBtyvs         ( Int );
+static Void   local enterSkolVars     ( Void );
+static Void   local leaveSkolVars     ( Int,Type,Int,Int );
+
+static Void   local typeError         ( Int,Cell,Cell,String,Type,Int );
+static Void   local reportTypeError   ( Int,Cell,Cell,String,Type,Type );
+static Void   local cantEstablish     ( Int,String,Cell,Type,List );
+static Void   local tooGeneral        ( Int,Cell,Type,Type );
+
+static Cell   local typeExpr          ( Int,Cell );
+
+static Cell   local typeAp            ( Int,Cell );
+static Type   local typeExpected      ( Int,String,Cell,Type,Int,Int,Bool );
+static Void   local typeAlt           ( String,Cell,Cell,Type,Int,Int );
+static Int    local funcType          ( Int );
+static Void   local typeCase          ( Int,Int,Cell );
+static Void   local typeComp          ( Int,Type,Cell,List );
+static Cell   local typeMonadComp     ( Int,Cell );
+static Void   local typeDo            ( Int,Cell );
+static Void   local typeConFlds       ( Int,Cell );
+static Void   local typeUpdFlds       ( Int,Cell );
 #if IPARAM
-static Cell   local typeWith	      Args((Int,Cell));
+static Cell   local typeWith	      ( Int,Cell );
 #endif
-static Cell   local typeFreshPat      Args((Int,Cell));
+static Cell   local typeFreshPat      ( Int,Cell );
 
-static Void   local typeBindings      Args((List));
-static Void   local removeTypeSigs    Args((Cell));
+static Void   local typeBindings      ( List );
+static Void   local removeTypeSigs    ( Cell );
 
-static Void   local monorestrict      Args((List));
-static Void   local restrictedBindAss Args((Cell));
-static Void   local restrictedAss     Args((Int,Cell,Type));
+static Void   local monorestrict      ( List );
+static Void   local restrictedBindAss ( Cell );
+static Void   local restrictedAss     ( Int,Cell,Type );
 
-static Void   local unrestricted      Args((List));
-static List   local itbscc            Args((List));
-static Void   local addEvidParams     Args((List,Cell));
+static Void   local unrestricted      ( List );
+static List   local itbscc            ( List );
+static Void   local addEvidParams     ( List,Cell );
 
-static Void   local typeClassDefn     Args((Class));
-static Void   local typeInstDefn      Args((Inst));
-static Void   local typeMember        Args((String,Name,Cell,List,Cell,Int));
+static Void   local typeClassDefn     ( Class );
+static Void   local typeInstDefn      ( Inst );
+static Void   local typeMember        ( String,Name,Cell,List,Cell,Int );
 
-static Void   local typeBind          Args((Cell));
-static Void   local typeDefAlt        Args((Int,Cell,Pair));
-static Cell   local typeRhs           Args((Cell));
-static Void   local guardedType       Args((Int,Cell));
+static Void   local typeBind          ( Cell );
+static Void   local typeDefAlt        ( Int,Cell,Pair );
+static Cell   local typeRhs           ( Cell );
+static Void   local guardedType       ( Int,Cell );
 
-static Void   local genBind           Args((List,Cell));
-static Void   local genAss            Args((Int,List,Cell,Type));
-static Type   local genTest           Args((Int,Cell,List,Type,Type,Int));
-static Type   local generalize        Args((List,Type));
-static Bool   local equalTypes        Args((Type,Type));
+static Void   local genBind           ( List,Cell );
+static Void   local genAss            ( Int,List,Cell,Type );
+static Type   local genTest           ( Int,Cell,List,Type,Type,Int );
+static Type   local generalize        ( List,Type );
+static Bool   local equalTypes        ( Type,Type );
 
-static Void   local typeDefnGroup     Args((List));
-static Pair   local typeSel           Args((Name));
+static Void   local typeDefnGroup     ( List );
+static Pair   local typeSel           ( Name );
 
 
 
@@ -151,6 +144,10 @@ static List localEvs;                   /*::[[(Pred,offset,ev)]]           */
 static List savedPs;                    /*::[[(Pred,offset,ev)]]           */
 static Cell dummyVar;                   /* Used to put extra tvars into ass*/
 
+Bool catchAmbigs       = FALSE;         /* TRUE => functions with ambig.   */
+                                        /*         types produce error     */
+
+
 #define saveVarsAss()     List saveAssump = hd(varsBounds)
 #define restoreVarsAss()  hd(varsBounds)  = saveAssump
 #define addVarAssump(v,t) hd(varsBounds)  = cons(pair(v,t),hd(varsBounds))
@@ -544,7 +541,7 @@ Type dt, it; {
 static int tcMode = EXPRESSION;
 
 #ifdef DEBUG_TYPES
-static Cell local mytypeExpr    Args((Int,Cell));
+static Cell local mytypeExpr    ( Int,Cell));
 static Cell local typeExpr(l,e)
 Int l;
 Cell e; {
@@ -725,12 +722,10 @@ Cell e; {
         case LAZYPAT    : snd(e) = typeExpr(l,snd(e));
                           break;
 
-#if NPLUSK
         case ADDPAT     : {   Int alpha = newTyvars(1);
                               inferType(typeVarToVar,alpha);
                               return ap(e,assumeEvid(predIntegral,alpha));
                           }
-#endif
 
         default         : internal("typeExpr");
    }
@@ -805,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));
         }
     }
@@ -1114,15 +1109,18 @@ Cell e;
 List qs; {
     static String boolQual = "boolean qualifier";
     static String genQual  = "generator";
+#if IPARAM
+    List svPreds;
+#endif
 
     STACK_CHECK
-    if (isNull(qs))                     /* no qualifiers left              */
-        fst(e) = typeExpr(l,fst(e));
-    else {
+    if (isNull(qs)) {			/* no qualifiers left		   */
+	spTypeExpr(l,fst(e));
+    } else {
         Cell q   = hd(qs);
         List qs1 = tl(qs);
         switch (whatIs(q)) {
-            case BOOLQUAL : check(l,snd(q),NIL,boolQual,typeBool,0);
+	    case BOOLQUAL : spCheck(l,snd(q),NIL,boolQual,typeBool,0);
                             typeComp(l,m,e,qs1);
                             break;
 
@@ -1136,7 +1134,7 @@ List qs; {
 
             case FROMQUAL : {   Int beta = newTyvars(1);
                                 saveVarsAss();
-                                check(l,snd(snd(q)),NIL,genQual,m,beta);
+				spCheck(l,snd(snd(q)),NIL,genQual,m,beta);
                                 enterSkolVars();
                                 fst(snd(q))
                                     = typeFreshPat(l,patBtyvs(fst(snd(q))));
@@ -1148,7 +1146,7 @@ List qs; {
                             }
                             break;
 
-            case DOQUAL   : check(l,snd(q),NIL,genQual,m,newTyvars(1));
+	    case DOQUAL   : spCheck(l,snd(q),NIL,genQual,m,newTyvars(1));
                             typeComp(l,m,e,qs1);
                             break;
         }
@@ -1199,6 +1197,9 @@ Cell e; {
     Int  to;
     Int  tf;
     Int  i;
+#if IPARAM
+    List svPreds;
+#endif
 
     instantiate(name(c).type);
     for (; nonNull(predsAre); predsAre=tl(predsAre))
@@ -1217,7 +1218,7 @@ Cell e; {
 	if (isPolyOrQualType(t))
             snd(hd(fs)) = typeExpected(l,conExpr,snd(hd(fs)),t,to,tf,TRUE);
         else {
-            check(l,snd(hd(fs)),e,conExpr,t,to);
+	    spCheck(l,snd(hd(fs)),e,conExpr,t,to);
         }
     }
     for (i=name(c).arity; i>0; i--)
@@ -1236,10 +1237,13 @@ Cell e; {                               /* bizarre manner for the benefit  */
     Int  alpha = newTyvars(2+n);
     Int  i;
     List fs1;
+#if IPARAM
+    List svPreds;
+#endif
 
     /* Calculate type and translation for each expr in the field list      */
     for (fs1=fs, i=alpha+2; nonNull(fs1); fs1=tl(fs1), i++) {
-        snd(hd(fs1)) = typeExpr(line,snd(hd(fs1)));
+ 	spTypeExpr(line,snd(hd(fs1)));
         bindTv(i,typeIs,typeOff);
     }
 
@@ -1256,7 +1260,7 @@ Cell e; {                               /* bizarre manner for the benefit  */
     ts = rev(ts);
 
     /* Type check expression to be updated                                 */
-    fst3(snd(e)) = typeExpr(line,fst3(snd(e)));
+    spTypeExpr(line,fst3(snd(e)));
     bindTv(alpha,typeIs,typeOff);
 
     for (; nonNull(cs); cs=tl(cs)) {    /* Loop through constrs            */
@@ -1755,9 +1759,11 @@ Class c; {				/* defaults for class c		   */
     }
 
     for (; nonNull(mems); mems=tl(mems)) {
-	static String deftext = "default_";
+        /* static String deftext = "default_"; */
+	static String deftext = "$dm";
 	String s	      = textToStr(name(hd(mems)).text);
 	Name   n;
+        i = j = 0;
 	for (; i<FILENAME_MAX && deftext[i]!='\0'; i++) {
 	    buf[i] = deftext[i];
 	}
@@ -1859,8 +1865,11 @@ Inst in; {                              /* member functions for instance in*/
     Int  beta    = newKindedVars(inst(in).kinds);
     List params  = makePredAss(inst(in).specifics,beta);
     Cell d       = inventDictVar();
+    /*
     List evids   = cons(triple(inst(in).head,mkInt(beta),d),
                         appendOnto(dupList(params),supers));
+    */
+    List evids   = dupList(params);
 
     List imps    = inst(in).implements;
     Cell l       = mkInt(inst(in).line);
@@ -1943,8 +1952,54 @@ Inst in; {                              /* member functions for instance in*/
     locs = cons(pair(d,singleton(pair(NIL,ap(l,dictDef)))),locs);
 
     name(inst(in).builder).defn			/* Register builder imp	   */
-	     = singleton(pair(args,ap(LETREC,pair(singleton(locs),
-						  ap(l,d)))));
+       = singleton(pair(args,ap(LETREC,pair(singleton(locs),
+	                                    ap(l,d)))));
+
+    /* Invent a GHC-compatible name for the instance decl */
+    {
+       char buf[FILENAME_MAX+1];
+       char buf2[10];
+       Int           i, j;
+       String        str;
+       Cell          qq      = inst(in).head;
+       Cell          pp      = NIL;
+       static String zdftext = "$f";
+
+       while (isAp(qq)) {
+          pp = cons(arg(qq),pp);
+          qq = fun(qq);
+       }
+       // pp is now the fwd list of args(?) to this pred
+
+       i = 0;
+       for (j = 0; i<FILENAME_MAX && zdftext[j]!='\0'; i++, j++) {
+          buf[i] = zdftext[j];
+       }
+       str = textToStr(cclass(inst(in).c).text);
+       for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
+          buf[i] = str[j];
+       }
+       if (nonNull(pp)) {
+          qq = hd(pp);
+          while (isAp(qq)) qq = fun(qq);
+          switch (whatIs(qq)) {
+             case TYCON:  str = textToStr(tycon(qq).text); break;
+             case TUPLE:  str = textToStr(ghcTupleText(qq)); break;
+             case OFFSET: sprintf(buf2,"%d",offsetOf(qq)); 
+                          str = buf2;
+                          break;
+             default: internal("typeInstDefn: making GHC name"); break;
+          }
+          for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
+             buf[i] = str[j];
+          }
+       }
+
+       buf[i++] = '\0';
+       name(inst(in).builder).text = findText(buf);
+       //fprintf ( stderr, "result = %s\n", buf );
+    }
+
     genDefns = cons(inst(in).builder,genDefns);
 }
 
@@ -2114,10 +2169,13 @@ Cell gded; {                           /*             ex :: (var,beta)     */
     static String guarded = "guarded expression";
     static String guard   = "guard";
     Int line = intOf(fst(gded));
+#if IPARAM
+    List svPreds;
+#endif
 
     gded     = snd(gded);
-    check(line,fst(gded),NIL,guard,typeBool,0);
-    check(line,snd(gded),NIL,guarded,aVar,beta);
+    spCheck(line,fst(gded),NIL,guard,typeBool,0);
+    spCheck(line,snd(gded),NIL,guarded,aVar,beta);
 }
 
 Cell rhsExpr(rhs)                      /* find first expression on a rhs   */
@@ -2497,7 +2555,7 @@ Name s; {                               /* particular selector, s.         */
  * Local function prototypes:
  * ------------------------------------------------------------------------*/
 
-static Type local basicType Args((Char));
+static Type local basicType ( Char );
 
 
 static Type stateVar = NIL;
@@ -2669,11 +2727,6 @@ Type primType( Int /*AsmMonad*/ monad, String a_kinds, String r_kinds )
         assert(length(tvars) == nextVar);
         r = mkPolyType(simpleKind(length(tvars)),r);
     }
-#if DEBUG_CODE
-    if (debugCode) {
-        printType(stdout,r); printf("\n");
-    }
-#endif
     return r;
 }    
 
@@ -2721,7 +2774,7 @@ Void typeChecker(what)
 Int what; {
     switch (what) {
         case RESET   : tcMode       = EXPRESSION;
-+ 		       daSccs	    = NIL;
+ 		       daSccs	    = NIL;
                        preds        = NIL;
                        pendingBtyvs = NIL;
                        daSccs       = NIL;
@@ -2748,65 +2801,115 @@ Int what; {
                        mark(predIntegral);
                        mark(starToStar);
                        mark(predMonad);
+		       mark(typeProgIO);
                        break;
 
-        case INSTALL : typeChecker(RESET);
-                       dummyVar     = inventVar();
-
-                       setCurrModule(modulePrelude);
-
-                       starToStar   = simpleKind(1);
-
-                       typeUnit     = addPrimTycon(findText("()"),
-                                                   STAR,0,DATATYPE,NIL);
-                       typeArrow    = addPrimTycon(findText("(->)"),
-                                                   simpleKind(2),2,
-                                                   DATATYPE,NIL);
-                       typeList     = addPrimTycon(findText("[]"),
-                                                   starToStar,1,
-                                                   DATATYPE,NIL);
-
-                       arrow        = fn(aVar,bVar);
-                       listof       = ap(typeList,aVar);
-                       boundPair    = ap(ap(mkTuple(2),aVar),aVar);
-
-                       nameUnit     = addPrimCfun(findText("()"),0,0,typeUnit);
-                       tycon(typeUnit).defn
-                                    = singleton(nameUnit);
-
-                       nameNil      = addPrimCfun(findText("[]"),0,1,
-                                                   mkPolyType(starToStar,
-                                                              listof));
-                       nameCons     = addPrimCfun(findText(":"),2,2,
-                                                   mkPolyType(starToStar,
-                                                              fn(aVar,
-                                                              fn(listof,
-                                                                 listof))));
-                       name(nameNil).parent =
-                       name(nameCons).parent = typeList;
-
-                       name(nameCons).syntax
-                                    = mkSyntax(RIGHT_ASS,5);
-
-                       tycon(typeList).defn
-                                    = cons(nameNil,cons(nameCons,NIL));
-
-                       typeVarToVar = fn(aVar,aVar);
+        case POSTPREL:
+
+           if (combined) {
+               setCurrModule(modulePrelude);
+               dummyVar     = inventVar();
+               typeUnit     = mkTuple(0);
+               arrow        = fn(aVar,bVar);
+               listof       = ap(typeList,aVar);
+               boundPair    = ap(ap(mkTuple(2),aVar),aVar);
+               nameUnit     = findQualNameWithoutConsultingExportList
+                                 (mkQVar(findText("PrelBase"),
+                                         findText("()")));
+               typeVarToVar = fn(aVar,aVar);
+           }
+           break;
+
+        case PREPREL : 
+           typeChecker(RESET);
+
+           if (combined) {
+               Module m = findFakeModule(findText("PrelBase"));
+               setCurrModule(m);
+
+               starToStar   = simpleKind(1);
+               typeList     = addPrimTycon(findText("[]"),
+                                           starToStar,1,
+                                           DATATYPE,NIL);
+
+               listof       = ap(typeList,aVar);
+               nameNil      = addPrimCfun(findText("[]"),0,1,
+                                           mkPolyType(starToStar,
+                                                      listof));
+               nameCons     = addPrimCfun(findText(":"),2,2,
+                                           mkPolyType(starToStar,
+                                                      fn(aVar,
+                                                      fn(listof,
+                                                         listof))));
+               name(nameNil).parent =
+               name(nameCons).parent = typeList;
+
+               name(nameCons).syntax
+                            = mkSyntax(RIGHT_ASS,5);
+
+               tycon(typeList).defn
+                            = cons(nameNil,cons(nameCons,NIL));
+
+           } else {
+               dummyVar     = inventVar();
+
+               setCurrModule(modulePrelPrim);
+
+               starToStar   = simpleKind(1);
+
+               typeUnit     = findTycon(findText("()"));
+                              assert(nonNull(typeUnit));
+
+               typeArrow    = addPrimTycon(findText("(->)"),
+                                           simpleKind(2),2,
+                                           DATATYPE,NIL);
+               typeList     = addPrimTycon(findText("[]"),
+                                           starToStar,1,
+                                           DATATYPE,NIL);
+
+               arrow        = fn(aVar,bVar);
+               listof       = ap(typeList,aVar);
+               boundPair    = ap(ap(mkTuple(2),aVar),aVar);
+
+               nameUnit     = addPrimCfun(findText("()"),0,0,typeUnit);
+               tycon(typeUnit).defn
+                            = singleton(nameUnit);
+
+               nameNil      = addPrimCfun(findText("[]"),0,1,
+                                           mkPolyType(starToStar,
+                                                      listof));
+               nameCons     = addPrimCfun(findText(":"),2,2,
+                                           mkPolyType(starToStar,
+                                                      fn(aVar,
+                                                      fn(listof,
+                                                         listof))));
+               name(nameNil).parent =
+               name(nameCons).parent = typeList;
+
+               name(nameCons).syntax
+                            = mkSyntax(RIGHT_ASS,5);
+
+               tycon(typeList).defn
+                            = cons(nameNil,cons(nameCons,NIL));
+
+               typeVarToVar = fn(aVar,aVar);
 #if TREX
-                       typeNoRow    = addPrimTycon(findText("EmptyRow"),
-                                                   ROW,0,DATATYPE,NIL);
-                       typeRec      = addPrimTycon(findText("Rec"),
-                                                   pair(ROW,STAR),1,
-                                                   DATATYPE,NIL);
-                       nameNoRec    = addPrimCfun(findText("EmptyRec"),0,0,
-                                                        ap(typeRec,typeNoRow));
+               typeNoRow    = addPrimTycon(findText("EmptyRow"),
+                                           ROW,0,DATATYPE,NIL);
+               typeRec      = addPrimTycon(findText("Rec"),
+                                           pair(ROW,STAR),1,
+                                           DATATYPE,NIL);
+               nameNoRec    = addPrimCfun(findText("EmptyRec"),0,0,
+                                                ap(typeRec,typeNoRow));
 #else
-                       /* bogus definitions to avoid changing the prelude */
-                       addPrimCfun(findText("Rec"),      0,0,typeUnit);
-                       addPrimCfun(findText("EmptyRow"), 0,0,typeUnit);
-                       addPrimCfun(findText("EmptyRec"), 0,0,typeUnit);
+               /* bogus definitions to avoid changing the prelude */
+               addPrimCfun(findText("Rec"),      0,0,typeUnit);
+               addPrimCfun(findText("EmptyRow"), 0,0,typeUnit);
+               addPrimCfun(findText("EmptyRec"), 0,0,typeUnit);
 #endif
-                       break;
+	   }
+           break;
+
     }
 }