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