2 /* --------------------------------------------------------------------------
3 * GHC interface file processing for Hugs
5 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
6 * All rights reserved. See NOTICE for details and conditions of use etc...
7 * Hugs version 1.4, December 1997
9 * $RCSfile: interface.c,v $
11 * $Date: 1999/06/07 17:22:51 $
12 * ------------------------------------------------------------------------*/
16 * o use vectored CONSTR_entry when appropriate
17 * o generate export list
19 * Needs GHC changes to generate member selectors,
20 * superclass selectors, etc
22 * o dictionary constructors ?
24 * o Get Hugs/GHC to agree on what interface files look like.
25 * o figure out how to replace the Hugs Prelude with the GHC Prelude
34 #include "Assembler.h" /* for wrapping GHC objects */
39 /* --------------------------------------------------------------------------
40 * The "addGHC*" functions act as "impedence matchers" between GHC
41 * interface files and Hugs. Their main job is to convert abstract
42 * syntax trees into Hugs' internal representations.
44 * The main trick here is how we deal with mutually recursive interface
47 * o As we read an import decl, we add it to a list of required imports
48 * (unless it's already loaded, of course).
50 * o Processing of declarations is split into two phases:
52 * 1) While reading the interface files, we construct all the Names,
53 * Tycons, etc declared in the interface file but we don't try to
54 * resolve references to any entities the declaration mentions.
56 * This is done by the "addGHC*" functions.
58 * 2) After reading all the interface files, we finish processing the
59 * declarations by resolving any references in the declarations
60 * and doing any other processing that may be required.
62 * This is done by the "finishGHC*" functions which use the
63 * "fixup*" functions to assist them.
65 * The interface between these two phases are the "ghc*Decls" which
66 * contain lists of decls that haven't been completed yet.
68 * ------------------------------------------------------------------------*/
70 /* --------------------------------------------------------------------------
72 * ------------------------------------------------------------------------*/
74 static List ghcVarDecls;
75 static List ghcConstrDecls;
76 static List ghcSynonymDecls;
77 static List ghcClassDecls;
78 static List ghcInstanceDecls;
80 /* --------------------------------------------------------------------------
81 * local function prototypes:
82 * ------------------------------------------------------------------------*/
84 static List local addGHCConstrs Args((Int,List,List));
85 static Name local addGHCSel Args((Int,Pair));
86 static Name local addGHCConstr Args((Int,Int,Triple));
89 static Void local finishGHCVar Args((Name));
90 static Void local finishGHCConstr Args((Name));
91 static Void local finishGHCSynonym Args((Tycon));
92 static Void local finishGHCClass Args((Class));
93 static Void local finishGHCInstance Args((Inst));
94 static Void local finishGHCImports Args((Triple));
95 static Void local finishGHCExports Args((Pair));
96 static Void local finishGHCModule Args((Module));
98 static Void local bindGHCNameTo Args((Name,Text));
99 static Kinds local tvsToKind Args((List));
100 static Int local arityFromType Args((Type));
102 static List local ifTyvarsIn Args((Type));
104 static Type local tvsToOffsets Args((Int,Type,List));
105 static Type local conidcellsToTycons Args((Int,Type));
107 static Void local resolveReferencesInObjectModule Args((Module));
108 static Bool local validateOImage Args((void*, Int));
110 static Text text_info;
111 static Text text_entry;
112 static Text text_closure;
113 static Text text_static_closure;
114 static Text text_static_info;
115 static Text text_con_info;
116 static Text text_con_entry;
119 /* --------------------------------------------------------------------------
121 * ------------------------------------------------------------------------*/
123 List ifImports; /* [ConId] -- modules imported by current interface */
125 List ghcImports; /* [(Module, Text, [ConId|VarId])]
126 each (m1, m2, names) in this list
127 represents 'module m1 where ... import m2 ( names ) ...'
128 The list acts as a list of names to fix up in
132 List ghcExports; /* [(ConId, [ConId|VarId])] */
134 List ghcModules; /* [Module] -- modules of the .his loaded in this group */
136 Void addGHCExports(mod,stuff)
139 ghcExports = cons( pair(mod,stuff), ghcExports );
142 static Void local finishGHCExports(paire)
144 Text modTxt = textOf(fst(paire));
145 List ids = snd(paire);
146 Module mod = findModule(modTxt);
148 ERRMSG(0) "Can't find module \"%s\" mentioned in export list",
153 for (; nonNull(ids); ids=tl(ids)) {
155 Cell id = hd(ids); /* ConId|VarId */
157 for (xs = module(mod).exports; nonNull(xs); xs=tl(xs)) {
159 if (isQCon(x)) continue; /* ToDo: fix this right */
160 if (textOf(x)==textOf(id)) { found = TRUE; break; }
163 printf ( "adding %s to exports of %s\n",
164 identToStr(id), textToStr(modTxt) );
165 module(mod).exports = cons ( id, module(mod).exports );
171 static Void local finishGHCImports(triple)
174 Module dstMod = fst3(triple); // the importing module
175 Text srcTxt = snd3(triple);
176 List names = thd3(triple);
177 Module srcMod = findModule ( srcTxt );
178 Module tmpCurrentModule = currentModule;
184 //fprintf(stderr, "finishGHCImports: dst=%s src=%s\n",
185 // textToStr(module(dstMod).text),
186 // textToStr(srcTxt) );
189 /* for each nm in names
190 nm should be in module(src).exports -- if not, error
191 if nm notElem module(dst).names cons it on
194 if (isNull(srcMod)) {
195 /* I don't think this can actually ever happen, but still ... */
196 ERRMSG(0) "Interface for module \"%s\" imports unknown module \"%s\"",
197 textToStr(module(dstMod).text),
201 //printf ( "exports of %s are\n", textToStr(module(srcMod).text) );
202 //print( module(srcMod).exports, 100 );
205 setCurrModule ( srcMod ); // so that later lookups succeed
207 for (; nonNull(names); names=tl(names)) {
209 /* Check the exporting module really exports it. */
211 for (exps=module(srcMod).exports; nonNull(exps); exps=tl(exps)) {
213 //if (isPair(c)) c=fst(c);
214 assert(whatIs(c)==CONIDCELL || whatIs(c)==VARIDCELL);
215 assert(whatIs(nm)==CONIDCELL || whatIs(nm)==VARIDCELL);
216 //printf( " compare `%s' `%s'\n", textToStr(textOf(c)), textToStr(textOf(nm)));
217 if (textOf(c)==textOf(nm)) { found=TRUE; break; }
220 ERRMSG(0) "Interface for module \"%s\" imports \"%s\" from\n"
221 "module \"%s\", but the latter doesn't export it",
222 textToStr(module(dstMod).text), textToStr(textOf(nm)),
223 textToStr(module(srcMod).text)
226 /* Ok, it's exported. Now figure out what it is we're really
233 if (!cellIsMember(x,module(dstMod).names))
234 module(dstMod).names = cons(x, module(dstMod).names);
240 if (!cellIsMember(x,module(dstMod).tycons))
241 module(dstMod).tycons = cons(x, module(dstMod).tycons);
247 if (!cellIsMember(x,module(dstMod).classes))
248 module(dstMod).classes = cons(x, module(dstMod).classes);
252 fprintf(stderr, "\npanic: Can't figure out what this is in finishGHCImports\n"
253 "\t%s\n", textToStr(tnm) );
254 internal("finishGHCImports");
257 setCurrModule(tmpCurrentModule);
261 Void loadInterface(String fname, Long fileSize)
264 parseInterface(fname,fileSize);
265 if (nonNull(ifImports))
270 Void finishInterfaces ( void )
272 /* the order of these doesn't matter
273 * (ToDo: unless synonyms have to be eliminated??)
275 mapProc(finishGHCVar, ghcVarDecls);
276 mapProc(finishGHCConstr, ghcConstrDecls);
277 mapProc(finishGHCSynonym, ghcSynonymDecls);
278 mapProc(finishGHCClass, ghcClassDecls);
279 mapProc(finishGHCInstance, ghcInstanceDecls);
280 mapProc(finishGHCExports, ghcExports);
281 mapProc(finishGHCImports, ghcImports);
282 mapProc(finishGHCModule, ghcModules);
284 ghcConstrDecls = NIL;
285 ghcSynonymDecls = NIL;
287 ghcInstanceDecls = NIL;
294 static Void local finishGHCModule(mod)
296 // do the implicit 'import Prelude' thing
297 List pxs = module(modulePrelude).exports;
298 for (; nonNull(pxs); pxs=tl(pxs)) {
301 switch (whatIs(px)) {
306 module(mod).names = cons ( px, module(mod).names );
309 module(mod).tycons = cons ( px, module(mod).tycons );
312 module(mod).classes = cons ( px, module(mod).classes );
315 fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
320 // Last, but by no means least ...
321 resolveReferencesInObjectModule ( mod );
328 Module m = findModule(t);
331 printf ( "new module %s\n", textToStr(t) );
332 } else if (m != modulePrelude) {
333 ERRMSG(0) "Module \"%s\" already loaded", textToStr(t)
337 // sizeObj and nameObj will magically be set to the right
338 // thing when we arrive here.
339 // All this crud should be replaced with mmap when we do this
341 img = malloc ( sizeObj );
343 ERRMSG(0) "Can't allocate memory to load object file for module \"%s\"",
347 f = fopen( nameObj, "rb" );
349 // Really, this shouldn't happen, since makeStackEntry ensures the
350 // object is available. Nevertheless ...
351 ERRMSG(0) "Object file \"%s\" can't be opened to read -- oops!",
355 if (sizeObj != fread ( img, 1, sizeObj, f)) {
356 ERRMSG(0) "Read of object file \"%s\" failed", nameObj
359 if (!validateOImage(img,sizeObj)) {
360 ERRMSG(0) "Validation of object file \"%s\" failed", nameObj
364 assert(!module(m).oImage);
365 module(m).oImage = img;
367 if (!cellIsMember(m, ghcModules))
368 ghcModules = cons(m, ghcModules);
374 Void addGHCImports(line,mn,syms)
376 Text mn; /* the module to import from */
377 List syms; { /* [ConId | VarId] -- the names to import */
381 printf("\naddGHCImport %s\n", textToStr(mn) );
384 // Hack to avoid chasing Prel* junk right now
385 if (strncmp(textToStr(mn), "Prel",4)==0) return;
388 for (t=ifImports; nonNull(t); t=tl(t)) {
389 if (textOf(hd(t)) == mn) {
395 ifImports = cons(mkCon(mn),ifImports);
396 ghcImports = cons( triple(currentModule,mn,syms), ghcImports );
400 void addGHCVar(line,v,ty)
408 /* if this var is the name of a ghc-compiled dictionary,
409 ie, starts zdfC where C is a capital,
414 printf("\nbegin addGHCVar %s\n", s);
416 if (s[0]=='z' && s[1]=='d' && s[2]=='f' && isupper((int)s[3])) {
418 printf(" ignoring %s\n", s);
424 ERRMSG(0) "Attempt to redefine variable \"%s\"", textToStr(v)
428 bindGHCNameTo(n, text_info);
429 bindGHCNameTo(n, text_closure);
431 tvs = nubList(ifTyvarsIn(ty));
432 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
433 hd(tmp) = pair(hd(tmp),STAR);
435 ty = mkPolyType(tvsToKind(tvs),ty);
437 ty = tvsToOffsets(line,ty,tvs);
439 /* prepare for finishGHCVar */
442 ghcVarDecls = cons(n,ghcVarDecls);
444 printf("end addGHCVar %s\n", s);
448 static Void local finishGHCVar(Name n)
450 Int line = name(n).line;
451 Type ty = name(n).type;
453 fprintf(stderr, "\nbegin finishGHCVar %s\n", textToStr(name(n).text) );
455 setCurrModule(name(n).mod);
456 name(n).type = conidcellsToTycons(line,ty);
458 fprintf(stderr, "end finishGHCVar %s\n", textToStr(name(n).text) );
462 Void addGHCSynonym(line,tycon,tvs,ty)
464 Cell tycon; /* ConId */
465 List tvs; /* [(VarId,Kind)] */
467 /* ToDo: worry about being given a decl for (->) ?
468 * and worry about qualidents for ()
470 Text t = textOf(tycon);
471 if (nonNull(findTycon(t))) {
472 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
476 Tycon tc = newTycon(t);
477 tycon(tc).line = line;
478 tycon(tc).arity = length(tvs);
479 tycon(tc).what = SYNONYM;
480 tycon(tc).kind = tvsToKind(tvs);
482 /* prepare for finishGHCSynonym */
483 tycon(tc).defn = tvsToOffsets(line,ty,tvs);
484 ghcSynonymDecls = cons(tc,ghcSynonymDecls);
488 static Void local finishGHCSynonym(Tycon tc)
490 Int line = tycon(tc).line;
492 setCurrModule(tycon(tc).mod);
493 tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
495 /* ToDo: can't really do this until I've done all synonyms
496 * and then I have to do them in order
497 * tycon(tc).defn = fullExpand(ty);
501 Void addGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
503 List ctx0; /* [(QConId,VarId)] */
504 Cell tycon; /* ConId */
505 List ktyvars; /* [(VarId,Kind)] */
506 List constrs0; /* [(ConId,[(Type,Text)],NIL)]
507 The NIL will become the constr's type
508 The Text is an optional field name */
509 /* ToDo: worry about being given a decl for (->) ?
510 * and worry about qualidents for ()
513 Type ty, resTy, selTy, conArgTy;
514 List tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
518 Pair conArg, ctxElem;
521 Text t = textOf(tycon);
523 fprintf(stderr, "\nbegin addGHCDataDecl %s\n",textToStr(t));
525 if (nonNull(findTycon(t))) {
526 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
530 Tycon tc = newTycon(t);
532 tycon(tc).line = line;
533 tycon(tc).arity = length(ktyvars);
534 tycon(tc).kind = tvsToKind(ktyvars);
535 tycon(tc).what = DATATYPE;
537 /* a list to accumulate selectors in :: [(VarId,Type)] */
540 /* make resTy the result type of the constr, T v1 ... vn */
542 for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
543 resTy = ap(resTy,fst(hd(tmp)));
545 /* for each constructor ... */
546 for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
547 constr = hd(constrs);
548 conid = fst3(constr);
549 fields = snd3(constr);
550 assert(isNull(thd3(constr)));
552 /* Build type of constr and handle any selectors found.
553 Also collect up tyvars occurring in the constr's arg
554 types, so we can throw away irrelevant parts of the
558 tyvarsMentioned = NIL; /* [VarId] */
559 conArgs = reverse(fields);
560 for (; nonNull(conArgs); conArgs=tl(conArgs)) {
561 conArg = hd(conArgs); /* (Type,Text) */
562 conArgTy = fst(conArg);
563 conArgNm = snd(conArg);
564 tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
566 ty = fn(conArgTy,ty);
567 if (nonNull(conArgNm)) {
568 /* a field name is mentioned too */
569 selTy = fn(resTy,conArgTy);
570 if (whatIs(tycon(tc).kind) != STAR)
571 selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
572 selTy = tvsToOffsets(line,selTy, ktyvars);
574 sels = cons( pair(conArgNm,selTy), sels);
578 /* Now ty is the constructor's type, not including context.
579 Throw away any parts of the context not mentioned in
580 tyvarsMentioned, and use it to qualify ty.
583 for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
584 ctxElem = hd(ctx); /* (QConId,VarId) */
585 if (nonNull(cellIsMember(textOf(snd(ctxElem)),tyvarsMentioned)))
586 ctx2 = cons(ctxElem, ctx2);
589 ty = ap(QUAL,pair(ctx2,ty));
591 /* stick the tycon's kind on, if not simply STAR */
592 if (whatIs(tycon(tc).kind) != STAR)
593 ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
595 ty = tvsToOffsets(line,ty, ktyvars);
597 /* Finally, stick the constructor's type onto it. */
598 thd3(hd(constrs)) = ty;
601 /* Final result is that
602 constrs :: [(ConId,[(Type,Text)],Type)]
603 lists the constructors and their types
604 sels :: [(VarId,Type)]
605 lists the selectors and their types
607 tycon(tc).defn = addGHCConstrs(line,constrs0,sels);
610 fprintf(stderr, "end addGHCDataDecl %s\n",textToStr(t));
615 static List local addGHCConstrs(line,cons,sels)
617 List cons; /* [(ConId,[(Type,Text)],Type)] */
618 List sels; { /* [(VarId,Type)] */
620 Int conNo = 0; /* or maybe 1? */
621 for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
622 Name c = addGHCConstr(line,conNo,hd(cs));
625 for(ss=sels; nonNull(ss); ss=tl(ss)) {
626 hd(ss) = addGHCSel(line,hd(ss));
628 return appendOnto(cons,sels);
631 static Name local addGHCSel(line,sel)
633 Pair sel; /* (VarId,Type) */
635 Text t = textOf(fst(sel));
636 Type type = snd(sel);
638 Name n = findName(t);
640 ERRMSG(line) "Repeated definition for selector \"%s\"",
647 name(n).number = SELNAME;
651 /* prepare for finishGHCVar */
653 ghcVarDecls = cons(n,ghcVarDecls);
658 static Name local addGHCConstr(line,conNo,constr)
661 Triple constr; { /* (ConId,[(Type,Text)],Type) */
662 /* ToDo: add rank2 annotation and existential annotation
663 * these affect how constr can be used.
665 Text con = textOf(fst3(constr));
666 Type type = thd3(constr);
667 Int arity = arityFromType(type);
668 Name n = findName(con); /* Allocate constructor fun name */
670 n = newName(con,NIL);
671 } else if (name(n).defn!=PREDEFINED) {
672 ERRMSG(line) "Repeated definition for constructor \"%s\"",
676 name(n).arity = arity; /* Save constructor fun details */
678 name(n).number = cfunNo(conNo);
681 // expect to find the names
683 // Mod_Con_static_closure
684 // Mod_Con_static_info
685 bindGHCNameTo(n, text_closure);
686 bindGHCNameTo(n, text_static_closure);
687 bindGHCNameTo(n, text_static_info);
689 // expect to find the names
694 // Mod_Con_static_info
695 bindGHCNameTo(n, text_closure);
696 bindGHCNameTo(n, text_entry);
697 bindGHCNameTo(n, text_info);
698 bindGHCNameTo(n, text_con_info);
699 bindGHCNameTo(n, text_static_info);
702 /* prepare for finishGHCCon */
704 ghcConstrDecls = cons(n,ghcConstrDecls);
709 static Void local finishGHCConstr(Name n)
711 Int line = name(n).line;
712 Type ty = name(n).type;
713 setCurrModule(name(n).mod);
715 printf ( "\nbegin finishGHCConstr %s\n", textToStr(name(n).text));
717 name(n).type = conidcellsToTycons(line,ty);
719 printf ( "end finishGHCConstr %s\n", textToStr(name(n).text));
724 Void addGHCNewType(line,ctx0,tycon,tvs,constr)
726 List ctx0; /* [(QConId,VarId)] */
727 Cell tycon; /* ConId | QualConId */
728 List tvs; /* [(VarId,Kind)] */
729 Cell constr; { /* (ConId,Type) */
730 /* ToDo: worry about being given a decl for (->) ?
731 * and worry about qualidents for ()
735 Text t = textOf(tycon);
736 if (nonNull(findTycon(t))) {
737 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
741 Tycon tc = newTycon(t);
742 tycon(tc).line = line;
743 tycon(tc).arity = length(tvs);
744 tycon(tc).what = NEWTYPE;
745 tycon(tc).kind = tvsToKind(tvs);
746 /* can't really do this until I've read in all synonyms */
748 assert(nonNull(constr));
749 if (isNull(constr)) {
750 tycon(tc).defn = NIL;
752 /* constr :: (ConId,Type) */
753 Text con = textOf(fst(constr));
754 Type type = snd(constr);
755 Name n = findName(con); /* Allocate constructor fun name */
757 n = newName(con,NIL);
758 } else if (name(n).defn!=PREDEFINED) {
759 ERRMSG(line) "Repeated definition for constructor \"%s\"",
763 name(n).arity = 1; /* Save constructor fun details */
765 name(n).number = cfunNo(0);
766 name(n).defn = nameId;
767 tycon(tc).defn = singleton(n);
769 /* prepare for finishGHCCon */
770 /* ToDo: we use finishGHCCon instead of finishGHCVar in case
771 * there's any existential quantification in the newtype -
772 * but I don't think that's allowed in newtype constrs.
773 * Still, no harm done by doing it this way...
776 /* make resTy the result type of the constr, T v1 ... vn */
778 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
779 resTy = ap(resTy,fst(hd(tmp)));
780 type = fn(type,resTy);
782 type = ap(QUAL,pair(ctx0,type));
784 type = tvsToOffsets(line,type,tvs);
787 ghcConstrDecls = cons(n,ghcConstrDecls);
792 Void addGHCClass(line,ctxt,tc_name,tv,mems0)
794 List ctxt; /* [(QConId, VarId)] */
795 Cell tc_name; /* ConId */
797 List mems0; { /* [(VarId, Type)] */
798 List mems; /* [(VarId, Type)] */
799 List tvsInT; /* [VarId] and then [(VarId,Kind)] */
800 List tvs; /* [(VarId,Kind)] */
801 Text ct = textOf(tc_name);
802 Pair newCtx = pair(tc_name, tv);
804 printf ( "\nbegin addGHCclass %s\n", textToStr(ct) );
806 if (nonNull(findClass(ct))) {
807 ERRMSG(line) "Repeated definition of class \"%s\"",
810 } else if (nonNull(findTycon(ct))) {
811 ERRMSG(line) "\"%s\" used as both class and type constructor",
815 Class nw = newClass(ct);
816 cclass(nw).text = ct;
817 cclass(nw).line = line;
818 cclass(nw).arity = 1;
819 cclass(nw).head = ap(nw,mkOffset(0));
820 cclass(nw).kinds = singleton(STAR); /* absolutely no idea at all */
821 cclass(nw).instances = NIL; /* what the kind should be */
822 cclass(nw).numSupers = length(ctxt);
824 /* Kludge to map the single tyvar in the context to Offset 0.
825 Need to do something better for multiparam type classes.
827 cclass(nw).supers = tvsToOffsets(line,ctxt,
828 singleton(pair(tv,STAR)));
830 for (mems=mems0; nonNull(mems); mems=tl(mems)) {
832 Type memT = snd(mem);
834 /* Stick the new context on the member type */
835 if (whatIs(memT)==POLYTYPE) internal("addGHCClass");
836 if (whatIs(memT)==QUAL) {
838 pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
841 pair(singleton(newCtx),memT));
844 /* Cook up a kind for the type. */
845 tvsInT = nubList(ifTyvarsIn(memT));
847 /* ToDo: maximally bogus */
848 for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs))
849 hd(tvs) = pair(hd(tvs),STAR);
851 memT = mkPolyType(tvsToKind(tvsInT),memT);
852 memT = tvsToOffsets(line,memT,tvsInT);
854 /* Park the type back on the member */
858 cclass(nw).members = mems0;
859 cclass(nw).numMembers = length(mems0);
860 ghcClassDecls = cons(nw,ghcClassDecls);
863 * cclass(nw).dsels = ?;
864 * cclass(nw).dbuild = ?;
865 * cclass(nm).dcon = ?;
866 * cclass(nm).defaults = ?;
870 printf ( "end addGHCclass %s\n", textToStr(ct) );
874 static Void local finishGHCClass(Class nw)
877 Int line = cclass(nw).line;
878 Int ctr = - length(cclass(nw).members);
881 printf ( "\nbegin finishGHCclass %s\n", textToStr(cclass(nw).text) );
884 setCurrModule(cclass(nw).mod);
886 cclass(nw).level = 0; /* ToDo: 1 + max (map level supers) */
887 cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
888 cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
889 cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
891 for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
892 Pair mem = hd(mems); /* (VarId, Type) */
893 Text txt = textOf(fst(mem));
895 Name n = findName(txt);
897 ERRMSG(cclass(nw).line)
898 "Repeated definition for class method \"%s\"",
902 n = newName(txt,NIL);
903 name(n).line = cclass(nw).line;
905 name(n).number = ctr++;
909 printf ( "end finishGHCclass %s\n", textToStr(cclass(nw).text) );
913 Void addGHCInstance (line,ctxt0,cls,var)
915 List ctxt0; /* [(QConId, Type)] */
916 Pair cls; /* (ConId, [Type]) */
917 Text var; { /* Text */
921 printf ( "\nbegin addGHCInstance\n" );
924 /* Make tvs into a list of tyvars with bogus kinds. */
925 tvs = nubList(ifTyvarsIn(snd(cls)));
927 for (tmp = tvs; nonNull(tmp); tmp=tl(tmp)) {
928 hd(tmp) = pair(hd(tmp),STAR);
932 inst(in).line = line;
933 inst(in).implements = NIL;
935 inst(in).specifics = tvsToOffsets(line,ctxt0,tvs);
936 inst(in).numSpecifics = length(ctxt0);
937 inst(in).head = tvsToOffsets(line,cls,tvs);
939 Is this still needed?
941 Name b = newName(inventText(),NIL);
943 name(b).arity = length(ctxt); /* unused? */
944 name(b).number = DFUNNAME;
945 inst(in).builder = b;
946 bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
949 ghcInstanceDecls = cons(in, ghcInstanceDecls);
951 printf ( "end addGHCInstance\n" );
955 static Void local finishGHCInstance(Inst in)
957 Int line = inst(in).line;
958 Cell cl = fst(inst(in).head);
961 printf ( "\nbegin finishGHCInstance\n" );
964 setCurrModule(inst(in).mod);
965 c = findClass(textOf(cl));
967 ERRMSG(line) "Unknown class \"%s\" in instance",
968 textToStr(textOf(cl))
971 inst(in).head = conidcellsToTycons(line,inst(in).head);
972 inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
973 cclass(c).instances = cons(in,cclass(c).instances);
975 printf ( "end finishGHCInstance\n" );
979 /* --------------------------------------------------------------------------
981 * ------------------------------------------------------------------------*/
983 /* This is called from the addGHC* functions. It traverses a structure
984 and converts varidcells, ie, type variables parsed by the interface
985 parser, into Offsets, which is how Hugs wants to see them internally.
986 The Offset for a type variable is determined by its place in the list
987 passed as the second arg; the associated kinds are irrelevant.
989 static Type local tvsToOffsets(line,type,ktyvars)
992 List ktyvars; { /* [(VarId|Text,Kind)] */
993 switch (whatIs(type)) {
1001 return ap( tvsToOffsets(line,fun(type),ktyvars),
1002 tvsToOffsets(line,arg(type),ktyvars) );
1006 tvsToOffsets(line,monotypeOf(type),ktyvars)
1010 return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
1011 tvsToOffsets(line,snd(snd(type)),ktyvars)));
1012 case VARIDCELL: /* Ha! some real work to do! */
1014 Text tv = textOf(type);
1015 for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
1016 Cell varid = fst(hd(ktyvars));
1017 Text tt = isVar(varid) ? textOf(varid) : varid;
1018 if (tv == tt) return mkOffset(i);
1020 ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
1025 fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
1027 fprintf(stderr,"\n");
1030 assert(0); /* NOTREACHED */
1034 /* This is called from the finishGHC* functions. It traverses a structure
1035 and converts conidcells, ie, type constructors parsed by the interface
1036 parser, into Tycons (or Classes), which is how Hugs wants to see them
1037 internally. Calls to this fn have to be deferred to the second phase
1038 of interface loading (finishGHC* rather than addGHC*) so that all relevant
1039 Tycons or Classes have been loaded into the symbol tables and can be
1042 static Type local conidcellsToTycons(line,type)
1045 switch (whatIs(type)) {
1054 Text m = qmodOf(type);
1055 Text v = qtextOf(type);
1056 Module mod = findModule(m);
1057 printf ( "lookup qualident " ); print(type,100); printf("\n");
1060 "Undefined module in qualified name \"%s\"",
1065 for (t=module(mod).tycons; nonNull(t); t=tl(t))
1066 if (v == tycon(hd(t)).text) return hd(t);
1067 for (t=module(mod).classes; nonNull(t); t=tl(t))
1068 if (v == cclass(hd(t)).text) return hd(t);
1070 "Undefined qualified class or type \"%s\"",
1078 tc = findQualTycon(type);
1079 if (nonNull(tc)) return tc;
1080 cl = findQualClass(type);
1081 if (nonNull(cl)) return cl;
1083 "Undefined class or type constructor \"%s\"",
1089 return ap( conidcellsToTycons(line,fun(type)),
1090 conidcellsToTycons(line,arg(type)) );
1094 conidcellsToTycons(line,monotypeOf(type))
1098 return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
1099 conidcellsToTycons(line,snd(snd(type)))));
1101 fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
1104 fprintf(stderr,"\n");
1107 assert(0); /* NOTREACHED */
1111 /* --------------------------------------------------------------------------
1114 * None of these do lookups or require that lookups have been resolved
1115 * so they can be performed while reading interfaces.
1116 * ------------------------------------------------------------------------*/
1118 static Kinds local tvsToKind(tvs)
1119 List tvs; { /* [(VarId,Kind)] */
1122 for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
1123 r = ap(snd(hd(rs)),r);
1128 /* arity of a constructor with this type */
1129 static Int local arityFromType(type)
1132 if (isPolyType(type)) {
1133 type = monotypeOf(type);
1135 if (whatIs(type) == QUAL) {
1136 type = snd(snd(type));
1138 if (whatIs(type) == EXIST) {
1139 type = snd(snd(type));
1141 if (whatIs(type)==RANK2) {
1142 type = snd(snd(type));
1144 while (isAp(type) && getHead(type)==typeArrow) {
1152 static List local ifTyvarsIn(type)
1154 List vs = typeVarsIn(type,NIL,NIL);
1156 for (; nonNull(vs2); vs2=tl(vs2)) {
1158 if (whatIs(v)==VARIDCELL || whatIs(v)==VAROPCELL) {
1159 hd(vs2) = textOf(hd(vs2));
1161 internal("ifTyvarsIn");
1168 /* --------------------------------------------------------------------------
1169 * Dynamic loading code (probably shouldn't be here)
1171 * o .hi file explicitly says which .so file to load.
1172 * This avoids the need for a 1-to-1 relationship between .hi and .so files.
1174 * ToDo: when doing a :reload, we ought to check the modification date
1177 * o module handles are unloaded (dlclosed) when we call dropScriptsFrom.
1179 * ToDo: do the same for foreign functions - but with complication that
1180 * there may be multiple .so files
1181 * ------------------------------------------------------------------------*/
1183 typedef struct { char* name; void* addr; } RtsTabEnt;
1185 /* not really true */
1186 extern int stg_gc_enter_1;
1187 extern int stg_chk_1;
1188 extern int stg_update_PAP;
1189 extern int __ap_2_upd_info;
1193 { "stg_gc_enter_1", &stg_gc_enter_1 },
1194 { "stg_chk_1", &stg_chk_1 },
1195 { "stg_update_PAP", &stg_update_PAP },
1196 { "__ap_2_upd_info", &__ap_2_upd_info },
1200 char* strsuffix ( char* s, char* suffix )
1203 int xl = strlen(suffix);
1204 if (xl > sl) return NULL;
1205 if (0 == strcmp(s+sl-xl,suffix)) return s+sl-xl;
1209 char* lookupObjName ( char* nameT )
1221 if (isupper(((int)(nameT[0])))) {
1222 // name defined in a module, eg Mod_xyz_static_closure
1223 // Place a zero after the module name, and after
1224 // the symbol name proper
1225 // --> Mod\0xyz\0static_closure
1226 nm = strchr(nameT, '_');
1227 if (!nm) internal ( "lookupObjName");
1230 if ((ty=strsuffix(nm, "_static_closure")))
1231 { *ty = 0; ty++; ts = text_static_closure; }
1233 if ((ty=strsuffix(nm, "_static_info" )))
1234 { *ty = 0; ty++; ts = text_static_info; }
1236 if ((ty=strsuffix(nm, "_con_info" )))
1237 { *ty = 0; ty++; ts = text_con_info; }
1239 if ((ty=strsuffix(nm, "_con_entry" )))
1240 { *ty = 0; ty++; ts = text_con_entry; }
1242 if ((ty=strsuffix(nm, "_info" )))
1243 { *ty = 0; ty++; ts = text_info; }
1245 if ((ty=strsuffix(nm, "_entry" )))
1246 { *ty = 0; ty++; ts = text_entry; }
1248 if ((ty=strsuffix(nm, "_closure" )))
1249 { *ty = 0; ty++; ts = text_closure; }
1251 fprintf(stderr, "lookupObjName: unknown suffix on %s\n", nameT );
1254 tm = findText(nameT);
1256 //printf ( "\nlooking at mod `%s' var `%s' ext `%s' \n",textToStr(tm),textToStr(tn),textToStr(ts));
1257 naam = jrsFindQualName(tm,tn);
1258 if (isNull(naam)) goto not_found;
1259 pr = cellAssoc ( ts, name(naam).ghc_names );
1260 if (isNull(pr)) goto no_info;
1261 return ptrOf(snd(pr));
1264 // name presumably originating from the RTS
1266 for (k = 0; rtsTab[k].name; k++) {
1267 if (0==strcmp(nameT,rtsTab[k].name)) {
1272 if (!a) goto not_found_rts;
1278 "lookupObjName: can't resolve name `%s'\n",
1283 "lookupObjName: no info for name `%s'\n",
1288 "lookupObjName: can't resolve RTS name `%s'\n",
1294 /* --------------------------------------------------------------------------
1296 * ------------------------------------------------------------------------*/
1300 static char* local findElfSection ( void* objImage, Elf32_Word sh_type )
1303 char* ehdrC = (char*)objImage;
1304 Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
1305 Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1307 for (i = 0; i < ehdr->e_shnum; i++) {
1308 if (shdr[i].sh_type == sh_type &&
1309 i != ehdr->e_shstrndx) {
1310 ptr = ehdrC + shdr[i].sh_offset;
1317 static AsmClosure local findObjectSymbol_elfo ( void* objImage, char* name )
1323 char* ehdrC = (char*)objImage;
1324 Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
1325 shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1327 strtab = findElfSection ( objImage, SHT_STRTAB );
1328 if (!strtab) internal("findObjectSymbol_elfo");
1330 for (i = 0; i < ehdr->e_shnum; i++) {
1331 if (shdr[i].sh_type != SHT_SYMTAB) continue;
1332 stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
1333 nent = shdr[i].sh_size / sizeof(Elf32_Sym);
1334 for (j = 0; j < nent; j++) {
1335 if ( strcmp(strtab + stab[j].st_name, name) == 0
1336 && ELF32_ST_BIND(stab[j].st_info)==STB_GLOBAL ) {
1337 return ehdrC + stab[j].st_value;
1344 static Void local resolveReferencesInObjectModule_elfo( objImage )
1346 char symbol[1000]; // ToDo
1350 char* ehdrC = (char*)objImage;
1351 Elf32_Ehdr* ehdr = (Elf32_Ehdr*) ehdrC;
1352 Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1354 // first find "the" symbol table
1355 //stab = findElfSection ( objImage, SHT_SYMTAB );
1357 // also go find the string table
1358 strtab = findElfSection ( objImage, SHT_STRTAB );
1360 if (!stab || !strtab)
1361 internal("resolveReferencesInObjectModule_elfo");
1363 for (i = 0; i < ehdr->e_shnum; i++) {
1364 if (shdr[i].sh_type == SHT_REL ) {
1365 Elf32_Rel* rtab = (Elf32_Rel*) (ehdrC + shdr[i].sh_offset);
1366 Int nent = shdr[i].sh_size / sizeof(Elf32_Rel);
1367 Int target_shndx = shdr[i].sh_info;
1368 Int symtab_shndx = shdr[i].sh_link;
1369 stab = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
1370 targ = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
1371 printf ( "relocations for section %d using symtab %d\n", target_shndx, symtab_shndx );
1372 for (j = 0; j < nent; j++) {
1373 Elf32_Addr offset = rtab[j].r_offset;
1374 Elf32_Word info = rtab[j].r_info;
1376 Elf32_Addr P = ((Elf32_Addr)targ) + offset;
1377 Elf32_Word* pP = (Elf32_Word*)P;
1381 printf ("Rel entry %3d is raw(%6p %6p) ", j, (void*)offset, (void*)info );
1383 printf ( " ZERO\n" );
1386 strcpy ( symbol, strtab+stab[ ELF32_R_SYM(info)].st_name );
1387 printf ( "`%s' ", symbol );
1388 if (symbol[0] == 0) {
1389 printf ( "-- ignore?\n" );
1393 S = (Elf32_Addr)lookupObjName ( symbol );
1394 printf ( "resolves to %p\n", (void*)S );
1397 switch (ELF32_R_TYPE(info)) {
1398 case R_386_32: *pP = S + A; break;
1399 case R_386_PC32: *pP = S + A - P; break;
1400 default: fprintf(stderr,
1401 "unhandled ELF relocation type %d\n",
1402 ELF32_R_TYPE(info));
1409 if (shdr[i].sh_type == SHT_RELA) {
1415 static Bool local validateOImage_elfo ( void* imgV, Int size )
1419 int i, j, nent, nstrtab, nsymtabs;
1423 char* ehdrC = (char*)imgV;
1424 Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
1426 if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
1427 ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
1428 ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
1429 ehdr->e_ident[EI_MAG3] != ELFMAG3) {
1430 printf ( "Not an ELF header\n" );
1433 printf ( "Is an ELF header\n" );
1435 if (ehdr->e_ident[EI_CLASS] != ELFCLASS32) {
1436 printf ( "Not 32 bit ELF\n" );
1439 printf ( "Is 32 bit ELF\n" );
1441 if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
1442 printf ( "Is little-endian\n" );
1444 if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
1445 printf ( "Is big-endian\n" );
1447 printf ( "Unknown endiannness\n" );
1451 if (ehdr->e_type != ET_REL) {
1452 printf ( "Not a relocatable object (.o) file\n" );
1455 printf ( "Is a relocatable object (.o) file\n" );
1457 printf ( "Architecture is " );
1458 switch (ehdr->e_machine) {
1459 case EM_386: printf ( "x86\n" ); break;
1460 case EM_SPARC: printf ( "sparc\n" ); break;
1461 default: printf ( "unknown\n" ); return FALSE;
1464 printf ( "\nSection header table: start %d, n_entries %d, ent_size %d\n",
1465 ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize );
1467 assert (ehdr->e_shentsize == sizeof(Elf32_Shdr));
1469 shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1471 if (ehdr->e_shstrndx == SHN_UNDEF) {
1472 printf ( "No section header string table\n" );
1475 printf ( "Section header string table is section %d\n",
1477 sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
1480 for (i = 0; i < ehdr->e_shnum; i++) {
1481 printf ( "%2d: ", i );
1482 printf ( "type=%2d ", shdr[i].sh_type );
1483 printf ( "size=%4d ", shdr[i].sh_size );
1484 if (shdr[i].sh_type == SHT_REL ) printf ( "Rel " ); else
1485 if (shdr[i].sh_type == SHT_RELA) printf ( "RelA " ); else
1487 if (sh_strtab) printf ( "sname=%s", sh_strtab + shdr[i].sh_name );
1491 printf ( "\n\nString tables\n" );
1494 for (i = 0; i < ehdr->e_shnum; i++) {
1495 if (shdr[i].sh_type == SHT_STRTAB &&
1496 i != ehdr->e_shstrndx) {
1497 printf ( " section %d is a normal string table\n", i );
1498 strtab = ehdrC + shdr[i].sh_offset;
1503 printf ( "WARNING: no string tables, or too many\n" );
1506 printf ( "\n\nSymbol tables\n" );
1507 for (i = 0; i < ehdr->e_shnum; i++) {
1508 if (shdr[i].sh_type != SHT_SYMTAB) continue;
1509 printf ( "section %d is a symbol table\n", i );
1511 stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
1512 nent = shdr[i].sh_size / sizeof(Elf32_Sym);
1513 printf ( " number of entries is apparently %d (%d rem)\n",
1515 shdr[i].sh_size % sizeof(Elf32_Sym)
1517 if (0 != shdr[i].sh_size % sizeof(Elf32_Sym)) {
1518 printf ( "non-integral number of symbol table entries\n");
1521 for (j = 0; j < nent; j++) {
1522 printf ( " %2d ", j );
1523 printf ( " sec=%-5d size=%-3d val=%-5p ",
1524 (int)stab[j].st_shndx,
1525 (int)stab[j].st_size,
1526 (char*)stab[j].st_value );
1529 switch (ELF32_ST_TYPE(stab[j].st_info)) {
1530 case STT_NOTYPE: printf ( "notype " ); break;
1531 case STT_OBJECT: printf ( "object " ); break;
1532 case STT_FUNC : printf ( "func " ); break;
1533 case STT_SECTION: printf ( "section" ); break;
1534 case STT_FILE: printf ( "file " ); break;
1535 default: printf ( "? " ); break;
1540 switch (ELF32_ST_BIND(stab[j].st_info)) {
1541 case STB_LOCAL : printf ( "local " ); break;
1542 case STB_GLOBAL: printf ( "global" ); break;
1543 case STB_WEAK : printf ( "weak " ); break;
1544 default: printf ( "? " ); break;
1548 printf ( "name=%s\n", strtab + stab[j].st_name );
1552 if (nsymtabs == 0) {
1553 printf ( "Didn't find any symbol tables\n" );
1561 /* --------------------------------------------------------------------------
1563 * ------------------------------------------------------------------------*/
1565 static Void local bindGHCNameTo ( Name n, Text suffix )
1567 char symbol[1000]; /* ToDo: arbitrary constants must die */
1569 sprintf(symbol,"%s_%s_%s",
1570 textToStr(module(currentModule).text),
1571 textToStr(name(n).text),textToStr(suffix));
1572 // fprintf(stderr, "\nbindGHCNameTo %s ", symbol);
1573 res = findObjectSymbol_elfo ( module(currentModule).oImage, symbol );
1575 ERRMSG(0) "Can't find symbol \"%s\" in object for module \"%s\"",
1577 textToStr(module(currentModule).text)
1580 //fprintf(stderr, " = %p\n", res );
1581 name(n).ghc_names = cons(pair(suffix,mkPtr(res)), name(n).ghc_names);
1583 // set the stgVar to be a CPTRCELL to the closure label.
1584 // prefer dynamic over static closures if given a choice
1585 if (suffix == text_closure || suffix == text_static_closure) {
1586 if (isNull(name(n).stgVar)) {
1587 // accept any old thing
1588 name(n).stgVar = mkCPtr(res);
1590 // only accept something more dynamic that what we have now
1591 if (suffix != text_static_closure
1592 && isCPtr(name(n).stgVar)
1593 && cptrOf(name(n).stgVar) != res)
1594 name(n).stgVar = mkCPtr(res);
1599 static Void local resolveReferencesInObjectModule ( Module m )
1601 fprintf(stderr, "resolveReferencesInObjectModule %s\n",textToStr(module(m).text));
1602 resolveReferencesInObjectModule_elfo ( module(m).oImage );
1605 static Bool local validateOImage(img,size)
1608 return validateOImage_elfo ( img, size );
1612 /* --------------------------------------------------------------------------
1614 * ------------------------------------------------------------------------*/
1616 Void interface(what)
1623 ghcConstrDecls = NIL;
1624 ghcSynonymDecls = NIL;
1625 ghcClassDecls = NIL;
1626 ghcInstanceDecls = NIL;
1630 text_info = findText("info");
1631 text_entry = findText("entry");
1632 text_closure = findText("closure");
1633 text_static_closure = findText("static_closure");
1634 text_static_info = findText("static_info");
1635 text_con_info = findText("con_info");
1636 text_con_entry = findText("con_entry");
1641 mark(ghcConstrDecls);
1642 mark(ghcSynonymDecls);
1643 mark(ghcClassDecls);
1644 mark(ghcInstanceDecls);
1652 /*-------------------------------------------------------------------------*/