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