ghc/interpreter/interface.c

   1
   2 /* --------------------------------------------------------------------------
   3  * GHC interface file processing for Hugs
   4  *
   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
   8  *
   9  * $RCSfile: interface.c,v $
  10  * $Revision: 1.7 $
  11  * $Date: 1999/11/29 18:59:28 $
  12  * ------------------------------------------------------------------------*/
  13
  14 /* ToDo:
  15  * o use Z encoding
  16  * o use vectored CONSTR_entry when appropriate
  17  * o generate export list
  18  *
  19  * Needs GHC changes to generate member selectors,
  20  * superclass selectors, etc
  21  * o instance decls
  22  * o dictionary constructors ?
  23  *
  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
  26  */
  27
  28 #include "prelude.h"
  29 #include "storage.h"
  30 #include "backend.h"
  31 #include "connect.h"
  32 #include "errors.h"
  33 #include "link.h"
  34 #include "Assembler.h"  /* for wrapping GHC objects */
  35 #include "dynamic.h"
  36
  37 #define DEBUG_IFACE
  38 #define VERBOSITY TRUE
  39
  40 extern void print ( Cell, Int );
  41
  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.
  46  *
  47  * The main trick here is how we deal with mutually recursive interface
  48  * files:
  49  *
  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).
  52  *
  53  * o Processing of declarations is split into two phases:
  54  *
  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.
  58  *
  59  *      This is done by the "addGHC*" functions.
  60  *
  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.
  64  *
  65  *      This is done by the "finishGHC*" functions which use the
  66  *      "fixup*" functions to assist them.
  67  *
  68  *   The interface between these two phases are the "ghc*Decls" which
  69  *   contain lists of decls that haven't been completed yet.
  70  *
  71  * ------------------------------------------------------------------------*/
  72
  73 /* --------------------------------------------------------------------------
  74  * local variables:
  75  * ------------------------------------------------------------------------*/
  76
  77 static List ghcVarDecls;
  78 static List ghcConstrDecls;
  79 static List ghcSynonymDecls;
  80 static List ghcClassDecls;
  81 static List ghcInstanceDecls;
  82
  83 /* --------------------------------------------------------------------------
  84  * local function prototypes:
  85  * ------------------------------------------------------------------------*/
  86
  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));
  90
  91
  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));
 100
 101 static Kinds local tvsToKind             Args((List));
 102 static Int   local arityFromType         Args((Type));
 103 static Int   local arityInclDictParams   Args((Type));
 104
 105
 106 static List       local ifTyvarsIn       Args((Type));
 107
 108 static Type       local tvsToOffsets       Args((Int,Type,List));
 109 static Type       local conidcellsToTycons Args((Int,Type));
 110
 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));
 114
 115 static void*      local lookupObjName ( char* );
 116
 117
 118 /* --------------------------------------------------------------------------
 119  * code:
 120  * ------------------------------------------------------------------------*/
 121
 122 List ifImports;   /* [ConId] -- modules imported by current interface */
 123
 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
 128                         finishInterfaces().
 129                   */
 130
 131 List ghcExports;  /* [(ConId,   -- module name
 132                         [ ConId | VarId | pair(ConId,[ConId|VarId])] )]
 133                                 -- list of entities
 134                   */
 135
 136 List ghcModules;  /* [Module] -- modules of the .his loaded in this group */
 137
 138 Void addGHCExports(mod,stuff)
 139 Cell mod;
 140 List stuff; {
 141    ghcExports = cons( pair(mod,stuff), ghcExports );
 142 }
 143
 144 static Void local finishGHCExports(paire)
 145 Pair paire; {
 146    Text modTxt   = textOf(fst(paire));
 147    List entities = snd(paire);
 148    Module mod    = findModule(modTxt);
 149    if (isNull(mod)) {
 150       ERRMSG(0) "Can't find module \"%s\" mentioned in export list",
 151                 textToStr(modTxt)
 152       EEND;
 153    }
 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");
 158
 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);
 162       List subents;
 163       Cell c;
 164       switch (whatIs(ent)) {
 165          case VARIDCELL: /* variable */
 166             c = findName ( snd(ent) );
 167             assert(nonNull(c));
 168 fprintf(stderr, "var %s\n", textToStr(name(c).text));
 169             module(mod).exports = cons(c, module(mod).exports);
 170             break;
 171          case CONIDCELL: /* non data tycon */
 172             c = findTycon ( snd(ent) );
 173             assert(nonNull(c));
 174 fprintf(stderr, "non data tycon %s\n", textToStr(tycon(c).text));
 175             module(mod).exports = cons(c, module(mod).exports);
 176             break;
 177          default: /* data T = C1 ... Cn  or class C where f1 ... fn */
 178             if (!isPair(ent)) internal("finishExports(2)");
 179             subents = snd(ent);
 180             ent = fst(ent);
 181             c = findTycon ( snd(ent) );
 182             if (nonNull(c)) {
 183               /* data */
 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);
 188                   assert(isCon(ent2));
 189                   c = findName ( snd(ent2) );
 190 fprintf(stderr, "%s ", textToStr(name(c).text));
 191                   assert(nonNull(c));
 192                   module(mod).exports = cons(c, module(mod).exports);
 193                }
 194 fprintf(stderr, "\n" );
 195             } else {
 196                /* class */
 197                c = findClass ( snd(ent) );
 198                assert(nonNull(c));
 199 fprintf(stderr, "class %s where ", textToStr(cclass(c).text));
 200                module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
 201
 202                for (; nonNull(subents); subents = tl(subents)) {
 203                   Cell ent2 = hd(subents);
 204                   assert(isVar(ent2));
 205                   c = findName ( snd(ent2) );
 206 fprintf(stderr, "%s ", textToStr(name(c).text));
 207                   assert(nonNull(c));
 208                   module(mod).exports = cons(c, module(mod).exports);
 209                }
 210 fprintf(stderr, "\n" );
 211
 212             }
 213             break;
 214       }
 215    }
 216 }
 217
 218 static Void local finishGHCImports(triple)
 219 Triple triple;
 220 {
 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;
 226    List   exps;
 227    Bool   found;
 228    Text   tnm;
 229    Cell   nm;
 230    Cell   x;
 231    //fprintf(stderr, "finishGHCImports: dst=%s   src=%s\n",
 232    //                textToStr(module(dstMod).text),
 233    //                textToStr(srcTxt) );
 234    //print(names, 100);
 235    //printf("\n");
 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
 239    */
 240
 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),
 245                 textToStr(srcTxt)
 246       EEND;
 247    }
 248    //printf ( "exports of %s are\n", textToStr(module(srcMod).text) );
 249    //print( module(srcMod).exports, 100 );
 250    //printf( "\n" );
 251
 252    setCurrModule ( srcMod ); // so that later lookups succeed
 253
 254    for (; nonNull(names); names=tl(names)) {
 255       nm = hd(names);
 256       /* Check the exporting module really exports it. */
 257       found = FALSE;
 258       for (exps=module(srcMod).exports; nonNull(exps); exps=tl(exps)) {
 259          Cell c = hd(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; }
 265       }
 266       if (!found) {
 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)
 271          EEND;
 272       }
 273       /* Ok, it's exported.  Now figure out what it is we're really
 274          importing.
 275       */
 276       tnm = textOf(nm);
 277
 278       x = findName(tnm);
 279       if (nonNull(x)) {
 280          if (!cellIsMember(x,module(dstMod).names))
 281             module(dstMod).names = cons(x, module(dstMod).names);
 282          continue;
 283       }
 284
 285       x = findTycon(tnm);
 286       if (nonNull(x)) {
 287          if (!cellIsMember(x,module(dstMod).tycons))
 288             module(dstMod).tycons = cons(x, module(dstMod).tycons);
 289          continue;
 290       }
 291
 292       x = findClass(tnm);
 293       if (nonNull(x)) {
 294          if (!cellIsMember(x,module(dstMod).classes))
 295             module(dstMod).classes = cons(x, module(dstMod).classes);
 296          continue;
 297       }
 298
 299       fprintf(stderr, "\npanic: Can't figure out what this is in finishGHCImports\n"
 300                       "\t%s\n", textToStr(tnm) );
 301       internal("finishGHCImports");
 302    }
 303
 304    setCurrModule(tmpCurrentModule);
 305 }
 306
 307
 308 Void loadInterface(String fname, Long fileSize)
 309 {
 310     ifImports = NIL;
 311     parseInterface(fname,fileSize);
 312     if (nonNull(ifImports))
 313        chase(ifImports);
 314 }
 315
 316
 317 Void finishInterfaces ( void )
 318 {
 319     /* the order of these doesn't matter
 320      * (ToDo: unless synonyms have to be eliminated??)
 321      */
 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);
 330     ghcVarDecls      = NIL;
 331     ghcConstrDecls   = NIL;
 332     ghcSynonymDecls  = NIL;
 333     ghcClassDecls    = NIL;
 334     ghcInstanceDecls = NIL;
 335     ghcImports       = NIL;
 336     ghcExports       = NIL;
 337     ghcModules       = NIL;
 338 }
 339
 340
 341 static Void local finishGHCModule(mod)
 342 Module mod; {
 343    // do the implicit 'import Prelude' thing
 344    List pxs = module(modulePrelude).exports;
 345    for (; nonNull(pxs); pxs=tl(pxs)) {
 346       Cell px = hd(pxs);
 347       again:
 348       switch (whatIs(px)) {
 349          case AP:
 350             px = fst(px);
 351             goto again;
 352          case NAME:
 353             module(mod).names = cons ( px, module(mod).names );
 354             break;
 355          case TYCON:
 356             module(mod).tycons = cons ( px, module(mod).tycons );
 357             break;
 358          case CLASS:
 359             module(mod).classes = cons ( px, module(mod).classes );
 360             break;
 361          default:
 362             fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
 363             break;
 364       }
 365    }
 366
 367    // Last, but by no means least ...
 368    resolveReferencesInObjectModule ( mod, FALSE );
 369 }
 370
 371 Void openGHCIface(t)
 372 Text t; {
 373     FILE* f;
 374     void* img;
 375
 376     Module m = findModule(t);
 377     if (isNull(m)) {
 378         m = newModule(t);
 379 printf ( "new module %s\n", textToStr(t) );
 380     } else if (m != modulePrelude) {
 381         ERRMSG(0) "Module \"%s\" already loaded", textToStr(t)
 382         EEND;
 383     }
 384
 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
 388     // for real(tm)
 389     img = malloc ( sizeObj );
 390     if (!img) {
 391        ERRMSG(0) "Can't allocate memory to load object file for module \"%s\"",
 392                  textToStr(t)
 393        EEND;
 394     }
 395     f = fopen( nameObj, "rb" );
 396     if (!f) {
 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!",
 400                  &(nameObj[0])
 401        EEND;
 402     }
 403     if (sizeObj != fread ( img, 1, sizeObj, f)) {
 404        ERRMSG(0) "Read of object file \"%s\" failed", nameObj
 405        EEND;
 406     }
 407     if (!validateOImage(img,sizeObj,VERBOSITY)) {
 408        ERRMSG(0) "Validation of object file \"%s\" failed", nameObj
 409        EEND;
 410     }
 411
 412     assert(!module(m).oImage);
 413     module(m).oImage = img;
 414
 415     readSyms(m,VERBOSITY);
 416
 417     if (!cellIsMember(m, ghcModules))
 418        ghcModules = cons(m, ghcModules);
 419
 420     setCurrModule(m);
 421 }
 422
 423
 424 Void addGHCImports(line,mn,syms)
 425 Int    line;
 426 Text   mn;       /* the module to import from */
 427 List   syms; {   /* [ConId | VarId] -- the names to import */
 428     List t;
 429     Bool found;
 430 #   ifdef DEBUG_IFACE
 431     printf("\naddGHCImport %s\n", textToStr(mn) );
 432 #   endif
 433
 434     // Hack to avoid chasing Prel* junk right now
 435     if (strncmp(textToStr(mn), "Prel",4)==0) return;
 436
 437     found = FALSE;
 438     for (t=ifImports; nonNull(t); t=tl(t)) {
 439        if (textOf(hd(t)) == mn) {
 440           found = TRUE;
 441           break;
 442        }
 443     }
 444     if (!found) {
 445        ifImports = cons(mkCon(mn),ifImports);
 446        ghcImports = cons( triple(currentModule,mn,syms), ghcImports );
 447     }
 448 }
 449
 450 void addGHCVar(line,v,ty)
 451 Int  line;
 452 Text v;
 453 Type ty;
 454 {
 455     Name   n;
 456     String s;
 457     List   tmp, tvs;
 458     /* if this var is the name of a ghc-compiled dictionary,
 459        ie, starts zdfC   where C is a capital,
 460        ignore it.
 461     */
 462     s = textToStr(v);
 463 #   ifdef DEBUG_IFACE
 464     printf("\nbegin addGHCVar %s\n", s);
 465 #   endif
 466     if (s[0]=='z' && s[1]=='d' && s[2]=='f' && isupper((int)s[3])) {
 467 #      ifdef DEBUG_IFACE
 468        printf("       ignoring %s\n", s);
 469 #      endif
 470        return;
 471     }
 472     n = findName(v);
 473     if (nonNull(n)) {
 474         ERRMSG(0) "Attempt to redefine variable \"%s\"", textToStr(v)
 475         EEND;
 476     }
 477     n = newName(v,NIL);
 478
 479     tvs = nubList(ifTyvarsIn(ty));
 480     for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
 481        hd(tmp) = pair(hd(tmp),STAR);
 482     if (nonNull(tvs))
 483        ty = mkPolyType(tvsToKind(tvs),ty);
 484
 485     ty = tvsToOffsets(line,ty,tvs);
 486
 487     /* prepare for finishGHCVar */
 488     name(n).type = ty;
 489     name(n).arity = arityInclDictParams(ty);
 490     name(n).line = line;
 491     ghcVarDecls = cons(n,ghcVarDecls);
 492 #   ifdef DEBUG_IFACE
 493     printf("end   addGHCVar %s\n", s);
 494 #   endif
 495 }
 496
 497 static Void local finishGHCVar(Name n)
 498 {
 499     Int  line = name(n).line;
 500     Type ty   = name(n).type;
 501 #   ifdef DEBUG_IFACE
 502     fprintf(stderr, "\nbegin finishGHCVar %s\n", textToStr(name(n).text) );
 503 #   endif
 504     setCurrModule(name(n).mod);
 505     name(n).type = conidcellsToTycons(line,ty);
 506 #   ifdef DEBUG_IFACE
 507     fprintf(stderr, "end   finishGHCVar %s\n", textToStr(name(n).text) );
 508 #   endif
 509 }
 510
 511 Void addGHCSynonym(line,tycon,tvs,ty)
 512 Int  line;
 513 Cell tycon;  /* ConId          */
 514 List tvs;    /* [(VarId,Kind)] */
 515 Type ty; {
 516     /* ToDo: worry about being given a decl for (->) ?
 517      * and worry about qualidents for ()
 518      */
 519     Text t = textOf(tycon);
 520     if (nonNull(findTycon(t))) {
 521         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
 522                      textToStr(t)
 523         EEND;
 524     } else {
 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);
 530
 531         /* prepare for finishGHCSynonym */
 532         tycon(tc).defn  = tvsToOffsets(line,ty,tvs);
 533         ghcSynonymDecls = cons(tc,ghcSynonymDecls);
 534     }
 535 }
 536
 537 static Void  local finishGHCSynonym(Tycon tc)
 538 {
 539     Int  line = tycon(tc).line;
 540
 541     setCurrModule(tycon(tc).mod);
 542     tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
 543
 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);
 547      */
 548 }
 549
 550 Void addGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
 551 Int  line;
 552 List ctx0;      /* [(QConId,VarId)]              */
 553 Cell tycon;     /* ConId                         */
 554 List ktyvars;   /* [(VarId,Kind)] */
 555 List constrs0;  /* [(ConId,[(Type,Text)],NIL)]
 556                    The NIL will become the constr's type
 557                    The Text is an optional field name */
 558     /* ToDo: worry about being given a decl for (->) ?
 559      * and worry about qualidents for ()
 560      */
 561 {
 562     Type    ty, resTy, selTy, conArgTy;
 563     List    tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
 564     List    ctx, ctx2;
 565     Triple  constr;
 566     Cell    conid;
 567     Pair    conArg, ctxElem;
 568     Text    conArgNm;
 569
 570     Text t = textOf(tycon);
 571 #   ifdef DEBUG_IFACE
 572     fprintf(stderr, "\nbegin addGHCDataDecl %s\n",textToStr(t));
 573 #   endif
 574     if (nonNull(findTycon(t))) {
 575         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
 576                      textToStr(t)
 577         EEND;
 578     } else {
 579         Tycon tc        = newTycon(t);
 580         tycon(tc).text  = t;
 581         tycon(tc).line  = line;
 582         tycon(tc).arity = length(ktyvars);
 583         tycon(tc).kind  = tvsToKind(ktyvars);
 584         tycon(tc).what  = DATATYPE;
 585
 586         /* a list to accumulate selectors in :: [(VarId,Type)] */
 587         sels = NIL;
 588
 589         /* make resTy the result type of the constr, T v1 ... vn */
 590         resTy = tycon;
 591         for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
 592            resTy = ap(resTy,fst(hd(tmp)));
 593
 594         /* for each constructor ... */
 595         for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
 596            constr = hd(constrs);
 597            conid  = fst3(constr);
 598            fields = snd3(constr);
 599            assert(isNull(thd3(constr)));
 600
 601            /* Build type of constr and handle any selectors found.
 602               Also collect up tyvars occurring in the constr's arg
 603               types, so we can throw away irrelevant parts of the
 604               context later.
 605            */
 606            ty = resTy;
 607            tyvarsMentioned = NIL;  /* [VarId] */
 608            conArgs = reverse(fields);
 609            for (; nonNull(conArgs); conArgs=tl(conArgs)) {
 610               conArg   = hd(conArgs); /* (Type,Text) */
 611               conArgTy = fst(conArg);
 612               conArgNm = snd(conArg);
 613               tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
 614                                             tyvarsMentioned);
 615               ty = fn(conArgTy,ty);
 616               if (nonNull(conArgNm)) {
 617                  /* a field name is mentioned too */
 618                  selTy = fn(resTy,conArgTy);
 619                  if (whatIs(tycon(tc).kind) != STAR)
 620                     selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
 621                  selTy = tvsToOffsets(line,selTy, ktyvars);
 622
 623                  sels = cons( pair(conArgNm,selTy), sels);
 624               }
 625            }
 626
 627            /* Now ty is the constructor's type, not including context.
 628               Throw away any parts of the context not mentioned in
 629               tyvarsMentioned, and use it to qualify ty.
 630            */
 631            ctx2 = NIL;
 632            for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
 633               ctxElem = hd(ctx);     /* (QConId,VarId) */
 634               if (nonNull(cellIsMember(textOf(snd(ctxElem)),tyvarsMentioned)))
 635                  ctx2 = cons(ctxElem, ctx2);
 636            }
 637            if (nonNull(ctx2))
 638               ty = ap(QUAL,pair(ctx2,ty));
 639
 640            /* stick the tycon's kind on, if not simply STAR */
 641            if (whatIs(tycon(tc).kind) != STAR)
 642               ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
 643
 644            ty = tvsToOffsets(line,ty, ktyvars);
 645
 646            /* Finally, stick the constructor's type onto it. */
 647            thd3(hd(constrs)) = ty;
 648         }
 649
 650         /* Final result is that
 651            constrs :: [(ConId,[(Type,Text)],Type)]
 652                       lists the constructors and their types
 653            sels :: [(VarId,Type)]
 654                    lists the selectors and their types
 655         */
 656         tycon(tc).defn  = addGHCConstrs(line,constrs0,sels);
 657     }
 658 #   ifdef DEBUG_IFACE
 659     fprintf(stderr, "end   addGHCDataDecl %s\n",textToStr(t));
 660 #   endif
 661 }
 662
 663
 664 static List local addGHCConstrs(line,cons,sels)
 665 Int  line;
 666 List cons;   /* [(ConId,[(Type,Text)],Type)] */
 667 List sels; { /* [(VarId,Type)]         */
 668     List cs, ss;
 669     Int  conNo = 0; /*  or maybe 1? */
 670     for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
 671         Name c  = addGHCConstr(line,conNo,hd(cs));
 672         hd(cs)  = c;
 673     }
 674     for(ss=sels; nonNull(ss); ss=tl(ss)) {
 675         hd(ss) = addGHCSel(line,hd(ss));
 676     }
 677     return appendOnto(cons,sels);
 678 }
 679
 680 static Name local addGHCSel(line,sel)
 681 Int  line;
 682 Pair sel;    /* (VarId,Type)        */
 683 {
 684     Text t      = textOf(fst(sel));
 685     Type type   = snd(sel);
 686
 687     Name n = findName(t);
 688     if (nonNull(n)) {
 689         ERRMSG(line) "Repeated definition for selector \"%s\"",
 690             textToStr(t)
 691         EEND;
 692     }
 693
 694     n              = newName(t,NIL);
 695     name(n).line   = line;
 696     name(n).number = SELNAME;
 697     name(n).arity  = 1;
 698     name(n).defn   = NIL;
 699
 700     /* prepare for finishGHCVar */
 701     name(n).type = type;
 702     ghcVarDecls = cons(n,ghcVarDecls);
 703
 704     return n;
 705 }
 706
 707 static Name local addGHCConstr(line,conNo,constr)
 708 Int    line;
 709 Int    conNo;
 710 Triple constr; { /* (ConId,[(Type,Text)],Type) */
 711     /* ToDo: add rank2 annotation and existential annotation
 712      * these affect how constr can be used.
 713      */
 714     Text con   = textOf(fst3(constr));
 715     Type type  = thd3(constr);
 716     Int  arity = arityFromType(type);
 717     Name n = findName(con);     /* Allocate constructor fun name   */
 718     if (isNull(n)) {
 719         n = newName(con,NIL);
 720     } else if (name(n).defn!=PREDEFINED) {
 721         ERRMSG(line) "Repeated definition for constructor \"%s\"",
 722             textToStr(con)
 723         EEND;
 724     }
 725     name(n).arity  = arity;     /* Save constructor fun details    */
 726     name(n).line   = line;
 727     name(n).number = cfunNo(conNo);
 728
 729     /* prepare for finishGHCCon */
 730     name(n).type   = type;
 731     ghcConstrDecls = cons(n,ghcConstrDecls);
 732
 733     return n;
 734 }
 735
 736 static Void local finishGHCConstr(Name n)
 737 {
 738     Int  line = name(n).line;
 739     Type ty   = name(n).type;
 740     setCurrModule(name(n).mod);
 741 #   ifdef DEBUG_IFACE
 742     printf ( "\nbegin finishGHCConstr %s\n", textToStr(name(n).text));
 743 #   endif
 744     name(n).type = conidcellsToTycons(line,ty);
 745 #   ifdef DEBUG_IFACE
 746     printf ( "end   finishGHCConstr %s\n", textToStr(name(n).text));
 747 #   endif
 748 }
 749
 750
 751 Void addGHCNewType(line,ctx0,tycon,tvs,constr)
 752 Int  line;
 753 List ctx0;      /* [(QConId,VarId)]      */
 754 Cell tycon;     /* ConId | QualConId     */
 755 List tvs;       /* [(VarId,Kind)]        */
 756 Cell constr; {  /* (ConId,Type)          */
 757     /* ToDo: worry about being given a decl for (->) ?
 758      * and worry about qualidents for ()
 759      */
 760     List tmp;
 761     Type resTy;
 762     Text t = textOf(tycon);
 763     if (nonNull(findTycon(t))) {
 764         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
 765                      textToStr(t)
 766         EEND;
 767     } else {
 768         Tycon tc        = newTycon(t);
 769         tycon(tc).line  = line;
 770         tycon(tc).arity = length(tvs);
 771         tycon(tc).what  = NEWTYPE;
 772         tycon(tc).kind  = tvsToKind(tvs);
 773         /* can't really do this until I've read in all synonyms */
 774
 775         assert(nonNull(constr));
 776         if (isNull(constr)) {
 777             tycon(tc).defn = NIL;
 778         } else {
 779             /* constr :: (ConId,Type) */
 780             Text con   = textOf(fst(constr));
 781             Type type  = snd(constr);
 782             Name n = findName(con);     /* Allocate constructor fun name   */
 783             if (isNull(n)) {
 784                 n = newName(con,NIL);
 785             } else if (name(n).defn!=PREDEFINED) {
 786                 ERRMSG(line) "Repeated definition for constructor \"%s\"",
 787                     textToStr(con)
 788                 EEND;
 789             }
 790             name(n).arity  = 1;         /* Save constructor fun details    */
 791             name(n).line   = line;
 792             name(n).number = cfunNo(0);
 793             name(n).defn   = nameId;
 794             tycon(tc).defn = singleton(n);
 795
 796             /* prepare for finishGHCCon */
 797             /* ToDo: we use finishGHCCon instead of finishGHCVar in case
 798              * there's any existential quantification in the newtype -
 799              * but I don't think that's allowed in newtype constrs.
 800              * Still, no harm done by doing it this way...
 801              */
 802
 803              /* make resTy the result type of the constr, T v1 ... vn */
 804             resTy = tycon;
 805             for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
 806                resTy = ap(resTy,fst(hd(tmp)));
 807             type = fn(type,resTy);
 808             if (nonNull(ctx0))
 809                type = ap(QUAL,pair(ctx0,type));
 810
 811             type = tvsToOffsets(line,type,tvs);
 812
 813             name(n).type   = type;
 814             ghcConstrDecls = cons(n,ghcConstrDecls);
 815         }
 816     }
 817 }
 818
 819 Void addGHCClass(line,ctxt,tc_name,tv,mems0)
 820 Int  line;
 821 List ctxt;       /* [(QConId, VarId)]     */
 822 Cell tc_name;    /* ConId                 */
 823 Text tv;         /* VarId                 */
 824 List mems0; {    /* [(VarId, Type)]       */
 825     List mems;   /* [(VarId, Type)]       */
 826     List tvsInT; /* [VarId] and then [(VarId,Kind)] */
 827     List tvs;    /* [(VarId,Kind)]        */
 828     Text ct     = textOf(tc_name);
 829     Pair newCtx = pair(tc_name, tv);
 830 #   ifdef DEBUG_IFACE
 831     printf ( "\nbegin addGHCclass %s\n", textToStr(ct) );
 832 #   endif
 833     if (nonNull(findClass(ct))) {
 834         ERRMSG(line) "Repeated definition of class \"%s\"",
 835                      textToStr(ct)
 836         EEND;
 837     } else if (nonNull(findTycon(ct))) {
 838         ERRMSG(line) "\"%s\" used as both class and type constructor",
 839                      textToStr(ct)
 840         EEND;
 841     } else {
 842         Class nw              = newClass(ct);
 843         cclass(nw).text       = ct;
 844         cclass(nw).line       = line;
 845         cclass(nw).arity      = 1;
 846         cclass(nw).head       = ap(nw,mkOffset(0));
 847         cclass(nw).kinds      = singleton(STAR); /* absolutely no idea at all */
 848         cclass(nw).instances  = NIL;             /* what the kind should be   */
 849         cclass(nw).numSupers  = length(ctxt);
 850
 851         /* Kludge to map the single tyvar in the context to Offset 0.
 852            Need to do something better for multiparam type classes.
 853         */
 854         cclass(nw).supers     = tvsToOffsets(line,ctxt,
 855                                              singleton(pair(tv,STAR)));
 856
 857         for (mems=mems0; nonNull(mems); mems=tl(mems)) {
 858            Pair mem  = hd(mems);
 859            Type memT = snd(mem);
 860            Text mnt  = textOf(fst(mem));
 861            Name mn;
 862
 863            /* Stick the new context on the member type */
 864            if (whatIs(memT)==POLYTYPE) internal("addGHCClass");
 865            if (whatIs(memT)==QUAL) {
 866               memT = pair(QUAL,
 867                           pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
 868            } else {
 869               memT = pair(QUAL,
 870                           pair(singleton(newCtx),memT));
 871            }
 872
 873            /* Cook up a kind for the type. */
 874            tvsInT = nubList(ifTyvarsIn(memT));
 875
 876            /* ToDo: maximally bogus */
 877            for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs))
 878               hd(tvs) = pair(hd(tvs),STAR);
 879
 880            memT = mkPolyType(tvsToKind(tvsInT),memT);
 881            memT = tvsToOffsets(line,memT,tvsInT);
 882
 883            /* Park the type back on the member */
 884            snd(mem) = memT;
 885
 886            /* Bind code to the member */
 887            mn = findName(mnt);
 888            if (nonNull(mn)) {
 889               ERRMSG(line)
 890                  "Repeated definition for class method \"%s\"",
 891                  textToStr(mnt)
 892               EEND;
 893            }
 894            mn = newName(mnt,NIL);
 895         }
 896
 897         cclass(nw).members    = mems0;
 898         cclass(nw).numMembers = length(mems0);
 899         ghcClassDecls = cons(nw,ghcClassDecls);
 900
 901         /* ToDo:
 902          * cclass(nw).dsels    = ?;
 903          * cclass(nw).dbuild   = ?;
 904          * cclass(nm).dcon     = ?;
 905          * cclass(nm).defaults = ?;
 906          */
 907     }
 908 #   ifdef DEBUG_IFACE
 909     printf ( "end   addGHCclass %s\n", textToStr(ct) );
 910 #   endif
 911 }
 912
 913 static Void  local finishGHCClass(Class nw)
 914 {
 915     List mems;
 916     Int line = cclass(nw).line;
 917     Int ctr  = - length(cclass(nw).members);
 918
 919 #   ifdef DEBUG_IFACE
 920     printf ( "\nbegin finishGHCclass %s\n", textToStr(cclass(nw).text) );
 921 #   endif
 922
 923     setCurrModule(cclass(nw).mod);
 924
 925     cclass(nw).level      = 0;  /* ToDo: 1 + max (map level supers) */
 926     cclass(nw).head       = conidcellsToTycons(line,cclass(nw).head);
 927     cclass(nw).supers     = conidcellsToTycons(line,cclass(nw).supers);
 928     cclass(nw).members    = conidcellsToTycons(line,cclass(nw).members);
 929
 930     for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
 931        Pair mem = hd(mems); /* (VarId, Type) */
 932        Text txt = textOf(fst(mem));
 933        Type ty  = snd(mem);
 934        Name n   = findName(txt);
 935        assert(nonNull(n));
 936        name(n).line   = cclass(nw).line;
 937        name(n).type   = ty;
 938        name(n).number = ctr++;
 939        hd(mems) = n;
 940     }
 941 #   ifdef DEBUG_IFACE
 942     printf ( "end   finishGHCclass %s\n", textToStr(cclass(nw).text) );
 943 #   endif
 944 }
 945
 946 Void addGHCInstance (line,ctxt0,cls,var)
 947 Int  line;
 948 List ctxt0;  /* [(QConId, Type)] */
 949 Pair cls;    /* (ConId, [Type])  */
 950 Text var; {  /* Text */
 951     List tmp, tvs, ks;
 952     Inst in = newInst();
 953 #   ifdef DEBUG_IFACE
 954     printf ( "\nbegin addGHCInstance\n" );
 955 #   endif
 956
 957     /* Make tvs into a list of tyvars with bogus kinds. */
 958     tvs = nubList(ifTyvarsIn(snd(cls)));
 959     ks = NIL;
 960     for (tmp = tvs; nonNull(tmp); tmp=tl(tmp)) {
 961        hd(tmp) = pair(hd(tmp),STAR);
 962        ks = cons(STAR,ks);
 963     }
 964
 965     inst(in).line         = line;
 966     inst(in).implements   = NIL;
 967     inst(in).kinds        = ks;
 968     inst(in).specifics    = tvsToOffsets(line,ctxt0,tvs);
 969     inst(in).numSpecifics = length(ctxt0);
 970     inst(in).head         = tvsToOffsets(line,cls,tvs);
 971 #if 0
 972 Is this still needed?
 973     {
 974         Name b         = newName(inventText(),NIL);
 975         name(b).line   = line;
 976         name(b).arity  = length(ctxt); /* unused? */
 977         name(b).number = DFUNNAME;
 978         inst(in).builder = b;
 979         bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
 980     }
 981 #endif
 982     ghcInstanceDecls = cons(in, ghcInstanceDecls);
 983 #   ifdef DEBUG_IFACE
 984     printf ( "end   addGHCInstance\n" );
 985 #   endif
 986 }
 987
 988 static Void  local finishGHCInstance(Inst in)
 989 {
 990     Int  line   = inst(in).line;
 991     Cell cl     = fst(inst(in).head);
 992     Class c;
 993 #   ifdef DEBUG_IFACE
 994     printf ( "\nbegin finishGHCInstance\n" );
 995 #   endif
 996
 997     setCurrModule(inst(in).mod);
 998     c = findClass(textOf(cl));
 999     if (isNull(c)) {
1000         ERRMSG(line) "Unknown class \"%s\" in instance",
1001                      textToStr(textOf(cl))
1002         EEND;
1003     }
1004     inst(in).head         = conidcellsToTycons(line,inst(in).head);
1005     inst(in).specifics    = conidcellsToTycons(line,inst(in).specifics);
1006     cclass(c).instances   = cons(in,cclass(c).instances);
1007 #   ifdef DEBUG_IFACE
1008     printf ( "end   finishGHCInstance\n" );
1009 #   endif
1010 }
1011
1012 /* --------------------------------------------------------------------------
1013  * Helper fns
1014  * ------------------------------------------------------------------------*/
1015
1016 /* This is called from the addGHC* functions.  It traverses a structure
1017    and converts varidcells, ie, type variables parsed by the interface
1018    parser, into Offsets, which is how Hugs wants to see them internally.
1019    The Offset for a type variable is determined by its place in the list
1020    passed as the second arg; the associated kinds are irrelevant.
1021 */
1022 static Type local tvsToOffsets(line,type,ktyvars)
1023 Int  line;
1024 Type type;
1025 List ktyvars; { /* [(VarId|Text,Kind)] */
1026    switch (whatIs(type)) {
1027       case NIL:
1028       case TUPLE:
1029       case QUALIDENT:
1030       case CONIDCELL:
1031       case TYCON:
1032          return type;
1033       case AP:
1034          return ap( tvsToOffsets(line,fun(type),ktyvars),
1035                     tvsToOffsets(line,arg(type),ktyvars) );
1036       case POLYTYPE:
1037          return mkPolyType (
1038                    polySigOf(type),
1039                    tvsToOffsets(line,monotypeOf(type),ktyvars)
1040                 );
1041          break;
1042       case QUAL:
1043          return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
1044                                tvsToOffsets(line,snd(snd(type)),ktyvars)));
1045       case DICTAP: /* bogus ?? */
1046          return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
1047       case VARIDCELL: /* Ha! some real work to do! */
1048        { Int i = 0;
1049          Text tv = textOf(type);
1050          for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
1051             Cell varid = fst(hd(ktyvars));
1052             Text tt = isVar(varid) ? textOf(varid) : varid;
1053             if (tv == tt) return mkOffset(i);
1054          }
1055          ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
1056          EEND;
1057          break;
1058        }
1059       default:
1060          fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
1061          print(type,20);
1062          fprintf(stderr,"\n");
1063          assert(0);
1064    }
1065    assert(0);
1066    return NIL; /* NOTREACHED */
1067 }
1068
1069
1070 /* This is called from the finishGHC* functions.  It traverses a structure
1071    and converts conidcells, ie, type constructors parsed by the interface
1072    parser, into Tycons (or Classes), which is how Hugs wants to see them
1073    internally.  Calls to this fn have to be deferred to the second phase
1074    of interface loading (finishGHC* rather than addGHC*) so that all relevant
1075    Tycons or Classes have been loaded into the symbol tables and can be
1076    looked up.
1077 */
1078 static Text kludgeGHCPrelText ( Text m )
1079 {
1080    if (strncmp(textToStr(m), "Prel", 4)==0)
1081       return textPrelude; else return m;
1082 }
1083
1084 static Type local conidcellsToTycons(line,type)
1085 Int  line;
1086 Type type; {
1087    switch (whatIs(type)) {
1088       case NIL:
1089       case OFFSET:
1090       case TYCON:
1091       case CLASS:
1092       case VARIDCELL:
1093          return type;
1094       case QUALIDENT:
1095        { List t;
1096          Text m     = kludgeGHCPrelText(qmodOf(type));
1097          Text v     = qtextOf(type);
1098          Module mod = findModule(m);
1099          //printf ( "lookup qualident " ); print(type,100); printf("\n");
1100          if (isNull(mod)) {
1101             ERRMSG(line)
1102                "Undefined module in qualified name \"%s\"",
1103                identToStr(type)
1104             EEND;
1105             return NIL;
1106          }
1107          for (t=module(mod).tycons; nonNull(t); t=tl(t))
1108             if (v == tycon(hd(t)).text) return hd(t);
1109          for (t=module(mod).classes; nonNull(t); t=tl(t))
1110             if (v == cclass(hd(t)).text) return hd(t);
1111          ERRMSG(line)
1112               "Undefined qualified class or type \"%s\"",
1113               identToStr(type)
1114          EEND;
1115          return NIL;
1116        }
1117       case CONIDCELL:
1118        { Tycon tc;
1119          Class cl;
1120          tc = findQualTycon(type);
1121          if (nonNull(tc)) return tc;
1122          cl = findQualClass(type);
1123          if (nonNull(cl)) return cl;
1124          ERRMSG(line)
1125              "Undefined class or type constructor \"%s\"",
1126              identToStr(type)
1127          EEND;
1128          return NIL;
1129        }
1130       case AP:
1131          return ap( conidcellsToTycons(line,fun(type)),
1132                     conidcellsToTycons(line,arg(type)) );
1133       case POLYTYPE:
1134          return mkPolyType (
1135                    polySigOf(type),
1136                    conidcellsToTycons(line,monotypeOf(type))
1137                 );
1138          break;
1139       case QUAL:
1140          return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
1141                                conidcellsToTycons(line,snd(snd(type)))));
1142       case DICTAP: /* bogus?? */
1143          return ap(DICTAP, conidcellsToTycons(line, snd(type)));
1144       default:
1145          fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
1146                  whatIs(type));
1147          print(type,20);
1148          fprintf(stderr,"\n");
1149          assert(0);
1150    }
1151    assert(0);
1152    return NIL; /* NOTREACHED */
1153 }
1154
1155
1156 /* --------------------------------------------------------------------------
1157  * Utilities
1158  *
1159  * None of these do lookups or require that lookups have been resolved
1160  * so they can be performed while reading interfaces.
1161  * ------------------------------------------------------------------------*/
1162
1163 static Kinds local tvsToKind(tvs)
1164 List tvs; { /* [(VarId,Kind)] */
1165     List  rs;
1166     Kinds r  = STAR;
1167     for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
1168         r = ap(snd(hd(rs)),r);
1169     }
1170     return r;
1171 }
1172
1173
1174 static Int local arityInclDictParams ( Type type )
1175 {
1176    Int arity = 0;
1177    if (isPolyType(type)) type = monotypeOf(type);
1178
1179    if (whatIs(type) == QUAL)
1180    {
1181       arity += length ( fst(snd(type)) );
1182       type = snd(snd(type));
1183    }
1184    while (isAp(type) && getHead(type)==typeArrow) {
1185       arity++;
1186       type = arg(type);
1187    }
1188    return arity;
1189 }
1190
1191 /* arity of a constructor with this type */
1192 static Int local arityFromType(type)
1193 Type type; {
1194     Int arity = 0;
1195     if (isPolyType(type)) {
1196         type = monotypeOf(type);
1197     }
1198     if (whatIs(type) == QUAL) {
1199         type = snd(snd(type));
1200     }
1201     if (whatIs(type) == EXIST) {
1202         type = snd(snd(type));
1203     }
1204     if (whatIs(type)==RANK2) {
1205         type = snd(snd(type));
1206     }
1207     while (isAp(type) && getHead(type)==typeArrow) {
1208         arity++;
1209         type = arg(type);
1210     }
1211     return arity;
1212 }
1213
1214
1215 static List local ifTyvarsIn(type)
1216 Type type; {
1217     List vs = typeVarsIn(type,NIL,NIL,NIL);
1218     List vs2 = vs;
1219     for (; nonNull(vs2); vs2=tl(vs2)) {
1220        Cell v = hd(vs2);
1221        if (whatIs(v)==VARIDCELL || whatIs(v)==VAROPCELL) {
1222           hd(vs2) = textOf(hd(vs2));
1223        } else {
1224           internal("ifTyvarsIn");
1225        }
1226     }
1227     return vs;
1228 }
1229
1230
1231 /* --------------------------------------------------------------------------
1232  * ELF specifics
1233  * ------------------------------------------------------------------------*/
1234
1235 #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
1236
1237 #include <elf.h>
1238
1239 static char* local findElfSection ( void* objImage, Elf32_Word sh_type )
1240 {
1241    Int i;
1242    char* ehdrC = (char*)objImage;
1243    Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
1244    Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1245    char* ptr = NULL;
1246    for (i = 0; i < ehdr->e_shnum; i++) {
1247       if (shdr[i].sh_type == sh_type &&
1248           i !=  ehdr->e_shstrndx) {
1249          ptr = ehdrC + shdr[i].sh_offset;
1250          break;
1251       }
1252    }
1253    return ptr;
1254 }
1255
1256
1257 static Void local resolveReferencesInObjectModule_elf ( Module m,
1258                                                         Bool   verb )
1259 {
1260    char symbol[1000]; // ToDo
1261    int i, j;
1262    Elf32_Sym*  stab = NULL;
1263    char* strtab;
1264    char* ehdrC = (char*)(module(m).oImage);
1265    Elf32_Ehdr* ehdr = (Elf32_Ehdr*) ehdrC;
1266    Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1267    Elf32_Word* targ;
1268    // first find "the" symbol table
1269    // why is this commented out???
1270    stab = findElfSection ( ehdrC, SHT_SYMTAB );
1271
1272    // also go find the string table
1273    strtab = findElfSection ( ehdrC, SHT_STRTAB );
1274
1275    if (!stab || !strtab)
1276       internal("resolveReferencesInObjectModule_elf");
1277
1278    for (i = 0; i < ehdr->e_shnum; i++) {
1279       if (shdr[i].sh_type == SHT_REL ) {
1280          Elf32_Rel*  rtab = (Elf32_Rel*) (ehdrC + shdr[i].sh_offset);
1281          Int         nent = shdr[i].sh_size / sizeof(Elf32_Rel);
1282          Int target_shndx = shdr[i].sh_info;
1283          Int symtab_shndx = shdr[i].sh_link;
1284          stab  = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
1285          targ  = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
1286          if (verb)
1287          fprintf ( stderr,
1288                   "relocations for section %d using symtab %d\n",
1289                   target_shndx, symtab_shndx );
1290          for (j = 0; j < nent; j++) {
1291             Elf32_Addr offset = rtab[j].r_offset;
1292             Elf32_Word info   = rtab[j].r_info;
1293
1294             Elf32_Addr  P = ((Elf32_Addr)targ) + offset;
1295             Elf32_Word* pP = (Elf32_Word*)P;
1296             Elf32_Addr  A = *pP;
1297             Elf32_Addr  S;
1298
1299             if (verb) fprintf ( stderr, "Rel entry %3d is raw(%6p %6p)   ",
1300                                 j, (void*)offset, (void*)info );
1301             if (!info) {
1302                if (verb) fprintf ( stderr, " ZERO\n" );
1303                S = 0;
1304             } else {
1305                if (stab[ ELF32_R_SYM(info)].st_name == 0) {
1306                   if (verb) fprintf ( stderr, "(noname)  ");
1307                   /* nameless (local) symbol */
1308                   S = (Elf32_Addr)(ehdrC
1309                                    + shdr[stab[ELF32_R_SYM(info)].st_shndx ].sh_offset
1310                                    + stab[ELF32_R_SYM(info)].st_value
1311                                   );
1312                   strcpy ( symbol, "(noname)");
1313                } else {
1314                   strcpy ( symbol, strtab+stab[ ELF32_R_SYM(info)].st_name );
1315                   if (verb) fprintf ( stderr, "`%s'  ", symbol );
1316                   S = (Elf32_Addr)lookupObjName ( symbol );
1317                }
1318                if (verb) fprintf ( stderr, "resolves to %p\n", (void*)S );
1319                if (!S) {
1320                   fprintf ( stderr, "link failure for `%s'\n",
1321                                     strtab+stab[ ELF32_R_SYM(info)].st_name );
1322                   assert(0);
1323                }
1324             }
1325             //fprintf ( stderr, "Reloc: P = %p   S = %p   A = %p\n\n",
1326             //      (void*)P, (void*)S, (void*)A );
1327             switch (ELF32_R_TYPE(info)) {
1328                case R_386_32:   *pP = S + A;     break;
1329                case R_386_PC32: *pP = S + A - P; break;
1330                default: fprintf(stderr,
1331                                 "unhandled ELF relocation type %d\n",
1332                                 ELF32_R_TYPE(info));
1333                         assert(0);
1334             }
1335
1336          }
1337       }
1338       else
1339       if (shdr[i].sh_type == SHT_RELA) {
1340          fprintf ( stderr, "RelA style reloc table -- not yet done" );
1341          assert(0);
1342       }
1343    }
1344 }
1345
1346
1347 static Bool local validateOImage_elf ( void*  imgV,
1348                                        Int    size,
1349                                        Bool   verb )
1350 {
1351    Elf32_Shdr* shdr;
1352    Elf32_Sym*  stab;
1353    int i, j, nent, nstrtab, nsymtabs;
1354    char* sh_strtab;
1355    char* strtab;
1356
1357    char* ehdrC = (char*)imgV;
1358    Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
1359
1360    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
1361        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
1362        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
1363        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
1364       if (verb) fprintf ( stderr, "Not an ELF header\n" );
1365       return FALSE;
1366    }
1367    if (verb) fprintf ( stderr, "Is an ELF header\n" );
1368
1369    if (ehdr->e_ident[EI_CLASS] != ELFCLASS32) {
1370       if (verb) fprintf ( stderr, "Not 32 bit ELF\n" );
1371       return FALSE;
1372    }
1373    if (verb) fprintf ( stderr, "Is 32 bit ELF\n" );
1374
1375    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
1376       if (verb) fprintf ( stderr, "Is little-endian\n" );
1377    } else
1378    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
1379       if (verb) fprintf ( stderr, "Is big-endian\n" );
1380    } else {
1381       if (verb) fprintf ( stderr, "Unknown endiannness\n" );
1382       return FALSE;
1383    }
1384
1385    if (ehdr->e_type != ET_REL) {
1386       if (verb) fprintf ( stderr, "Not a relocatable object (.o) file\n" );
1387       return FALSE;
1388    }
1389    if (verb) fprintf ( stderr, "Is a relocatable object (.o) file\n" );
1390
1391    if (verb) fprintf ( stderr, "Architecture is " );
1392    switch (ehdr->e_machine) {
1393       case EM_386:   if (verb) fprintf ( stderr, "x86\n" ); break;
1394       case EM_SPARC: if (verb) fprintf ( stderr, "sparc\n" ); break;
1395       default:       if (verb) fprintf ( stderr, "unknown\n" ); return FALSE;
1396    }
1397
1398    if (verb)
1399    fprintf ( stderr,
1400              "\nSection header table: start %d, n_entries %d, ent_size %d\n",
1401              ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  );
1402
1403    assert (ehdr->e_shentsize == sizeof(Elf32_Shdr));
1404
1405    shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1406
1407    if (ehdr->e_shstrndx == SHN_UNDEF) {
1408       if (verb) fprintf ( stderr, "No section header string table\n" );
1409       sh_strtab = NULL;
1410       return FALSE;
1411    } else {
1412       if (verb) fprintf (  stderr,"Section header string table is section %d\n",
1413                           ehdr->e_shstrndx);
1414       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
1415    }
1416
1417    for (i = 0; i < ehdr->e_shnum; i++) {
1418       if (verb) fprintf ( stderr, "%2d:  ", i );
1419       if (verb) fprintf ( stderr, "type=%2d  ", shdr[i].sh_type );
1420       if (verb) fprintf ( stderr, "size=%4d  ", shdr[i].sh_size );
1421       if (verb) fprintf ( stderr, "offs=%4d  ", shdr[i].sh_offset );
1422       if (verb) fprintf ( stderr, "  (%p .. %p)  ",
1423                ehdrC + shdr[i].sh_offset,
1424                ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
1425
1426       if (shdr[i].sh_type == SHT_REL  && verb) fprintf ( stderr, "Rel  " ); else
1427       if (shdr[i].sh_type == SHT_RELA && verb) fprintf ( stderr, "RelA " ); else
1428       if (verb)                                fprintf ( stderr, "     " );
1429       if (sh_strtab && verb)
1430          fprintf ( stderr, "sname=%s", sh_strtab + shdr[i].sh_name );
1431       if (verb) fprintf ( stderr, "\n" );
1432    }
1433
1434    if (verb) fprintf ( stderr, "\n\nString tables\n" );
1435    strtab = NULL;
1436    nstrtab = 0;
1437    for (i = 0; i < ehdr->e_shnum; i++) {
1438       if (shdr[i].sh_type == SHT_STRTAB &&
1439           i !=  ehdr->e_shstrndx) {
1440          if (verb)
1441             fprintf ( stderr, "   section %d is a normal string table\n", i );
1442          strtab = ehdrC + shdr[i].sh_offset;
1443          nstrtab++;
1444       }
1445    }
1446    if (nstrtab != 1) {
1447       if (verb) fprintf ( stderr, "WARNING: no string tables, or too many\n" );
1448       return FALSE;
1449    }
1450
1451    nsymtabs = 0;
1452    if (verb) fprintf ( stderr, "\n\nSymbol tables\n" );
1453    for (i = 0; i < ehdr->e_shnum; i++) {
1454       if (shdr[i].sh_type != SHT_SYMTAB) continue;
1455       if (verb) fprintf ( stderr, "section %d is a symbol table\n", i );
1456       nsymtabs++;
1457       stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
1458       nent = shdr[i].sh_size / sizeof(Elf32_Sym);
1459       if (verb) fprintf ( stderr, "   number of entries is apparently %d (%d rem)\n",
1460                nent,
1461                shdr[i].sh_size % sizeof(Elf32_Sym)
1462              );
1463       if (0 != shdr[i].sh_size % sizeof(Elf32_Sym)) {
1464          if (verb) fprintf ( stderr, "non-integral number of symbol table entries\n");
1465          return FALSE;
1466       }
1467       for (j = 0; j < nent; j++) {
1468          if (verb) fprintf ( stderr, "   %2d  ", j );
1469          if (verb) fprintf ( stderr, "  sec=%-5d  size=%-3d  val=%-5p  ",
1470                              (int)stab[j].st_shndx,
1471                              (int)stab[j].st_size,
1472                              (char*)stab[j].st_value );
1473
1474          if (verb) fprintf ( stderr, "type=" );
1475          switch (ELF32_ST_TYPE(stab[j].st_info)) {
1476             case STT_NOTYPE:  if (verb) fprintf ( stderr, "notype " ); break;
1477             case STT_OBJECT:  if (verb) fprintf ( stderr, "object " ); break;
1478             case STT_FUNC  :  if (verb) fprintf ( stderr, "func   " ); break;
1479             case STT_SECTION: if (verb) fprintf ( stderr, "section" ); break;
1480             case STT_FILE:    if (verb) fprintf ( stderr, "file   " ); break;
1481             default:          if (verb) fprintf ( stderr, "?      " ); break;
1482          }
1483          if (verb) fprintf ( stderr, "  " );
1484
1485          if (verb) fprintf ( stderr, "bind=" );
1486          switch (ELF32_ST_BIND(stab[j].st_info)) {
1487             case STB_LOCAL :  if (verb) fprintf ( stderr, "local " ); break;
1488             case STB_GLOBAL:  if (verb) fprintf ( stderr, "global" ); break;
1489             case STB_WEAK  :  if (verb) fprintf ( stderr, "weak  " ); break;
1490             default:          if (verb) fprintf ( stderr, "?     " ); break;
1491          }
1492          if (verb) fprintf ( stderr, "  " );
1493
1494          if (verb) fprintf ( stderr, "name=%s\n", strtab + stab[j].st_name );
1495       }
1496    }
1497
1498    if (nsymtabs == 0) {
1499       if (verb) fprintf ( stderr, "Didn't find any symbol tables\n" );
1500       return FALSE;
1501    }
1502
1503    return TRUE;
1504 }
1505
1506
1507 static void readSyms_elf ( Module m, Bool verb )
1508 {
1509    int i, j, k, nent;
1510    Elf32_Sym* stab;
1511
1512    char*       ehdrC      = (char*)(module(m).oImage);
1513    Elf32_Ehdr* ehdr       = (Elf32_Ehdr*)ehdrC;
1514    char*       strtab     = findElfSection ( ehdrC, SHT_STRTAB );
1515    Elf32_Shdr* shdr       = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1516    char*       sh_strtab  = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
1517
1518    if (!strtab) internal("readSyms_elf");
1519
1520    k = 0;
1521    for (i = 0; i < ehdr->e_shnum; i++) {
1522
1523       /* make a HugsDLSection entry for relevant sections */
1524       DLSect kind = HUGS_DL_SECTION_OTHER;
1525       if (0==strcmp(".data",sh_strtab+shdr[i].sh_name) ||
1526           0==strcmp(".data1",sh_strtab+shdr[i].sh_name))
1527          kind = HUGS_DL_SECTION_RWDATA;
1528       if (0==strcmp(".text",sh_strtab+shdr[i].sh_name) ||
1529           0==strcmp(".rodata",sh_strtab+shdr[i].sh_name) ||
1530           0==strcmp(".rodata1",sh_strtab+shdr[i].sh_name))
1531          kind = HUGS_DL_SECTION_CODE_OR_RODATA;
1532       if (kind != HUGS_DL_SECTION_OTHER)
1533          addDLSect (
1534             m,
1535             ehdrC + shdr[i].sh_offset,
1536             ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1,
1537             kind
1538          );
1539
1540       if (shdr[i].sh_type != SHT_SYMTAB) continue;
1541
1542       /* copy stuff into this module's object symbol table */
1543       stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
1544       nent = shdr[i].sh_size / sizeof(Elf32_Sym);
1545       for (j = 0; j < nent; j++) {
1546          if ( ( ELF32_ST_BIND(stab[j].st_info)==STB_GLOBAL ||
1547                 ELF32_ST_BIND(stab[j].st_info)==STB_LOCAL
1548               )
1549               &&
1550               ( ELF32_ST_TYPE(stab[j].st_info)==STT_FUNC ||
1551                 ELF32_ST_TYPE(stab[j].st_info)==STT_OBJECT )
1552               ) {
1553             char* nm = strtab + stab[j].st_name;
1554             char* ad = ehdrC
1555                        + shdr[ stab[j].st_shndx ].sh_offset
1556                        + stab[j].st_value;
1557             assert(nm);
1558             assert(ad);
1559             if (verb)
1560                fprintf(stderr, "addOTabName: %10p  %s %s\n",
1561                        ad, textToStr(module(m).text), nm );
1562             addOTabName ( m, nm, ad );
1563          }
1564       }
1565
1566    }
1567 }
1568
1569 #endif /* defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) */
1570
1571
1572 /* --------------------------------------------------------------------------
1573  * Arch-independent interface to the runtime linker
1574  * ------------------------------------------------------------------------*/
1575
1576 static Bool local validateOImage ( void* img, Int size, Bool verb )
1577 {
1578 #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
1579    return
1580       validateOImage_elf ( img, size, verb );
1581 #else
1582    internal("validateOImage: not implemented on this platform");
1583 #endif
1584 }
1585
1586
1587 static Void local resolveReferencesInObjectModule ( Module m, Bool verb )
1588 {
1589 #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
1590    resolveReferencesInObjectModule_elf ( m, verb );
1591 #else
1592    internal("resolveReferencesInObjectModule: not implemented on this platform");
1593 #endif
1594 }
1595
1596
1597 static Void local readSyms ( Module m, Bool verb )
1598 {
1599 #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
1600    readSyms_elf ( m, verb );
1601 #else
1602    internal("readSyms: not implemented on this platform");
1603 #endif
1604 }
1605
1606
1607 /* --------------------------------------------------------------------------
1608  * General object symbol query stuff
1609  * ------------------------------------------------------------------------*/
1610
1611 /* entirely bogus claims about types of these symbols */
1612 extern int stg_gc_enter_1;
1613 extern int stg_chk_0;
1614 extern int stg_chk_1;
1615 extern int stg_update_PAP;
1616 extern int __ap_2_upd_info;
1617 extern int MainRegTable;
1618 extern int Upd_frame_info;
1619
1620 OSym rtsTab[]
1621    = {
1622        { "stg_gc_enter_1",    &stg_gc_enter_1  },
1623        { "stg_chk_0",         &stg_chk_0       },
1624        { "stg_chk_1",         &stg_chk_1       },
1625        { "stg_update_PAP",    &stg_update_PAP  },
1626        { "__ap_2_upd_info",   &__ap_2_upd_info },
1627        { "MainRegTable",      &MainRegTable    },
1628        { "Upd_frame_info",    &Upd_frame_info  },
1629        {0,0}
1630      };
1631
1632
1633 void* lookupObjName ( char* nm )
1634 {
1635    int    k;
1636    char*  pp;
1637    void*  a;
1638    Text   t;
1639    Module m;
1640    char   nm2[200];
1641
1642    nm2[199] = 0;
1643    strncpy(nm2,nm,200);
1644
1645    // first see if it's an RTS name
1646    for (k = 0; rtsTab[k].nm; k++)
1647       if (0==strcmp(nm2,rtsTab[k].nm))
1648          return rtsTab[k].ad;
1649
1650    // if not an RTS name, look in the
1651    // relevant module's object symbol table
1652    pp = strchr(nm2, '_');
1653    if (!pp) goto not_found;
1654    *pp = 0;
1655    t = unZcodeThenFindText(nm2);
1656    m = findModule(t);
1657    if (isNull(m)) goto not_found;
1658    a = lookupOTabName ( m, nm );
1659    if (a) return a;
1660
1661   not_found:
1662    fprintf ( stderr,
1663              "lookupObjName: can't resolve name `%s'\n",
1664              nm );
1665    return NULL;
1666 }
1667
1668
1669 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
1670 {
1671    return
1672       lookupDLSect(p) == HUGS_DL_SECTION_CODE_OR_RODATA;
1673 }
1674
1675
1676 int is_dynamically_loaded_rwdata_ptr ( char* p )
1677 {
1678    return
1679       lookupDLSect(p) == HUGS_DL_SECTION_RWDATA;
1680 }
1681
1682
1683 int is_not_dynamically_loaded_ptr ( char* p )
1684 {
1685    return
1686       lookupDLSect(p) == HUGS_DL_SECTION_OTHER;
1687 }
1688
1689
1690 /* --------------------------------------------------------------------------
1691  * Control:
1692  * ------------------------------------------------------------------------*/
1693
1694 Void interface(what)
1695 Int what; {
1696     switch (what) {
1697     case INSTALL:
1698     case RESET:
1699             ifImports           = NIL;
1700             ghcVarDecls         = NIL;
1701             ghcConstrDecls      = NIL;
1702             ghcSynonymDecls     = NIL;
1703             ghcClassDecls       = NIL;
1704             ghcInstanceDecls    = NIL;
1705             ghcExports          = NIL;
1706             ghcImports          = NIL;
1707             ghcModules          = NIL;
1708             break;
1709     case MARK:
1710             mark(ifImports);
1711             mark(ghcVarDecls);
1712             mark(ghcConstrDecls);
1713             mark(ghcSynonymDecls);
1714             mark(ghcClassDecls);
1715             mark(ghcInstanceDecls);
1716             mark(ghcImports);
1717             mark(ghcExports);
1718             mark(ghcModules);
1719             break;
1720     }
1721 }
1722
1723 /*-------------------------------------------------------------------------*/