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