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.12 $
  11  * $Date: 1999/12/16 16:42:56 $
  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  * (This comment is now out of date.  JRS, 991216).
  44  * The "addGHC*" functions act as "impedence matchers" between GHC
  45  * interface files and Hugs.  Their main job is to convert abstract
  46  * syntax trees into Hugs' internal representations.
  47  *
  48  * The main trick here is how we deal with mutually recursive interface
  49  * files:
  50  *
  51  * o As we read an import decl, we add it to a list of required imports
  52  *   (unless it's already loaded, of course).
  53  *
  54  * o Processing of declarations is split into two phases:
  55  *
  56  *   1) While reading the interface files, we construct all the Names,
  57  *      Tycons, etc declared in the interface file but we don't try to
  58  *      resolve references to any entities the declaration mentions.
  59  *
  60  *      This is done by the "addGHC*" functions.
  61  *
  62  *   2) After reading all the interface files, we finish processing the
  63  *      declarations by resolving any references in the declarations
  64  *      and doing any other processing that may be required.
  65  *
  66  *      This is done by the "finishGHC*" functions which use the
  67  *      "fixup*" functions to assist them.
  68  *
  69  *   The interface between these two phases are the "ghc*Decls" which
  70  *   contain lists of decls that haven't been completed yet.
  71  *
  72  * ------------------------------------------------------------------------*/
  73
  74
  75 /*
  76 New comment, 991216, explaining roughly how it all works.
  77 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  78
  79 Interfaces can contain references to unboxed types, and these need to
  80 be handled carefully.  The following is a summary of how the interface
  81 loader now works.  It is applied to groups of interfaces simultaneously,
  82 viz, the entire Prelude at once:
  83
  84 0.  Parse interfaces, chasing imports until a complete
  85     strongly-connected-component of ifaces has been parsed.
  86     All interfaces in this scc are processed together, in
  87     steps 1 .. 8 below.
  88
  89 1.  Throw away any entity not mentioned in the export lists.
  90
  91 2.  Delete type (not data or newtype) definitions which refer to
  92     unknown types in their right hand sides.  Because Hugs doesn't
  93     know of any unboxed types, this has the side effect of removing
  94     all type defns referring to unboxed types.  Repeat step 2 until
  95     a fixed point is reached.
  96
  97 3.  Make abstract all data/newtype defns which refer to an unknown
  98     type.  eg, data Word = MkW Word# becomes data Word, because
  99     Word# is unknown.  Hugs is happy to know about abstract boxed
 100     Words, but not about Word#s.
 101
 102 4.  Step 2 could delete types referred to by values, instances and
 103     classes.  So filter all entities, and delete those referring to
 104     unknown types _or_ classes.  This could cause other entities
 105     to become invalid, so iterate step 4 to a fixed point.
 106
 107     After step 4, the interfaces no longer contain anything
 108     unpalatable to Hugs.
 109
 110 5.  Steps 1-4 operate purely on the iface syntax trees.  We now start
 111     creating symbol table entries.  First, create a module table
 112     entry for each interface, and locate and read in the corresponding
 113     object file.  This is done by the startGHCModule function.
 114
 115 6.  Traverse all interfaces.  For each entity, create an entry in
 116     the name, tycon, class or instance table, and fill in relevant
 117     fields, but do not attempt to link tycon/class/instance/name uses
 118     to their symbol table entries.  This is done by the startGHC*
 119     functions.
 120
 121 7.  Revisit all symbol table entries created in step 6.  We should
 122     now be able to replace all references to tycons/classes/instances/
 123     names with the relevant symbol table entries.  This is done by
 124     the finishGHC* functions.
 125
 126 8.  Traverse all interfaces.  For each iface, examine the export lists
 127     and use it to build export lists in the module table.  Do the
 128     implicit 'import Prelude' thing if necessary.  Finally, resolve
 129     references in the object code for this module.  This is done
 130     by the finishGHCModule function.
 131 */
 132
 133 /* --------------------------------------------------------------------------
 134  * local function prototypes:
 135  * ------------------------------------------------------------------------*/
 136
 137 static Void startGHCValue       Args((Int,VarId,Type));
 138 static Void finishGHCValue      Args((VarId));
 139
 140 static Void startGHCSynonym     Args((Int,Cell,List,Type));
 141 static Void finishGHCSynonym    Args((Tycon));
 142
 143 static Void startGHCClass       Args((Int,List,Cell,List,List));
 144 static Void finishGHCClass      Args((Class));
 145
 146 static Inst startGHCInstance    Args((Int,List,Pair,VarId));
 147 static Void finishGHCInstance   Args((Inst));
 148
 149 static Void startGHCImports     Args((ConId,List));
 150 static Void finishGHCImports    Args((ConId,List));
 151
 152 static Void startGHCExports     Args((ConId,List));
 153 static Void finishGHCExports    Args((ConId,List));
 154
 155 static Void finishGHCModule     Args((Cell));
 156 static Void startGHCModule      Args((Text, Int, Text));
 157
 158 static Void startGHCDataDecl    Args((Int,List,Cell,List,List));
 159 static Void finishGHCDataDecl   ( ConId tyc );
 160
 161 static Void startGHCNewType     Args((Int,List,Cell,List,Cell));
 162 static Void finishGHCNewType    ( ConId tyc );
 163
 164
 165 /* Supporting stuff for {start|finish}GHCDataDecl */
 166 static List startGHCConstrs Args((Int,List,List));
 167 static Name startGHCSel     Args((Int,Pair));
 168 static Name startGHCConstr  Args((Int,Int,Triple));
 169
 170
 171
 172 static Kinds tvsToKind             Args((List));
 173 static Int   arityFromType         Args((Type));
 174 static Int   arityInclDictParams   Args((Type));
 175 static Bool  allTypesKnown ( Type type, List aktys /* [QualId] */, ConId thisMod );
 176
 177 static List       ifTyvarsIn       Args((Type));
 178
 179 static Type       tvsToOffsets       Args((Int,Type,List));
 180 static Type       conidcellsToTycons Args((Int,Type));
 181
 182 static Void       resolveReferencesInObjectModule Args((Module,Bool));
 183 static Bool       validateOImage Args((void*, Int, Bool));
 184 static Void       readSyms Args((Module,Bool));
 185
 186 static void*      lookupObjName ( char* );
 187
 188
 189
 190
 191
 192 /* --------------------------------------------------------------------------
 193  * Top-level interface processing
 194  * ------------------------------------------------------------------------*/
 195
 196 /* getIEntityName :: I_IMPORT..I_VALUE -> ConVarId | NIL */
 197 ConVarId getIEntityName ( Cell c )
 198 {
 199    switch (whatIs(c)) {
 200       case I_IMPORT:     return NIL;
 201       case I_INSTIMPORT: return NIL;
 202       case I_EXPORT:     return NIL;
 203       case I_FIXDECL:    return zthd3(unap(I_FIXDECL,c));
 204       case I_INSTANCE:   return NIL;
 205       case I_TYPE:       return zsel24(unap(I_TYPE,c));
 206       case I_DATA:       return zsel35(unap(I_DATA,c));
 207       case I_NEWTYPE:    return zsel35(unap(I_NEWTYPE,c));
 208       case I_CLASS:      return zsel35(unap(I_CLASS,c));
 209       case I_VALUE:      return zsnd3(unap(I_VALUE,c));
 210       default:           internal("getIEntityName");
 211    }
 212 }
 213
 214
 215 /* Filter the contents of an interface, using the supplied predicate.
 216    For flexibility, the predicate is passed as a second arg the value
 217    extraArgs.  This is a hack to get round the lack of partial applications
 218    in C.  Pred should not have any side effects.  The dumpaction param
 219    gives us the chance to print a message or some such for dumped items.
 220    When a named entity is deleted, filterInterface also deletes the name
 221    in the export lists.
 222 */
 223 Cell filterInterface ( Cell root,
 224                        Bool (*pred)(Cell,Cell),
 225                        Cell extraArgs,
 226                        Void (*dumpAction)(Cell) )
 227 {
 228    List tops;
 229    Cell iface       = unap(I_INTERFACE,root);
 230    List tops2       = NIL;
 231    List deleted_ids = NIL; /* :: [ConVarId] */
 232
 233    for (tops = zsnd(iface); nonNull(tops); tops=tl(tops)) {
 234       if (pred(hd(tops),extraArgs)) {
 235          tops2 = cons( hd(tops), tops2 );
 236       } else {
 237          ConVarId deleted_id = getIEntityName ( hd(tops) );
 238          if (nonNull(deleted_id))
 239             deleted_ids = cons ( deleted_id, deleted_ids );
 240          if (dumpAction)
 241             dumpAction ( hd(tops) );
 242       }
 243    }
 244    tops2 = reverse(tops2);
 245
 246    /* Clean up the export list now. */
 247    for (tops=tops2; nonNull(tops); tops=tl(tops)) {
 248       if (whatIs(hd(tops))==I_EXPORT) {
 249          Cell exdecl  = unap(I_EXPORT,hd(tops));
 250          List exlist  = zsnd(exdecl);
 251          List exlist2 = NIL;
 252          for (; nonNull(exlist); exlist=tl(exlist)) {
 253             Cell ex       = hd(exlist);
 254             ConVarId exid = isZPair(ex) ? zfst(ex) : ex;
 255             assert (isCon(exid) || isVar(exid));
 256             if (!varIsMember(textOf(exid),deleted_ids))
 257                exlist2 = cons(ex, exlist2);
 258          }
 259          hd(tops) = ap(I_EXPORT,zpair(zfst(exdecl),exlist2));
 260       }
 261    }
 262
 263    return ap(I_INTERFACE, zpair(zfst(iface),tops2));
 264 }
 265
 266
 267 ZPair readInterface(String fname, Long fileSize)
 268 {
 269     List  tops;
 270     List  imports = NIL;
 271     ZPair iface   = parseInterface(fname,fileSize);
 272     assert (whatIs(iface)==I_INTERFACE);
 273
 274     for (tops = zsnd(unap(I_INTERFACE,iface)); nonNull(tops); tops=tl(tops))
 275        if (whatIs(hd(tops)) == I_IMPORT) {
 276           ZPair imp_decl = unap(I_IMPORT,hd(tops));
 277           ConId m_to_imp = zfst(imp_decl);
 278           if (textOf(m_to_imp) != findText("PrelGHC")) {
 279              imports = cons(m_to_imp,imports);
 280              /* fprintf(stderr, "add iface %s\n", textToStr(textOf(m_to_imp))); */
 281           }
 282        }
 283     return zpair(iface,imports);
 284 }
 285
 286
 287 /* getExportDeclsInIFace :: I_INTERFACE -> [I_EXPORT] */
 288 static List getExportDeclsInIFace ( Cell root )
 289 {
 290    Cell  iface   = unap(I_INTERFACE,root);
 291    List  decls   = zsnd(iface);
 292    List  exports = NIL;
 293    List  ds;
 294    for (ds=decls; nonNull(ds); ds=tl(ds))
 295       if (whatIs(hd(ds))==I_EXPORT)
 296          exports = cons(hd(ds), exports);
 297    return exports;
 298 }
 299
 300
 301
 302 static Bool isExportedIFaceEntity ( Cell ife, List exlist_list )
 303 {
 304    /* ife         :: I_IMPORT..I_VALUE                      */
 305    /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
 306    Text  tnm;
 307    List  exlist;
 308    List  t;
 309
 310    ConVarId ife_id = getIEntityName ( ife );
 311
 312    if (isNull(ife_id)) return TRUE;
 313
 314    tnm = textOf(ife_id);
 315
 316    /* for each export list ... */
 317    for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
 318       exlist = hd(exlist_list);
 319
 320       /* for each entity in an export list ... */
 321       for (t=exlist; nonNull(t); t=tl(t)) {
 322          if (isZPair(hd(t))) {
 323             /* A pair, which means an export entry
 324                of the form ClassName(foo,bar). */
 325             List subents = cons(zfst(hd(t)),zsnd(hd(t)));
 326             for (; nonNull(subents); subents=tl(subents))
 327                if (textOf(hd(subents)) == tnm) goto retain;
 328          } else {
 329             /* Single name in the list. */
 330             if (textOf(hd(t)) == tnm) goto retain;
 331          }
 332       }
 333
 334    }
 335    fprintf ( stderr, "     dump %s\n", textToStr(tnm) );
 336    return FALSE;
 337
 338  retain:
 339    fprintf ( stderr, "   retain %s\n", textToStr(tnm) );
 340    return TRUE;
 341 }
 342
 343
 344 static Bool isExportedAbstractly ( ConId ife_id, List exlist_list )
 345 {
 346    /* ife_id      :: ConId                                  */
 347    /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
 348    Text  tnm;
 349    List  exlist;
 350    List  t;
 351
 352    assert (isCon(ife_id));
 353    tnm = textOf(ife_id);
 354
 355    /* for each export list ... */
 356    for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
 357       exlist = hd(exlist_list);
 358
 359       /* for each entity in an export list ... */
 360       for (t=exlist; nonNull(t); t=tl(t)) {
 361          if (isZPair(hd(t))) {
 362             /* A pair, which means an export entry
 363                of the form ClassName(foo,bar). */
 364             if (textOf(zfst(hd(t))) == tnm) return FALSE;
 365          } else {
 366             if (textOf(hd(t)) == tnm) return TRUE;
 367          }
 368       }
 369    }
 370    internal("isExportedAbstractly");
 371    return FALSE; /*notreached*/
 372 }
 373
 374
 375 /* Remove entities not mentioned in any of the export lists. */
 376 static Cell deleteUnexportedIFaceEntities ( Cell root )
 377 {
 378    Cell  iface       = unap(I_INTERFACE,root);
 379    ConId iname       = zfst(iface);
 380    List  decls       = zsnd(iface);
 381    List  decls2      = NIL;
 382    List  exlist_list = NIL;
 383    List  t;
 384
 385    fprintf(stderr, "\ncleanIFace: %s\n", textToStr(textOf(iname)));
 386
 387    exlist_list = getExportDeclsInIFace ( root );
 388    /* exlist_list :: [I_EXPORT] */
 389
 390    for (t=exlist_list; nonNull(t); t=tl(t))
 391       hd(t) = zsnd(unap(I_EXPORT,hd(t)));
 392    /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
 393
 394    if (isNull(exlist_list)) {
 395       ERRMSG(0) "Can't find any export lists in interface file"
 396       EEND;
 397    }
 398
 399    return filterInterface ( root, isExportedIFaceEntity,
 400                             exlist_list, NULL );
 401 }
 402
 403
 404 /* addTyconsAndClassesFromIFace :: I_INTERFACE -> [QualId] -> [QualId] */
 405 List addTyconsAndClassesFromIFace ( Cell root, List aktys )
 406 {
 407    Cell iface = unap(I_INTERFACE,root);
 408    Text mname = textOf(zfst(iface));
 409    List defns = zsnd(iface);
 410    for (; nonNull(defns); defns = tl(defns)) {
 411       Cell defn = hd(defns);
 412       Cell what = whatIs(defn);
 413       if (what==I_TYPE || what==I_DATA
 414           || what==I_NEWTYPE || what==I_CLASS) {
 415          QualId q = mkQCon ( mname, textOf(getIEntityName(defn)) );
 416          if (!qualidIsMember ( q, aktys ))
 417             aktys = cons ( q, aktys );
 418       }
 419    }
 420    return aktys;
 421 }
 422
 423
 424 Void ifentityAllTypesKnown_dumpmsg ( Cell entity )
 425 {
 426    ConVarId id = getIEntityName ( entity );
 427    fprintf ( stderr,
 428              "dumping %s because of unknown type(s)\n",
 429              isNull(id) ? "(nameless entity?!)" : textToStr(textOf(id)) );
 430 }
 431
 432 /* ifentityAllTypesKnown :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
 433 /* mod is the current module being processed -- so we can qualify unqual'd
 434    names.  Strange calling convention for aktys and mod is so we can call this
 435    from filterInterface.
 436 */
 437 Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod )
 438 {
 439    List  t, u;
 440    List  aktys = zfst ( aktys_mod );
 441    ConId mod   = zsnd ( aktys_mod );
 442    switch (whatIs(entity)) {
 443       case I_IMPORT:
 444       case I_INSTIMPORT:
 445       case I_EXPORT:
 446       case I_FIXDECL:
 447          return TRUE;
 448       case I_INSTANCE: {
 449          Cell inst = unap(I_INSTANCE,entity);
 450          List ctx  = zsel25 ( inst ); /* :: [((QConId,VarId))] */
 451          Type cls  = zsel35 ( inst ); /* :: Type */
 452          for (t = ctx; nonNull(t); t=tl(t))
 453             if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
 454          if (!allTypesKnown(cls, aktys,mod)) return FALSE;
 455          return TRUE;
 456       }
 457       case I_TYPE:
 458          return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
 459       case I_DATA: {
 460          Cell data    = unap(I_DATA,entity);
 461          List ctx     = zsel25 ( data ); /* :: [((QConId,VarId))] */
 462          List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
 463          for (t = ctx; nonNull(t); t=tl(t))
 464             if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
 465          for (t = constrs; nonNull(t); t=tl(t))
 466             for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
 467                if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) return FALSE;
 468          return TRUE;
 469       }
 470       case I_NEWTYPE: {
 471          Cell  newty  = unap(I_NEWTYPE,entity);
 472          List  ctx    = zsel25(newty);    /* :: [((QConId,VarId))] */
 473          ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
 474          for (t = ctx; nonNull(t); t=tl(t))
 475             if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
 476          if (nonNull(constr)
 477              && !allTypesKnown(zsnd(constr),aktys,mod)) return FALSE;
 478          return TRUE;
 479       }
 480       case I_CLASS: {
 481          Cell klass = unap(I_CLASS,entity);
 482          List ctx   = zsel25(klass);  /* :: [((QConId,VarId))] */
 483          List sigs  = zsel55(klass);  /* :: [((VarId,Type))] */
 484          for (t = ctx; nonNull(t); t=tl(t))
 485             if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
 486          for (t = sigs; nonNull(t); t=tl(t))
 487             if (!allTypesKnown(zsnd(hd(t)),aktys,mod)) return FALSE;
 488          return TRUE;
 489       }
 490       case I_VALUE:
 491          return allTypesKnown( zthd3(unap(I_VALUE,entity)), aktys,mod );
 492       default:
 493          internal("ifentityAllTypesKnown");
 494    }
 495 }
 496
 497
 498 #if 0
 499 I hope this can be nuked.
 500 /* Kludge.  Stuff imported from PrelGHC isn't referred to in a
 501    qualified way, so arrange it so it is.
 502 */
 503 QualId magicRequalify ( ConId id )
 504 {
 505    Text tid;
 506    Text tmid;
 507    assert(isCon(id));
 508    tid = textOf(id);
 509
 510    fprintf ( stderr, "$--$--$--$--$--$ magicRequalify: %s",
 511              textToStr(tid) );
 512
 513    if (tid == findText("[]")) {
 514       tmid = findText("PrelList");
 515    } else
 516    if (tid == findText("Ratio")) {
 517       tmid = findText("PrelNum");
 518    } else
 519    if (tid == findText("Char")) {
 520       tmid = findText("PrelGHC");
 521    } else {
 522       fprintf(stderr, "??? \n");
 523       return id;
 524    }
 525
 526    fprintf ( stderr, " -> %s.%s\n",
 527              textToStr(tmid), textToStr(tid) );
 528    return mkQualId ( mkCon(tmid), id );
 529 }
 530 #endif
 531
 532
 533 /* ifTypeDoesntRefUnknownTycon :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
 534 /* mod is the current module being processed -- so we can qualify unqual'd
 535    names.  Strange calling convention for aktys and mod is so we can call this
 536    from filterInterface.
 537 */
 538 Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod )
 539 {
 540    List  t, u;
 541    List  aktys = zfst ( aktys_mod );
 542    ConId mod   = zsnd ( aktys_mod );
 543    if (whatIs(entity) != I_TYPE) {
 544       return TRUE;
 545    } else {
 546       return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
 547    }
 548 }
 549
 550 Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity )
 551 {
 552    ConVarId id = getIEntityName ( entity );
 553    assert (whatIs(entity)==I_TYPE);
 554    assert (isCon(id));
 555    fprintf ( stderr,
 556              "dumping type %s because of unknown tycon(s)\n",
 557              textToStr(textOf(id)) );
 558 }
 559
 560
 561 /* abstractifyExport :: I_EXPORT -> ConId -> I_EXPORT
 562 */
 563 List abstractifyExDecl ( Cell root, ConId toabs )
 564 {
 565    ZPair exdecl = unap(I_EXPORT,root);
 566    List  exlist = zsnd(exdecl);
 567    List  res    = NIL;
 568    for (; nonNull(exlist); exlist = tl(exlist)) {
 569       if (isZPair(hd(exlist))
 570           && textOf(toabs) == textOf(zfst(hd(exlist)))) {
 571          /* it's toabs, exported non-abstractly */
 572          res = cons ( zfst(hd(exlist)), res );
 573       } else {
 574          res = cons ( hd(exlist), res );
 575       }
 576    }
 577    return ap(I_EXPORT,zpair(zfst(exdecl),reverse(res)));
 578 }
 579
 580
 581 Void ppModule ( Text modt )
 582 {
 583    fflush(stderr); fflush(stdout);
 584    fprintf(stderr, "---------------- MODULE %s ----------------\n",
 585                    textToStr(modt) );
 586 }
 587
 588
 589 /* ifaces_outstanding holds a list of parsed interfaces
 590    for which we need to load objects and create symbol
 591    table entries.
 592 */
 593 Void processInterfaces ( void )
 594 {
 595     List    tmp;
 596     List    xs;
 597     ZTriple tr;
 598     Cell    iface;
 599     Int     sizeObj;
 600     Text    nameObj;
 601     Text    mname;
 602     List    decls;
 603     Module  mod;
 604     List    all_known_types;
 605     Int     num_known_types;
 606
 607     List ifaces       = NIL;  /* :: List I_INTERFACE */
 608     List iface_sizes  = NIL;  /* :: List Int         */
 609     List iface_onames = NIL;  /* :: List Text        */
 610
 611     fprintf ( stderr,
 612               "processInterfaces: %d interfaces to process\n",
 613               length(ifaces_outstanding) );
 614
 615
 616     /* unzip3 ifaces_outstanding into ifaces, iface_sizes, iface_onames */
 617     for (xs = ifaces_outstanding; nonNull(xs); xs=tl(xs)) {
 618        ifaces       = cons ( zfst3(hd(xs)), ifaces       );
 619        iface_onames = cons ( zsnd3(hd(xs)), iface_onames );
 620        iface_sizes  = cons ( zthd3(hd(xs)), iface_sizes  );
 621     }
 622
 623     ifaces       = reverse(ifaces);
 624     iface_onames = reverse(iface_onames);
 625     iface_sizes  = reverse(iface_sizes);
 626
 627     /* Clean up interfaces -- dump non-exported value, class, type decls */
 628     for (xs = ifaces; nonNull(xs); xs = tl(xs))
 629        hd(xs) = deleteUnexportedIFaceEntities(hd(xs));
 630
 631
 632     /* Iteratively delete any type declarations which refer to unknown
 633        tycons.
 634     */
 635     num_known_types = 999999999;
 636     while (TRUE) {
 637        Int i;
 638
 639        /* Construct a list of all known tycons.  This is a list of QualIds.
 640           Unfortunately it also has to contain all known class names, since
 641           allTypesKnown cannot distinguish between tycons and classes -- a
 642           deficiency of the iface abs syntax.
 643        */
 644        all_known_types = getAllKnownTyconsAndClasses();
 645        for (xs = ifaces; nonNull(xs); xs=tl(xs))
 646           all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
 647
 648        /* Have we reached a fixed point? */
 649        i = length(all_known_types);
 650        printf ( "\n============= %d known types =============\n", i );
 651        if (num_known_types == i) break;
 652        num_known_types = i;
 653
 654        /* Delete all entities which refer to unknown tycons. */
 655        for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
 656           ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
 657           assert(nonNull(mod));
 658           hd(xs) = filterInterface ( hd(xs),
 659                                      ifTypeDoesntRefUnknownTycon,
 660                                      zpair(all_known_types,mod),
 661                                      ifTypeDoesntRefUnknownTycon_dumpmsg );
 662        }
 663     }
 664
 665     /* Now abstractify any datas and newtypes which refer to unknown tycons
 666        -- including, of course, the type decls just deleted.
 667     */
 668     for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
 669        List  absify = NIL;                      /* :: [ConId] */
 670        ZPair iface  = unap(I_INTERFACE,hd(xs)); /* ((ConId, [I_IMPORT..I_VALUE])) */
 671        ConId mod    = zfst(iface);
 672        List  aktys  = all_known_types;          /* just a renaming */
 673        List  es,t,u;
 674        List  exlist_list;
 675
 676        /* Compute into absify the list of all ConIds (tycons) we need to
 677           abstractify.
 678        */
 679        for (es = zsnd(iface); nonNull(es); es=tl(es)) {
 680           Cell ent      = hd(es);
 681           Bool allKnown = TRUE;
 682
 683           if (whatIs(ent)==I_DATA) {
 684              Cell data    = unap(I_DATA,ent);
 685              List ctx     = zsel25 ( data ); /* :: [((QConId,VarId))] */
 686              List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
 687              for (t = ctx; nonNull(t); t=tl(t))
 688                 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
 689              for (t = constrs; nonNull(t); t=tl(t))
 690                 for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
 691                     if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE;
 692           }
 693           else if (whatIs(ent)==I_NEWTYPE) {
 694              Cell  newty  = unap(I_NEWTYPE,ent);
 695              List  ctx    = zsel25(newty);    /* :: [((QConId,VarId))] */
 696              ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
 697              for (t = ctx; nonNull(t); t=tl(t))
 698                 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
 699              if (!allTypesKnown(zsnd(constr),aktys,mod)) allKnown = FALSE;
 700           }
 701
 702           if (!allKnown) {
 703              absify = cons ( getIEntityName(ent), absify );
 704              fprintf ( stderr,
 705                        "abstractifying %s because it uses an unknown type\n",
 706                        textToStr(textOf(getIEntityName(ent))) );
 707           }
 708        }
 709
 710        /* mark in exports as abstract all names in absify (modifies iface) */
 711        for (; nonNull(absify); absify=tl(absify)) {
 712           ConId toAbs = hd(absify);
 713           for (es = zsnd(iface); nonNull(es); es=tl(es)) {
 714              if (whatIs(hd(es)) != I_EXPORT) continue;
 715              hd(es) = abstractifyExDecl ( hd(es), toAbs );
 716           }
 717        }
 718
 719        /* For each data/newtype in the export list marked as abstract,
 720           remove the constructor lists.  This catches all abstractification
 721           caused by the code above, and it also catches tycons which really
 722           were exported abstractly.
 723        */
 724
 725        exlist_list = getExportDeclsInIFace ( ap(I_INTERFACE,iface) );
 726        /* exlist_list :: [I_EXPORT] */
 727        for (t=exlist_list; nonNull(t); t=tl(t))
 728           hd(t) = zsnd(unap(I_EXPORT,hd(t)));
 729        /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
 730
 731        for (es = zsnd(iface); nonNull(es); es=tl(es)) {
 732           Cell ent = hd(es);
 733           if (whatIs(ent)==I_DATA
 734               && isExportedAbstractly ( getIEntityName(ent),
 735                                         exlist_list )) {
 736              Cell data = unap(I_DATA,ent);
 737              data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
 738                             zsel45(data), NIL /* the constr list */ );
 739              hd(es) = ap(I_DATA,data);
 740 fprintf(stderr, "abstractify data %s\n", textToStr(textOf(getIEntityName(ent))) );
 741           }
 742           else if (whatIs(ent)==I_NEWTYPE
 743               && isExportedAbstractly ( getIEntityName(ent),
 744                                         exlist_list )) {
 745              Cell data = unap(I_NEWTYPE,ent);
 746              data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
 747                             zsel45(data), NIL /* the constr-type pair */ );
 748              hd(es) = ap(I_NEWTYPE,data);
 749 fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent))) );
 750           }
 751        }
 752
 753        /* We've finally finished mashing this iface.  Update the iface list. */
 754        hd(xs) = ap(I_INTERFACE,iface);
 755     }
 756
 757
 758     /* At this point, the interfaces are cleaned up so that no type, data or
 759        newtype defn refers to a non-existant type.  However, there still may
 760        be value defns, classes and instances which refer to unknown types.
 761        Delete iteratively until a fixed point is reached.
 762     */
 763 printf("\n");
 764
 765     num_known_types = 999999999;
 766     while (TRUE) {
 767        Int i;
 768
 769        /* Construct a list of all known tycons.  This is a list of QualIds.
 770           Unfortunately it also has to contain all known class names, since
 771           allTypesKnown cannot distinguish between tycons and classes -- a
 772           deficiency of the iface abs syntax.
 773        */
 774        all_known_types = getAllKnownTyconsAndClasses();
 775        for (xs = ifaces; nonNull(xs); xs=tl(xs))
 776           all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
 777
 778        /* Have we reached a fixed point? */
 779        i = length(all_known_types);
 780        printf ( "\n------------- %d known types -------------\n", i );
 781        if (num_known_types == i) break;
 782        num_known_types = i;
 783
 784        /* Delete all entities which refer to unknown tycons. */
 785        for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
 786           ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
 787           assert(nonNull(mod));
 788
 789           hd(xs) = filterInterface ( hd(xs),
 790                                      ifentityAllTypesKnown,
 791                                      zpair(all_known_types,mod),
 792                                      ifentityAllTypesKnown_dumpmsg );
 793        }
 794     }
 795
 796
 797     /* Allocate module table entries and read in object code. */
 798     for (xs=ifaces;
 799          nonNull(xs);
 800          xs=tl(xs), iface_sizes=tl(iface_sizes), iface_onames=tl(iface_onames)) {
 801        startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))),
 802                         intOf(hd(iface_sizes)),
 803                         hd(iface_onames) );
 804     }
 805     assert (isNull(iface_sizes));
 806     assert (isNull(iface_onames));
 807
 808
 809     /* Now work through the decl lists of the modules, and call the
 810        startGHC* functions on the entities.  This creates names in
 811        various tables but doesn't bind them to anything.
 812     */
 813
 814     for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
 815        iface   = unap(I_INTERFACE,hd(xs));
 816        mname   = textOf(zfst(iface));
 817        mod     = findModule(mname);
 818        if (isNull(mod)) internal("processInterfaces(4)");
 819        setCurrModule(mod);
 820        ppModule ( module(mod).text );
 821
 822        for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
 823           Cell decl = hd(decls);
 824           switch(whatIs(decl)) {
 825              case I_EXPORT: {
 826                 Cell exdecl = unap(I_EXPORT,decl);
 827                 startGHCExports ( zfst(exdecl), zsnd(exdecl) );
 828                 break;
 829              }
 830              case I_IMPORT: {
 831                 Cell imdecl = unap(I_IMPORT,decl);
 832                 startGHCImports ( zfst(imdecl), zsnd(imdecl) );
 833                 break;
 834              }
 835              case I_FIXDECL: {
 836                 break;
 837              }
 838              case I_INSTANCE: {
 839                 /* Trying to find the instance table location allocated by
 840                    startGHCInstance in subsequent processing is a nightmare, so
 841                    cache it on the tree.
 842                 */
 843                 Cell instance = unap(I_INSTANCE,decl);
 844                 Inst in = startGHCInstance ( zsel15(instance), zsel25(instance),
 845                                              zsel35(instance), zsel45(instance) );
 846                 hd(decls) = ap(I_INSTANCE,
 847                                z5ble( zsel15(instance), zsel25(instance),
 848                                       zsel35(instance), zsel45(instance), in ));
 849                 break;
 850              }
 851              case I_TYPE: {
 852                 Cell tydecl = unap(I_TYPE,decl);
 853                 startGHCSynonym ( zsel14(tydecl), zsel24(tydecl),
 854                                   zsel34(tydecl), zsel44(tydecl) );
 855                 break;
 856              }
 857              case I_DATA: {
 858                 Cell ddecl = unap(I_DATA,decl);
 859                 startGHCDataDecl ( zsel15(ddecl), zsel25(ddecl),
 860                                    zsel35(ddecl), zsel45(ddecl), zsel55(ddecl) );
 861                 break;
 862              }
 863              case I_NEWTYPE: {
 864                 Cell ntdecl = unap(I_NEWTYPE,decl);
 865                 startGHCNewType ( zsel15(ntdecl), zsel25(ntdecl),
 866                                   zsel35(ntdecl), zsel45(ntdecl),
 867                                   zsel55(ntdecl) );
 868                 break;
 869              }
 870              case I_CLASS: {
 871                 Cell klass = unap(I_CLASS,decl);
 872                 startGHCClass ( zsel15(klass), zsel25(klass),
 873                                 zsel35(klass), zsel45(klass),
 874                                 zsel55(klass) );
 875                 break;
 876              }
 877              case I_VALUE: {
 878                 Cell value = unap(I_VALUE,decl);
 879                 startGHCValue ( zfst3(value), zsnd3(value), zthd3(value) );
 880                 break;
 881              }
 882              default:
 883                 internal("processInterfaces(1)");
 884           }
 885        }
 886     }
 887
 888     fprintf(stderr, "\n=========================================================\n");
 889     fprintf(stderr, "=========================================================\n");
 890
 891     /* Traverse again the decl lists of the modules, this time
 892        calling the finishGHC* functions.  But don't process
 893        the export lists; those must wait for later.
 894     */
 895     for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
 896        iface   = unap(I_INTERFACE,hd(xs));
 897        mname   = textOf(zfst(iface));
 898        mod     = findModule(mname);
 899        if (isNull(mod)) internal("processInterfaces(3)");
 900        setCurrModule(mod);
 901        ppModule ( module(mod).text );
 902
 903        for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
 904           Cell decl = hd(decls);
 905           switch(whatIs(decl)) {
 906              case I_EXPORT: {
 907                 break;
 908              }
 909              case I_IMPORT: {
 910                 break;
 911              }
 912              case I_FIXDECL: {
 913                 break;
 914              }
 915              case I_INSTANCE: {
 916                 Cell instance = unap(I_INSTANCE,decl);
 917                 finishGHCInstance ( zsel55(instance) );
 918                 break;
 919              }
 920              case I_TYPE: {
 921                 Cell tydecl = unap(I_TYPE,decl);
 922                 finishGHCSynonym ( zsel24(tydecl) );
 923                 break;
 924              }
 925              case I_DATA: {
 926                 Cell ddecl = unap(I_DATA,decl);
 927                 finishGHCDataDecl ( zsel35(ddecl) );
 928                 break;
 929              }
 930              case I_NEWTYPE: {
 931                 Cell ntdecl = unap(I_NEWTYPE,decl);
 932                 finishGHCNewType ( zsel35(ntdecl) );
 933                 break;
 934              }
 935              case I_CLASS: {
 936                 Cell klass = unap(I_CLASS,decl);
 937                 finishGHCClass ( zsel35(klass) );
 938                 break;
 939              }
 940              case I_VALUE: {
 941                 Cell value = unap(I_VALUE,decl);
 942                 finishGHCValue ( zsnd3(value) );
 943                 break;
 944              }
 945              default:
 946                 internal("processInterfaces(2)");
 947           }
 948        }
 949     }
 950
 951     fprintf(stderr, "\n+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
 952     fprintf(stderr, "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
 953     /* Build the module(m).export lists for each module, by running
 954        through the export lists in the iface.  Also, do the implicit
 955        'import Prelude' thing.  And finally, do the object code
 956        linking.
 957     */
 958     for (xs = ifaces; nonNull(xs); xs = tl(xs))
 959        finishGHCModule(hd(xs));
 960
 961     /* Finished! */
 962     ifaces_outstanding = NIL;
 963 }
 964
 965
 966 /* --------------------------------------------------------------------------
 967  * Modules
 968  * ------------------------------------------------------------------------*/
 969
 970 Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
 971 {
 972     FILE* f;
 973     void* img;
 974
 975     Module m = findModule(mname);
 976     if (isNull(m)) {
 977        m = newModule(mname);
 978        fprintf ( stderr, "startGHCIface: name %16s   objsize %d\n",
 979                           textToStr(mname), sizeObj );
 980     } else {
 981        if (module(m).fake) {
 982           module(m).fake = FALSE;
 983        } else {
 984           ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname)
 985           EEND;
 986        }
 987     }
 988
 989     img = malloc ( sizeObj );
 990     if (!img) {
 991        ERRMSG(0) "Can't allocate memory to load object file for module \"%s\"",
 992                  textToStr(mname)
 993        EEND;
 994     }
 995     f = fopen( textToStr(nameObj), "rb" );
 996     if (!f) {
 997        /* Really, this shouldn't happen, since makeStackEntry ensures the
 998           object is available.  Nevertheless ...
 999        */
1000        ERRMSG(0) "Object file \"%s\" can't be opened to read -- oops!",
1001                  &(textToStr(nameObj)[0])
1002        EEND;
1003     }
1004     if (sizeObj != fread ( img, 1, sizeObj, f)) {
1005        ERRMSG(0) "Read of object file \"%s\" failed", textToStr(nameObj)
1006        EEND;
1007     }
1008     if (!validateOImage(img,sizeObj,VERBOSE)) {
1009        ERRMSG(0) "Validation of object file \"%s\" failed",
1010                  textToStr(nameObj)
1011        EEND;
1012     }
1013
1014     assert(!module(m).oImage);
1015     module(m).oImage = img;
1016
1017     readSyms(m,VERBOSE);
1018
1019     /* setCurrModule(m); */
1020 }
1021
1022
1023 /* For the module mod, augment both the export environment (.exports)
1024    and the eval environment (.names, .tycons, .classes)
1025    with the symbols mentioned in exlist.  We don't actually need
1026    to modify the names, tycons, classes or instances in the eval
1027    environment, since previous processing of the
1028    top-level decls in the iface should have done this already.
1029
1030    mn is the module mentioned in the export list; it is the "original"
1031    module for the symbols in the export list.  We should also record
1032    this info with the symbols, since references to object code need to
1033    refer to the original module in which a symbol was defined, rather
1034    than to some module it has been imported into and then re-exported.
1035
1036    We take the policy that if something mentioned in an export list
1037    can't be found in the symbol tables, it is simply ignored.  After all,
1038    previous processing of the iface syntax trees has already removed
1039    everything which Hugs can't handle, so if there is mention of these
1040    things still lurking in export lists somewhere, about the only thing
1041    to do is to ignore it.
1042
1043    Also do an implicit 'import Prelude' thingy for the module,
1044    if appropriate.
1045 */
1046
1047
1048 Void finishGHCModule ( Cell root )
1049 {
1050    /* root :: I_INTERFACE */
1051    Cell   iface       = unap(I_INTERFACE,root);
1052    ConId  iname       = zfst(iface);
1053    Module mod         = findModule(textOf(iname));
1054    List   exlist_list = NIL;
1055    List   t;
1056
1057    fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
1058
1059    if (isNull(mod)) internal("finishExports(1)");
1060    setCurrModule(mod);
1061
1062    exlist_list = getExportDeclsInIFace ( root );
1063    /* exlist_list :: [I_EXPORT] */
1064
1065    for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
1066       ZPair exdecl = unap(I_EXPORT,hd(exlist_list));
1067       ConId exmod  = zfst(exdecl);
1068       List  exlist = zsnd(exdecl);
1069       /* exlist :: [ ConVarId | ((ConId, [ConVarId])) ] */
1070
1071       for (; nonNull(exlist); exlist=tl(exlist)) {
1072          Bool   abstract;
1073          List   subents;
1074          Cell   c;
1075          QualId q;
1076          Cell   ex = hd(exlist);
1077
1078          switch (whatIs(ex)) {
1079
1080             case VARIDCELL: /* variable */
1081                q = mkQualId(exmod,ex);
1082                c = findQualNameWithoutConsultingExportList ( q );
1083                if (isNull(c)) goto notfound;
1084                fprintf(stderr, "   var %s\n", textToStr(textOf(ex)) );
1085                module(mod).exports = cons(c, module(mod).exports);
1086                break;
1087
1088             case CONIDCELL: /* non data tycon */
1089                q = mkQualId(exmod,ex);
1090                c = findQualTyconWithoutConsultingExportList ( q );
1091                if (isNull(c)) goto notfound;
1092                fprintf(stderr, "   type %s\n", textToStr(textOf(ex)) );
1093                module(mod).exports = cons(c, module(mod).exports);
1094                break;
1095
1096             case ZTUP2: /* data T = C1 ... Cn  or class C where f1 ... fn */
1097                subents = zsnd(ex);  /* :: [ConVarId] */
1098                ex      = zfst(ex);  /* :: ConId */
1099                q       = mkQualId(exmod,ex);
1100                c       = findQualTyconWithoutConsultingExportList ( q );
1101
1102                if (nonNull(c)) { /* data */
1103                   fprintf(stderr, "   data/newtype %s = { ", textToStr(textOf(ex)) );
1104                   assert(tycon(c).what == DATATYPE || tycon(c).what==NEWTYPE);
1105                   abstract = isNull(tycon(c).defn);
1106                   /* This data/newtype could be abstract even tho the export list
1107                      says to export it non-abstractly.  That happens if it was
1108                      imported from some other module and is now being re-exported,
1109                      and previous cleanup phases have abstractified it in the
1110                      original (defining) module.
1111                   */
1112                   if (abstract) {
1113                      module(mod).exports = cons ( ex, module(mod).exports );
1114                      fprintf ( stderr, "(abstract) ");
1115                   } else {
1116                      module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1117                      for (; nonNull(subents); subents = tl(subents)) {
1118                         Cell ent2 = hd(subents);
1119                         assert(isCon(ent2) || isVar(ent2));
1120                                               /* isVar since could be a field name */
1121                         q = mkQualId(exmod,ent2);
1122                         c = findQualNameWithoutConsultingExportList ( q );
1123                         fprintf(stderr, "%s ", textToStr(name(c).text));
1124                         assert(nonNull(c));
1125                         module(mod).exports = cons(c, module(mod).exports);
1126                      }
1127                   }
1128                   fprintf(stderr, "}\n" );
1129                } else { /* class */
1130                   q = mkQualId(exmod,ex);
1131                   c = findQualClassWithoutConsultingExportList ( q );
1132                   if (isNull(c)) goto notfound;
1133                   fprintf(stderr, "   class %s { ", textToStr(textOf(ex)) );
1134                   module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1135                   for (; nonNull(subents); subents = tl(subents)) {
1136                      Cell ent2 = hd(subents);
1137                      assert(isVar(ent2));
1138                      q = mkQualId(exmod,ent2);
1139                      c = findQualNameWithoutConsultingExportList ( q );
1140                      fprintf(stderr, "%s ", textToStr(name(c).text));
1141                      if (isNull(c)) goto notfound;
1142                      module(mod).exports = cons(c, module(mod).exports);
1143                   }
1144                   fprintf(stderr, "}\n" );
1145                }
1146                break;
1147
1148             default:
1149                internal("finishExports(2)");
1150
1151          } /* switch */
1152          continue;  /* so notfound: can be placed after this */
1153
1154         notfound:
1155          /* q holds what ain't found */
1156          assert(whatIs(q)==QUALIDENT);
1157          fprintf( stderr, "   ------ IGNORED: %s.%s\n",
1158                   textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
1159          continue;
1160       }
1161    }
1162
1163    if (preludeLoaded) {
1164       /* do the implicit 'import Prelude' thing */
1165       List pxs = module(modulePrelude).exports;
1166       for (; nonNull(pxs); pxs=tl(pxs)) {
1167          Cell px = hd(pxs);
1168          again:
1169          switch (whatIs(px)) {
1170             case AP:
1171                px = fst(px);
1172                goto again;
1173             case NAME:
1174                module(mod).names = cons ( px, module(mod).names );
1175                break;
1176             case TYCON:
1177                module(mod).tycons = cons ( px, module(mod).tycons );
1178                break;
1179             case CLASS:
1180                module(mod).classes = cons ( px, module(mod).classes );
1181                break;
1182             default:
1183                fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
1184                internal("finishGHCModule -- implicit import Prelude");
1185                break;
1186          }
1187       }
1188    }
1189
1190    /* Last, but by no means least ... */
1191    resolveReferencesInObjectModule ( mod, VERBOSE );
1192 }
1193
1194
1195 /* --------------------------------------------------------------------------
1196  * Exports
1197  * ------------------------------------------------------------------------*/
1198
1199 Void startGHCExports ( ConId mn, List exlist )
1200 {
1201 #   ifdef DEBUG_IFACE
1202     printf("startGHCExports %s\n", textToStr(textOf(mn)) );
1203 #   endif
1204    /* Nothing to do. */
1205 }
1206
1207 Void finishGHCExports ( ConId mn, List exlist )
1208 {
1209 #   ifdef DEBUG_IFACE
1210     printf("finishGHCExports %s\n", textToStr(textOf(mn)) );
1211 #   endif
1212    /* Nothing to do. */
1213 }
1214
1215
1216 /* --------------------------------------------------------------------------
1217  * Imports
1218  * ------------------------------------------------------------------------*/
1219
1220 Void startGHCImports ( ConId mn, List syms )
1221 /* nm     the module to import from */
1222 /* syms   [ConId | VarId] -- the names to import */
1223 {
1224 #  ifdef DEBUG_IFACE
1225    printf("startGHCImports %s\n", textToStr(textOf(mn)) );
1226 #  endif
1227    /* Nothing to do. */
1228 }
1229
1230
1231 Void finishGHCImports ( ConId nm, List syms )
1232 /* nm     the module to import from */
1233 /* syms   [ConId | VarId] -- the names to import */
1234 {
1235 #  ifdef DEBUG_IFACE
1236    printf("finishGHCImports %s\n", textToStr(textOf(nm)) );
1237 #  endif
1238   /* Nothing to do. */
1239 }
1240
1241
1242 /* --------------------------------------------------------------------------
1243  * Vars (values)
1244  * ------------------------------------------------------------------------*/
1245
1246 void startGHCValue ( Int line, VarId vid, Type ty )
1247 {
1248     Name   n;
1249     List   tmp, tvs;
1250     Text   v = textOf(vid);
1251
1252 #   ifdef DEBUG_IFACE
1253     printf("begin startGHCValue %s\n", textToStr(v));
1254 #   endif
1255
1256     n = findName(v);
1257     if (nonNull(n)) {
1258         ERRMSG(0) "Attempt to redefine variable \"%s\"", textToStr(v)
1259         EEND;
1260     }
1261     n = newName(v,NIL);
1262
1263     tvs = ifTyvarsIn(ty);
1264     for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1265        hd(tmp) = zpair(hd(tmp),STAR);
1266     if (nonNull(tvs))
1267        ty = mkPolyType(tvsToKind(tvs),ty);
1268
1269     ty = tvsToOffsets(line,ty,tvs);
1270     name(n).type  = ty;
1271     name(n).arity = arityInclDictParams(ty);
1272     name(n).line  = line;
1273 }
1274
1275
1276 void finishGHCValue ( VarId vid )
1277 {
1278     Name n    = findName ( textOf(vid) );
1279     Int  line = name(n).line;
1280 #   ifdef DEBUG_IFACE
1281     fprintf(stderr, "begin finishGHCValue %s\n", textToStr(name(n).text) );
1282 #   endif
1283     assert(currentModule == name(n).mod);
1284     name(n).type = conidcellsToTycons(line,name(n).type);
1285 }
1286
1287
1288 /* --------------------------------------------------------------------------
1289  * Type synonyms
1290  * ------------------------------------------------------------------------*/
1291
1292 Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
1293 {
1294     /* tycon :: ConId             */
1295     /* tvs   ::  [((VarId,Kind))] */
1296     /* ty    :: Type              */
1297     Text t = textOf(tycon);
1298 #   ifdef DEBUG_IFACE
1299     fprintf(stderr, "begin startGHCSynonym %s\n", textToStr(t) );
1300 #   endif
1301     if (nonNull(findTycon(t))) {
1302         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1303                      textToStr(t)
1304         EEND;
1305     } else {
1306         Tycon tc        = newTycon(t);
1307         tycon(tc).line  = line;
1308         tycon(tc).arity = length(tvs);
1309         tycon(tc).what  = SYNONYM;
1310         tycon(tc).kind  = tvsToKind(tvs);
1311
1312         /* prepare for finishGHCSynonym */
1313         tycon(tc).defn  = tvsToOffsets(line,ty,tvs);
1314     }
1315 }
1316
1317
1318 static Void  finishGHCSynonym ( ConId tyc )
1319 {
1320     Tycon tc   = findTycon(textOf(tyc));
1321     Int   line = tycon(tc).line;
1322 #   ifdef DEBUG_IFACE
1323     fprintf(stderr, "begin finishGHCSynonym %s\n", textToStr(textOf(tyc)) );
1324 #   endif
1325
1326     assert (currentModule == tycon(tc).mod);
1327     //    setCurrModule(tycon(tc).mod);
1328     tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
1329
1330     /* (ADR) ToDo: can't really do this until I've done all synonyms
1331      * and then I have to do them in order
1332      * tycon(tc).defn = fullExpand(ty);
1333      * (JRS) What?!?!  i don't understand
1334      */
1335 }
1336
1337
1338 /* --------------------------------------------------------------------------
1339  * Data declarations
1340  * ------------------------------------------------------------------------*/
1341
1342 Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
1343 Int   line;
1344 List  ctx0;      /* [((QConId,VarId))]                */
1345 Cell  tycon;     /* ConId                             */
1346 List  ktyvars;   /* [((VarId,Kind))]                  */
1347 List  constrs0;  /* [((ConId,[((Type,VarId,Int))]))]  */
1348                  /* The Text is an optional field name
1349                     The Int indicates strictness */
1350     /* ToDo: worry about being given a decl for (->) ?
1351      * and worry about qualidents for ()
1352      */
1353 {
1354     Type    ty, resTy, selTy, conArgTy;
1355     List    tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
1356     List    ctx, ctx2;
1357     Triple  constr;
1358     Cell    conid;
1359     Pair    conArg, ctxElem;
1360     Text    conArgNm;
1361     Int     conArgStrictness;
1362
1363     Text t = textOf(tycon);
1364 #   ifdef DEBUG_IFACE
1365     fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
1366 #   endif
1367
1368     if (nonNull(findTycon(t))) {
1369         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1370                      textToStr(t)
1371         EEND;
1372     } else {
1373         Tycon tc        = newTycon(t);
1374         tycon(tc).text  = t;
1375         tycon(tc).line  = line;
1376         tycon(tc).arity = length(ktyvars);
1377         tycon(tc).kind  = tvsToKind(ktyvars);
1378         tycon(tc).what  = DATATYPE;
1379
1380         /* a list to accumulate selectors in :: [((VarId,Type))] */
1381         sels = NIL;
1382
1383         /* make resTy the result type of the constr, T v1 ... vn */
1384         resTy = tycon;
1385         for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
1386            resTy = ap(resTy,fst(hd(tmp)));
1387
1388         /* for each constructor ... */
1389         for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
1390            constr = hd(constrs);
1391            conid  = zfst(constr);
1392            fields = zsnd(constr);
1393
1394            /* Build type of constr and handle any selectors found.
1395               Also collect up tyvars occurring in the constr's arg
1396               types, so we can throw away irrelevant parts of the
1397               context later.
1398            */
1399            ty = resTy;
1400            tyvarsMentioned = NIL;
1401            /* tyvarsMentioned :: [VarId] */
1402
1403            conArgs = reverse(fields);
1404            for (; nonNull(conArgs); conArgs=tl(conArgs)) {
1405               conArg           = hd(conArgs); /* (Type,Text) */
1406               conArgTy         = zfst3(conArg);
1407               conArgNm         = zsnd3(conArg);
1408               conArgStrictness = intOf(zthd3(conArg));
1409               tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
1410                                             tyvarsMentioned);
1411               if (conArgStrictness > 0) conArgTy = bang(conArgTy);
1412               ty = fn(conArgTy,ty);
1413               if (nonNull(conArgNm)) {
1414                  /* a field name is mentioned too */
1415                  selTy = fn(resTy,conArgTy);
1416                  if (whatIs(tycon(tc).kind) != STAR)
1417                     selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
1418                  selTy = tvsToOffsets(line,selTy, ktyvars);
1419                  sels = cons( zpair(conArgNm,selTy), sels);
1420               }
1421            }
1422
1423            /* Now ty is the constructor's type, not including context.
1424               Throw away any parts of the context not mentioned in
1425               tyvarsMentioned, and use it to qualify ty.
1426            */
1427            ctx2 = NIL;
1428            for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
1429               ctxElem = hd(ctx);
1430               /* ctxElem :: ((QConId,VarId)) */
1431               if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
1432                  ctx2 = cons(ctxElem, ctx2);
1433            }
1434            if (nonNull(ctx2))
1435               ty = ap(QUAL,pair(ctx2,ty));
1436
1437            /* stick the tycon's kind on, if not simply STAR */
1438            if (whatIs(tycon(tc).kind) != STAR)
1439               ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
1440
1441            ty = tvsToOffsets(line,ty, ktyvars);
1442
1443            /* Finally, stick the constructor's type onto it. */
1444            hd(constrs) = ztriple(conid,fields,ty);
1445         }
1446
1447         /* Final result is that
1448            constrs :: [((ConId,[((Type,Text))],Type))]
1449                       lists the constructors and their types
1450            sels :: [((VarId,Type))]
1451                    lists the selectors and their types
1452         */
1453         tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
1454     }
1455 }
1456
1457
1458 static List startGHCConstrs ( Int line, List cons, List sels )
1459 {
1460     /* cons :: [((ConId,[((Type,Text,Int))],Type))] */
1461     /* sels :: [((VarId,Type))]                     */
1462     /* returns [Name]                               */
1463     List cs, ss;
1464     Int  conNo = length(cons)>1 ? 1 : 0;
1465     for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
1466         Name c  = startGHCConstr(line,conNo,hd(cs));
1467         hd(cs)  = c;
1468     }
1469     /* cons :: [Name] */
1470
1471     for(ss=sels; nonNull(ss); ss=tl(ss)) {
1472         hd(ss) = startGHCSel(line,hd(ss));
1473     }
1474     /* sels :: [Name] */
1475     return appendOnto(cons,sels);
1476 }
1477
1478
1479 static Name startGHCSel ( Int line, ZPair sel )
1480 {
1481     /* sel :: ((VarId, Type))  */
1482     Text t      = textOf(zfst(sel));
1483     Type type   = zsnd(sel);
1484
1485     Name n = findName(t);
1486     if (nonNull(n)) {
1487         ERRMSG(line) "Repeated definition for selector \"%s\"",
1488             textToStr(t)
1489         EEND;
1490     }
1491
1492     n              = newName(t,NIL);
1493     name(n).line   = line;
1494     name(n).number = SELNAME;
1495     name(n).arity  = 1;
1496     name(n).defn   = NIL;
1497     name(n).type = type;
1498     return n;
1499 }
1500
1501
1502 static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
1503 {
1504     /* constr :: ((ConId,[((Type,Text,Int))],Type)) */
1505     /* (ADR) ToDo: add rank2 annotation and existential annotation
1506      * these affect how constr can be used.
1507      */
1508     Text con   = textOf(zfst3(constr));
1509     Type type  = zthd3(constr);
1510     Int  arity = arityFromType(type);
1511     Name n = findName(con);     /* Allocate constructor fun name   */
1512     if (isNull(n)) {
1513         n = newName(con,NIL);
1514     } else if (name(n).defn!=PREDEFINED) {
1515         ERRMSG(line) "Repeated definition for constructor \"%s\"",
1516             textToStr(con)
1517         EEND;
1518     }
1519     name(n).arity  = arity;     /* Save constructor fun details    */
1520     name(n).line   = line;
1521     name(n).number = cfunNo(conNo);
1522     name(n).type   = type;
1523     return n;
1524 }
1525
1526
1527 static Void finishGHCDataDecl ( ConId tyc )
1528 {
1529     List  nms;
1530     Tycon tc = findTycon(textOf(tyc));
1531 #   ifdef DEBUG_IFACE
1532     printf ( "begin finishGHCDataDecl %s\n", textToStr(textOf(tyc)) );
1533 #   endif
1534     if (isNull(tc)) internal("finishGHCDataDecl");
1535
1536     for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) {
1537        Name n    = hd(nms);
1538        Int  line = name(n).line;
1539        assert(currentModule == name(n).mod);
1540        name(n).type = conidcellsToTycons(line,name(n).type);
1541     }
1542 }
1543
1544
1545 /* --------------------------------------------------------------------------
1546  * Newtype decls
1547  * ------------------------------------------------------------------------*/
1548
1549 Void startGHCNewType ( Int line, List ctx0,
1550                        ConId tycon, List tvs, Cell constr )
1551 {
1552     /* ctx0   :: [((QConId,VarId))]                */
1553     /* tycon  :: ConId                             */
1554     /* tvs    :: [((VarId,Kind))]                  */
1555     /* constr :: ((ConId,Type)) or NIL if abstract */
1556     List tmp;
1557     Type resTy;
1558     Text t = textOf(tycon);
1559 #   ifdef DEBUG_IFACE
1560     fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
1561 #   endif
1562     if (nonNull(findTycon(t))) {
1563         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1564                      textToStr(t)
1565         EEND;
1566     } else {
1567         Tycon tc        = newTycon(t);
1568         tycon(tc).line  = line;
1569         tycon(tc).arity = length(tvs);
1570         tycon(tc).what  = NEWTYPE;
1571         tycon(tc).kind  = tvsToKind(tvs);
1572         /* can't really do this until I've read in all synonyms */
1573
1574         if (isNull(constr)) {
1575            tycon(tc).defn = NIL;
1576         } else {
1577            /* constr :: ((ConId,Type)) */
1578            Text con   = textOf(zfst(constr));
1579            Type type  = zsnd(constr);
1580            Name n = findName(con);     /* Allocate constructor fun name   */
1581            if (isNull(n)) {
1582                n = newName(con,NIL);
1583            } else if (name(n).defn!=PREDEFINED) {
1584                ERRMSG(line) "Repeated definition for constructor \"%s\"",
1585                   textToStr(con)
1586                EEND;
1587            }
1588            name(n).arity  = 1;         /* Save constructor fun details    */
1589            name(n).line   = line;
1590            name(n).number = cfunNo(0);
1591            name(n).defn   = nameId;
1592            tycon(tc).defn = singleton(n);
1593
1594            /* make resTy the result type of the constr, T v1 ... vn */
1595            resTy = tycon;
1596            for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1597               resTy = ap(resTy,zfst(hd(tmp)));
1598            type = fn(type,resTy);
1599            if (nonNull(ctx0))
1600               type = ap(QUAL,pair(ctx0,type));
1601            type = tvsToOffsets(line,type,tvs);
1602            name(n).type   = type;
1603         }
1604     }
1605 }
1606
1607
1608 static Void finishGHCNewType ( ConId tyc )
1609 {
1610     Tycon tc = findTycon(textOf(tyc));
1611 #   ifdef DEBUG_IFACE
1612     printf ( "begin finishGHCNewType %s\n", textToStr(textOf(tyc)) );
1613 #   endif
1614
1615     if (isNull(tc)) internal("finishGHCNewType");
1616
1617     if (isNull(tycon(tc).defn)) {
1618        /* it's an abstract type */
1619     }
1620     else if (length(tycon(tc).defn) == 1) {
1621        /* As we expect, has a single constructor */
1622        Name n    = hd(tycon(tc).defn);
1623        Int  line = name(n).line;
1624        assert(currentModule == name(n).mod);
1625        name(n).type = conidcellsToTycons(line,name(n).type);
1626     } else {
1627        internal("finishGHCNewType(2)");
1628     }
1629 }
1630
1631
1632 /* --------------------------------------------------------------------------
1633  * Class declarations
1634  * ------------------------------------------------------------------------*/
1635
1636 Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
1637 Int   line;
1638 List  ctxt;       /* [((QConId, VarId))]   */
1639 ConId tc_name;    /* ConId                 */
1640 List  kinded_tvs; /* [((VarId, Kind))]     */
1641 List  mems0; {    /* [((VarId, Type))]     */
1642
1643     List mems;    /* [((VarId, Type))]     */
1644     List tvsInT;  /* [VarId] and then [((VarId,Kind))] */
1645     List tvs;     /* [((VarId,Kind))]      */
1646
1647     ZPair kinded_tv = hd(kinded_tvs);
1648     Text ct         = textOf(tc_name);
1649     Pair newCtx     = pair(tc_name, zfst(kinded_tv));
1650 #   ifdef DEBUG_IFACE
1651     printf ( "begin startGHCClass %s\n", textToStr(ct) );
1652 #   endif
1653
1654     if (length(kinded_tvs) != 1) {
1655         ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
1656         EEND;
1657     }
1658
1659     if (nonNull(findClass(ct))) {
1660         ERRMSG(line) "Repeated definition of class \"%s\"",
1661                      textToStr(ct)
1662         EEND;
1663     } else if (nonNull(findTycon(ct))) {
1664         ERRMSG(line) "\"%s\" used as both class and type constructor",
1665                      textToStr(ct)
1666         EEND;
1667     } else {
1668         Class nw              = newClass(ct);
1669         cclass(nw).text       = ct;
1670         cclass(nw).line       = line;
1671         cclass(nw).arity      = 1;
1672         cclass(nw).head       = ap(nw,mkOffset(0));
1673         cclass(nw).kinds      = singleton(STAR); /* absolutely no idea at all */
1674         cclass(nw).instances  = NIL;             /* what the kind should be   */
1675         cclass(nw).numSupers  = length(ctxt);
1676
1677         /* Kludge to map the single tyvar in the context to Offset 0.
1678            Need to do something better for multiparam type classes.
1679
1680         cclass(nw).supers     = tvsToOffsets(line,ctxt,
1681                                              singleton(pair(tv,STAR)));
1682         */
1683         cclass(nw).supers     = tvsToOffsets(line,ctxt,
1684                                              singleton(kinded_tv));
1685
1686
1687         for (mems=mems0; nonNull(mems); mems=tl(mems)) {
1688            ZPair mem  = hd(mems);
1689            Type  memT = zsnd(mem);
1690            Text  mnt  = textOf(zfst(mem));
1691            Name  mn;
1692
1693            /* Stick the new context on the member type */
1694            if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
1695            if (whatIs(memT)==QUAL) {
1696               memT = pair(QUAL,
1697                           pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
1698            } else {
1699               memT = pair(QUAL,
1700                           pair(singleton(newCtx),memT));
1701            }
1702
1703            /* Cook up a kind for the type. */
1704            tvsInT = ifTyvarsIn(memT);
1705            /* tvsInT :: [VarId] */
1706
1707            /* ToDo: maximally bogus */
1708            for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs))
1709               hd(tvs) = zpair(hd(tvs),STAR);
1710            /* tvsIntT :: [((VarId,STAR))] */
1711
1712            memT = mkPolyType(tvsToKind(tvsInT),memT);
1713            memT = tvsToOffsets(line,memT,tvsInT);
1714
1715            /* Park the type back on the member */
1716            mem = zpair(zfst(mem),memT);
1717
1718            /* Bind code to the member */
1719            mn = findName(mnt);
1720            if (nonNull(mn)) {
1721               ERRMSG(line)
1722                  "Repeated definition for class method \"%s\"",
1723                  textToStr(mnt)
1724               EEND;
1725            }
1726            mn = newName(mnt,NIL);
1727
1728            hd(mems) = mem;
1729         }
1730
1731         cclass(nw).members    = mems0;
1732         cclass(nw).numMembers = length(mems0);
1733
1734         /* (ADR) ToDo:
1735          * cclass(nw).dsels    = ?;
1736          * cclass(nw).dbuild   = ?;
1737          * cclass(nm).dcon     = ?;
1738          * cclass(nm).defaults = ?;
1739          */
1740     }
1741 }
1742
1743
1744 static Void finishGHCClass ( Tycon cls_tyc )
1745 {
1746     List  mems;
1747     Int   line;
1748     Int   ctr;
1749     Class nw = findClass ( textOf(cls_tyc) );
1750 #   ifdef DEBUG_IFACE
1751     printf ( "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
1752 #   endif
1753     if (isNull(nw)) internal("finishGHCClass");
1754
1755     line = cclass(nw).line;
1756     ctr  = - length(cclass(nw).members);
1757     assert (currentModule == cclass(nw).mod);
1758
1759     cclass(nw).level   = 0;  /* (ADR) ToDo: 1 + max (map level supers) */
1760     cclass(nw).head    = conidcellsToTycons(line,cclass(nw).head);
1761     cclass(nw).supers  = conidcellsToTycons(line,cclass(nw).supers);
1762     cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
1763
1764     for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
1765        Pair mem = hd(mems); /* (VarId, Type) */
1766        Text txt = textOf(fst(mem));
1767        Type ty  = snd(mem);
1768        Name n   = findName(txt);
1769        assert(nonNull(n));
1770        name(n).line   = cclass(nw).line;
1771        name(n).type   = ty;
1772        name(n).number = ctr++;
1773        hd(mems) = n;
1774     }
1775 }
1776
1777
1778 /* --------------------------------------------------------------------------
1779  * Instances
1780  * ------------------------------------------------------------------------*/
1781
1782 Inst startGHCInstance (line,ctxt0,cls,var)
1783 Int   line;
1784 List  ctxt0;  /* [((QConId, VarId))] */
1785 Type  cls;    /* Type  */
1786 VarId var; {  /* VarId */
1787     List tmp, tvs, ks;
1788     Inst in = newInst();
1789 #   ifdef DEBUG_IFACE
1790     printf ( "begin startGHCInstance\n" );
1791 #   endif
1792
1793     /* Make tvs into a list of tyvars with bogus kinds. */
1794     tvs = ifTyvarsIn(cls);
1795     /* tvs :: [VarId] */
1796
1797     ks = NIL;
1798     for (tmp = tvs; nonNull(tmp); tmp=tl(tmp)) {
1799        hd(tmp) = zpair(hd(tmp),STAR);
1800        ks = cons(STAR,ks);
1801     }
1802     /* tvs :: [((VarId,STAR))] */
1803     inst(in).line         = line;
1804     inst(in).implements   = NIL;
1805     inst(in).kinds        = ks;
1806     inst(in).specifics    = tvsToOffsets(line,ctxt0,tvs);
1807     inst(in).numSpecifics = length(ctxt0);
1808     inst(in).head         = tvsToOffsets(line,cls,tvs);
1809
1810     /* Figure out the name of the class being instanced, and store it
1811        at inst(in).c.  finishGHCInstance will resolve it to a real Class. */
1812     {
1813        Cell cl = inst(in).head;
1814        while (isAp(cl)) cl = arg(cl);
1815        assert(whatIs(cl)==DICTAP);
1816        cl = unap(DICTAP,cl);
1817        cl = fst(cl);
1818        assert ( isQCon(cl) );
1819        inst(in).c = cl;
1820     }
1821
1822 #if 0
1823     Is this still needed?
1824     {
1825         Name b         = newName(inventText(),NIL);
1826         name(b).line   = line;
1827         name(b).arity  = length(ctxt); /* unused? */
1828         name(b).number = DFUNNAME;
1829         inst(in).builder = b;
1830         bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
1831     }
1832 #endif
1833     return in;
1834 }
1835
1836
1837 static Void finishGHCInstance ( Inst in )
1838 {
1839     Int    line;
1840     Class  c;
1841     Type   cls;
1842
1843 #   ifdef DEBUG_IFACE
1844     printf ( "begin finishGHCInstance\n" );
1845 #   endif
1846
1847     assert (nonNull(in));
1848     line = inst(in).line;
1849     assert (currentModule==inst(in).mod);
1850
1851     /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
1852        since beginGHCInstance couldn't possibly have resolved it to
1853        a Class at that point.  We convert it to a Class now.
1854     */
1855     c = inst(in).c;
1856     assert(isQCon(c));
1857     c = findQualClassWithoutConsultingExportList(c);
1858     assert(nonNull(c));
1859     inst(in).c = c;
1860
1861     inst(in).head         = conidcellsToTycons(line,inst(in).head);
1862     inst(in).specifics    = conidcellsToTycons(line,inst(in).specifics);
1863     cclass(c).instances   = cons(in,cclass(c).instances);
1864 }
1865
1866
1867 /* --------------------------------------------------------------------------
1868  * Helper fns
1869  * ------------------------------------------------------------------------*/
1870
1871 /* This is called from the startGHC* functions.  It traverses a structure
1872    and converts varidcells, ie, type variables parsed by the interface
1873    parser, into Offsets, which is how Hugs wants to see them internally.
1874    The Offset for a type variable is determined by its place in the list
1875    passed as the second arg; the associated kinds are irrelevant.
1876
1877    ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
1878 */
1879
1880 /* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
1881 static Type tvsToOffsets(line,type,ktyvars)
1882 Int  line;
1883 Type type;
1884 List ktyvars; { /* [((VarId,Kind))] */
1885    switch (whatIs(type)) {
1886       case NIL:
1887       case TUPLE:
1888       case QUALIDENT:
1889       case CONIDCELL:
1890       case TYCON:
1891          return type;
1892       case ZTUP2: /* convert to the untyped representation */
1893          return ap( tvsToOffsets(line,zfst(type),ktyvars),
1894                     tvsToOffsets(line,zsnd(type),ktyvars) );
1895       case AP:
1896          return ap( tvsToOffsets(line,fun(type),ktyvars),
1897                     tvsToOffsets(line,arg(type),ktyvars) );
1898       case POLYTYPE:
1899          return mkPolyType (
1900                    polySigOf(type),
1901                    tvsToOffsets(line,monotypeOf(type),ktyvars)
1902                 );
1903          break;
1904       case QUAL:
1905          return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
1906                                tvsToOffsets(line,snd(snd(type)),ktyvars)));
1907       case DICTAP: /* bogus ?? */
1908          return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
1909       case UNBOXEDTUP:  /* bogus?? */
1910          return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
1911       case BANG:  /* bogus?? */
1912          return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
1913       case VARIDCELL: /* Ha! some real work to do! */
1914        { Int i = 0;
1915          Text tv = textOf(type);
1916          for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
1917             Cell varid;
1918             Text tt;
1919             assert(isZPair(hd(ktyvars)));
1920             varid = zfst(hd(ktyvars));
1921             tt    = textOf(varid);
1922             if (tv == tt) return mkOffset(i);
1923          }
1924          ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
1925          EEND;
1926          break;
1927        }
1928       default:
1929          fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
1930          print(type,20);
1931          fprintf(stderr,"\n");
1932          assert(0);
1933    }
1934    assert(0);
1935    return NIL; /* NOTREACHED */
1936 }
1937
1938
1939 /* This is called from the finishGHC* functions.  It traverses a structure
1940    and converts conidcells, ie, type constructors parsed by the interface
1941    parser, into Tycons (or Classes), which is how Hugs wants to see them
1942    internally.  Calls to this fn have to be deferred to the second phase
1943    of interface loading (finishGHC* rather than startGHC*) so that all relevant
1944    Tycons or Classes have been loaded into the symbol tables and can be
1945    looked up.
1946 */
1947 static Type conidcellsToTycons ( Int line, Type type )
1948 {
1949    switch (whatIs(type)) {
1950       case NIL:
1951       case OFFSET:
1952       case TYCON:
1953       case CLASS:
1954       case VARIDCELL:
1955       case TUPLE:
1956       case STAR:
1957          return type;
1958       case QUALIDENT:
1959        { Cell t;  /* Tycon or Class */
1960          Text m     = qmodOf(type);
1961          Module mod = findModule(m);
1962          if (isNull(mod)) {
1963             ERRMSG(line)
1964                "Undefined module in qualified name \"%s\"",
1965                identToStr(type)
1966             EEND;
1967             return NIL;
1968          }
1969          t = findQualTyconWithoutConsultingExportList(type);
1970          if (nonNull(t)) return t;
1971          t = findQualClassWithoutConsultingExportList(type);
1972          if (nonNull(t)) return t;
1973          ERRMSG(line)
1974               "Undefined qualified class or type \"%s\"",
1975               identToStr(type)
1976          EEND;
1977          return NIL;
1978        }
1979       case CONIDCELL:
1980        { Tycon tc;
1981          Class cl;
1982          cl = findQualClass(type);
1983          if (nonNull(cl)) return cl;
1984          if (textOf(type)==findText("[]"))
1985             /* a hack; magically qualify [] into PrelBase.[] */
1986             return conidcellsToTycons(line,
1987                                       mkQualId(mkCon(findText("PrelBase")),type));
1988          tc = findQualTycon(type);
1989          if (nonNull(tc)) return tc;
1990          ERRMSG(line)
1991              "Undefined class or type constructor \"%s\"",
1992              identToStr(type)
1993          EEND;
1994          return NIL;
1995        }
1996       case AP:
1997          return ap( conidcellsToTycons(line,fun(type)),
1998                     conidcellsToTycons(line,arg(type)) );
1999       case ZTUP2: /* convert to std pair */
2000          return ap( conidcellsToTycons(line,zfst(type)),
2001                     conidcellsToTycons(line,zsnd(type)) );
2002
2003       case POLYTYPE:
2004          return mkPolyType (
2005                    polySigOf(type),
2006                    conidcellsToTycons(line,monotypeOf(type))
2007                 );
2008          break;
2009       case QUAL:
2010          return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
2011                                conidcellsToTycons(line,snd(snd(type)))));
2012       case DICTAP: /* bogus?? */
2013          return ap(DICTAP, conidcellsToTycons(line, snd(type)));
2014       case UNBOXEDTUP:
2015          return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
2016       case BANG:
2017          return ap(BANG, conidcellsToTycons(line, snd(type)));
2018       default:
2019          fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
2020                  whatIs(type));
2021          print(type,20);
2022          fprintf(stderr,"\n");
2023          assert(0);
2024    }
2025    assert(0);
2026    return NIL; /* NOTREACHED */
2027 }
2028
2029
2030 /* Find out if a type mentions a type constructor not present in
2031    the supplied list of qualified tycons.
2032 */
2033 static Bool allTypesKnown ( Type  type,
2034                             List  aktys /* [QualId] */,
2035                             ConId thisMod )
2036 {
2037    switch (whatIs(type)) {
2038       case NIL:
2039       case OFFSET:
2040       case VARIDCELL:
2041       case TUPLE:
2042          return TRUE;
2043       case AP:
2044          return allTypesKnown(fun(type),aktys,thisMod)
2045                 && allTypesKnown(arg(type),aktys,thisMod);
2046       case ZTUP2:
2047          return allTypesKnown(zfst(type),aktys,thisMod)
2048                 && allTypesKnown(zsnd(type),aktys,thisMod);
2049       case DICTAP:
2050          return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
2051
2052       case CONIDCELL:
2053         if (textOf(type)==findText("[]"))
2054             /* a hack; magically qualify [] into PrelBase.[] */
2055             type = mkQualId(mkCon(findText("PrelBase")),type); else
2056             type = mkQualId(thisMod,type);
2057          /* fall through */
2058       case QUALIDENT:
2059          if (isNull(qualidIsMember(type,aktys))) goto missing;
2060          return TRUE;
2061
2062       default:
2063          fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
2064          print(type,10);printf("\n");
2065          internal("allTypesKnown");
2066          return TRUE; /*notreached*/
2067    }
2068   missing:
2069    printf ( "allTypesKnown: unknown " ); print(type,10); printf("\n");
2070    return FALSE;
2071 }
2072
2073
2074 /* --------------------------------------------------------------------------
2075  * Utilities
2076  *
2077  * None of these do lookups or require that lookups have been resolved
2078  * so they can be performed while reading interfaces.
2079  * ------------------------------------------------------------------------*/
2080
2081 /* tvsToKind :: [((VarId,Kind))] -> Kinds */
2082 static Kinds tvsToKind(tvs)
2083 List tvs; { /* [((VarId,Kind))] */
2084     List  rs;
2085     Kinds r  = STAR;
2086     for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
2087         if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)");
2088         if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)");
2089         r = ap(zsnd(hd(rs)),r);
2090     }
2091     return r;
2092 }
2093
2094
2095 static Int arityInclDictParams ( Type type )
2096 {
2097    Int arity = 0;
2098    if (isPolyType(type)) type = monotypeOf(type);
2099
2100    if (whatIs(type) == QUAL)
2101    {
2102       arity += length ( fst(snd(type)) );
2103       type = snd(snd(type));
2104    }
2105    while (isAp(type) && getHead(type)==typeArrow) {
2106       arity++;
2107       type = arg(type);
2108    }
2109    return arity;
2110 }
2111
2112 /* arity of a constructor with this type */
2113 static Int arityFromType(type)
2114 Type type; {
2115     Int arity = 0;
2116     if (isPolyType(type)) {
2117         type = monotypeOf(type);
2118     }
2119     if (whatIs(type) == QUAL) {
2120         type = snd(snd(type));
2121     }
2122     if (whatIs(type) == EXIST) {
2123         type = snd(snd(type));
2124     }
2125     if (whatIs(type)==RANK2) {
2126         type = snd(snd(type));
2127     }
2128     while (isAp(type) && getHead(type)==typeArrow) {
2129         arity++;
2130         type = arg(type);
2131     }
2132     return arity;
2133 }
2134
2135
2136 /* ifTyvarsIn :: Type -> [VarId]
2137    The returned list has no duplicates -- is a set.
2138 */
2139 static List ifTyvarsIn(type)
2140 Type type; {
2141     List vs = typeVarsIn(type,NIL,NIL,NIL);
2142     List vs2 = vs;
2143     for (; nonNull(vs2); vs2=tl(vs2))
2144        if (whatIs(hd(vs2)) != VARIDCELL)
2145           internal("ifTyvarsIn");
2146     return vs;
2147 }
2148
2149
2150 /* --------------------------------------------------------------------------
2151  * ELF specifics
2152  * ------------------------------------------------------------------------*/
2153
2154 #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
2155
2156 #include <elf.h>
2157
2158 static char* findElfSection ( void* objImage, Elf32_Word sh_type )
2159 {
2160    Int i;
2161    char* ehdrC = (char*)objImage;
2162    Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
2163    Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
2164    char* ptr = NULL;
2165    for (i = 0; i < ehdr->e_shnum; i++) {
2166       if (shdr[i].sh_type == sh_type &&
2167           i !=  ehdr->e_shstrndx) {
2168          ptr = ehdrC + shdr[i].sh_offset;
2169          break;
2170       }
2171    }
2172    return ptr;
2173 }
2174
2175
2176 static Void resolveReferencesInObjectModule_elf ( Module m,
2177                                                         Bool   verb )
2178 {
2179    char symbol[1000]; // ToDo
2180    int i, j;
2181    Elf32_Sym*  stab = NULL;
2182    char* strtab;
2183    char* ehdrC = (char*)(module(m).oImage);
2184    Elf32_Ehdr* ehdr = (Elf32_Ehdr*) ehdrC;
2185    Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
2186    Elf32_Word* targ;
2187    // first find "the" symbol table
2188    // why is this commented out???
2189    stab = (Elf32_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
2190
2191    // also go find the string table
2192    strtab = findElfSection ( ehdrC, SHT_STRTAB );
2193
2194    if (!stab || !strtab)
2195       internal("resolveReferencesInObjectModule_elf");
2196
2197    for (i = 0; i < ehdr->e_shnum; i++) {
2198       if (shdr[i].sh_type == SHT_REL ) {
2199          Elf32_Rel*  rtab = (Elf32_Rel*) (ehdrC + shdr[i].sh_offset);
2200          Int         nent = shdr[i].sh_size / sizeof(Elf32_Rel);
2201          Int target_shndx = shdr[i].sh_info;
2202          Int symtab_shndx = shdr[i].sh_link;
2203          stab  = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2204          targ  = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
2205          if (verb)
2206          fprintf ( stderr,
2207                   "relocations for section %d using symtab %d\n",
2208                   target_shndx, symtab_shndx );
2209          for (j = 0; j < nent; j++) {
2210             Elf32_Addr offset = rtab[j].r_offset;
2211             Elf32_Word info   = rtab[j].r_info;
2212
2213             Elf32_Addr  P = ((Elf32_Addr)targ) + offset;
2214             Elf32_Word* pP = (Elf32_Word*)P;
2215             Elf32_Addr  A = *pP;
2216             Elf32_Addr  S;
2217
2218             if (verb) fprintf ( stderr, "Rel entry %3d is raw(%6p %6p)   ",
2219                                 j, (void*)offset, (void*)info );
2220             if (!info) {
2221                if (verb) fprintf ( stderr, " ZERO\n" );
2222                S = 0;
2223             } else {
2224                if (stab[ ELF32_R_SYM(info)].st_name == 0) {
2225                   if (verb) fprintf ( stderr, "(noname)  ");
2226                   /* nameless (local) symbol */
2227                   S = (Elf32_Addr)(ehdrC
2228                                    + shdr[stab[ELF32_R_SYM(info)].st_shndx ].sh_offset
2229                                    + stab[ELF32_R_SYM(info)].st_value
2230                                   );
2231                   strcpy ( symbol, "(noname)");
2232                } else {
2233                   strcpy ( symbol, strtab+stab[ ELF32_R_SYM(info)].st_name );
2234                   if (verb) fprintf ( stderr, "`%s'  ", symbol );
2235                   S = (Elf32_Addr)lookupObjName ( symbol );
2236                }
2237                if (verb) fprintf ( stderr, "resolves to %p\n", (void*)S );
2238                if (!S) {
2239                   fprintf ( stderr, "link failure for `%s'\n",
2240                                     strtab+stab[ ELF32_R_SYM(info)].st_name );
2241                   assert(0);
2242                }
2243             }
2244             //fprintf ( stderr, "Reloc: P = %p   S = %p   A = %p\n\n",
2245             //      (void*)P, (void*)S, (void*)A );
2246             switch (ELF32_R_TYPE(info)) {
2247                case R_386_32:   *pP = S + A;     break;
2248                case R_386_PC32: *pP = S + A - P; break;
2249                default: fprintf(stderr,
2250                                 "unhandled ELF relocation type %d\n",
2251                                 ELF32_R_TYPE(info));
2252                         assert(0);
2253             }
2254
2255          }
2256       }
2257       else
2258       if (shdr[i].sh_type == SHT_RELA) {
2259          fprintf ( stderr, "RelA style reloc table -- not yet done" );
2260          assert(0);
2261       }
2262    }
2263 }
2264
2265
2266 static Bool validateOImage_elf ( void*  imgV,
2267                                        Int    size,
2268                                        Bool   verb )
2269 {
2270    Elf32_Shdr* shdr;
2271    Elf32_Sym*  stab;
2272    int i, j, nent, nstrtab, nsymtabs;
2273    char* sh_strtab;
2274    char* strtab;
2275
2276    char* ehdrC = (char*)imgV;
2277    Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
2278
2279    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
2280        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
2281        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
2282        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
2283       if (verb) fprintf ( stderr, "Not an ELF header\n" );
2284       return FALSE;
2285    }
2286    if (verb) fprintf ( stderr, "Is an ELF header\n" );
2287
2288    if (ehdr->e_ident[EI_CLASS] != ELFCLASS32) {
2289       if (verb) fprintf ( stderr, "Not 32 bit ELF\n" );
2290       return FALSE;
2291    }
2292    if (verb) fprintf ( stderr, "Is 32 bit ELF\n" );
2293
2294    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
2295       if (verb) fprintf ( stderr, "Is little-endian\n" );
2296    } else
2297    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
2298       if (verb) fprintf ( stderr, "Is big-endian\n" );
2299    } else {
2300       if (verb) fprintf ( stderr, "Unknown endiannness\n" );
2301       return FALSE;
2302    }
2303
2304    if (ehdr->e_type != ET_REL) {
2305       if (verb) fprintf ( stderr, "Not a relocatable object (.o) file\n" );
2306       return FALSE;
2307    }
2308    if (verb) fprintf ( stderr, "Is a relocatable object (.o) file\n" );
2309
2310    if (verb) fprintf ( stderr, "Architecture is " );
2311    switch (ehdr->e_machine) {
2312       case EM_386:   if (verb) fprintf ( stderr, "x86\n" ); break;
2313       case EM_SPARC: if (verb) fprintf ( stderr, "sparc\n" ); break;
2314       default:       if (verb) fprintf ( stderr, "unknown\n" ); return FALSE;
2315    }
2316
2317    if (verb)
2318    fprintf ( stderr,
2319              "\nSection header table: start %d, n_entries %d, ent_size %d\n",
2320              ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  );
2321
2322    assert (ehdr->e_shentsize == sizeof(Elf32_Shdr));
2323
2324    shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
2325
2326    if (ehdr->e_shstrndx == SHN_UNDEF) {
2327       if (verb) fprintf ( stderr, "No section header string table\n" );
2328       sh_strtab = NULL;
2329       return FALSE;
2330    } else {
2331       if (verb) fprintf (  stderr,"Section header string table is section %d\n",
2332                           ehdr->e_shstrndx);
2333       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2334    }
2335
2336    for (i = 0; i < ehdr->e_shnum; i++) {
2337       if (verb) fprintf ( stderr, "%2d:  ", i );
2338       if (verb) fprintf ( stderr, "type=%2d  ", shdr[i].sh_type );
2339       if (verb) fprintf ( stderr, "size=%4d  ", shdr[i].sh_size );
2340       if (verb) fprintf ( stderr, "offs=%4d  ", shdr[i].sh_offset );
2341       if (verb) fprintf ( stderr, "  (%p .. %p)  ",
2342                ehdrC + shdr[i].sh_offset,
2343                ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
2344
2345       if (shdr[i].sh_type == SHT_REL  && verb) fprintf ( stderr, "Rel  " ); else
2346       if (shdr[i].sh_type == SHT_RELA && verb) fprintf ( stderr, "RelA " ); else
2347       if (verb)                                fprintf ( stderr, "     " );
2348       if (sh_strtab && verb)
2349          fprintf ( stderr, "sname=%s", sh_strtab + shdr[i].sh_name );
2350       if (verb) fprintf ( stderr, "\n" );
2351    }
2352
2353    if (verb) fprintf ( stderr, "\n\nString tables\n" );
2354    strtab = NULL;
2355    nstrtab = 0;
2356    for (i = 0; i < ehdr->e_shnum; i++) {
2357       if (shdr[i].sh_type == SHT_STRTAB &&
2358           i !=  ehdr->e_shstrndx) {
2359          if (verb)
2360             fprintf ( stderr, "   section %d is a normal string table\n", i );
2361          strtab = ehdrC + shdr[i].sh_offset;
2362          nstrtab++;
2363       }
2364    }
2365    if (nstrtab != 1) {
2366       if (verb) fprintf ( stderr, "WARNING: no string tables, or too many\n" );
2367       return FALSE;
2368    }
2369
2370    nsymtabs = 0;
2371    if (verb) fprintf ( stderr, "\n\nSymbol tables\n" );
2372    for (i = 0; i < ehdr->e_shnum; i++) {
2373       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2374       if (verb) fprintf ( stderr, "section %d is a symbol table\n", i );
2375       nsymtabs++;
2376       stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
2377       nent = shdr[i].sh_size / sizeof(Elf32_Sym);
2378       if (verb) fprintf ( stderr, "   number of entries is apparently %d (%d rem)\n",
2379                nent,
2380                shdr[i].sh_size % sizeof(Elf32_Sym)
2381              );
2382       if (0 != shdr[i].sh_size % sizeof(Elf32_Sym)) {
2383          if (verb) fprintf ( stderr, "non-integral number of symbol table entries\n");
2384          return FALSE;
2385       }
2386       for (j = 0; j < nent; j++) {
2387          if (verb) fprintf ( stderr, "   %2d  ", j );
2388          if (verb) fprintf ( stderr, "  sec=%-5d  size=%-3d  val=%-5p  ",
2389                              (int)stab[j].st_shndx,
2390                              (int)stab[j].st_size,
2391                              (char*)stab[j].st_value );
2392
2393          if (verb) fprintf ( stderr, "type=" );
2394          switch (ELF32_ST_TYPE(stab[j].st_info)) {
2395             case STT_NOTYPE:  if (verb) fprintf ( stderr, "notype " ); break;
2396             case STT_OBJECT:  if (verb) fprintf ( stderr, "object " ); break;
2397             case STT_FUNC  :  if (verb) fprintf ( stderr, "func   " ); break;
2398             case STT_SECTION: if (verb) fprintf ( stderr, "section" ); break;
2399             case STT_FILE:    if (verb) fprintf ( stderr, "file   " ); break;
2400             default:          if (verb) fprintf ( stderr, "?      " ); break;
2401          }
2402          if (verb) fprintf ( stderr, "  " );
2403
2404          if (verb) fprintf ( stderr, "bind=" );
2405          switch (ELF32_ST_BIND(stab[j].st_info)) {
2406             case STB_LOCAL :  if (verb) fprintf ( stderr, "local " ); break;
2407             case STB_GLOBAL:  if (verb) fprintf ( stderr, "global" ); break;
2408             case STB_WEAK  :  if (verb) fprintf ( stderr, "weak  " ); break;
2409             default:          if (verb) fprintf ( stderr, "?     " ); break;
2410          }
2411          if (verb) fprintf ( stderr, "  " );
2412
2413          if (verb) fprintf ( stderr, "name=%s\n", strtab + stab[j].st_name );
2414       }
2415    }
2416
2417    if (nsymtabs == 0) {
2418       if (verb) fprintf ( stderr, "Didn't find any symbol tables\n" );
2419       return FALSE;
2420    }
2421
2422    return TRUE;
2423 }
2424
2425
2426 static void readSyms_elf ( Module m, Bool verb )
2427 {
2428    int i, j, k, nent;
2429    Elf32_Sym* stab;
2430
2431    char*       ehdrC      = (char*)(module(m).oImage);
2432    Elf32_Ehdr* ehdr       = (Elf32_Ehdr*)ehdrC;
2433    char*       strtab     = findElfSection ( ehdrC, SHT_STRTAB );
2434    Elf32_Shdr* shdr       = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
2435    char*       sh_strtab  = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2436
2437    if (!strtab) internal("readSyms_elf");
2438
2439    k = 0;
2440    for (i = 0; i < ehdr->e_shnum; i++) {
2441
2442       /* make a HugsDLSection entry for relevant sections */
2443       DLSect kind = HUGS_DL_SECTION_OTHER;
2444       if (0==strcmp(".data",sh_strtab+shdr[i].sh_name) ||
2445           0==strcmp(".data1",sh_strtab+shdr[i].sh_name))
2446          kind = HUGS_DL_SECTION_RWDATA;
2447       if (0==strcmp(".text",sh_strtab+shdr[i].sh_name) ||
2448           0==strcmp(".rodata",sh_strtab+shdr[i].sh_name) ||
2449           0==strcmp(".rodata1",sh_strtab+shdr[i].sh_name))
2450          kind = HUGS_DL_SECTION_CODE_OR_RODATA;
2451       if (kind != HUGS_DL_SECTION_OTHER)
2452          addDLSect (
2453             m,
2454             ehdrC + shdr[i].sh_offset,
2455             ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1,
2456             kind
2457          );
2458
2459       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2460
2461       /* copy stuff into this module's object symbol table */
2462       stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
2463       nent = shdr[i].sh_size / sizeof(Elf32_Sym);
2464       for (j = 0; j < nent; j++) {
2465          if ( ( ELF32_ST_BIND(stab[j].st_info)==STB_GLOBAL ||
2466                 ELF32_ST_BIND(stab[j].st_info)==STB_LOCAL
2467               )
2468               &&
2469               ( ELF32_ST_TYPE(stab[j].st_info)==STT_FUNC ||
2470                 ELF32_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
2471                 ELF32_ST_TYPE(stab[j].st_info)==STT_NOTYPE)
2472               ) {
2473             char* nm = strtab + stab[j].st_name;
2474             char* ad = ehdrC
2475                        + shdr[ stab[j].st_shndx ].sh_offset
2476                        + stab[j].st_value;
2477             assert(nm);
2478             assert(ad);
2479             if (verb)
2480                fprintf(stderr, "addOTabName: %10p  %s %s\n",
2481                        ad, textToStr(module(m).text), nm );
2482             addOTabName ( m, nm, ad );
2483          }
2484          //else fprintf(stderr, "skipping `%s'\n", strtab + stab[j].st_name );
2485       }
2486
2487    }
2488 }
2489
2490 #endif /* defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) */
2491
2492
2493 /* --------------------------------------------------------------------------
2494  * Arch-independent interface to the runtime linker
2495  * ------------------------------------------------------------------------*/
2496
2497 static Bool validateOImage ( void* img, Int size, Bool verb )
2498 {
2499 #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
2500    return
2501       validateOImage_elf ( img, size, verb );
2502 #else
2503    internal("validateOImage: not implemented on this platform");
2504 #endif
2505 }
2506
2507
2508 static Void resolveReferencesInObjectModule ( Module m, Bool verb )
2509 {
2510 #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
2511    resolveReferencesInObjectModule_elf ( m, verb );
2512 #else
2513    internal("resolveReferencesInObjectModule: not implemented on this platform");
2514 #endif
2515 }
2516
2517
2518 static Void readSyms ( Module m, Bool verb )
2519 {
2520 #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
2521    readSyms_elf ( m, verb );
2522 #else
2523    internal("readSyms: not implemented on this platform");
2524 #endif
2525 }
2526
2527
2528 /* --------------------------------------------------------------------------
2529  * General object symbol query stuff
2530  * ------------------------------------------------------------------------*/
2531
2532 /* entirely bogus claims about types of these symbols */
2533 extern int stg_gc_enter_1;
2534 extern int stg_chk_0;
2535 extern int stg_chk_1;
2536 extern int stg_update_PAP;
2537 extern int __ap_2_upd_info;
2538 extern int MainRegTable;
2539 extern int Upd_frame_info;
2540 extern int CAF_BLACKHOLE_info;
2541 extern int IND_STATIC_info;
2542 extern int newCAF;
2543
2544 OSym rtsTab[]
2545    = {
2546        { "stg_gc_enter_1",        &stg_gc_enter_1     },
2547        { "stg_chk_0",             &stg_chk_0          },
2548        { "stg_chk_1",             &stg_chk_1          },
2549        { "stg_update_PAP",        &stg_update_PAP     },
2550        { "__ap_2_upd_info",       &__ap_2_upd_info    },
2551        { "MainRegTable",          &MainRegTable       },
2552        { "Upd_frame_info",        &Upd_frame_info     },
2553        { "CAF_BLACKHOLE_info",    &CAF_BLACKHOLE_info },
2554        { "IND_STATIC_info",       &IND_STATIC_info    },
2555        { "newCAF",                &newCAF             },
2556        {0,0}
2557      };
2558
2559
2560 void* lookupObjName ( char* nm )
2561 {
2562    int    k;
2563    char*  pp;
2564    void*  a;
2565    Text   t;
2566    Module m;
2567    char   nm2[200];
2568
2569    nm2[199] = 0;
2570    strncpy(nm2,nm,200);
2571
2572    // first see if it's an RTS name
2573    for (k = 0; rtsTab[k].nm; k++)
2574       if (0==strcmp(nm2,rtsTab[k].nm))
2575          return rtsTab[k].ad;
2576
2577    // if not an RTS name, look in the
2578    // relevant module's object symbol table
2579    pp = strchr(nm2, '_');
2580    if (!pp) goto not_found;
2581    *pp = 0;
2582    t = unZcodeThenFindText(nm2);
2583    m = findModule(t);
2584    if (isNull(m)) goto not_found;
2585 fprintf(stderr, "   %%%% %s\n", nm );
2586    a = lookupOTabName ( m, nm );
2587    if (a) return a;
2588
2589   not_found:
2590    fprintf ( stderr,
2591              "lookupObjName: can't resolve name `%s'\n",
2592              nm );
2593    return NULL;
2594 }
2595
2596
2597 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
2598 {
2599    return
2600       lookupDLSect(p) == HUGS_DL_SECTION_CODE_OR_RODATA;
2601 }
2602
2603
2604 int is_dynamically_loaded_rwdata_ptr ( char* p )
2605 {
2606    return
2607       lookupDLSect(p) == HUGS_DL_SECTION_RWDATA;
2608 }
2609
2610
2611 int is_not_dynamically_loaded_ptr ( char* p )
2612 {
2613    return
2614       lookupDLSect(p) == HUGS_DL_SECTION_OTHER;
2615 }
2616
2617
2618 /* --------------------------------------------------------------------------
2619  * Control:
2620  * ------------------------------------------------------------------------*/
2621
2622 Void interface(what)
2623 Int what; {
2624     switch (what) {
2625        case POSTPREL: break;
2626
2627        case PREPREL:
2628        case RESET:
2629           ifaces_outstanding  = NIL;
2630           break;
2631        case MARK:
2632           mark(ifaces_outstanding);
2633           break;
2634     }
2635 }
2636
2637 /*-------------------------------------------------------------------------*/