X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Flink.c;h=44362c315e1558d5992740d9db57aa558dce5923;hb=38ddf533bb61c3d3f1789545712f7f3b3eae0cd9;hp=5a660b0b2c54149bc408f80f73445803637cfa4d;hpb=1b39436bdf0dbc46008460669d1ac81a98df6c84;p=ghc-hetmet.git diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index 5a660b0..44362c3 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: link.c,v $ - * $Revision: 1.14 $ - * $Date: 1999/11/18 12:10:19 $ + * $Revision: 1.34 $ + * $Date: 2000/01/11 17:09:38 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -89,7 +89,9 @@ Name nameBind; /* for translating monad comps */ Name nameZero; /* for monads with a zero */ Name nameId; -Name nameRunIO; +Name nameShow; +Name namePutStr; +Name nameRunIO_toplevel; Name namePrint; Name nameOtherwise; @@ -99,8 +101,6 @@ Name namePmSub; #endif Name namePMFail; Name nameEqChar; -Name nameEqInt; -Name nameEqDouble; Name namePmInt; Name namePmInteger; Name namePmDouble; @@ -108,23 +108,13 @@ Name namePmLe; Name namePmSubtract; Name namePmFromInteger; Name nameMkIO; -Name nameRunST; Name nameUnpackString; Name nameError; Name nameInd; Name nameCreateAdjThunk; Name nameAnd; -Name nameConCmp; Name nameCompAux; -Name nameEnFrTh; -Name nameEnFrTo; -Name nameEnFrom; -Name nameEnFrEn; -Name nameEnToEn; -Name nameEnInRng; -Name nameEnIndex; -Name nameEnRange; Name nameRangeSize; Name nameComp; Name nameShowField; @@ -209,6 +199,8 @@ Cell predFractional; /* Fractional (mkOffset(0)) */ Cell predIntegral; /* Integral (mkOffset(0)) */ Kind starToStar; /* Type -> Type */ Cell predMonad; /* Monad (mkOffset(0)) */ +Type typeProgIO; /* IO a */ + /* -------------------------------------------------------------------------- * @@ -217,16 +209,19 @@ Cell predMonad; /* Monad (mkOffset(0)) */ static Tycon linkTycon ( String s ); static Tycon linkClass ( String s ); static Name linkName ( String s ); -static Void mkTypes ( void ); static Name predefinePrim ( String s ); static Tycon linkTycon( String s ) { Tycon tc = findTycon(findText(s)); - if (nonNull(tc)) { - return tc; + if (nonNull(tc)) return tc; + if (combined) { + tc = findTyconInAnyModule(findText(s)); + if (nonNull(tc)) return tc; } +fprintf(stderr, "frambozenvla! unknown tycon %s\n", s ); +return NIL; ERRMSG(0) "Prelude does not define standard type \"%s\"", s EEND; } @@ -234,9 +229,13 @@ static Tycon linkTycon( String s ) static Class linkClass( String s ) { Class cc = findClass(findText(s)); - if (nonNull(cc)) { - return cc; - } + if (nonNull(cc)) return cc; + if (combined) { + cc = findClassInAnyModule(findText(s)); + if (nonNull(cc)) return cc; + } +fprintf(stderr, "frambozenvla! unknown class %s\n", s ); +return NIL; ERRMSG(0) "Prelude does not define standard class \"%s\"", s EEND; } @@ -244,9 +243,13 @@ static Class linkClass( String s ) static Name linkName( String s ) { Name n = findName(findText(s)); - if (nonNull(n)) { - return n; - } + if (nonNull(n)) return n; + if (combined) { + n = findNameInAnyModule(findText(s)); + if (nonNull(n)) return n; + } +fprintf(stderr, "frambozenvla! unknown name %s\n", s ); +return NIL; ERRMSG(0) "Prelude does not define standard name \"%s\"", s EEND; } @@ -265,6 +268,21 @@ static Name predefinePrim ( String s ) return nm; } + +/* -------------------------------------------------------------------------- + * + * ------------------------------------------------------------------------*/ + +/* In standalone mode, linkPreludeTC, linkPreludeCM and linkPreludeNames + 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). + + linkPreludeTC, linkPreludeCM and linkPreludeNames are needed in both + standalone and combined modes. +*/ + + Void linkPreludeTC(void) { /* Hook to tycons and classes in */ static Bool initialised = FALSE; /* prelude when first loaded */ if (!initialised) { @@ -272,118 +290,98 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ initialised = TRUE; setCurrModule(modulePrelude); - typeChar = linkTycon("Char"); - typeInt = linkTycon("Int"); - typeInteger = linkTycon("Integer"); - typeWord = linkTycon("Word"); - typeAddr = linkTycon("Addr"); + typeChar = linkTycon("Char"); + typeInt = linkTycon("Int"); + typeInteger = linkTycon("Integer"); + typeWord = linkTycon("Word"); + typeAddr = linkTycon("Addr"); typePrimArray = linkTycon("PrimArray"); typePrimByteArray = linkTycon("PrimByteArray"); - typeRef = linkTycon("Ref"); + typeRef = linkTycon("STRef"); typePrimMutableArray = linkTycon("PrimMutableArray"); typePrimMutableByteArray = linkTycon("PrimMutableByteArray"); - typeFloat = linkTycon("Float"); - typeDouble = linkTycon("Double"); - typeStable = linkTycon("StablePtr"); -#ifdef PROVIDE_WEAK - typeWeak = linkTycon("Weak"); -#endif -#ifdef PROVIDE_FOREIGN - typeForeign = linkTycon("ForeignObj"); -#endif - typeThreadId = linkTycon("ThreadId"); - typeMVar = linkTycon("MVar"); - typeBool = linkTycon("Bool"); - typeST = linkTycon("ST"); - typeIO = linkTycon("IO"); - typeException = linkTycon("Exception"); - typeString = linkTycon("String"); - typeOrdering = linkTycon("Ordering"); - - classEq = linkClass("Eq"); - classOrd = linkClass("Ord"); - classIx = linkClass("Ix"); - classEnum = linkClass("Enum"); - classShow = linkClass("Show"); - classRead = linkClass("Read"); - classBounded = linkClass("Bounded"); - classReal = linkClass("Real"); - classIntegral = linkClass("Integral"); - classRealFrac = linkClass("RealFrac"); - classRealFloat = linkClass("RealFloat"); - classFractional = linkClass("Fractional"); - classFloating = linkClass("Floating"); - classNum = linkClass("Num"); - classMonad = linkClass("Monad"); - - stdDefaults = NIL; - stdDefaults = cons(typeDouble,stdDefaults); -#if DEFAULT_BIGNUM - stdDefaults = cons(typeInteger,stdDefaults); -#else - stdDefaults = cons(typeInt,stdDefaults); -#endif - mkTypes(); - - nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP); - nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP); - nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP); - nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP); - nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP); - nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP); - nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP); - nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP); - -#ifdef PROVIDE_FOREIGN - nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0); -#endif -#ifdef PROVIDE_WEAK - nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0); -#endif - nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0); - nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0); - nameMkRef = addPrimCfunREP(findText("Ref#"),1,0,0); - nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0); + typeFloat = linkTycon("Float"); + typeDouble = linkTycon("Double"); + typeStable = linkTycon("StablePtr"); +# ifdef PROVIDE_WEAK + typeWeak = linkTycon("Weak"); +# endif +# ifdef PROVIDE_FOREIGN + typeForeign = linkTycon("ForeignObj"); +# endif + typeThreadId = linkTycon("ThreadId"); + typeMVar = linkTycon("MVar"); + typeBool = linkTycon("Bool"); + typeST = linkTycon("ST"); + typeIO = linkTycon("IO"); + typeException = linkTycon("Exception"); + typeString = linkTycon("String"); + typeOrdering = linkTycon("Ordering"); + + classEq = linkClass("Eq"); + classOrd = linkClass("Ord"); + classIx = linkClass("Ix"); + classEnum = linkClass("Enum"); + classShow = linkClass("Show"); + classRead = linkClass("Read"); + classBounded = linkClass("Bounded"); + classReal = linkClass("Real"); + classIntegral = linkClass("Integral"); + classRealFrac = linkClass("RealFrac"); + classRealFloat = linkClass("RealFloat"); + classFractional = linkClass("Fractional"); + 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); + predIntegral = ap(classIntegral,aVar); + predMonad = ap(classMonad,aVar); + typeProgIO = ap(typeIO,aVar); + + nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP); + nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP); + nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP); + nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP); + nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP); + nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP); + nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP); + nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP); + +# ifdef PROVIDE_FOREIGN + nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0); +# endif +# ifdef PROVIDE_WEAK + nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0); +# endif + nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0); + nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0); + nameMkRef = addPrimCfunREP(findText("STRef#"),1,0,0); + nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0); nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0); - nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0); - nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0); - - /* The following primitives are referred to in derived instances and - * hence require types; the following types are a little more general - * than we might like, but they are the closest we can get without a - * special datatype class. - */ - name(nameConCmp).type - = mkPolyType(starToStar,fn(aVar,fn(aVar,typeOrdering))); - name(nameEnRange).type - = mkPolyType(starToStar,fn(boundPair,listof)); - name(nameEnIndex).type - = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeInt))); - name(nameEnInRng).type - = mkPolyType(starToStar,fn(boundPair,fn(aVar,typeBool))); - name(nameEnToEn).type - = mkPolyType(starToStar,fn(aVar,fn(typeInt,aVar))); - name(nameEnFrEn).type - = mkPolyType(starToStar,fn(aVar,typeInt)); - name(nameEnFrom).type - = mkPolyType(starToStar,fn(aVar,listof)); - name(nameEnFrTo).type - = name(nameEnFrTh).type - = mkPolyType(starToStar,fn(aVar,fn(aVar,listof))); - - name(namePrimSeq).type - = primType(MONAD_Id, "ab", "b"); - name(namePrimCatch).type - = primType(MONAD_Id, "aH", "a"); - name(namePrimRaise).type - = primType(MONAD_Id, "E", "a"); + 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"); + 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); @@ -392,17 +390,10 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ addTupInst(classRead,i); addTupInst(classBounded,i); } + } } } -static Void mkTypes ( void ) -{ - predNum = ap(classNum,aVar); - predFractional = ap(classFractional,aVar); - predIntegral = ap(classIntegral,aVar); - predMonad = ap(classMonad,aVar); -} - Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */ static Bool initialised = FALSE; /* prelude when first loaded */ if (!initialised) { @@ -438,9 +429,11 @@ 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)"), - pair(STAR,pair(STAR,STAR)), - 2,DATATYPE,NIL); - - /* newtype and USE_NEWTYPE_FOR_DICTS */ - pFun(nameId, "id"); - - /* desugaring */ - pFun(nameInd, "_indirect"); - name(nameInd).number = DFUNNAME; - - /* pmc */ - pFun(nameSel, "_SEL"); - - /* strict constructors */ - pFun(nameFlip, "flip" ); - - /* parser */ - pFun(nameFromTo, "enumFromTo"); - pFun(nameFromThenTo, "enumFromThenTo"); - pFun(nameFrom, "enumFrom"); - pFun(nameFromThen, "enumFromThen"); - - /* deriving */ - pFun(nameApp, "++"); - pFun(nameReadField, "readField"); - pFun(nameReadParen, "readParen"); - pFun(nameShowField, "showField"); - pFun(nameShowParen, "showParen"); - pFun(nameLex, "lex"); - pFun(nameEnToEn, "toEnumPR"); //not sure - pFun(nameEnFrEn, "fromEnum"); //not sure - pFun(nameEnFrom, "enumFrom"); //not sure - pFun(nameEnFrTh, "enumFromThen"); //not sure - pFun(nameEnFrTo, "enumFromTo"); //not sure - pFun(nameEnRange, "range"); //not sure - pFun(nameEnIndex, "index"); //not sure - pFun(nameEnInRng, "inRange"); //not sure - pFun(nameConCmp, "_concmp"); //very not sure - pFun(nameComp, "."); - pFun(nameAnd, "&&"); - pFun(nameCompAux, "primCompAux"); - pFun(nameMap, "map"); - - /* implementTagToCon */ - pFun(namePMFail, "primPmFail"); - pFun(nameError, "error"); - pFun(nameUnpackString, "primUnpackString"); - - /* hooks for handwritten bytecode */ - pFun(namePrimSeq, "primSeq"); - pFun(namePrimCatch, "primCatch"); - pFun(namePrimRaise, "primRaise"); - pFun(namePrimTakeMVar, "primTakeMVar"); - { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimSeq; - name(n).line = 0; - name(n).arity = 1; - name(n).type = NIL; - vv = mkStgVar(NIL,NIL); - stgVarInfo(vv) = mkPtr ( asm_BCO_seq() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); - namePrimSeq = n; - } - { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimCatch; - name(n).line = 0; - name(n).arity = 2; - name(n).type = NIL; - stgVarInfo(vv) = mkPtr ( asm_BCO_catch() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); - } - { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimRaise; - name(n).line = 0; - name(n).arity = 1; - name(n).type = NIL; - stgVarInfo(vv) = mkPtr ( asm_BCO_raise() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); - } - { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimTakeMVar; - name(n).line = 0; - name(n).arity = 2; - name(n).type = NIL; - stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); - } - break; + case POSTPREL: { + Module modulePrelBase = findModule(findText("PrelBase")); + assert(nonNull(modulePrelBase)); +#if 1 + fprintf(stderr, "linkControl(POSTPREL)\n"); +#if 1 + setCurrModule(modulePrelude); + linkPreludeTC(); + linkPreludeCM(); + linkPreludeNames(); + name(nameNil).stgVar + = mkCPtr(lookupOTabName(modulePrelBase, "PrelBase_ZMZN_closure")); + name(nameCons).stgVar + = mkCPtr(lookupOTabName(modulePrelBase, "PrelBase_ZC_closure")); +#endif +#endif + break; + } + case PREPREL : + + if (combined) { + + 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 ); + nameMkInteger + = addWiredInBoxingTycon("PrelNum","Integer","Integer#",0 ,STAR ); + nameMkPrimByteArray + = addWiredInBoxingTycon("PrelGHC","ByteArray","PrimByteArray#",0 ,STAR ); + + for (i=0; i)"), + pair(STAR,pair(STAR,STAR)), + 2,DATATYPE,NIL); + } else { + + modulePrelude = newModule(textPrelude); + setCurrModule(modulePrelude); + + for (i=0; i)"), + pair(STAR,pair(STAR,STAR)), + 2,DATATYPE,NIL); + + /* newtype and USE_NEWTYPE_FOR_DICTS */ + pFun(nameId, "id"); + + /* desugaring */ + pFun(nameInd, "_indirect"); + name(nameInd).number = DFUNNAME; + + /* pmc */ + pFun(nameSel, "_SEL"); + + /* strict constructors */ + pFun(nameFlip, "flip" ); + + /* parser */ + pFun(nameFromTo, "enumFromTo"); + pFun(nameFromThenTo, "enumFromThenTo"); + pFun(nameFrom, "enumFrom"); + pFun(nameFromThen, "enumFromThen"); + + /* deriving */ + pFun(nameApp, "++"); + pFun(nameReadField, "readField"); + pFun(nameReadParen, "readParen"); + pFun(nameShowField, "showField"); + pFun(nameShowParen, "showParen"); + pFun(nameLex, "lex"); + pFun(nameComp, "."); + pFun(nameAnd, "&&"); + pFun(nameCompAux, "primCompAux"); + pFun(nameMap, "map"); + + /* implementTagToCon */ + pFun(namePMFail, "primPmFail"); + pFun(nameError, "error"); + pFun(nameUnpackString, "primUnpackString"); + + /* hooks for handwritten bytecode */ + pFun(namePrimSeq, "primSeq"); + pFun(namePrimCatch, "primCatch"); + pFun(namePrimRaise, "primRaise"); + pFun(namePrimTakeMVar, "primTakeMVar"); + { + StgVar vv = mkStgVar(NIL,NIL); + Name n = namePrimSeq; + name(n).line = 0; + name(n).arity = 1; + name(n).type = NIL; + vv = mkStgVar(NIL,NIL); + stgVarInfo(vv) = mkPtr ( asm_BCO_seq() ); + name(n).stgVar = vv; + stgGlobals=cons(pair(n,vv),stgGlobals); + namePrimSeq = n; + } + { + StgVar vv = mkStgVar(NIL,NIL); + Name n = namePrimCatch; + name(n).line = 0; + name(n).arity = 2; + name(n).type = NIL; + stgVarInfo(vv) = mkPtr ( asm_BCO_catch() ); + name(n).stgVar = vv; + stgGlobals=cons(pair(n,vv),stgGlobals); + } + { + StgVar vv = mkStgVar(NIL,NIL); + Name n = namePrimRaise; + name(n).line = 0; + name(n).arity = 1; + name(n).type = NIL; + stgVarInfo(vv) = mkPtr ( asm_BCO_raise() ); + name(n).stgVar = vv; + stgGlobals=cons(pair(n,vv),stgGlobals); + } + { + StgVar vv = mkStgVar(NIL,NIL); + Name n = namePrimTakeMVar; + name(n).line = 0; + name(n).arity = 2; + name(n).type = NIL; + stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() ); + name(n).stgVar = vv; + stgGlobals=cons(pair(n,vv),stgGlobals); + } + } + break; } } #undef pFun