X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Flink.c;h=98235f3b97e9f8803288dbe4c16404bdeae0bfda;hb=e3bb5d64a61847a306ef38f14b39768adb721cf6;hp=3444cd4c55792c96e9da8f5bf39e04ffa0dfd845;hpb=3e2280b12b060fe5e8a2430beff7a49e3137ffb3;p=ghc-hetmet.git

diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c
index 3444cd4..98235f3 100644
--- a/ghc/interpreter/link.c
+++ b/ghc/interpreter/link.c
@@ -9,18 +9,17 @@
  * included in the distribution.
  *
  * $RCSfile: link.c,v $
- * $Revision: 1.33 $
- * $Date: 2000/01/11 15:40:57 $
+ * $Revision: 1.54 $
+ * $Date: 2000/03/23 14:54:21 $
  * ------------------------------------------------------------------------*/
 
-#include "prelude.h"
+#include "hugsbasictypes.h"
 #include "storage.h"
-#include "backend.h"
 #include "connect.h"
 #include "errors.h"
-#include "Assembler.h" /* for asmPrimOps and AsmReps */
-
-#include "link.h"
+#include "Assembler.h"                  /* for asmPrimOps and AsmReps      */
+#include "Rts.h"                        /* to make Prelude.h palatable     */
+#include "Prelude.h"                    /* for fixupRTStoPreludeRefs       */
 
 
 Type typeArrow;                         /* Function spaces                 */
@@ -96,9 +95,7 @@ Name namePrint;
 
 Name nameOtherwise;
 Name nameUndefined;                     /* generic undefined value         */
-#if NPLUSK
 Name namePmSub; 
-#endif
 Name namePMFail;
 Name nameEqChar;
 Name namePmInt;
@@ -136,6 +133,17 @@ Name nameFrom;
 Name nameFromThenTo;
 Name nameNegate;
 
+Name nameAssert;
+Name nameAssertError;
+Name nameTangleMessage;
+Name nameIrrefutPatError;
+Name nameNoMethodBindingError;
+Name nameNonExhaustiveGuardsError;
+Name namePatError;
+Name nameRecSelError;
+Name nameRecConError;
+Name nameRecUpdError;
+
 /* these names are required before we've had a chance to do the right thing */
 Name nameSel;
 Name nameUnsafeUnpackCString;
@@ -273,7 +281,7 @@ static Name predefinePrim ( String s )
  * 
  * ------------------------------------------------------------------------*/
 
-/* In standalone mode, linkPreludeTC, linkPreludeCM and linkPreludeNames
+/* In standalone mode, linkPreludeTC, linkPreludeCM and linkPrimNames
    are called, in that order, during static analysis of Prelude.hs.
    In combined mode such an analysis does not happen.  Instead these
    calls will be made as a result of a call link(POSTPREL).
@@ -333,15 +341,10 @@ Void linkPreludeTC(void) {              /* Hook to tycons and classes in   */
         classFloating            = linkClass("Floating");
         classNum                 = linkClass("Num");
         classMonad               = linkClass("Monad");
-assert(nonNull(typeDouble));
-assert(nonNull(typeInteger));
+
         stdDefaults              = NIL;
         stdDefaults              = cons(typeDouble,stdDefaults);
-#       if DEFAULT_BIGNUM
         stdDefaults              = cons(typeInteger,stdDefaults);
-#       else
-        stdDefaults              = cons(typeInt,stdDefaults);
-#       endif
 
         predNum                  = ap(classNum,aVar);
         predFractional           = ap(classFractional,aVar);
@@ -372,24 +375,26 @@ assert(nonNull(typeInteger));
         nameMkPrimMVar           = addPrimCfunREP(findText("MVar#"),1,0,0);
         nameMkInteger            = addPrimCfunREP(findText("Integer#"),1,0,0);
 
-        name(namePrimSeq).type   = primType(MONAD_Id, "ab", "b");
-        name(namePrimCatch).type = primType(MONAD_Id, "aH", "a");
-        name(namePrimRaise).type = primType(MONAD_Id, "E", "a");
-
-        /* This is a lie.  For a more accurate type of primTakeMVar
-           see ghc/interpreter/lib/Prelude.hs.
-	*/
-        name(namePrimTakeMVar).type = primType(MONAD_Id, "rbc", "d");
-
-        if (combined) {
-        for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
-            addTupInst(classEq,i);
-            addTupInst(classOrd,i);
-            addTupInst(classIx,i);
-            addTupInst(classShow,i);
-            addTupInst(classRead,i);
-            addTupInst(classBounded,i);
+        if (!combined) {
+           name(namePrimSeq).type   = primType(MONAD_Id, "ab", "b");
+           name(namePrimCatch).type = primType(MONAD_Id, "aH", "a");
+           name(namePrimRaise).type = primType(MONAD_Id, "E", "a");
+
+           /* This is a lie.  For a more accurate type of primTakeMVar
+              see ghc/interpreter/lib/Prelude.hs.
+	   */
+           name(namePrimTakeMVar).type = primType(MONAD_Id, "rbc", "d");
         }
+
+        if (!combined) {
+           for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
+               addTupInst(classEq,i);
+               addTupInst(classOrd,i);
+               addTupInst(classIx,i);
+               addTupInst(classShow,i);
+               addTupInst(classRead,i);
+               addTupInst(classBounded,i);
+           }
         }
     }
 }
@@ -410,9 +415,9 @@ Void linkPreludeCM(void) {              /* Hook to cfuns and mfuns in      */
         nameEq           = linkName("==");
         nameFromInt      = linkName("fromInt");
         nameFromInteger  = linkName("fromInteger");
-        nameFromDouble   = linkName("fromDouble");
         nameReturn       = linkName("return");
         nameBind         = linkName(">>=");
+	nameMFail        = linkName("fail");
         nameLe           = linkName("<=");
         nameGt           = linkName(">");
         nameShowsPrec    = linkName("showsPrec");
@@ -429,18 +434,18 @@ Void linkPreludeCM(void) {              /* Hook to cfuns and mfuns in      */
         nameInRange      = linkName("inRange");
         nameMinus        = linkName("-");
         /* These come before calls to implementPrim */
-        if (combined) {
-        for(i=0; i<NUM_TUPLES; ++i) {
-            implementTuple(i);
-        }
+        if (!combined) {
+           for(i=0; i<NUM_TUPLES; ++i) {
+               if (i != 1) implementTuple(i);
+           }
         }
     }
 }
 
-Void linkPreludeNames(void) {           /* Hook to names defined in Prelude */
+Void linkPrimNames ( void ) {        /* Hook to names defined in Prelude */
     static Bool initialised = FALSE;
+
     if (!initialised) {
-        Int i;
         initialised = TRUE;
 
         setCurrModule(modulePrelude);
@@ -449,22 +454,29 @@ Void linkPreludeNames(void) {           /* Hook to names defined in Prelude */
         nameMkIO           = linkName("hugsprimMkIO");
 
         if (!combined) {
-           for (i=0; asmPrimOps[i].name; ++i) {
-               Text t = findText(asmPrimOps[i].name);
-               Name n = findName(t);
-               if (isNull(n)) {
-                   n = newName(t,NIL);
-               }
-               name(n).line   = 0;
-               name(n).defn   = NIL;
-               name(n).type   = primType(asmPrimOps[i].monad,
-                                         asmPrimOps[i].args,
-                                         asmPrimOps[i].results);
-               name(n).arity  = strlen(asmPrimOps[i].args);
-               name(n).primop = &(asmPrimOps[i]);
-               implementPrim(n);
-           }
+	  Int i;
+	  for (i=0; asmPrimOps[i].name; ++i) {
+	    Text t = findText(asmPrimOps[i].name);
+	    Name n = findName(t);
+	    if (isNull(n)) {
+	      n = newName(t,NIL);
+	      name(n).line   = 0;
+	      name(n).defn   = NIL;
+	      name(n).type   = primType(asmPrimOps[i].monad,
+					asmPrimOps[i].args,
+					asmPrimOps[i].results);
+	      name(n).arity  = strlen(asmPrimOps[i].args);
+	      name(n).primop = &(asmPrimOps[i]);
+	      implementPrim(n);
+	    } else {
+	      ERRMSG(0) "Link Error in Prelude, surplus definition of \"%s\"", 
+				asmPrimOps[i].name
+              EEND;	      
+	      // Name already defined!
+	    }
+	  }
         }
+
         /* static(tidyInfix)                        */
         nameNegate         = linkName("negate");
         /* user interface                           */
@@ -476,23 +488,25 @@ Void linkPreludeNames(void) {           /* Hook to names defined in Prelude */
         nameOtherwise      = linkName("otherwise");
         nameUndefined      = linkName("undefined");
         /* pmc                                      */
-#       if NPLUSK                      
         namePmSub          = linkName("hugsprimPmSub");
-#       endif                          
         /* translator                               */
         nameEqChar         = linkName("hugsprimEqChar");
         nameCreateAdjThunk = linkName("hugsprimCreateAdjThunk");
         namePmInt          = linkName("hugsprimPmInt");
         namePmInteger      = linkName("hugsprimPmInteger");
         namePmDouble       = linkName("hugsprimPmDouble");
- 
+
+        nameFromDouble     = linkName("fromDouble");
         namePmFromInteger = linkName("hugsprimPmFromInteger");
+
         namePmSubtract    = linkName("hugsprimPmSubtract");
         namePmLe          = linkName("hugsprimPmLe");
 
-        implementCfun ( nameCons, NIL );
-        implementCfun ( nameNil, NIL );
-        implementCfun ( nameUnit, NIL );
+        if (!combined) {
+           implementCfun ( nameCons, NIL );
+           implementCfun ( nameNil, NIL );
+           implementCfun ( nameUnit, NIL );
+        }
     }
 }
 
@@ -508,63 +522,181 @@ Void linkControl(what)
 Int what; {
     Int i;
     switch (what) {
+      //case EXIT : fooble();break;
         case RESET   :
         case MARK    : 
                        break;
 
-        case POSTPREL: 
-#if 1
-	  fprintf(stderr, "linkControl(POSTPREL)\n");
-#if 1
-          setCurrModule(modulePrelude);
-          linkPreludeTC();
-          linkPreludeCM();
-          linkPreludeNames();
-#endif
-#endif
-          break;
+        case POSTPREL: {
+           Name nm;
+           Module modulePrelBase = findModule(findText("PrelBase"));
+           assert(nonNull(modulePrelBase));
+	   /* fprintf(stderr, "linkControl(POSTPREL)\n"); */
+           setCurrModule(modulePrelude);
+           linkPreludeTC();
+           linkPreludeCM();
+           linkPrimNames();
+           fixupRTStoPreludeRefs ( lookupObjName );
+
+           nameUnpackString = linkName("hugsprimUnpackString");
+           namePMFail       = linkName("hugsprimPmFail");
+assert(nonNull(namePMFail));
+#define xyzzy(aaa,bbb) aaa = linkName(bbb)
+
+
+               /* pmc                                   */
+               pFun(nameSel,            "_SEL");
+
+               /* strict constructors                   */
+               xyzzy(nameFlip,           "flip"     );
 
+               /* parser                                */
+               xyzzy(nameFromTo,         "enumFromTo");
+               xyzzy(nameFromThenTo,     "enumFromThenTo");
+               xyzzy(nameFrom,           "enumFrom");
+               xyzzy(nameFromThen,       "enumFromThen");
+
+               /* deriving                              */
+               xyzzy(nameApp,            "++");
+               xyzzy(nameReadField,      "hugsprimReadField");
+               xyzzy(nameReadParen,      "readParen");
+               xyzzy(nameShowField,      "hugsprimShowField");
+               xyzzy(nameShowParen,      "showParen");
+               xyzzy(nameLex,            "lex");
+               xyzzy(nameComp,           ".");
+               xyzzy(nameAnd,            "&&");
+               xyzzy(nameCompAux,        "hugsprimCompAux");
+               xyzzy(nameMap,            "map");
+
+               /* implementTagToCon                     */
+               xyzzy(nameError,          "hugsprimError");
+
+
+           typeStable = linkTycon("Stable");
+           typeRef    = linkTycon("IORef");
+           // {Prim,PrimByte,PrimMutable,PrimMutableByte}Array ?
+
+           ifLinkConstrItbl ( nameFalse );
+           ifLinkConstrItbl ( nameTrue );
+           ifLinkConstrItbl ( nameNil );
+           ifLinkConstrItbl ( nameCons );
+
+           /* PrelErr.hi doesn't give a type for error, alas.  
+              So error never appears in any symbol table.
+              So we fake it by copying the table entry for
+              hugsprimError -- which is just a call to error.
+              Although we put it on the Prelude export list, we
+              have to claim internally that it lives in PrelErr, 
+              so that the correct symbol (PrelErr_error_closure)
+              is referred to.
+              Big Big Sigh.
+           */
+           nm            = newName ( findText("error"), NIL );
+           name(nm)      = name(nameError);
+           name(nm).mod  = findModule(findText("PrelErr"));
+           name(nm).text = findText("error");
+           setCurrModule(modulePrelude);
+           module(modulePrelude).exports
+              = cons ( nm, module(modulePrelude).exports );
+
+           /* The GHC prelude doesn't seem to export Addr.  Add it to the
+              export list for the sake of compatibility with standalone mode.
+	   */
+           module(modulePrelude).exports
+              = cons ( pair(typeAddr,DOTDOT), 
+                       module(modulePrelude).exports );
+           addTycon(typeAddr);
+
+           /* Make nameListMonad be the builder fn for instance Monad [].
+              Standalone hugs does this with a disgusting hack in 
+              checkInstDefn() in static.c.  We have a slightly different
+              disgusting hack for the combined case.
+           */
+           {
+           Class cm;   /* :: Class   */
+           List  is;   /* :: [Inst]  */
+           cm = findClassInAnyModule(findText("Monad"));
+           assert(nonNull(cm));
+           is = cclass(cm).instances;
+           assert(nonNull(is));
+           while (nonNull(is) && snd(inst(hd(is)).head) != typeList)
+              is = tl(is);
+           assert(nonNull(is));
+           nameListMonad = inst(hd(is)).builder;
+           assert(nonNull(nameListMonad));
+           }
+
+           break;
+        }
         case PREPREL : 
 
            if (combined) {
+               Module modulePrelBase;
 
                modulePrelude = findFakeModule(textPrelude);
-               module(modulePrelude).objectExtraNames 
-                  = singleton(findText("libHS_cbits"));
 
-               nameMkC = addWiredInBoxingTycon("PrelBase", "Char",  "C#",CHAR_REP,   STAR );
-               nameMkI = addWiredInBoxingTycon("PrelBase", "Int",   "I#",INT_REP,    STAR );
-               nameMkW = addWiredInBoxingTycon("PrelAddr", "Word",  "W#",WORD_REP,   STAR );
-               nameMkA = addWiredInBoxingTycon("PrelAddr", "Addr",  "A#",ADDR_REP,   STAR );
-               nameMkF = addWiredInBoxingTycon("PrelFloat","Float", "F#",FLOAT_REP,  STAR );
-               nameMkD = addWiredInBoxingTycon("PrelFloat","Double","D#",DOUBLE_REP, STAR );
+               nameMkC = addWiredInBoxingTycon("PrelBase", "Char",  "C#",
+                                               CHAR_REP,   STAR );
+               nameMkI = addWiredInBoxingTycon("PrelBase", "Int",   "I#",
+                                               INT_REP,    STAR );
+               nameMkW = addWiredInBoxingTycon("PrelAddr", "Word",  "W#",
+                                               WORD_REP,   STAR );
+               nameMkA = addWiredInBoxingTycon("PrelAddr", "Addr",  "A#",
+                                               ADDR_REP,   STAR );
+               nameMkF = addWiredInBoxingTycon("PrelFloat","Float", "F#",
+                                               FLOAT_REP,  STAR );
+               nameMkD = addWiredInBoxingTycon("PrelFloat","Double","D#",
+                                               DOUBLE_REP, STAR );
                nameMkInteger            
-                       = addWiredInBoxingTycon("PrelNum","Integer","Integer#",0 ,STAR );
+                       = addWiredInBoxingTycon("PrelNum","Integer","Integer#",
+                                               0 ,STAR );
                nameMkPrimByteArray      
-                       = addWiredInBoxingTycon("PrelGHC","ByteArray","PrimByteArray#",0 ,STAR );
+                       = addWiredInBoxingTycon("PrelGHC","ByteArray",
+                                               "PrimByteArray#",0 ,STAR );
 
                for (i=0; i<NUM_TUPLES; ++i) {
-                   addTupleTycon(i);
+                   if (i != 1) addTupleTycon(i);
                }
 	       addWiredInEnumTycon("PrelBase","Bool",
-                                   doubleton(findText("False"),findText("True")));
+                                   doubleton(findText("False"),
+                                             findText("True")));
 
                //nameMkThreadId
-               //        = addWiredInBoxingTycon("PrelConc","ThreadId","ThreadId#"
-               //                                ,1,0,THREADID_REP);
+               //   = addWiredInBoxingTycon("PrelConc","ThreadId","ThreadId#"
+               //                           ,1,0,THREADID_REP);
 
                setCurrModule(modulePrelude);
 
                typeArrow = addPrimTycon(findText("(->)"),
                                         pair(STAR,pair(STAR,STAR)),
                                         2,DATATYPE,NIL);
+
+               /* desugaring                            */
+               pFun(nameInd,            "_indirect");
+               name(nameInd).number = DFUNNAME;
+
+               /* newtype and USE_NEWTYPE_FOR_DICTS     */
+               /* make a name entry for PrelBase.id _before_ loading Prelude
+                  since ifSetClassDefaultsAndDCon() may need to refer to
+                  nameId. 
+               */
+               modulePrelBase = findModule(findText("PrelBase"));
+               module(modulePrelBase).objectExtraNames 
+                  = singleton(findText("libHS_cbits"));
+
+               setCurrModule(modulePrelBase);
+               pFun(nameId,             "id");
+               setCurrModule(modulePrelude);
+
            } else {
+               fixupRTStoPreludeRefs(NULL);
 
-               modulePrelude = newModule(textPrelude);
+               modulePrelude = //newModule(textPrelude);
+                               findFakeModule(textPrelude);
                setCurrModule(modulePrelude);
         
                for (i=0; i<NUM_TUPLES; ++i) {
-                   addTupleTycon(i);
+                   if (i != 1) addTupleTycon(i);
                }
                setCurrModule(modulePrelude);
 
@@ -593,20 +725,35 @@ Int what; {
 
                /* deriving                              */
                pFun(nameApp,            "++");
-               pFun(nameReadField,      "readField");
+               pFun(nameReadField,      "hugsprimReadField");
                pFun(nameReadParen,      "readParen");
-               pFun(nameShowField,      "showField");
+               pFun(nameShowField,      "hugsprimShowField");
                pFun(nameShowParen,      "showParen");
                pFun(nameLex,            "lex");
                pFun(nameComp,           ".");
                pFun(nameAnd,            "&&");
-               pFun(nameCompAux,        "primCompAux");
+               pFun(nameCompAux,        "hugsprimCompAux");
                pFun(nameMap,            "map");
 
                /* implementTagToCon                     */
-               pFun(namePMFail,         "primPmFail");
+               pFun(namePMFail,         "hugsprimPmFail");
                pFun(nameError,          "error");
-               pFun(nameUnpackString,   "primUnpackString");
+               pFun(nameUnpackString,   "hugsprimUnpackString");
+
+	       /* assertion and exception issues */
+	       pFun(nameAssert,	        "assert");
+	       pFun(nameAssertError,	"assertError");
+	       pFun(nameTangleMessage,	"tangleMessager");
+	       pFun(nameIrrefutPatError,	
+		                        "irrefutPatError");
+	       pFun(nameNoMethodBindingError,
+		                        "noMethodBindingError");
+	       pFun(nameNonExhaustiveGuardsError,
+		                        "nonExhaustiveGuardsError");
+	       pFun(namePatError,	"patError");
+	       pFun(nameRecSelError,	"recSelError");
+	       pFun(nameRecConError,	"recConError");
+	       pFun(nameRecUpdError,	"recUpdError");
 
                /* hooks for handwritten bytecode */
                pFun(namePrimSeq,        "primSeq");
@@ -661,5 +808,5 @@ Int what; {
 }
 #undef pFun
 
-
+//#include "fooble.c"
 /*-------------------------------------------------------------------------*/