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