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/12/03 17:01:21 $
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 */
37 // #define DEBUG_IFACE
40 extern void print ( Cell, Int );
42 /* --------------------------------------------------------------------------
43 * The "addGHC*" functions act as "impedence matchers" between GHC
44 * interface files and Hugs. Their main job is to convert abstract
45 * syntax trees into Hugs' internal representations.
47 * The main trick here is how we deal with mutually recursive interface
50 * o As we read an import decl, we add it to a list of required imports
51 * (unless it's already loaded, of course).
53 * o Processing of declarations is split into two phases:
55 * 1) While reading the interface files, we construct all the Names,
56 * Tycons, etc declared in the interface file but we don't try to
57 * resolve references to any entities the declaration mentions.
59 * This is done by the "addGHC*" functions.
61 * 2) After reading all the interface files, we finish processing the
62 * declarations by resolving any references in the declarations
63 * and doing any other processing that may be required.
65 * This is done by the "finishGHC*" functions which use the
66 * "fixup*" functions to assist them.
68 * The interface between these two phases are the "ghc*Decls" which
69 * contain lists of decls that haven't been completed yet.
71 * ------------------------------------------------------------------------*/
73 /* --------------------------------------------------------------------------
75 * ------------------------------------------------------------------------*/
77 static List ghcVarDecls;
78 static List ghcConstrDecls;
79 static List ghcSynonymDecls;
80 static List ghcClassDecls;
81 static List ghcInstanceDecls;
83 /* --------------------------------------------------------------------------
84 * local function prototypes:
85 * ------------------------------------------------------------------------*/
87 static List local addGHCConstrs Args((Int,List,List));
88 static Name local addGHCSel Args((Int,Pair));
89 static Name local addGHCConstr Args((Int,Int,Triple));
92 static Void local finishGHCVar Args((Name));
93 static Void local finishGHCConstr Args((Name));
94 static Void local finishGHCSynonym Args((Tycon));
95 static Void local finishGHCClass Args((Class));
96 static Void local finishGHCInstance Args((Inst));
97 static Void local finishGHCImports Args((Triple));
98 static Void local finishGHCExports Args((Pair));
99 static Void local finishGHCModule Args((Module));
101 static Kinds local tvsToKind Args((List));
102 static Int local arityFromType Args((Type));
103 static Int local arityInclDictParams Args((Type));
106 static List local ifTyvarsIn Args((Type));
108 static Type local tvsToOffsets Args((Int,Type,List));
109 static Type local conidcellsToTycons Args((Int,Type));
111 static Void local resolveReferencesInObjectModule Args((Module,Bool));
112 static Bool local validateOImage Args((void*, Int, Bool));
113 static Void local readSyms Args((Module,Bool));
115 static void* local lookupObjName ( char* );
118 /* --------------------------------------------------------------------------
120 * ------------------------------------------------------------------------*/
122 List ifImports; /* [ConId] -- modules imported by current interface */
124 List ghcImports; /* [(Module, Text, [ConId|VarId])]
125 each (m1, m2, names) in this list
126 represents 'module m1 where ... import m2 ( names ) ...'
127 The list acts as a list of names to fix up in
131 List ghcExports; /* [(ConId, -- module name
132 [ ConId | VarId | pair(ConId,[ConId|VarId])] )]
136 List ghcModules; /* [Module] -- modules of the .his loaded in this group */
138 Void addGHCExports(mod,stuff)
141 ghcExports = cons( pair(mod,stuff), ghcExports );
144 static Void local finishGHCExports(paire)
146 Text modTxt = textOf(fst(paire));
147 List entities = snd(paire);
148 Module mod = findModule(modTxt);
150 ERRMSG(0) "Can't find module \"%s\" mentioned in export list",
154 fprintf(stderr, "----------------------------------finishexports\n");
155 /* Assume that each .hi file only contains one export decl */
156 if (nonNull(module(mod).exports))
157 internal("finishGHCExports: non-empty export list");
159 /* Run along what the parser gave us and make export list entries */
160 for (; nonNull(entities); entities=tl(entities)) {
161 Cell ent = hd(entities);
164 switch (whatIs(ent)) {
165 case VARIDCELL: /* variable */
166 c = findName ( snd(ent) );
168 fprintf(stderr, "var %s\n", textToStr(name(c).text));
169 module(mod).exports = cons(c, module(mod).exports);
171 case CONIDCELL: /* non data tycon */
172 c = findTycon ( snd(ent) );
174 fprintf(stderr, "non data tycon %s\n", textToStr(tycon(c).text));
175 module(mod).exports = cons(c, module(mod).exports);
177 default: /* data T = C1 ... Cn or class C where f1 ... fn */
178 if (!isPair(ent)) internal("finishExports(2)");
181 c = findTycon ( snd(ent) );
184 fprintf(stderr, "data %s = ", textToStr(tycon(c).text));
185 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
186 for (; nonNull(subents); subents = tl(subents)) {
187 Cell ent2 = hd(subents);
189 c = findName ( snd(ent2) );
190 fprintf(stderr, "%s ", textToStr(name(c).text));
192 module(mod).exports = cons(c, module(mod).exports);
194 fprintf(stderr, "\n" );
197 c = findClass ( snd(ent) );
199 fprintf(stderr, "class %s where ", textToStr(cclass(c).text));
200 module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
202 for (; nonNull(subents); subents = tl(subents)) {
203 Cell ent2 = hd(subents);
205 c = findName ( snd(ent2) );
206 fprintf(stderr, "%s ", textToStr(name(c).text));
208 module(mod).exports = cons(c, module(mod).exports);
210 fprintf(stderr, "\n" );
218 static Void local finishGHCImports(triple)
221 Module dstMod = fst3(triple); // the importing module
222 Text srcTxt = snd3(triple);
223 List names = thd3(triple);
224 Module srcMod = findModule ( srcTxt );
225 Module tmpCurrentModule = currentModule;
231 //fprintf(stderr, "finishGHCImports: dst=%s src=%s\n",
232 // textToStr(module(dstMod).text),
233 // textToStr(srcTxt) );
236 /* for each nm in names
237 nm should be in module(src).exports -- if not, error
238 if nm notElem module(dst).names cons it on
241 if (isNull(srcMod)) {
242 /* I don't think this can actually ever happen, but still ... */
243 ERRMSG(0) "Interface for module \"%s\" imports unknown module \"%s\"",
244 textToStr(module(dstMod).text),
248 //printf ( "exports of %s are\n", textToStr(module(srcMod).text) );
249 //print( module(srcMod).exports, 100 );
252 setCurrModule ( srcMod ); // so that later lookups succeed
254 for (; nonNull(names); names=tl(names)) {
256 /* Check the exporting module really exports it. */
258 for (exps=module(srcMod).exports; nonNull(exps); exps=tl(exps)) {
260 //if (isPair(c)) c=fst(c);
261 assert(whatIs(c)==CONIDCELL || whatIs(c)==VARIDCELL);
262 assert(whatIs(nm)==CONIDCELL || whatIs(nm)==VARIDCELL);
263 //printf( " compare `%s' `%s'\n", textToStr(textOf(c)), textToStr(textOf(nm)));
264 if (textOf(c)==textOf(nm)) { found=TRUE; break; }
267 ERRMSG(0) "Interface for module \"%s\" imports \"%s\" from\n"
268 "module \"%s\", but the latter doesn't export it",
269 textToStr(module(dstMod).text), textToStr(textOf(nm)),
270 textToStr(module(srcMod).text)
273 /* Ok, it's exported. Now figure out what it is we're really
280 if (!cellIsMember(x,module(dstMod).names))
281 module(dstMod).names = cons(x, module(dstMod).names);
287 if (!cellIsMember(x,module(dstMod).tycons))
288 module(dstMod).tycons = cons(x, module(dstMod).tycons);
294 if (!cellIsMember(x,module(dstMod).classes))
295 module(dstMod).classes = cons(x, module(dstMod).classes);
299 fprintf(stderr, "\npanic: Can't figure out what this is in finishGHCImports\n"
300 "\t%s\n", textToStr(tnm) );
301 internal("finishGHCImports");
304 setCurrModule(tmpCurrentModule);
308 Void loadInterface(String fname, Long fileSize)
311 parseInterface(fname,fileSize);
312 if (nonNull(ifImports))
317 Void finishInterfaces ( void )
319 /* the order of these doesn't matter
320 * (ToDo: unless synonyms have to be eliminated??)
322 mapProc(finishGHCVar, ghcVarDecls);
323 mapProc(finishGHCConstr, ghcConstrDecls);
324 mapProc(finishGHCSynonym, ghcSynonymDecls);
325 mapProc(finishGHCClass, ghcClassDecls);
326 mapProc(finishGHCInstance, ghcInstanceDecls);
327 mapProc(finishGHCExports, ghcExports);
328 mapProc(finishGHCImports, ghcImports);
329 mapProc(finishGHCModule, ghcModules);
331 ghcConstrDecls = NIL;
332 ghcSynonymDecls = NIL;
334 ghcInstanceDecls = NIL;
341 static Void local finishGHCModule(mod)
343 // do the implicit 'import Prelude' thing
344 List pxs = module(modulePrelude).exports;
345 for (; nonNull(pxs); pxs=tl(pxs)) {
348 switch (whatIs(px)) {
353 module(mod).names = cons ( px, module(mod).names );
356 module(mod).tycons = cons ( px, module(mod).tycons );
359 module(mod).classes = cons ( px, module(mod).classes );
362 fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
367 // Last, but by no means least ...
368 resolveReferencesInObjectModule ( mod, TRUE );
376 Module m = findModule(t);
379 //printf ( "new module %s\n", textToStr(t) );
380 } else if (m != modulePrelude) {
381 ERRMSG(0) "Module \"%s\" already loaded", textToStr(t)
385 // sizeObj and nameObj will magically be set to the right
386 // thing when we arrive here.
387 // All this crud should be replaced with mmap when we do this
389 img = malloc ( sizeObj );
391 ERRMSG(0) "Can't allocate memory to load object file for module \"%s\"",
395 f = fopen( nameObj, "rb" );
397 // Really, this shouldn't happen, since makeStackEntry ensures the
398 // object is available. Nevertheless ...
399 ERRMSG(0) "Object file \"%s\" can't be opened to read -- oops!",
403 if (sizeObj != fread ( img, 1, sizeObj, f)) {
404 ERRMSG(0) "Read of object file \"%s\" failed", nameObj
407 if (!validateOImage(img,sizeObj,VERBOSE)) {
408 ERRMSG(0) "Validation of object file \"%s\" failed", nameObj
412 assert(!module(m).oImage);
413 module(m).oImage = img;
417 if (!cellIsMember(m, ghcModules))
418 ghcModules = cons(m, ghcModules);
424 Void addGHCImports(line,mn,syms)
426 Text mn; /* the module to import from */
427 List syms; { /* [ConId | VarId] -- the names to import */
431 printf("\naddGHCImport %s\n", textToStr(mn) );
434 /* Don't chase PrelGHC -- it doesn't exist */
435 if (strncmp(textToStr(mn), "PrelGHC",7)==0) return;
438 for (t=ifImports; nonNull(t); t=tl(t)) {
439 if (textOf(hd(t)) == mn) {
445 ifImports = cons(mkCon(mn),ifImports);
446 ghcImports = cons( triple(currentModule,mn,syms), ghcImports );
450 void addGHCVar(line,v,ty)
458 /* if this var is the name of a ghc-compiled dictionary,
459 ie, starts zdfC where C is a capital,
464 printf("\nbegin addGHCVar %s\n", s);
466 if (s[0]=='z' && s[1]=='d' && s[2]=='f' && isupper((int)s[3])) {
468 printf(" ignoring %s\n", s);
474 ERRMSG(0) "Attempt to redefine variable \"%s\"", textToStr(v)
479 tvs = nubList(ifTyvarsIn(ty));
480 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
481 hd(tmp) = pair(hd(tmp),STAR);
483 ty = mkPolyType(tvsToKind(tvs),ty);
485 ty = tvsToOffsets(line,ty,tvs);
487 /* prepare for finishGHCVar */
489 name(n).arity = arityInclDictParams(ty);
491 ghcVarDecls = cons(n,ghcVarDecls);
493 printf("end addGHCVar %s\n", s);
497 static Void local finishGHCVar(Name n)
499 Int line = name(n).line;
500 Type ty = name(n).type;
502 fprintf(stderr, "\nbegin finishGHCVar %s\n", textToStr(name(n).text) );
504 setCurrModule(name(n).mod);
505 name(n).type = conidcellsToTycons(line,ty);
507 fprintf(stderr, "end finishGHCVar %s\n", textToStr(name(n).text) );
511 Void addGHCSynonym(line,tycon,tvs,ty)
513 Cell tycon; /* ConId */
514 List tvs; /* [(VarId,Kind)] */
516 /* ToDo: worry about being given a decl for (->) ?
517 * and worry about qualidents for ()
519 Text t = textOf(tycon);
520 if (nonNull(findTycon(t))) {
521 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
525 Tycon tc = newTycon(t);
526 tycon(tc).line = line;
527 tycon(tc).arity = length(tvs);
528 tycon(tc).what = SYNONYM;
529 tycon(tc).kind = tvsToKind(tvs);
531 /* prepare for finishGHCSynonym */
532 tycon(tc).defn = tvsToOffsets(line,ty,tvs);
533 ghcSynonymDecls = cons(tc,ghcSynonymDecls);
537 static Void local finishGHCSynonym(Tycon tc)
539 Int line = tycon(tc).line;
541 setCurrModule(tycon(tc).mod);
542 tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
544 /* ToDo: can't really do this until I've done all synonyms
545 * and then I have to do them in order
546 * tycon(tc).defn = fullExpand(ty);
550 Void addGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
552 List ctx0; /* [(QConId,VarId)] */
553 Cell tycon; /* ConId */
554 List ktyvars; /* [(VarId,Kind)] */
555 List constrs0; /* [(ConId,[(Type,Text,Int)],NIL)]
556 The NIL will become the constr's type
557 The Text is an optional field name
558 The Int indicates strictness */
559 /* ToDo: worry about being given a decl for (->) ?
560 * and worry about qualidents for ()
563 Type ty, resTy, selTy, conArgTy;
564 List tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
568 Pair conArg, ctxElem;
570 Int conArgStrictness;
572 Text t = textOf(tycon);
574 fprintf(stderr, "\nbegin addGHCDataDecl %s\n",textToStr(t));
576 if (nonNull(findTycon(t))) {
577 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
581 Tycon tc = newTycon(t);
583 tycon(tc).line = line;
584 tycon(tc).arity = length(ktyvars);
585 tycon(tc).kind = tvsToKind(ktyvars);
586 tycon(tc).what = DATATYPE;
588 /* a list to accumulate selectors in :: [(VarId,Type)] */
591 /* make resTy the result type of the constr, T v1 ... vn */
593 for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
594 resTy = ap(resTy,fst(hd(tmp)));
596 /* for each constructor ... */
597 for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
598 constr = hd(constrs);
599 conid = fst3(constr);
600 fields = snd3(constr);
601 assert(isNull(thd3(constr)));
603 /* Build type of constr and handle any selectors found.
604 Also collect up tyvars occurring in the constr's arg
605 types, so we can throw away irrelevant parts of the
609 tyvarsMentioned = NIL; /* [VarId] */
610 conArgs = reverse(fields);
611 for (; nonNull(conArgs); conArgs=tl(conArgs)) {
612 conArg = hd(conArgs); /* (Type,Text) */
613 conArgTy = fst3(conArg);
614 conArgNm = snd3(conArg);
615 conArgStrictness = intOf(thd3(conArg));
616 tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
618 if (conArgStrictness > 0) conArgTy = bang(conArgTy);
619 ty = fn(conArgTy,ty);
620 if (nonNull(conArgNm)) {
621 /* a field name is mentioned too */
622 selTy = fn(resTy,conArgTy);
623 if (whatIs(tycon(tc).kind) != STAR)
624 selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
625 selTy = tvsToOffsets(line,selTy, ktyvars);
627 sels = cons( pair(conArgNm,selTy), sels);
631 /* Now ty is the constructor's type, not including context.
632 Throw away any parts of the context not mentioned in
633 tyvarsMentioned, and use it to qualify ty.
636 for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
637 ctxElem = hd(ctx); /* (QConId,VarId) */
638 if (nonNull(cellIsMember(textOf(snd(ctxElem)),tyvarsMentioned)))
639 ctx2 = cons(ctxElem, ctx2);
642 ty = ap(QUAL,pair(ctx2,ty));
644 /* stick the tycon's kind on, if not simply STAR */
645 if (whatIs(tycon(tc).kind) != STAR)
646 ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
648 ty = tvsToOffsets(line,ty, ktyvars);
650 /* Finally, stick the constructor's type onto it. */
651 thd3(hd(constrs)) = ty;
654 /* Final result is that
655 constrs :: [(ConId,[(Type,Text)],Type)]
656 lists the constructors and their types
657 sels :: [(VarId,Type)]
658 lists the selectors and their types
660 tycon(tc).defn = addGHCConstrs(line,constrs0,sels);
663 fprintf(stderr, "end addGHCDataDecl %s\n",textToStr(t));
668 static List local addGHCConstrs(line,cons,sels)
670 List cons; /* [(ConId,[(Type,Text,Int)],Type)] */
671 List sels; { /* [(VarId,Type)] */
673 Int conNo = 0; /* or maybe 1? */
674 for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
675 Name c = addGHCConstr(line,conNo,hd(cs));
678 for(ss=sels; nonNull(ss); ss=tl(ss)) {
679 hd(ss) = addGHCSel(line,hd(ss));
681 return appendOnto(cons,sels);
684 static Name local addGHCSel(line,sel)
686 Pair sel; /* (VarId,Type) */
688 Text t = textOf(fst(sel));
689 Type type = snd(sel);
691 Name n = findName(t);
693 ERRMSG(line) "Repeated definition for selector \"%s\"",
700 name(n).number = SELNAME;
704 /* prepare for finishGHCVar */
706 ghcVarDecls = cons(n,ghcVarDecls);
711 static Name local addGHCConstr(line,conNo,constr)
714 Triple constr; { /* (ConId,[(Type,Text,Int)],Type) */
715 /* ToDo: add rank2 annotation and existential annotation
716 * these affect how constr can be used.
718 Text con = textOf(fst3(constr));
719 Type type = thd3(constr);
720 Int arity = arityFromType(type);
721 Name n = findName(con); /* Allocate constructor fun name */
723 n = newName(con,NIL);
724 } else if (name(n).defn!=PREDEFINED) {
725 ERRMSG(line) "Repeated definition for constructor \"%s\"",
729 name(n).arity = arity; /* Save constructor fun details */
731 name(n).number = cfunNo(conNo);
733 /* prepare for finishGHCCon */
735 ghcConstrDecls = cons(n,ghcConstrDecls);
740 static Void local finishGHCConstr(Name n)
742 Int line = name(n).line;
743 Type ty = name(n).type;
744 setCurrModule(name(n).mod);
746 printf ( "\nbegin finishGHCConstr %s\n", textToStr(name(n).text));
748 name(n).type = conidcellsToTycons(line,ty);
750 printf ( "end finishGHCConstr %s\n", textToStr(name(n).text));
755 Void addGHCNewType(line,ctx0,tycon,tvs,constr)
757 List ctx0; /* [(QConId,VarId)] */
758 Cell tycon; /* ConId | QualConId */
759 List tvs; /* [(VarId,Kind)] */
760 Cell constr; { /* (ConId,Type) */
761 /* ToDo: worry about being given a decl for (->) ?
762 * and worry about qualidents for ()
766 Text t = textOf(tycon);
767 if (nonNull(findTycon(t))) {
768 ERRMSG(line) "Repeated definition of type constructor \"%s\"",
772 Tycon tc = newTycon(t);
773 tycon(tc).line = line;
774 tycon(tc).arity = length(tvs);
775 tycon(tc).what = NEWTYPE;
776 tycon(tc).kind = tvsToKind(tvs);
777 /* can't really do this until I've read in all synonyms */
779 assert(nonNull(constr));
780 if (isNull(constr)) {
781 tycon(tc).defn = NIL;
783 /* constr :: (ConId,Type) */
784 Text con = textOf(fst(constr));
785 Type type = snd(constr);
786 Name n = findName(con); /* Allocate constructor fun name */
788 n = newName(con,NIL);
789 } else if (name(n).defn!=PREDEFINED) {
790 ERRMSG(line) "Repeated definition for constructor \"%s\"",
794 name(n).arity = 1; /* Save constructor fun details */
796 name(n).number = cfunNo(0);
797 name(n).defn = nameId;
798 tycon(tc).defn = singleton(n);
800 /* prepare for finishGHCCon */
801 /* ToDo: we use finishGHCCon instead of finishGHCVar in case
802 * there's any existential quantification in the newtype -
803 * but I don't think that's allowed in newtype constrs.
804 * Still, no harm done by doing it this way...
807 /* make resTy the result type of the constr, T v1 ... vn */
809 for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
810 resTy = ap(resTy,fst(hd(tmp)));
811 type = fn(type,resTy);
813 type = ap(QUAL,pair(ctx0,type));
815 type = tvsToOffsets(line,type,tvs);
818 ghcConstrDecls = cons(n,ghcConstrDecls);
823 Void addGHCClass(line,ctxt,tc_name,kinded_tv,mems0)
825 List ctxt; /* [(QConId, VarId)] */
826 Cell tc_name; /* ConId */
827 Text kinded_tv; /* (VarId, Kind) */
828 List mems0; { /* [(VarId, Type)] */
829 List mems; /* [(VarId, Type)] */
830 List tvsInT; /* [VarId] and then [(VarId,Kind)] */
831 List tvs; /* [(VarId,Kind)] */
832 Text ct = textOf(tc_name);
833 Pair newCtx = pair(tc_name, fst(kinded_tv));
835 printf ( "\nbegin addGHCclass %s\n", textToStr(ct) );
837 if (nonNull(findClass(ct))) {
838 ERRMSG(line) "Repeated definition of class \"%s\"",
841 } else if (nonNull(findTycon(ct))) {
842 ERRMSG(line) "\"%s\" used as both class and type constructor",
846 Class nw = newClass(ct);
847 cclass(nw).text = ct;
848 cclass(nw).line = line;
849 cclass(nw).arity = 1;
850 cclass(nw).head = ap(nw,mkOffset(0));
851 cclass(nw).kinds = singleton(STAR); /* absolutely no idea at all */
852 cclass(nw).instances = NIL; /* what the kind should be */
853 cclass(nw).numSupers = length(ctxt);
855 /* Kludge to map the single tyvar in the context to Offset 0.
856 Need to do something better for multiparam type classes.
858 cclass(nw).supers = tvsToOffsets(line,ctxt,
859 singleton(pair(tv,STAR)));
861 cclass(nw).supers = tvsToOffsets(line,ctxt,
862 singleton(kinded_tv));
865 for (mems=mems0; nonNull(mems); mems=tl(mems)) {
867 Type memT = snd(mem);
868 Text mnt = textOf(fst(mem));
871 /* Stick the new context on the member type */
872 if (whatIs(memT)==POLYTYPE) internal("addGHCClass");
873 if (whatIs(memT)==QUAL) {
875 pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
878 pair(singleton(newCtx),memT));
881 /* Cook up a kind for the type. */
882 tvsInT = nubList(ifTyvarsIn(memT));
884 /* ToDo: maximally bogus */
885 for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs))
886 hd(tvs) = pair(hd(tvs),STAR);
888 memT = mkPolyType(tvsToKind(tvsInT),memT);
889 memT = tvsToOffsets(line,memT,tvsInT);
891 /* Park the type back on the member */
894 /* Bind code to the member */
898 "Repeated definition for class method \"%s\"",
902 mn = newName(mnt,NIL);
905 cclass(nw).members = mems0;
906 cclass(nw).numMembers = length(mems0);
907 ghcClassDecls = cons(nw,ghcClassDecls);
910 * cclass(nw).dsels = ?;
911 * cclass(nw).dbuild = ?;
912 * cclass(nm).dcon = ?;
913 * cclass(nm).defaults = ?;
917 printf ( "end addGHCclass %s\n", textToStr(ct) );
921 static Void local finishGHCClass(Class nw)
924 Int line = cclass(nw).line;
925 Int ctr = - length(cclass(nw).members);
928 printf ( "\nbegin finishGHCclass %s\n", textToStr(cclass(nw).text) );
931 setCurrModule(cclass(nw).mod);
933 cclass(nw).level = 0; /* ToDo: 1 + max (map level supers) */
934 cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
935 cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
936 cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
938 for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
939 Pair mem = hd(mems); /* (VarId, Type) */
940 Text txt = textOf(fst(mem));
942 Name n = findName(txt);
944 name(n).line = cclass(nw).line;
946 name(n).number = ctr++;
950 printf ( "end finishGHCclass %s\n", textToStr(cclass(nw).text) );
954 Void addGHCInstance (line,ctxt0,cls,var)
956 List ctxt0; /* [(QConId, Type)] */
957 List cls; /* [(ConId, Type)] */
958 Text var; { /* Text */
962 printf ( "\nbegin addGHCInstance\n" );
965 /* Make tvs into a list of tyvars with bogus kinds. */
966 //print ( cls, 10 ); printf ( "\n");
967 tvs = nubList(ifTyvarsIn(cls));
970 for (tmp = tvs; nonNull(tmp); tmp=tl(tmp)) {
971 hd(tmp) = pair(hd(tmp),STAR);
975 inst(in).line = line;
976 inst(in).implements = NIL;
978 inst(in).specifics = tvsToOffsets(line,ctxt0,tvs);
979 inst(in).numSpecifics = length(ctxt0);
980 inst(in).head = tvsToOffsets(line,cls,tvs);
982 Is this still needed?
984 Name b = newName(inventText(),NIL);
986 name(b).arity = length(ctxt); /* unused? */
987 name(b).number = DFUNNAME;
988 inst(in).builder = b;
989 bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
992 ghcInstanceDecls = cons(in, ghcInstanceDecls);
994 printf ( "end addGHCInstance\n" );
998 static Void local finishGHCInstance(Inst in)
1000 Int line = inst(in).line;
1001 Cell cl = fst(inst(in).head);
1004 printf ( "\nbegin finishGHCInstance\n" );
1007 setCurrModule(inst(in).mod);
1008 c = findClass(textOf(cl));
1010 ERRMSG(line) "Unknown class \"%s\" in instance",
1011 textToStr(textOf(cl))
1014 inst(in).head = conidcellsToTycons(line,inst(in).head);
1015 inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
1016 cclass(c).instances = cons(in,cclass(c).instances);
1018 printf ( "end finishGHCInstance\n" );
1022 /* --------------------------------------------------------------------------
1024 * ------------------------------------------------------------------------*/
1026 /* This is called from the addGHC* functions. It traverses a structure
1027 and converts varidcells, ie, type variables parsed by the interface
1028 parser, into Offsets, which is how Hugs wants to see them internally.
1029 The Offset for a type variable is determined by its place in the list
1030 passed as the second arg; the associated kinds are irrelevant.
1032 static Type local tvsToOffsets(line,type,ktyvars)
1035 List ktyvars; { /* [(VarId|Text,Kind)] */
1036 switch (whatIs(type)) {
1044 return ap( tvsToOffsets(line,fun(type),ktyvars),
1045 tvsToOffsets(line,arg(type),ktyvars) );
1049 tvsToOffsets(line,monotypeOf(type),ktyvars)
1053 return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
1054 tvsToOffsets(line,snd(snd(type)),ktyvars)));
1055 case DICTAP: /* bogus ?? */
1056 return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
1057 case UNBOXEDTUP: /* bogus?? */
1058 return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
1059 case BANG: /* bogus?? */
1060 return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
1061 case VARIDCELL: /* Ha! some real work to do! */
1063 Text tv = textOf(type);
1064 for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
1065 Cell varid = fst(hd(ktyvars));
1066 Text tt = isVar(varid) ? textOf(varid) : varid;
1067 if (tv == tt) return mkOffset(i);
1069 ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
1074 fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
1076 fprintf(stderr,"\n");
1080 return NIL; /* NOTREACHED */
1083 /* ToDo: nuke this */
1084 static Text kludgeGHCPrelText ( Text m )
1088 if (strncmp(textToStr(m), "Prel", 4)==0)
1089 return textPrelude; else return m;
1094 /* This is called from the finishGHC* functions. It traverses a structure
1095 and converts conidcells, ie, type constructors parsed by the interface
1096 parser, into Tycons (or Classes), which is how Hugs wants to see them
1097 internally. Calls to this fn have to be deferred to the second phase
1098 of interface loading (finishGHC* rather than addGHC*) so that all relevant
1099 Tycons or Classes have been loaded into the symbol tables and can be
1103 static Type local conidcellsToTycons(line,type)
1106 switch (whatIs(type)) {
1115 Text m = kludgeGHCPrelText(qmodOf(type));
1116 Text v = qtextOf(type);
1117 Module mod = findModule(m);
1118 //printf ( "lookup qualident " ); print(type,100); printf("\n");
1121 "Undefined module in qualified name \"%s\"",
1126 for (t=module(mod).tycons; nonNull(t); t=tl(t))
1127 if (v == tycon(hd(t)).text) return hd(t);
1128 for (t=module(mod).classes; nonNull(t); t=tl(t))
1129 if (v == cclass(hd(t)).text) return hd(t);
1131 "Undefined qualified class or type \"%s\"",
1139 tc = findQualTycon(type);
1140 if (nonNull(tc)) return tc;
1141 cl = findQualClass(type);
1142 if (nonNull(cl)) return cl;
1144 "Undefined class or type constructor \"%s\"",
1150 return ap( conidcellsToTycons(line,fun(type)),
1151 conidcellsToTycons(line,arg(type)) );
1155 conidcellsToTycons(line,monotypeOf(type))
1159 return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
1160 conidcellsToTycons(line,snd(snd(type)))));
1161 case DICTAP: /* bogus?? */
1162 return ap(DICTAP, conidcellsToTycons(line, snd(type)));
1164 return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
1166 fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
1169 fprintf(stderr,"\n");
1173 return NIL; /* NOTREACHED */
1177 /* --------------------------------------------------------------------------
1180 * None of these do lookups or require that lookups have been resolved
1181 * so they can be performed while reading interfaces.
1182 * ------------------------------------------------------------------------*/
1184 static Kinds local tvsToKind(tvs)
1185 List tvs; { /* [(VarId,Kind)] */
1188 for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
1189 r = ap(snd(hd(rs)),r);
1195 static Int local arityInclDictParams ( Type type )
1198 if (isPolyType(type)) type = monotypeOf(type);
1200 if (whatIs(type) == QUAL)
1202 arity += length ( fst(snd(type)) );
1203 type = snd(snd(type));
1205 while (isAp(type) && getHead(type)==typeArrow) {
1212 /* arity of a constructor with this type */
1213 static Int local arityFromType(type)
1216 if (isPolyType(type)) {
1217 type = monotypeOf(type);
1219 if (whatIs(type) == QUAL) {
1220 type = snd(snd(type));
1222 if (whatIs(type) == EXIST) {
1223 type = snd(snd(type));
1225 if (whatIs(type)==RANK2) {
1226 type = snd(snd(type));
1228 while (isAp(type) && getHead(type)==typeArrow) {
1236 static List local ifTyvarsIn(type)
1238 List vs = typeVarsIn(type,NIL,NIL,NIL);
1240 for (; nonNull(vs2); vs2=tl(vs2)) {
1242 if (whatIs(v)==VARIDCELL || whatIs(v)==VAROPCELL) {
1243 hd(vs2) = textOf(hd(vs2));
1245 internal("ifTyvarsIn");
1252 /* --------------------------------------------------------------------------
1254 * ------------------------------------------------------------------------*/
1256 #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
1260 static char* local findElfSection ( void* objImage, Elf32_Word sh_type )
1263 char* ehdrC = (char*)objImage;
1264 Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
1265 Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1267 for (i = 0; i < ehdr->e_shnum; i++) {
1268 if (shdr[i].sh_type == sh_type &&
1269 i != ehdr->e_shstrndx) {
1270 ptr = ehdrC + shdr[i].sh_offset;
1278 static Void local resolveReferencesInObjectModule_elf ( Module m,
1281 char symbol[1000]; // ToDo
1283 Elf32_Sym* stab = NULL;
1285 char* ehdrC = (char*)(module(m).oImage);
1286 Elf32_Ehdr* ehdr = (Elf32_Ehdr*) ehdrC;
1287 Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1289 // first find "the" symbol table
1290 // why is this commented out???
1291 stab = (Elf32_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
1293 // also go find the string table
1294 strtab = findElfSection ( ehdrC, SHT_STRTAB );
1296 if (!stab || !strtab)
1297 internal("resolveReferencesInObjectModule_elf");
1299 for (i = 0; i < ehdr->e_shnum; i++) {
1300 if (shdr[i].sh_type == SHT_REL ) {
1301 Elf32_Rel* rtab = (Elf32_Rel*) (ehdrC + shdr[i].sh_offset);
1302 Int nent = shdr[i].sh_size / sizeof(Elf32_Rel);
1303 Int target_shndx = shdr[i].sh_info;
1304 Int symtab_shndx = shdr[i].sh_link;
1305 stab = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
1306 targ = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
1309 "relocations for section %d using symtab %d\n",
1310 target_shndx, symtab_shndx );
1311 for (j = 0; j < nent; j++) {
1312 Elf32_Addr offset = rtab[j].r_offset;
1313 Elf32_Word info = rtab[j].r_info;
1315 Elf32_Addr P = ((Elf32_Addr)targ) + offset;
1316 Elf32_Word* pP = (Elf32_Word*)P;
1320 if (verb) fprintf ( stderr, "Rel entry %3d is raw(%6p %6p) ",
1321 j, (void*)offset, (void*)info );
1323 if (verb) fprintf ( stderr, " ZERO\n" );
1326 if (stab[ ELF32_R_SYM(info)].st_name == 0) {
1327 if (verb) fprintf ( stderr, "(noname) ");
1328 /* nameless (local) symbol */
1329 S = (Elf32_Addr)(ehdrC
1330 + shdr[stab[ELF32_R_SYM(info)].st_shndx ].sh_offset
1331 + stab[ELF32_R_SYM(info)].st_value
1333 strcpy ( symbol, "(noname)");
1335 strcpy ( symbol, strtab+stab[ ELF32_R_SYM(info)].st_name );
1336 if (verb) fprintf ( stderr, "`%s' ", symbol );
1337 S = (Elf32_Addr)lookupObjName ( symbol );
1339 if (verb) fprintf ( stderr, "resolves to %p\n", (void*)S );
1341 fprintf ( stderr, "link failure for `%s'\n",
1342 strtab+stab[ ELF32_R_SYM(info)].st_name );
1346 //fprintf ( stderr, "Reloc: P = %p S = %p A = %p\n\n",
1347 // (void*)P, (void*)S, (void*)A );
1348 switch (ELF32_R_TYPE(info)) {
1349 case R_386_32: *pP = S + A; break;
1350 case R_386_PC32: *pP = S + A - P; break;
1351 default: fprintf(stderr,
1352 "unhandled ELF relocation type %d\n",
1353 ELF32_R_TYPE(info));
1360 if (shdr[i].sh_type == SHT_RELA) {
1361 fprintf ( stderr, "RelA style reloc table -- not yet done" );
1368 static Bool local validateOImage_elf ( void* imgV,
1374 int i, j, nent, nstrtab, nsymtabs;
1378 char* ehdrC = (char*)imgV;
1379 Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
1381 if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
1382 ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
1383 ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
1384 ehdr->e_ident[EI_MAG3] != ELFMAG3) {
1385 if (verb) fprintf ( stderr, "Not an ELF header\n" );
1388 if (verb) fprintf ( stderr, "Is an ELF header\n" );
1390 if (ehdr->e_ident[EI_CLASS] != ELFCLASS32) {
1391 if (verb) fprintf ( stderr, "Not 32 bit ELF\n" );
1394 if (verb) fprintf ( stderr, "Is 32 bit ELF\n" );
1396 if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
1397 if (verb) fprintf ( stderr, "Is little-endian\n" );
1399 if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
1400 if (verb) fprintf ( stderr, "Is big-endian\n" );
1402 if (verb) fprintf ( stderr, "Unknown endiannness\n" );
1406 if (ehdr->e_type != ET_REL) {
1407 if (verb) fprintf ( stderr, "Not a relocatable object (.o) file\n" );
1410 if (verb) fprintf ( stderr, "Is a relocatable object (.o) file\n" );
1412 if (verb) fprintf ( stderr, "Architecture is " );
1413 switch (ehdr->e_machine) {
1414 case EM_386: if (verb) fprintf ( stderr, "x86\n" ); break;
1415 case EM_SPARC: if (verb) fprintf ( stderr, "sparc\n" ); break;
1416 default: if (verb) fprintf ( stderr, "unknown\n" ); return FALSE;
1421 "\nSection header table: start %d, n_entries %d, ent_size %d\n",
1422 ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize );
1424 assert (ehdr->e_shentsize == sizeof(Elf32_Shdr));
1426 shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1428 if (ehdr->e_shstrndx == SHN_UNDEF) {
1429 if (verb) fprintf ( stderr, "No section header string table\n" );
1433 if (verb) fprintf ( stderr,"Section header string table is section %d\n",
1435 sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
1438 for (i = 0; i < ehdr->e_shnum; i++) {
1439 if (verb) fprintf ( stderr, "%2d: ", i );
1440 if (verb) fprintf ( stderr, "type=%2d ", shdr[i].sh_type );
1441 if (verb) fprintf ( stderr, "size=%4d ", shdr[i].sh_size );
1442 if (verb) fprintf ( stderr, "offs=%4d ", shdr[i].sh_offset );
1443 if (verb) fprintf ( stderr, " (%p .. %p) ",
1444 ehdrC + shdr[i].sh_offset,
1445 ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
1447 if (shdr[i].sh_type == SHT_REL && verb) fprintf ( stderr, "Rel " ); else
1448 if (shdr[i].sh_type == SHT_RELA && verb) fprintf ( stderr, "RelA " ); else
1449 if (verb) fprintf ( stderr, " " );
1450 if (sh_strtab && verb)
1451 fprintf ( stderr, "sname=%s", sh_strtab + shdr[i].sh_name );
1452 if (verb) fprintf ( stderr, "\n" );
1455 if (verb) fprintf ( stderr, "\n\nString tables\n" );
1458 for (i = 0; i < ehdr->e_shnum; i++) {
1459 if (shdr[i].sh_type == SHT_STRTAB &&
1460 i != ehdr->e_shstrndx) {
1462 fprintf ( stderr, " section %d is a normal string table\n", i );
1463 strtab = ehdrC + shdr[i].sh_offset;
1468 if (verb) fprintf ( stderr, "WARNING: no string tables, or too many\n" );
1473 if (verb) fprintf ( stderr, "\n\nSymbol tables\n" );
1474 for (i = 0; i < ehdr->e_shnum; i++) {
1475 if (shdr[i].sh_type != SHT_SYMTAB) continue;
1476 if (verb) fprintf ( stderr, "section %d is a symbol table\n", i );
1478 stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
1479 nent = shdr[i].sh_size / sizeof(Elf32_Sym);
1480 if (verb) fprintf ( stderr, " number of entries is apparently %d (%d rem)\n",
1482 shdr[i].sh_size % sizeof(Elf32_Sym)
1484 if (0 != shdr[i].sh_size % sizeof(Elf32_Sym)) {
1485 if (verb) fprintf ( stderr, "non-integral number of symbol table entries\n");
1488 for (j = 0; j < nent; j++) {
1489 if (verb) fprintf ( stderr, " %2d ", j );
1490 if (verb) fprintf ( stderr, " sec=%-5d size=%-3d val=%-5p ",
1491 (int)stab[j].st_shndx,
1492 (int)stab[j].st_size,
1493 (char*)stab[j].st_value );
1495 if (verb) fprintf ( stderr, "type=" );
1496 switch (ELF32_ST_TYPE(stab[j].st_info)) {
1497 case STT_NOTYPE: if (verb) fprintf ( stderr, "notype " ); break;
1498 case STT_OBJECT: if (verb) fprintf ( stderr, "object " ); break;
1499 case STT_FUNC : if (verb) fprintf ( stderr, "func " ); break;
1500 case STT_SECTION: if (verb) fprintf ( stderr, "section" ); break;
1501 case STT_FILE: if (verb) fprintf ( stderr, "file " ); break;
1502 default: if (verb) fprintf ( stderr, "? " ); break;
1504 if (verb) fprintf ( stderr, " " );
1506 if (verb) fprintf ( stderr, "bind=" );
1507 switch (ELF32_ST_BIND(stab[j].st_info)) {
1508 case STB_LOCAL : if (verb) fprintf ( stderr, "local " ); break;
1509 case STB_GLOBAL: if (verb) fprintf ( stderr, "global" ); break;
1510 case STB_WEAK : if (verb) fprintf ( stderr, "weak " ); break;
1511 default: if (verb) fprintf ( stderr, "? " ); break;
1513 if (verb) fprintf ( stderr, " " );
1515 if (verb) fprintf ( stderr, "name=%s\n", strtab + stab[j].st_name );
1519 if (nsymtabs == 0) {
1520 if (verb) fprintf ( stderr, "Didn't find any symbol tables\n" );
1528 static void readSyms_elf ( Module m, Bool verb )
1533 char* ehdrC = (char*)(module(m).oImage);
1534 Elf32_Ehdr* ehdr = (Elf32_Ehdr*)ehdrC;
1535 char* strtab = findElfSection ( ehdrC, SHT_STRTAB );
1536 Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1537 char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
1539 if (!strtab) internal("readSyms_elf");
1542 for (i = 0; i < ehdr->e_shnum; i++) {
1544 /* make a HugsDLSection entry for relevant sections */
1545 DLSect kind = HUGS_DL_SECTION_OTHER;
1546 if (0==strcmp(".data",sh_strtab+shdr[i].sh_name) ||
1547 0==strcmp(".data1",sh_strtab+shdr[i].sh_name))
1548 kind = HUGS_DL_SECTION_RWDATA;
1549 if (0==strcmp(".text",sh_strtab+shdr[i].sh_name) ||
1550 0==strcmp(".rodata",sh_strtab+shdr[i].sh_name) ||
1551 0==strcmp(".rodata1",sh_strtab+shdr[i].sh_name))
1552 kind = HUGS_DL_SECTION_CODE_OR_RODATA;
1553 if (kind != HUGS_DL_SECTION_OTHER)
1556 ehdrC + shdr[i].sh_offset,
1557 ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1,
1561 if (shdr[i].sh_type != SHT_SYMTAB) continue;
1563 /* copy stuff into this module's object symbol table */
1564 stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
1565 nent = shdr[i].sh_size / sizeof(Elf32_Sym);
1566 for (j = 0; j < nent; j++) {
1567 if ( ( ELF32_ST_BIND(stab[j].st_info)==STB_GLOBAL ||
1568 ELF32_ST_BIND(stab[j].st_info)==STB_LOCAL
1571 ( ELF32_ST_TYPE(stab[j].st_info)==STT_FUNC ||
1572 ELF32_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
1573 ELF32_ST_TYPE(stab[j].st_info)==STT_NOTYPE)
1575 char* nm = strtab + stab[j].st_name;
1577 + shdr[ stab[j].st_shndx ].sh_offset
1582 fprintf(stderr, "addOTabName: %10p %s %s\n",
1583 ad, textToStr(module(m).text), nm );
1584 addOTabName ( m, nm, ad );
1586 //else fprintf(stderr, "skipping `%s'\n", strtab + stab[j].st_name );
1592 #endif /* defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) */
1595 /* --------------------------------------------------------------------------
1596 * Arch-independent interface to the runtime linker
1597 * ------------------------------------------------------------------------*/
1599 static Bool local validateOImage ( void* img, Int size, Bool verb )
1601 #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
1603 validateOImage_elf ( img, size, verb );
1605 internal("validateOImage: not implemented on this platform");
1610 static Void local resolveReferencesInObjectModule ( Module m, Bool verb )
1612 #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
1613 resolveReferencesInObjectModule_elf ( m, verb );
1615 internal("resolveReferencesInObjectModule: not implemented on this platform");
1620 static Void local readSyms ( Module m, Bool verb )
1622 #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
1623 readSyms_elf ( m, verb );
1625 internal("readSyms: not implemented on this platform");
1630 /* --------------------------------------------------------------------------
1631 * General object symbol query stuff
1632 * ------------------------------------------------------------------------*/
1634 /* entirely bogus claims about types of these symbols */
1635 extern int stg_gc_enter_1;
1636 extern int stg_chk_0;
1637 extern int stg_chk_1;
1638 extern int stg_update_PAP;
1639 extern int __ap_2_upd_info;
1640 extern int MainRegTable;
1641 extern int Upd_frame_info;
1642 extern int CAF_BLACKHOLE_info;
1643 extern int IND_STATIC_info;
1648 { "stg_gc_enter_1", &stg_gc_enter_1 },
1649 { "stg_chk_0", &stg_chk_0 },
1650 { "stg_chk_1", &stg_chk_1 },
1651 { "stg_update_PAP", &stg_update_PAP },
1652 { "__ap_2_upd_info", &__ap_2_upd_info },
1653 { "MainRegTable", &MainRegTable },
1654 { "Upd_frame_info", &Upd_frame_info },
1655 { "CAF_BLACKHOLE_info", &CAF_BLACKHOLE_info },
1656 { "IND_STATIC_info", &IND_STATIC_info },
1657 { "newCAF", &newCAF },
1662 void* lookupObjName ( char* nm )
1672 strncpy(nm2,nm,200);
1674 // first see if it's an RTS name
1675 for (k = 0; rtsTab[k].nm; k++)
1676 if (0==strcmp(nm2,rtsTab[k].nm))
1677 return rtsTab[k].ad;
1679 // if not an RTS name, look in the
1680 // relevant module's object symbol table
1681 pp = strchr(nm2, '_');
1682 if (!pp) goto not_found;
1684 t = kludgeGHCPrelText( unZcodeThenFindText(nm2) );
1686 if (isNull(m)) goto not_found;
1687 a = lookupOTabName ( m, nm );
1692 "lookupObjName: can't resolve name `%s'\n",
1698 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
1701 lookupDLSect(p) == HUGS_DL_SECTION_CODE_OR_RODATA;
1705 int is_dynamically_loaded_rwdata_ptr ( char* p )
1708 lookupDLSect(p) == HUGS_DL_SECTION_RWDATA;
1712 int is_not_dynamically_loaded_ptr ( char* p )
1715 lookupDLSect(p) == HUGS_DL_SECTION_OTHER;
1719 /* --------------------------------------------------------------------------
1721 * ------------------------------------------------------------------------*/
1723 Void interface(what)
1730 ghcConstrDecls = NIL;
1731 ghcSynonymDecls = NIL;
1732 ghcClassDecls = NIL;
1733 ghcInstanceDecls = NIL;
1741 mark(ghcConstrDecls);
1742 mark(ghcSynonymDecls);
1743 mark(ghcClassDecls);
1744 mark(ghcInstanceDecls);
1752 /*-------------------------------------------------------------------------*/