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.5 $
  11  * $Date: 1999/07/06 15:24:38 $
  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); /* NOTREACHED */
1063 }
1064
1065
1066 /* This is called from the finishGHC* functions.  It traverses a structure
1067    and converts conidcells, ie, type constructors parsed by the interface
1068    parser, into Tycons (or Classes), which is how Hugs wants to see them
1069    internally.  Calls to this fn have to be deferred to the second phase
1070    of interface loading (finishGHC* rather than addGHC*) so that all relevant
1071    Tycons or Classes have been loaded into the symbol tables and can be
1072    looked up.
1073 */
1074 static Type local conidcellsToTycons(line,type)
1075 Int  line;
1076 Type type; {
1077    switch (whatIs(type)) {
1078       case NIL:
1079       case OFFSET:
1080       case TYCON:
1081       case CLASS:
1082       case VARIDCELL:
1083          return type;
1084       case QUALIDENT:
1085        { List t;
1086          Text m     = qmodOf(type);
1087          Text v     = qtextOf(type);
1088          Module mod = findModule(m);
1089 printf ( "lookup qualident " ); print(type,100); printf("\n");
1090          if (isNull(mod)) {
1091             ERRMSG(line)
1092                "Undefined module in qualified name \"%s\"",
1093                identToStr(type)
1094             EEND;
1095             return NIL;
1096          }
1097          for (t=module(mod).tycons; nonNull(t); t=tl(t))
1098             if (v == tycon(hd(t)).text) return hd(t);
1099          for (t=module(mod).classes; nonNull(t); t=tl(t))
1100             if (v == cclass(hd(t)).text) return hd(t);
1101          ERRMSG(line)
1102               "Undefined qualified class or type \"%s\"",
1103               identToStr(type)
1104          EEND;
1105          return NIL;
1106        }
1107       case CONIDCELL:
1108        { Tycon tc;
1109          Class cl;
1110          tc = findQualTycon(type);
1111          if (nonNull(tc)) return tc;
1112          cl = findQualClass(type);
1113          if (nonNull(cl)) return cl;
1114          ERRMSG(line)
1115              "Undefined class or type constructor \"%s\"",
1116              identToStr(type)
1117          EEND;
1118          return NIL;
1119        }
1120       case AP:
1121          return ap( conidcellsToTycons(line,fun(type)),
1122                     conidcellsToTycons(line,arg(type)) );
1123       case POLYTYPE:
1124          return mkPolyType (
1125                    polySigOf(type),
1126                    conidcellsToTycons(line,monotypeOf(type))
1127                 );
1128          break;
1129       case QUAL:
1130          return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
1131                                conidcellsToTycons(line,snd(snd(type)))));
1132       default:
1133          fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
1134                  whatIs(type));
1135          print(type,20);
1136          fprintf(stderr,"\n");
1137          assert(0);
1138    }
1139    assert(0); /* NOTREACHED */
1140 }
1141
1142
1143 /* --------------------------------------------------------------------------
1144  * Utilities
1145  *
1146  * None of these do lookups or require that lookups have been resolved
1147  * so they can be performed while reading interfaces.
1148  * ------------------------------------------------------------------------*/
1149
1150 static Kinds local tvsToKind(tvs)
1151 List tvs; { /* [(VarId,Kind)] */
1152     List  rs;
1153     Kinds r  = STAR;
1154     for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
1155         r = ap(snd(hd(rs)),r);
1156     }
1157     return r;
1158 }
1159
1160
1161 static Int local arityInclDictParams ( Type type )
1162 {
1163    Int arity = 0;
1164    if (isPolyType(type)) type = monotypeOf(type);
1165
1166    if (whatIs(type) == QUAL)
1167    {
1168       arity += length ( fst(snd(type)) );
1169       type = snd(snd(type));
1170    }
1171    while (isAp(type) && getHead(type)==typeArrow) {
1172       arity++;
1173       type = arg(type);
1174    }
1175    return arity;
1176 }
1177
1178 /* arity of a constructor with this type */
1179 static Int local arityFromType(type)
1180 Type type; {
1181     Int arity = 0;
1182     if (isPolyType(type)) {
1183         type = monotypeOf(type);
1184     }
1185     if (whatIs(type) == QUAL) {
1186         type = snd(snd(type));
1187     }
1188     if (whatIs(type) == EXIST) {
1189         type = snd(snd(type));
1190     }
1191     if (whatIs(type)==RANK2) {
1192         type = snd(snd(type));
1193     }
1194     while (isAp(type) && getHead(type)==typeArrow) {
1195         arity++;
1196         type = arg(type);
1197     }
1198     return arity;
1199 }
1200
1201
1202 static List local ifTyvarsIn(type)
1203 Type type; {
1204     List vs = typeVarsIn(type,NIL,NIL);
1205     List vs2 = vs;
1206     for (; nonNull(vs2); vs2=tl(vs2)) {
1207        Cell v = hd(vs2);
1208        if (whatIs(v)==VARIDCELL || whatIs(v)==VAROPCELL) {
1209           hd(vs2) = textOf(hd(vs2));
1210        } else {
1211           internal("ifTyvarsIn");
1212        }
1213     }
1214     return vs;
1215 }
1216
1217
1218 /* --------------------------------------------------------------------------
1219  * ELF specifics
1220  * ------------------------------------------------------------------------*/
1221
1222 #include <elf.h>
1223
1224 static char* local findElfSection ( void* objImage, Elf32_Word sh_type )
1225 {
1226    Int i;
1227    char* ehdrC = (char*)objImage;
1228    Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
1229    Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1230    char* ptr = NULL;
1231    for (i = 0; i < ehdr->e_shnum; i++) {
1232       if (shdr[i].sh_type == sh_type &&
1233           i !=  ehdr->e_shstrndx) {
1234          ptr = ehdrC + shdr[i].sh_offset;
1235          break;
1236       }
1237    }
1238    return ptr;
1239 }
1240
1241
1242 static Void local resolveReferencesInObjectModule_elf ( Module m,
1243                                                         Bool   verb )
1244 {
1245    char symbol[1000]; // ToDo
1246    int i, j;
1247    Elf32_Sym*  stab;
1248    char* strtab;
1249    char* ehdrC = (char*)(module(m).oImage);
1250    Elf32_Ehdr* ehdr = (Elf32_Ehdr*) ehdrC;
1251    Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1252    Elf32_Word* targ;
1253    // first find "the" symbol table
1254    //stab = findElfSection ( objImage, SHT_SYMTAB );
1255
1256    // also go find the string table
1257    strtab = findElfSection ( ehdrC, SHT_STRTAB );
1258
1259    if (!stab || !strtab)
1260       internal("resolveReferencesInObjectModule_elf");
1261
1262    for (i = 0; i < ehdr->e_shnum; i++) {
1263       if (shdr[i].sh_type == SHT_REL ) {
1264          Elf32_Rel*  rtab = (Elf32_Rel*) (ehdrC + shdr[i].sh_offset);
1265          Int         nent = shdr[i].sh_size / sizeof(Elf32_Rel);
1266          Int target_shndx = shdr[i].sh_info;
1267          Int symtab_shndx = shdr[i].sh_link;
1268          stab  = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
1269          targ  = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
1270          if (verb)
1271          fprintf ( stderr,
1272                   "relocations for section %d using symtab %d\n",
1273                   target_shndx, symtab_shndx );
1274          for (j = 0; j < nent; j++) {
1275             Elf32_Addr offset = rtab[j].r_offset;
1276             Elf32_Word info   = rtab[j].r_info;
1277
1278             Elf32_Addr  P = ((Elf32_Addr)targ) + offset;
1279             Elf32_Word* pP = (Elf32_Word*)P;
1280             Elf32_Addr  A = *pP;
1281             Elf32_Addr  S;
1282
1283             if (verb) fprintf ( stderr, "Rel entry %3d is raw(%6p %6p)   ",
1284                                 j, (void*)offset, (void*)info );
1285             if (!info) {
1286                if (verb) fprintf ( stderr, " ZERO\n" );
1287                S = 0;
1288             } else {
1289                if (stab[ ELF32_R_SYM(info)].st_name == 0) {
1290                   if (verb) fprintf ( stderr, "(noname)  ");
1291                   /* nameless (local) symbol */
1292                   S = (Elf32_Addr)(ehdrC
1293                                    + shdr[stab[ELF32_R_SYM(info)].st_shndx ].sh_offset
1294                                    + stab[ELF32_R_SYM(info)].st_value
1295                                   );
1296                   strcpy ( symbol, "(noname)");
1297                } else {
1298                   strcpy ( symbol, strtab+stab[ ELF32_R_SYM(info)].st_name );
1299                   if (verb) fprintf ( stderr, "`%s'  ", symbol );
1300                   S = (Elf32_Addr)lookupObjName ( symbol );
1301                }
1302                if (verb) fprintf ( stderr, "resolves to %p\n", (void*)S );
1303                if (!S) {
1304                   fprintf ( stderr, "link failure for `%s'\n",
1305                                     strtab+stab[ ELF32_R_SYM(info)].st_name );
1306                   assert(0);
1307                }
1308             }
1309             //fprintf ( stderr, "Reloc: P = %p   S = %p   A = %p\n\n",
1310             //      (void*)P, (void*)S, (void*)A );
1311             switch (ELF32_R_TYPE(info)) {
1312                case R_386_32:   *pP = S + A;     break;
1313                case R_386_PC32: *pP = S + A - P; break;
1314                default: fprintf(stderr,
1315                                 "unhandled ELF relocation type %d\n",
1316                                 ELF32_R_TYPE(info));
1317                         assert(0);
1318             }
1319
1320          }
1321       }
1322       else
1323       if (shdr[i].sh_type == SHT_RELA) {
1324          fprintf ( stderr, "RelA style reloc table -- not yet done" );
1325          assert(0);
1326       }
1327    }
1328 }
1329
1330
1331 static Bool local validateOImage_elf ( void*  imgV,
1332                                        Int    size,
1333                                        Bool   verb )
1334 {
1335    Elf32_Shdr* shdr;
1336    Elf32_Sym*  stab;
1337    int i, j, nent, nstrtab, nsymtabs;
1338    char* sh_strtab;
1339    char* strtab;
1340
1341    char* ehdrC = (char*)imgV;
1342    Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
1343
1344    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
1345        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
1346        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
1347        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
1348       if (verb) fprintf ( stderr, "Not an ELF header\n" );
1349       return FALSE;
1350    }
1351    if (verb) fprintf ( stderr, "Is an ELF header\n" );
1352
1353    if (ehdr->e_ident[EI_CLASS] != ELFCLASS32) {
1354       if (verb) fprintf ( stderr, "Not 32 bit ELF\n" );
1355       return FALSE;
1356    }
1357    if (verb) fprintf ( stderr, "Is 32 bit ELF\n" );
1358
1359    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
1360       if (verb) fprintf ( stderr, "Is little-endian\n" );
1361    } else
1362    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
1363       if (verb) fprintf ( stderr, "Is big-endian\n" );
1364    } else {
1365       if (verb) fprintf ( stderr, "Unknown endiannness\n" );
1366       return FALSE;
1367    }
1368
1369    if (ehdr->e_type != ET_REL) {
1370       if (verb) fprintf ( stderr, "Not a relocatable object (.o) file\n" );
1371       return FALSE;
1372    }
1373    if (verb) fprintf ( stderr, "Is a relocatable object (.o) file\n" );
1374
1375    if (verb) fprintf ( stderr, "Architecture is " );
1376    switch (ehdr->e_machine) {
1377       case EM_386:   if (verb) fprintf ( stderr, "x86\n" ); break;
1378       case EM_SPARC: if (verb) fprintf ( stderr, "sparc\n" ); break;
1379       default:       if (verb) fprintf ( stderr, "unknown\n" ); return FALSE;
1380    }
1381
1382    if (verb)
1383    fprintf ( stderr,
1384              "\nSection header table: start %d, n_entries %d, ent_size %d\n",
1385              ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  );
1386
1387    assert (ehdr->e_shentsize == sizeof(Elf32_Shdr));
1388
1389    shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1390
1391    if (ehdr->e_shstrndx == SHN_UNDEF) {
1392       if (verb) fprintf ( stderr, "No section header string table\n" );
1393       sh_strtab = NULL;
1394       return FALSE;
1395    } else {
1396       if (verb) fprintf (  stderr,"Section header string table is section %d\n",
1397                           ehdr->e_shstrndx);
1398       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
1399    }
1400
1401    for (i = 0; i < ehdr->e_shnum; i++) {
1402       if (verb) fprintf ( stderr, "%2d:  ", i );
1403       if (verb) fprintf ( stderr, "type=%2d  ", shdr[i].sh_type );
1404       if (verb) fprintf ( stderr, "size=%4d  ", shdr[i].sh_size );
1405       if (verb) fprintf ( stderr, "offs=%4d  ", shdr[i].sh_offset );
1406       if (verb) fprintf ( stderr, "  (%p .. %p)  ",
1407                ehdrC + shdr[i].sh_offset,
1408                ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
1409
1410       if (shdr[i].sh_type == SHT_REL  && verb) fprintf ( stderr, "Rel  " ); else
1411       if (shdr[i].sh_type == SHT_RELA && verb) fprintf ( stderr, "RelA " ); else
1412       if (verb)                                fprintf ( stderr, "     " );
1413       if (sh_strtab && verb) fprintf ( stderr, "sname=%s", sh_strtab + shdr[i].sh_name );
1414       if (verb) fprintf ( stderr, "\n" );
1415    }
1416
1417    if (verb) fprintf ( stderr, "\n\nString tables\n" );
1418    strtab = NULL;
1419    nstrtab = 0;
1420    for (i = 0; i < ehdr->e_shnum; i++) {
1421       if (shdr[i].sh_type == SHT_STRTAB &&
1422           i !=  ehdr->e_shstrndx) {
1423          if (verb) fprintf ( stderr, "   section %d is a normal string table\n", i );
1424          strtab = ehdrC + shdr[i].sh_offset;
1425          nstrtab++;
1426       }
1427    }
1428    if (nstrtab != 1) {
1429       if (verb) fprintf ( stderr, "WARNING: no string tables, or too many\n" );
1430       return FALSE;
1431    }
1432
1433    nsymtabs = 0;
1434    if (verb) fprintf ( stderr, "\n\nSymbol tables\n" );
1435    for (i = 0; i < ehdr->e_shnum; i++) {
1436       if (shdr[i].sh_type != SHT_SYMTAB) continue;
1437       if (verb) fprintf ( stderr, "section %d is a symbol table\n", i );
1438       nsymtabs++;
1439       stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
1440       nent = shdr[i].sh_size / sizeof(Elf32_Sym);
1441       if (verb) fprintf ( stderr, "   number of entries is apparently %d (%d rem)\n",
1442                nent,
1443                shdr[i].sh_size % sizeof(Elf32_Sym)
1444              );
1445       if (0 != shdr[i].sh_size % sizeof(Elf32_Sym)) {
1446          if (verb) fprintf ( stderr, "non-integral number of symbol table entries\n");
1447          return FALSE;
1448       }
1449       for (j = 0; j < nent; j++) {
1450          if (verb) fprintf ( stderr, "   %2d  ", j );
1451          if (verb) fprintf ( stderr, "  sec=%-5d  size=%-3d  val=%-5p  ",
1452                              (int)stab[j].st_shndx,
1453                              (int)stab[j].st_size,
1454                              (char*)stab[j].st_value );
1455
1456          if (verb) fprintf ( stderr, "type=" );
1457          switch (ELF32_ST_TYPE(stab[j].st_info)) {
1458             case STT_NOTYPE:  if (verb) fprintf ( stderr, "notype " ); break;
1459             case STT_OBJECT:  if (verb) fprintf ( stderr, "object " ); break;
1460             case STT_FUNC  :  if (verb) fprintf ( stderr, "func   " ); break;
1461             case STT_SECTION: if (verb) fprintf ( stderr, "section" ); break;
1462             case STT_FILE:    if (verb) fprintf ( stderr, "file   " ); break;
1463             default:          if (verb) fprintf ( stderr, "?      " ); break;
1464          }
1465          if (verb) fprintf ( stderr, "  " );
1466
1467          if (verb) fprintf ( stderr, "bind=" );
1468          switch (ELF32_ST_BIND(stab[j].st_info)) {
1469             case STB_LOCAL :  if (verb) fprintf ( stderr, "local " ); break;
1470             case STB_GLOBAL:  if (verb) fprintf ( stderr, "global" ); break;
1471             case STB_WEAK  :  if (verb) fprintf ( stderr, "weak  " ); break;
1472             default:          if (verb) fprintf ( stderr, "?     " ); break;
1473          }
1474          if (verb) fprintf ( stderr, "  " );
1475
1476          if (verb) fprintf ( stderr, "name=%s\n", strtab + stab[j].st_name );
1477       }
1478    }
1479
1480    if (nsymtabs == 0) {
1481       if (verb) fprintf ( stderr, "Didn't find any symbol tables\n" );
1482       return FALSE;
1483    }
1484
1485    return TRUE;
1486 }
1487
1488
1489 static void readSyms_elf ( Module m )
1490 {
1491    int i, j, k, nent;
1492    Elf32_Sym* stab;
1493
1494    char*       ehdrC      = (char*)(module(m).oImage);
1495    Elf32_Ehdr* ehdr       = (Elf32_Ehdr*)ehdrC;
1496    char*       strtab     = findElfSection ( ehdrC, SHT_STRTAB );
1497    Elf32_Shdr* shdr       = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1498    char*       sh_strtab  = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
1499
1500    if (!strtab) internal("readSyms_elf");
1501
1502    k = 0;
1503    for (i = 0; i < ehdr->e_shnum; i++) {
1504
1505       /* make a HugsDLSection entry for relevant sections */
1506       DLSect kind = HUGS_DL_SECTION_OTHER;
1507       if (0==strcmp(".data",sh_strtab+shdr[i].sh_name) ||
1508           0==strcmp(".data1",sh_strtab+shdr[i].sh_name))
1509          kind = HUGS_DL_SECTION_RWDATA;
1510       if (0==strcmp(".text",sh_strtab+shdr[i].sh_name) ||
1511           0==strcmp(".rodata",sh_strtab+shdr[i].sh_name) ||
1512           0==strcmp(".rodata1",sh_strtab+shdr[i].sh_name))
1513          kind = HUGS_DL_SECTION_CODE_OR_RODATA;
1514       if (kind != HUGS_DL_SECTION_OTHER)
1515          addDLSect (
1516             m,
1517             ehdrC + shdr[i].sh_offset,
1518             ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1,
1519             kind
1520          );
1521
1522       if (shdr[i].sh_type != SHT_SYMTAB) continue;
1523
1524       /* copy stuff into this module's object symbol table */
1525       stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
1526       nent = shdr[i].sh_size / sizeof(Elf32_Sym);
1527       for (j = 0; j < nent; j++) {
1528          if ( ( ELF32_ST_BIND(stab[j].st_info)==STB_GLOBAL ||
1529                 ELF32_ST_BIND(stab[j].st_info)==STB_LOCAL
1530               )
1531               &&
1532               ( ELF32_ST_TYPE(stab[j].st_info)==STT_FUNC ||
1533                 ELF32_ST_TYPE(stab[j].st_info)==STT_OBJECT )
1534               ) {
1535             char* nm = strtab + stab[j].st_name;
1536             char* ad = ehdrC
1537                        + shdr[ stab[j].st_shndx ].sh_offset
1538                        + stab[j].st_value;
1539             assert(nm);
1540             assert(ad);
1541             /* fprintf(stderr, "addOTabName: %s %s %p\n",
1542                textToStr(module(m).text), nm, ad );
1543             */
1544             addOTabName ( m, nm, ad );
1545          }
1546       }
1547
1548    }
1549 }
1550
1551
1552 /* --------------------------------------------------------------------------
1553  * Arch-independent interface to the runtime linker
1554  * ------------------------------------------------------------------------*/
1555
1556 static Bool local validateOImage ( void* img, Int size, Bool verb )
1557 {
1558    return
1559       validateOImage_elf ( img, size, verb );
1560 }
1561
1562
1563 static Void local resolveReferencesInObjectModule ( Module m, Bool verb )
1564 {
1565    resolveReferencesInObjectModule_elf ( m, verb );
1566 }
1567
1568
1569 static Void local readSyms ( Module m )
1570 {
1571    readSyms_elf ( m );
1572 }
1573
1574
1575 /* --------------------------------------------------------------------------
1576  * General object symbol query stuff
1577  * ------------------------------------------------------------------------*/
1578
1579 /* entirely bogus claims about types of these symbols */
1580 extern int stg_gc_enter_1;
1581 extern int stg_chk_0;
1582 extern int stg_chk_1;
1583 extern int stg_update_PAP;
1584 extern int __ap_2_upd_info;
1585 extern int MainRegTable;
1586 extern int Upd_frame_info;
1587
1588 OSym rtsTab[]
1589    = {
1590        { "stg_gc_enter_1",    &stg_gc_enter_1  },
1591        { "stg_chk_0",         &stg_chk_0       },
1592        { "stg_chk_1",         &stg_chk_1       },
1593        { "stg_update_PAP",    &stg_update_PAP  },
1594        { "__ap_2_upd_info",   &__ap_2_upd_info },
1595        { "MainRegTable",      &MainRegTable    },
1596        { "Upd_frame_info",    &Upd_frame_info  },
1597        {0,0}
1598      };
1599
1600
1601 void* lookupObjName ( char* nm )
1602 {
1603    int    k;
1604    char*  pp;
1605    void*  a;
1606    Text   t;
1607    Module m;
1608    char   nm2[200];
1609
1610    nm2[199] = 0;
1611    strncpy(nm2,nm,200);
1612
1613    // first see if it's an RTS name
1614    for (k = 0; rtsTab[k].nm; k++)
1615       if (0==strcmp(nm2,rtsTab[k].nm))
1616          return rtsTab[k].ad;
1617
1618    // if not an RTS name, look in the
1619    // relevant module's object symbol table
1620    pp = strchr(nm2, '_');
1621    if (!pp) goto not_found;
1622    *pp = 0;
1623    t = findText(nm2);
1624    m = findModule(t);
1625    if (isNull(m)) goto not_found;
1626    a = lookupOTabName ( m, nm );
1627    if (a) return a;
1628
1629   not_found:
1630    fprintf ( stderr,
1631              "lookupObjName: can't resolve name `%s'\n",
1632              nm );
1633    return NULL;
1634 }
1635
1636
1637 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
1638 {
1639    return
1640       lookupDLSect(p) == HUGS_DL_SECTION_CODE_OR_RODATA;
1641 }
1642
1643
1644 int is_dynamically_loaded_rwdata_ptr ( char* p )
1645 {
1646    return
1647       lookupDLSect(p) == HUGS_DL_SECTION_RWDATA;
1648 }
1649
1650
1651 int is_not_dynamically_loaded_ptr ( char* p )
1652 {
1653    return
1654       lookupDLSect(p) == HUGS_DL_SECTION_OTHER;
1655 }
1656
1657
1658 /* --------------------------------------------------------------------------
1659  * Control:
1660  * ------------------------------------------------------------------------*/
1661
1662 Void interface(what)
1663 Int what; {
1664     switch (what) {
1665     case INSTALL:
1666     case RESET:
1667             ifImports           = NIL;
1668             ghcVarDecls         = NIL;
1669             ghcConstrDecls      = NIL;
1670             ghcSynonymDecls     = NIL;
1671             ghcClassDecls       = NIL;
1672             ghcInstanceDecls    = NIL;
1673             ghcExports          = NIL;
1674             ghcImports          = NIL;
1675             ghcModules          = NIL;
1676             break;
1677     case MARK:
1678             mark(ifImports);
1679             mark(ghcVarDecls);
1680             mark(ghcConstrDecls);
1681             mark(ghcSynonymDecls);
1682             mark(ghcClassDecls);
1683             mark(ghcInstanceDecls);
1684             mark(ghcImports);
1685             mark(ghcExports);
1686             mark(ghcModules);
1687             break;
1688     }
1689 }
1690
1691 /*-------------------------------------------------------------------------*/