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.16 $
  11  * $Date: 2000/01/05 15:57:40 $
  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                addName(c);
1096                break;
1097
1098             case CONIDCELL: /* non data tycon */
1099                q = mkQualId(exmod,ex);
1100                c = findQualTyconWithoutConsultingExportList ( q );
1101                if (isNull(c)) goto notfound;
1102                fprintf(stderr, "   type %s\n", textToStr(textOf(ex)) );
1103                module(mod).exports = cons(c, module(mod).exports);
1104                addTycon(c);
1105                break;
1106
1107             case ZTUP2: /* data T = C1 ... Cn  or class C where f1 ... fn */
1108                subents = zsnd(ex);  /* :: [ConVarId] */
1109                ex      = zfst(ex);  /* :: ConId */
1110                q       = mkQualId(exmod,ex);
1111                c       = findQualTyconWithoutConsultingExportList ( q );
1112
1113                if (nonNull(c)) { /* data */
1114                   fprintf(stderr, "   data/newtype %s = { ", textToStr(textOf(ex)) );
1115                   assert(tycon(c).what == DATATYPE || tycon(c).what==NEWTYPE);
1116                   abstract = isNull(tycon(c).defn);
1117                   /* This data/newtype could be abstract even tho the export list
1118                      says to export it non-abstractly.  That happens if it was
1119                      imported from some other module and is now being re-exported,
1120                      and previous cleanup phases have abstractified it in the
1121                      original (defining) module.
1122                   */
1123                   if (abstract) {
1124                      module(mod).exports = cons(c, module(mod).exports);
1125                      addTycon(c);
1126                      fprintf ( stderr, "(abstract) ");
1127                   } else {
1128                      module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1129                      addTycon(c);
1130                      for (; nonNull(subents); subents = tl(subents)) {
1131                         Cell ent2 = hd(subents);
1132                         assert(isCon(ent2) || isVar(ent2));
1133                                               /* isVar since could be a field name */
1134                         q = mkQualId(exmod,ent2);
1135                         c = findQualNameWithoutConsultingExportList ( q );
1136                         fprintf(stderr, "%s ", textToStr(name(c).text));
1137                         assert(nonNull(c));
1138                         module(mod).exports = cons(c, module(mod).exports);
1139                         addName(c);
1140                      }
1141                   }
1142                   fprintf(stderr, "}\n" );
1143                } else { /* class */
1144                   q = mkQualId(exmod,ex);
1145                   c = findQualClassWithoutConsultingExportList ( q );
1146                   if (isNull(c)) goto notfound;
1147                   fprintf(stderr, "   class %s { ", textToStr(textOf(ex)) );
1148                   module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1149                   addClass(c);
1150                   for (; nonNull(subents); subents = tl(subents)) {
1151                      Cell ent2 = hd(subents);
1152                      assert(isVar(ent2));
1153                      q = mkQualId(exmod,ent2);
1154                      c = findQualNameWithoutConsultingExportList ( q );
1155                      fprintf(stderr, "%s ", textToStr(name(c).text));
1156                      if (isNull(c)) goto notfound;
1157                      module(mod).exports = cons(c, module(mod).exports);
1158                      addName(c);
1159                   }
1160                   fprintf(stderr, "}\n" );
1161                }
1162                break;
1163
1164             default:
1165                internal("finishExports(2)");
1166
1167          } /* switch */
1168          continue;  /* so notfound: can be placed after this */
1169
1170         notfound:
1171          /* q holds what ain't found */
1172          assert(whatIs(q)==QUALIDENT);
1173          fprintf( stderr, "   ------ IGNORED: %s.%s\n",
1174                   textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
1175          continue;
1176       }
1177    }
1178
1179 #if 0
1180    if (preludeLoaded) {
1181       /* do the implicit 'import Prelude' thing */
1182       List pxs = module(modulePrelude).exports;
1183       for (; nonNull(pxs); pxs=tl(pxs)) {
1184          Cell px = hd(pxs);
1185          again:
1186          switch (whatIs(px)) {
1187             case AP:
1188                px = fst(px);
1189                goto again;
1190             case NAME:
1191                module(mod).names = cons ( px, module(mod).names );
1192                break;
1193             case TYCON:
1194                module(mod).tycons = cons ( px, module(mod).tycons );
1195                break;
1196             case CLASS:
1197                module(mod).classes = cons ( px, module(mod).classes );
1198                break;
1199             default:
1200                fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
1201                internal("finishGHCModule -- implicit import Prelude");
1202                break;
1203          }
1204       }
1205    }
1206 #endif
1207
1208    /* Last, but by no means least ... */
1209    if (!ocResolve(module(mod).object,0||VERBOSE))
1210       internal("finishGHCModule: object resolution failed");
1211
1212    for (oc=module(mod).objectExtras; oc; oc=oc->next) {
1213       if (!ocResolve(oc, 0||VERBOSE))
1214          internal("finishGHCModule: extra object resolution failed");
1215    }
1216 }
1217
1218
1219 /* --------------------------------------------------------------------------
1220  * Exports
1221  * ------------------------------------------------------------------------*/
1222
1223 Void startGHCExports ( ConId mn, List exlist )
1224 {
1225 #   ifdef DEBUG_IFACE
1226     printf("startGHCExports %s\n", textToStr(textOf(mn)) );
1227 #   endif
1228    /* Nothing to do. */
1229 }
1230
1231 Void finishGHCExports ( ConId mn, List exlist )
1232 {
1233 #   ifdef DEBUG_IFACE
1234     printf("finishGHCExports %s\n", textToStr(textOf(mn)) );
1235 #   endif
1236    /* Nothing to do. */
1237 }
1238
1239
1240 /* --------------------------------------------------------------------------
1241  * Imports
1242  * ------------------------------------------------------------------------*/
1243
1244 Void startGHCImports ( ConId mn, List syms )
1245 /* nm     the module to import from */
1246 /* syms   [ConId | VarId] -- the names to import */
1247 {
1248 #  ifdef DEBUG_IFACE
1249    printf("startGHCImports %s\n", textToStr(textOf(mn)) );
1250 #  endif
1251    /* Nothing to do. */
1252 }
1253
1254
1255 Void finishGHCImports ( ConId nm, List syms )
1256 /* nm     the module to import from */
1257 /* syms   [ConId | VarId] -- the names to import */
1258 {
1259 #  ifdef DEBUG_IFACE
1260    printf("finishGHCImports %s\n", textToStr(textOf(nm)) );
1261 #  endif
1262   /* Nothing to do. */
1263 }
1264
1265
1266 /* --------------------------------------------------------------------------
1267  * Vars (values)
1268  * ------------------------------------------------------------------------*/
1269
1270 void startGHCValue ( Int line, VarId vid, Type ty )
1271 {
1272     Name   n;
1273     List   tmp, tvs;
1274     Text   v = textOf(vid);
1275
1276 #   ifdef DEBUG_IFACE
1277     printf("begin startGHCValue %s\n", textToStr(v));
1278 #   endif
1279
1280     n = findName(v);
1281     if (nonNull(n)) {
1282         ERRMSG(0) "Attempt to redefine variable \"%s\"", textToStr(v)
1283         EEND;
1284     }
1285     n = newName(v,NIL);
1286
1287     tvs = ifTyvarsIn(ty);
1288     for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1289        hd(tmp) = zpair(hd(tmp),STAR);
1290     if (nonNull(tvs))
1291        ty = mkPolyType(tvsToKind(tvs),ty);
1292
1293     ty = tvsToOffsets(line,ty,tvs);
1294     name(n).type  = ty;
1295     name(n).arity = arityInclDictParams(ty);
1296     name(n).line  = line;
1297 }
1298
1299
1300 void finishGHCValue ( VarId vid )
1301 {
1302     Name n    = findName ( textOf(vid) );
1303     Int  line = name(n).line;
1304 #   ifdef DEBUG_IFACE
1305     fprintf(stderr, "begin finishGHCValue %s\n", textToStr(name(n).text) );
1306 #   endif
1307     assert(currentModule == name(n).mod);
1308     name(n).type = conidcellsToTycons(line,name(n).type);
1309 }
1310
1311
1312 /* --------------------------------------------------------------------------
1313  * Type synonyms
1314  * ------------------------------------------------------------------------*/
1315
1316 Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
1317 {
1318     /* tycon :: ConId             */
1319     /* tvs   ::  [((VarId,Kind))] */
1320     /* ty    :: Type              */
1321     Text t = textOf(tycon);
1322 #   ifdef DEBUG_IFACE
1323     fprintf(stderr, "begin startGHCSynonym %s\n", textToStr(t) );
1324 #   endif
1325     if (nonNull(findTycon(t))) {
1326         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1327                      textToStr(t)
1328         EEND;
1329     } else {
1330         Tycon tc        = newTycon(t);
1331         tycon(tc).line  = line;
1332         tycon(tc).arity = length(tvs);
1333         tycon(tc).what  = SYNONYM;
1334         tycon(tc).kind  = tvsToKind(tvs);
1335
1336         /* prepare for finishGHCSynonym */
1337         tycon(tc).defn  = tvsToOffsets(line,ty,tvs);
1338     }
1339 }
1340
1341
1342 static Void  finishGHCSynonym ( ConId tyc )
1343 {
1344     Tycon tc   = findTycon(textOf(tyc));
1345     Int   line = tycon(tc).line;
1346 #   ifdef DEBUG_IFACE
1347     fprintf(stderr, "begin finishGHCSynonym %s\n", textToStr(textOf(tyc)) );
1348 #   endif
1349
1350     assert (currentModule == tycon(tc).mod);
1351     //    setCurrModule(tycon(tc).mod);
1352     tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
1353
1354     /* (ADR) ToDo: can't really do this until I've done all synonyms
1355      * and then I have to do them in order
1356      * tycon(tc).defn = fullExpand(ty);
1357      * (JRS) What?!?!  i don't understand
1358      */
1359 }
1360
1361
1362 /* --------------------------------------------------------------------------
1363  * Data declarations
1364  * ------------------------------------------------------------------------*/
1365
1366 Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
1367 Int   line;
1368 List  ctx0;      /* [((QConId,VarId))]                */
1369 Cell  tycon;     /* ConId                             */
1370 List  ktyvars;   /* [((VarId,Kind))]                  */
1371 List  constrs0;  /* [((ConId,[((Type,VarId,Int))]))]  */
1372                  /* The Text is an optional field name
1373                     The Int indicates strictness */
1374     /* ToDo: worry about being given a decl for (->) ?
1375      * and worry about qualidents for ()
1376      */
1377 {
1378     Type    ty, resTy, selTy, conArgTy;
1379     List    tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
1380     List    ctx, ctx2;
1381     Triple  constr;
1382     Cell    conid;
1383     Pair    conArg, ctxElem;
1384     Text    conArgNm;
1385     Int     conArgStrictness;
1386
1387     Text t = textOf(tycon);
1388 #   ifdef DEBUG_IFACE
1389     fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
1390 #   endif
1391
1392     if (nonNull(findTycon(t))) {
1393         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1394                      textToStr(t)
1395         EEND;
1396     } else {
1397         Tycon tc        = newTycon(t);
1398         tycon(tc).text  = t;
1399         tycon(tc).line  = line;
1400         tycon(tc).arity = length(ktyvars);
1401         tycon(tc).kind  = tvsToKind(ktyvars);
1402         tycon(tc).what  = DATATYPE;
1403
1404         /* a list to accumulate selectors in :: [((VarId,Type))] */
1405         sels = NIL;
1406
1407         /* make resTy the result type of the constr, T v1 ... vn */
1408         resTy = tycon;
1409         for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
1410            resTy = ap(resTy,fst(hd(tmp)));
1411
1412         /* for each constructor ... */
1413         for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
1414            constr = hd(constrs);
1415            conid  = zfst(constr);
1416            fields = zsnd(constr);
1417
1418            /* Build type of constr and handle any selectors found.
1419               Also collect up tyvars occurring in the constr's arg
1420               types, so we can throw away irrelevant parts of the
1421               context later.
1422            */
1423            ty = resTy;
1424            tyvarsMentioned = NIL;
1425            /* tyvarsMentioned :: [VarId] */
1426
1427            conArgs = reverse(fields);
1428            for (; nonNull(conArgs); conArgs=tl(conArgs)) {
1429               conArg           = hd(conArgs); /* (Type,Text) */
1430               conArgTy         = zfst3(conArg);
1431               conArgNm         = zsnd3(conArg);
1432               conArgStrictness = intOf(zthd3(conArg));
1433               tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
1434                                             tyvarsMentioned);
1435               if (conArgStrictness > 0) conArgTy = bang(conArgTy);
1436               ty = fn(conArgTy,ty);
1437               if (nonNull(conArgNm)) {
1438                  /* a field name is mentioned too */
1439                  selTy = fn(resTy,conArgTy);
1440                  if (whatIs(tycon(tc).kind) != STAR)
1441                     selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
1442                  selTy = tvsToOffsets(line,selTy, ktyvars);
1443                  sels = cons( zpair(conArgNm,selTy), sels);
1444               }
1445            }
1446
1447            /* Now ty is the constructor's type, not including context.
1448               Throw away any parts of the context not mentioned in
1449               tyvarsMentioned, and use it to qualify ty.
1450            */
1451            ctx2 = NIL;
1452            for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
1453               ctxElem = hd(ctx);
1454               /* ctxElem :: ((QConId,VarId)) */
1455               if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
1456                  ctx2 = cons(ctxElem, ctx2);
1457            }
1458            if (nonNull(ctx2))
1459               ty = ap(QUAL,pair(ctx2,ty));
1460
1461            /* stick the tycon's kind on, if not simply STAR */
1462            if (whatIs(tycon(tc).kind) != STAR)
1463               ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
1464
1465            ty = tvsToOffsets(line,ty, ktyvars);
1466
1467            /* Finally, stick the constructor's type onto it. */
1468            hd(constrs) = ztriple(conid,fields,ty);
1469         }
1470
1471         /* Final result is that
1472            constrs :: [((ConId,[((Type,Text))],Type))]
1473                       lists the constructors and their types
1474            sels :: [((VarId,Type))]
1475                    lists the selectors and their types
1476         */
1477         tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
1478     }
1479 }
1480
1481
1482 static List startGHCConstrs ( Int line, List cons, List sels )
1483 {
1484     /* cons :: [((ConId,[((Type,Text,Int))],Type))] */
1485     /* sels :: [((VarId,Type))]                     */
1486     /* returns [Name]                               */
1487     List cs, ss;
1488     Int  conNo = length(cons)>1 ? 1 : 0;
1489     for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
1490         Name c  = startGHCConstr(line,conNo,hd(cs));
1491         hd(cs)  = c;
1492     }
1493     /* cons :: [Name] */
1494
1495     for(ss=sels; nonNull(ss); ss=tl(ss)) {
1496         hd(ss) = startGHCSel(line,hd(ss));
1497     }
1498     /* sels :: [Name] */
1499     return appendOnto(cons,sels);
1500 }
1501
1502
1503 static Name startGHCSel ( Int line, ZPair sel )
1504 {
1505     /* sel :: ((VarId, Type))  */
1506     Text t      = textOf(zfst(sel));
1507     Type type   = zsnd(sel);
1508
1509     Name n = findName(t);
1510     if (nonNull(n)) {
1511         ERRMSG(line) "Repeated definition for selector \"%s\"",
1512             textToStr(t)
1513         EEND;
1514     }
1515
1516     n              = newName(t,NIL);
1517     name(n).line   = line;
1518     name(n).number = SELNAME;
1519     name(n).arity  = 1;
1520     name(n).defn   = NIL;
1521     name(n).type = type;
1522     return n;
1523 }
1524
1525
1526 static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
1527 {
1528     /* constr :: ((ConId,[((Type,Text,Int))],Type)) */
1529     /* (ADR) ToDo: add rank2 annotation and existential annotation
1530      * these affect how constr can be used.
1531      */
1532     Text con   = textOf(zfst3(constr));
1533     Type type  = zthd3(constr);
1534     Int  arity = arityFromType(type);
1535     Name n = findName(con);     /* Allocate constructor fun name   */
1536     if (isNull(n)) {
1537         n = newName(con,NIL);
1538     } else if (name(n).defn!=PREDEFINED) {
1539         ERRMSG(line) "Repeated definition for constructor \"%s\"",
1540             textToStr(con)
1541         EEND;
1542     }
1543     name(n).arity  = arity;     /* Save constructor fun details    */
1544     name(n).line   = line;
1545     name(n).number = cfunNo(conNo);
1546     name(n).type   = type;
1547     return n;
1548 }
1549
1550
1551 static Void finishGHCDataDecl ( ConId tyc )
1552 {
1553     List  nms;
1554     Tycon tc = findTycon(textOf(tyc));
1555 #   ifdef DEBUG_IFACE
1556     printf ( "begin finishGHCDataDecl %s\n", textToStr(textOf(tyc)) );
1557 #   endif
1558     if (isNull(tc)) internal("finishGHCDataDecl");
1559
1560     for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) {
1561        Name n    = hd(nms);
1562        Int  line = name(n).line;
1563        assert(currentModule == name(n).mod);
1564        name(n).type = conidcellsToTycons(line,name(n).type);
1565     }
1566 }
1567
1568
1569 /* --------------------------------------------------------------------------
1570  * Newtype decls
1571  * ------------------------------------------------------------------------*/
1572
1573 Void startGHCNewType ( Int line, List ctx0,
1574                        ConId tycon, List tvs, Cell constr )
1575 {
1576     /* ctx0   :: [((QConId,VarId))]                */
1577     /* tycon  :: ConId                             */
1578     /* tvs    :: [((VarId,Kind))]                  */
1579     /* constr :: ((ConId,Type)) or NIL if abstract */
1580     List tmp;
1581     Type resTy;
1582     Text t = textOf(tycon);
1583 #   ifdef DEBUG_IFACE
1584     fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
1585 #   endif
1586     if (nonNull(findTycon(t))) {
1587         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1588                      textToStr(t)
1589         EEND;
1590     } else {
1591         Tycon tc        = newTycon(t);
1592         tycon(tc).line  = line;
1593         tycon(tc).arity = length(tvs);
1594         tycon(tc).what  = NEWTYPE;
1595         tycon(tc).kind  = tvsToKind(tvs);
1596         /* can't really do this until I've read in all synonyms */
1597
1598         if (isNull(constr)) {
1599            tycon(tc).defn = NIL;
1600         } else {
1601            /* constr :: ((ConId,Type)) */
1602            Text con   = textOf(zfst(constr));
1603            Type type  = zsnd(constr);
1604            Name n = findName(con);     /* Allocate constructor fun name   */
1605            if (isNull(n)) {
1606                n = newName(con,NIL);
1607            } else if (name(n).defn!=PREDEFINED) {
1608                ERRMSG(line) "Repeated definition for constructor \"%s\"",
1609                   textToStr(con)
1610                EEND;
1611            }
1612            name(n).arity  = 1;         /* Save constructor fun details    */
1613            name(n).line   = line;
1614            name(n).number = cfunNo(0);
1615            name(n).defn   = nameId;
1616            tycon(tc).defn = singleton(n);
1617
1618            /* make resTy the result type of the constr, T v1 ... vn */
1619            resTy = tycon;
1620            for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1621               resTy = ap(resTy,zfst(hd(tmp)));
1622            type = fn(type,resTy);
1623            if (nonNull(ctx0))
1624               type = ap(QUAL,pair(ctx0,type));
1625            type = tvsToOffsets(line,type,tvs);
1626            name(n).type   = type;
1627         }
1628     }
1629 }
1630
1631
1632 static Void finishGHCNewType ( ConId tyc )
1633 {
1634     Tycon tc = findTycon(textOf(tyc));
1635 #   ifdef DEBUG_IFACE
1636     printf ( "begin finishGHCNewType %s\n", textToStr(textOf(tyc)) );
1637 #   endif
1638
1639     if (isNull(tc)) internal("finishGHCNewType");
1640
1641     if (isNull(tycon(tc).defn)) {
1642        /* it's an abstract type */
1643     }
1644     else if (length(tycon(tc).defn) == 1) {
1645        /* As we expect, has a single constructor */
1646        Name n    = hd(tycon(tc).defn);
1647        Int  line = name(n).line;
1648        assert(currentModule == name(n).mod);
1649        name(n).type = conidcellsToTycons(line,name(n).type);
1650     } else {
1651        internal("finishGHCNewType(2)");
1652     }
1653 }
1654
1655
1656 /* --------------------------------------------------------------------------
1657  * Class declarations
1658  * ------------------------------------------------------------------------*/
1659
1660 Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
1661 Int   line;
1662 List  ctxt;       /* [((QConId, VarId))]   */
1663 ConId tc_name;    /* ConId                 */
1664 List  kinded_tvs; /* [((VarId, Kind))]     */
1665 List  mems0; {    /* [((VarId, Type))]     */
1666
1667     List mems;    /* [((VarId, Type))]     */
1668     List tvsInT;  /* [VarId] and then [((VarId,Kind))] */
1669     List tvs;     /* [((VarId,Kind))]      */
1670
1671     ZPair kinded_tv = hd(kinded_tvs);
1672     Text ct         = textOf(tc_name);
1673     Pair newCtx     = pair(tc_name, zfst(kinded_tv));
1674 #   ifdef DEBUG_IFACE
1675     printf ( "begin startGHCClass %s\n", textToStr(ct) );
1676 #   endif
1677
1678     if (length(kinded_tvs) != 1) {
1679         ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
1680         EEND;
1681     }
1682
1683     if (nonNull(findClass(ct))) {
1684         ERRMSG(line) "Repeated definition of class \"%s\"",
1685                      textToStr(ct)
1686         EEND;
1687     } else if (nonNull(findTycon(ct))) {
1688         ERRMSG(line) "\"%s\" used as both class and type constructor",
1689                      textToStr(ct)
1690         EEND;
1691     } else {
1692         Class nw              = newClass(ct);
1693         cclass(nw).text       = ct;
1694         cclass(nw).line       = line;
1695         cclass(nw).arity      = 1;
1696         cclass(nw).head       = ap(nw,mkOffset(0));
1697         cclass(nw).kinds      = singleton(STAR); /* absolutely no idea at all */
1698         cclass(nw).instances  = NIL;             /* what the kind should be   */
1699         cclass(nw).numSupers  = length(ctxt);
1700
1701         /* Kludge to map the single tyvar in the context to Offset 0.
1702            Need to do something better for multiparam type classes.
1703
1704         cclass(nw).supers     = tvsToOffsets(line,ctxt,
1705                                              singleton(pair(tv,STAR)));
1706         */
1707         cclass(nw).supers     = tvsToOffsets(line,ctxt,
1708                                              singleton(kinded_tv));
1709
1710
1711         for (mems=mems0; nonNull(mems); mems=tl(mems)) {
1712            ZPair mem  = hd(mems);
1713            Type  memT = zsnd(mem);
1714            Text  mnt  = textOf(zfst(mem));
1715            Name  mn;
1716
1717            /* Stick the new context on the member type */
1718            if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
1719            if (whatIs(memT)==QUAL) {
1720               memT = pair(QUAL,
1721                           pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
1722            } else {
1723               memT = pair(QUAL,
1724                           pair(singleton(newCtx),memT));
1725            }
1726
1727            /* Cook up a kind for the type. */
1728            tvsInT = ifTyvarsIn(memT);
1729            /* tvsInT :: [VarId] */
1730
1731            /* ToDo: maximally bogus */
1732            for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs))
1733               hd(tvs) = zpair(hd(tvs),STAR);
1734            /* tvsIntT :: [((VarId,STAR))] */
1735
1736            memT = mkPolyType(tvsToKind(tvsInT),memT);
1737            memT = tvsToOffsets(line,memT,tvsInT);
1738
1739            /* Park the type back on the member */
1740            mem = zpair(zfst(mem),memT);
1741
1742            /* Bind code to the member */
1743            mn = findName(mnt);
1744            if (nonNull(mn)) {
1745               ERRMSG(line)
1746                  "Repeated definition for class method \"%s\"",
1747                  textToStr(mnt)
1748               EEND;
1749            }
1750            mn = newName(mnt,NIL);
1751
1752            hd(mems) = mem;
1753         }
1754
1755         cclass(nw).members    = mems0;
1756         cclass(nw).numMembers = length(mems0);
1757
1758         /* (ADR) ToDo:
1759          * cclass(nw).dsels    = ?;
1760          * cclass(nw).dbuild   = ?;
1761          * cclass(nm).dcon     = ?;
1762          * cclass(nm).defaults = ?;
1763          */
1764     }
1765 }
1766
1767
1768 static Void finishGHCClass ( Tycon cls_tyc )
1769 {
1770     List  mems;
1771     Int   line;
1772     Int   ctr;
1773     Class nw = findClass ( textOf(cls_tyc) );
1774 #   ifdef DEBUG_IFACE
1775     printf ( "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
1776 #   endif
1777     if (isNull(nw)) internal("finishGHCClass");
1778
1779     line = cclass(nw).line;
1780     ctr  = - length(cclass(nw).members);
1781     assert (currentModule == cclass(nw).mod);
1782
1783     cclass(nw).level   = 0;  /* (ADR) ToDo: 1 + max (map level supers) */
1784     cclass(nw).head    = conidcellsToTycons(line,cclass(nw).head);
1785     cclass(nw).supers  = conidcellsToTycons(line,cclass(nw).supers);
1786     cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
1787
1788     for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
1789        Pair mem = hd(mems); /* (VarId, Type) */
1790        Text txt = textOf(fst(mem));
1791        Type ty  = snd(mem);
1792        Name n   = findName(txt);
1793        assert(nonNull(n));
1794        name(n).line   = cclass(nw).line;
1795        name(n).type   = ty;
1796        name(n).number = ctr++;
1797        hd(mems) = n;
1798     }
1799 }
1800
1801
1802 /* --------------------------------------------------------------------------
1803  * Instances
1804  * ------------------------------------------------------------------------*/
1805
1806 Inst startGHCInstance (line,ktyvars,cls,var)
1807 Int   line;
1808 List  ktyvars; /* [((VarId,Kind))] */
1809 Type  cls;     /* Type  */
1810 VarId var; {   /* VarId */
1811     List tmp, tvs, ks, spec;
1812
1813     List xs1, xs2;
1814     Kind k;
1815
1816     Inst in = newInst();
1817 #   ifdef DEBUG_IFACE
1818     printf ( "begin startGHCInstance\n" );
1819 #   endif
1820
1821     tvs = ifTyvarsIn(cls);  /* :: [VarId] */
1822     /* tvs :: [VarId].
1823        The order of tvs is important for tvsToOffsets.
1824        tvs should be a permutation of ktyvars.  Fish the tyvar kinds
1825        out of ktyvars and attach them to tvs.
1826     */
1827     for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
1828        k = NIL;
1829        for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
1830           if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
1831              k = zsnd(hd(xs2));
1832        if (isNull(k)) internal("startGHCInstance: finding kinds");
1833        hd(xs1) = zpair(hd(xs1),k);
1834     }
1835
1836     cls = tvsToOffsets(line,cls,tvs);
1837     spec = NIL;
1838     while (isAp(cls)) {
1839        spec = cons(fun(cls),spec);
1840        cls  = arg(cls);
1841     }
1842     spec = reverse(spec);
1843
1844     inst(in).line         = line;
1845     inst(in).implements   = NIL;
1846     inst(in).kinds        = simpleKind(length(tvs)); /* do this right */
1847     inst(in).specifics    = spec;
1848     inst(in).numSpecifics = length(spec);
1849     inst(in).head         = cls;
1850
1851     /* Figure out the name of the class being instanced, and store it
1852        at inst(in).c.  finishGHCInstance will resolve it to a real Class. */
1853     {
1854        Cell cl = inst(in).head;
1855        assert(whatIs(cl)==DICTAP);
1856        cl = unap(DICTAP,cl);
1857        cl = fst(cl);
1858        assert ( isQCon(cl) );
1859        inst(in).c = cl;
1860     }
1861
1862 #if 0
1863     Is this still needed?
1864     {
1865         Name b         = newName(inventText(),NIL);
1866         name(b).line   = line;
1867         name(b).arity  = length(ctxt); /* unused? */
1868         name(b).number = DFUNNAME;
1869         inst(in).builder = b;
1870         bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
1871     }
1872 #endif
1873     return in;
1874 }
1875
1876
1877 static Void finishGHCInstance ( Inst in )
1878 {
1879     Int    line;
1880     Class  c;
1881     Type   cls;
1882
1883 #   ifdef DEBUG_IFACE
1884     printf ( "begin finishGHCInstance\n" );
1885 #   endif
1886
1887     assert (nonNull(in));
1888     line = inst(in).line;
1889     assert (currentModule==inst(in).mod);
1890
1891     /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
1892        since startGHCInstance couldn't possibly have resolved it to
1893        a Class at that point.  We convert it to a Class now.
1894     */
1895     c = inst(in).c;
1896     assert(isQCon(c));
1897     c = findQualClassWithoutConsultingExportList(c);
1898     assert(nonNull(c));
1899     inst(in).c = c;
1900
1901     inst(in).head         = conidcellsToTycons(line,inst(in).head);
1902     inst(in).specifics    = conidcellsToTycons(line,inst(in).specifics);
1903     cclass(c).instances   = cons(in,cclass(c).instances);
1904 }
1905
1906
1907 /* --------------------------------------------------------------------------
1908  * Helper fns
1909  * ------------------------------------------------------------------------*/
1910
1911 /* This is called from the startGHC* functions.  It traverses a structure
1912    and converts varidcells, ie, type variables parsed by the interface
1913    parser, into Offsets, which is how Hugs wants to see them internally.
1914    The Offset for a type variable is determined by its place in the list
1915    passed as the second arg; the associated kinds are irrelevant.
1916
1917    ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
1918 */
1919
1920 /* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
1921 static Type tvsToOffsets(line,type,ktyvars)
1922 Int  line;
1923 Type type;
1924 List ktyvars; { /* [((VarId,Kind))] */
1925    switch (whatIs(type)) {
1926       case NIL:
1927       case TUPLE:
1928       case QUALIDENT:
1929       case CONIDCELL:
1930       case TYCON:
1931          return type;
1932       case ZTUP2: /* convert to the untyped representation */
1933          return ap( tvsToOffsets(line,zfst(type),ktyvars),
1934                     tvsToOffsets(line,zsnd(type),ktyvars) );
1935       case AP:
1936          return ap( tvsToOffsets(line,fun(type),ktyvars),
1937                     tvsToOffsets(line,arg(type),ktyvars) );
1938       case POLYTYPE:
1939          return mkPolyType (
1940                    polySigOf(type),
1941                    tvsToOffsets(line,monotypeOf(type),ktyvars)
1942                 );
1943          break;
1944       case QUAL:
1945          return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
1946                                tvsToOffsets(line,snd(snd(type)),ktyvars)));
1947       case DICTAP: /* bogus ?? */
1948          return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
1949       case UNBOXEDTUP:  /* bogus?? */
1950          return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
1951       case BANG:  /* bogus?? */
1952          return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
1953       case VARIDCELL: /* Ha! some real work to do! */
1954        { Int i = 0;
1955          Text tv = textOf(type);
1956          for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
1957             Cell varid;
1958             Text tt;
1959             assert(isZPair(hd(ktyvars)));
1960             varid = zfst(hd(ktyvars));
1961             tt    = textOf(varid);
1962             if (tv == tt) return mkOffset(i);
1963          }
1964          ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
1965          EEND;
1966          break;
1967        }
1968       default:
1969          fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
1970          print(type,20);
1971          fprintf(stderr,"\n");
1972          assert(0);
1973    }
1974    assert(0);
1975    return NIL; /* NOTREACHED */
1976 }
1977
1978
1979 /* This is called from the finishGHC* functions.  It traverses a structure
1980    and converts conidcells, ie, type constructors parsed by the interface
1981    parser, into Tycons (or Classes), which is how Hugs wants to see them
1982    internally.  Calls to this fn have to be deferred to the second phase
1983    of interface loading (finishGHC* rather than startGHC*) so that all relevant
1984    Tycons or Classes have been loaded into the symbol tables and can be
1985    looked up.
1986 */
1987 static Type conidcellsToTycons ( Int line, Type type )
1988 {
1989    switch (whatIs(type)) {
1990       case NIL:
1991       case OFFSET:
1992       case TYCON:
1993       case CLASS:
1994       case VARIDCELL:
1995       case TUPLE:
1996       case STAR:
1997          return type;
1998       case QUALIDENT:
1999        { Cell t;  /* Tycon or Class */
2000          Text m     = qmodOf(type);
2001          Module mod = findModule(m);
2002          if (isNull(mod)) {
2003             ERRMSG(line)
2004                "Undefined module in qualified name \"%s\"",
2005                identToStr(type)
2006             EEND;
2007             return NIL;
2008          }
2009          t = findQualTyconWithoutConsultingExportList(type);
2010          if (nonNull(t)) return t;
2011          t = findQualClassWithoutConsultingExportList(type);
2012          if (nonNull(t)) return t;
2013          ERRMSG(line)
2014               "Undefined qualified class or type \"%s\"",
2015               identToStr(type)
2016          EEND;
2017          return NIL;
2018        }
2019       case CONIDCELL:
2020        { Tycon tc;
2021          Class cl;
2022          cl = findQualClass(type);
2023          if (nonNull(cl)) return cl;
2024          if (textOf(type)==findText("[]"))
2025             /* a hack; magically qualify [] into PrelBase.[] */
2026             return conidcellsToTycons(line,
2027                                       mkQualId(mkCon(findText("PrelBase")),type));
2028          tc = findQualTycon(type);
2029          if (nonNull(tc)) return tc;
2030          ERRMSG(line)
2031              "Undefined class or type constructor \"%s\"",
2032              identToStr(type)
2033          EEND;
2034          return NIL;
2035        }
2036       case AP:
2037          return ap( conidcellsToTycons(line,fun(type)),
2038                     conidcellsToTycons(line,arg(type)) );
2039       case ZTUP2: /* convert to std pair */
2040          return ap( conidcellsToTycons(line,zfst(type)),
2041                     conidcellsToTycons(line,zsnd(type)) );
2042
2043       case POLYTYPE:
2044          return mkPolyType (
2045                    polySigOf(type),
2046                    conidcellsToTycons(line,monotypeOf(type))
2047                 );
2048          break;
2049       case QUAL:
2050          return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
2051                                conidcellsToTycons(line,snd(snd(type)))));
2052       case DICTAP: /* :: ap(DICTAP, pair(Class,[Type]))
2053                       Not sure if this is really the right place to
2054                       convert it to the form Hugs wants, but will do so anyway.
2055                     */
2056          /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
2057         {
2058            Class cl   = fst(unap(DICTAP,type));
2059            List  args = snd(unap(DICTAP,type));
2060            if (length(args) != 1)
2061               internal("conidcellsToTycons: DICTAP: multiparam ap");
2062            return
2063               conidcellsToTycons(line,pair(cl,hd(args)));
2064         }
2065       case UNBOXEDTUP:
2066          return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
2067       case BANG:
2068          return ap(BANG, conidcellsToTycons(line, snd(type)));
2069       default:
2070          fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
2071                  whatIs(type));
2072          print(type,20);
2073          fprintf(stderr,"\n");
2074          assert(0);
2075    }
2076    assert(0);
2077    return NIL; /* NOTREACHED */
2078 }
2079
2080
2081 /* Find out if a type mentions a type constructor not present in
2082    the supplied list of qualified tycons.
2083 */
2084 static Bool allTypesKnown ( Type  type,
2085                             List  aktys /* [QualId] */,
2086                             ConId thisMod )
2087 {
2088    switch (whatIs(type)) {
2089       case NIL:
2090       case OFFSET:
2091       case VARIDCELL:
2092       case TUPLE:
2093          return TRUE;
2094       case AP:
2095          return allTypesKnown(fun(type),aktys,thisMod)
2096                 && allTypesKnown(arg(type),aktys,thisMod);
2097       case ZTUP2:
2098          return allTypesKnown(zfst(type),aktys,thisMod)
2099                 && allTypesKnown(zsnd(type),aktys,thisMod);
2100       case DICTAP:
2101          return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
2102
2103       case CONIDCELL:
2104         if (textOf(type)==findText("[]"))
2105             /* a hack; magically qualify [] into PrelBase.[] */
2106             type = mkQualId(mkCon(findText("PrelBase")),type); else
2107             type = mkQualId(thisMod,type);
2108          /* fall through */
2109       case QUALIDENT:
2110          if (isNull(qualidIsMember(type,aktys))) goto missing;
2111          return TRUE;
2112
2113       default:
2114          fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
2115          print(type,10);printf("\n");
2116          internal("allTypesKnown");
2117          return TRUE; /*notreached*/
2118    }
2119   missing:
2120    printf ( "allTypesKnown: unknown " ); print(type,10); printf("\n");
2121    return FALSE;
2122 }
2123
2124
2125 /* --------------------------------------------------------------------------
2126  * Utilities
2127  *
2128  * None of these do lookups or require that lookups have been resolved
2129  * so they can be performed while reading interfaces.
2130  * ------------------------------------------------------------------------*/
2131
2132 /* tvsToKind :: [((VarId,Kind))] -> Kinds */
2133 static Kinds tvsToKind(tvs)
2134 List tvs; { /* [((VarId,Kind))] */
2135     List  rs;
2136     Kinds r  = STAR;
2137     for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
2138         if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)");
2139         if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)");
2140         r = ap(zsnd(hd(rs)),r);
2141     }
2142     return r;
2143 }
2144
2145
2146 static Int arityInclDictParams ( Type type )
2147 {
2148    Int arity = 0;
2149    if (isPolyType(type)) type = monotypeOf(type);
2150
2151    if (whatIs(type) == QUAL)
2152    {
2153       arity += length ( fst(snd(type)) );
2154       type = snd(snd(type));
2155    }
2156    while (isAp(type) && getHead(type)==typeArrow) {
2157       arity++;
2158       type = arg(type);
2159    }
2160    return arity;
2161 }
2162
2163 /* arity of a constructor with this type */
2164 static Int arityFromType(type)
2165 Type type; {
2166     Int arity = 0;
2167     if (isPolyType(type)) {
2168         type = monotypeOf(type);
2169     }
2170     if (whatIs(type) == QUAL) {
2171         type = snd(snd(type));
2172     }
2173     if (whatIs(type) == EXIST) {
2174         type = snd(snd(type));
2175     }
2176     if (whatIs(type)==RANK2) {
2177         type = snd(snd(type));
2178     }
2179     while (isAp(type) && getHead(type)==typeArrow) {
2180         arity++;
2181         type = arg(type);
2182     }
2183     return arity;
2184 }
2185
2186
2187 /* ifTyvarsIn :: Type -> [VarId]
2188    The returned list has no duplicates -- is a set.
2189 */
2190 static List ifTyvarsIn(type)
2191 Type type; {
2192     List vs = typeVarsIn(type,NIL,NIL,NIL);
2193     List vs2 = vs;
2194     for (; nonNull(vs2); vs2=tl(vs2))
2195        if (whatIs(hd(vs2)) != VARIDCELL)
2196           internal("ifTyvarsIn");
2197     return vs;
2198 }
2199
2200
2201
2202 /* --------------------------------------------------------------------------
2203  * General object symbol query stuff
2204  * ------------------------------------------------------------------------*/
2205
2206 #define EXTERN_SYMS                  \
2207       Sym(stg_gc_enter_1)            \
2208       Sym(stg_gc_noregs)             \
2209       Sym(stg_gc_seq_1)              \
2210       Sym(stg_gc_d1)                 \
2211       Sym(stg_chk_0)                 \
2212       Sym(stg_chk_1)                 \
2213       Sym(stg_gen_chk)               \
2214       Sym(stg_exit)                  \
2215       Sym(stg_update_PAP)            \
2216       Sym(stg_error_entry)           \
2217       Sym(__ap_2_upd_info)           \
2218       Sym(__ap_3_upd_info)           \
2219       Sym(__ap_4_upd_info)           \
2220       Sym(__ap_5_upd_info)           \
2221       Sym(__ap_6_upd_info)           \
2222       Sym(__sel_0_upd_info)          \
2223       Sym(__sel_1_upd_info)          \
2224       Sym(__sel_2_upd_info)          \
2225       Sym(__sel_3_upd_info)          \
2226       Sym(__sel_4_upd_info)          \
2227       Sym(__sel_5_upd_info)          \
2228       Sym(__sel_6_upd_info)          \
2229       Sym(__sel_7_upd_info)          \
2230       Sym(__sel_8_upd_info)          \
2231       Sym(__sel_9_upd_info)          \
2232       Sym(__sel_10_upd_info)         \
2233       Sym(__sel_11_upd_info)         \
2234       Sym(__sel_12_upd_info)         \
2235       Sym(MainRegTable)              \
2236       Sym(Upd_frame_info)            \
2237       Sym(seq_frame_info)            \
2238       Sym(CAF_BLACKHOLE_info)        \
2239       Sym(IND_STATIC_info)           \
2240       Sym(EMPTY_MVAR_info)           \
2241       Sym(MUT_ARR_PTRS_FROZEN_info)  \
2242       Sym(newCAF)                    \
2243       Sym(putMVarzh_fast)            \
2244       Sym(newMVarzh_fast)            \
2245       Sym(takeMVarzh_fast)           \
2246       Sym(catchzh_fast)              \
2247       Sym(raisezh_fast)              \
2248       Sym(delayzh_fast)              \
2249       Sym(yieldzh_fast)              \
2250       Sym(killThreadzh_fast)         \
2251       Sym(waitReadzh_fast)           \
2252       Sym(waitWritezh_fast)          \
2253       Sym(CHARLIKE_closure)          \
2254       Sym(suspendThread)             \
2255       Sym(resumeThread)              \
2256       Sym(stackOverflow)             \
2257       Sym(int2Integerzh_fast)        \
2258       Sym(stg_gc_unbx_r1)            \
2259       Sym(ErrorHdrHook)              \
2260       Sym(makeForeignObjzh_fast)     \
2261       Sym(__encodeDouble)            \
2262       Sym(decodeDoublezh_fast)       \
2263       Sym(isDoubleNaN)               \
2264       Sym(isDoubleInfinite)          \
2265       Sym(isDoubleDenormalized)      \
2266       Sym(isDoubleNegativeZero)      \
2267       Sym(__encodeFloat)             \
2268       Sym(decodeFloatzh_fast)        \
2269       Sym(isFloatNaN)                \
2270       Sym(isFloatInfinite)           \
2271       Sym(isFloatDenormalized)       \
2272       Sym(isFloatNegativeZero)       \
2273       Sym(__int_encodeFloat)         \
2274       Sym(__int_encodeDouble)        \
2275       Sym(mpz_cmp_si)                \
2276       Sym(mpz_cmp)                   \
2277       Sym(newArrayzh_fast)           \
2278       Sym(unsafeThawArrayzh_fast)    \
2279       Sym(newDoubleArrayzh_fast)     \
2280       Sym(newFloatArrayzh_fast)      \
2281       Sym(newAddrArrayzh_fast)       \
2282       Sym(newWordArrayzh_fast)       \
2283       Sym(newIntArrayzh_fast)        \
2284       Sym(newCharArrayzh_fast)       \
2285       Sym(newMutVarzh_fast)          \
2286       Sym(quotRemIntegerzh_fast)     \
2287       Sym(divModIntegerzh_fast)      \
2288       Sym(timesIntegerzh_fast)       \
2289       Sym(minusIntegerzh_fast)       \
2290       Sym(plusIntegerzh_fast)        \
2291       Sym(addr2Integerzh_fast)       \
2292       Sym(mkWeakzh_fast)             \
2293       Sym(prog_argv)                 \
2294       Sym(prog_argc)                 \
2295       Sym(resetNonBlockingFd)        \
2296                                      \
2297       /* needed by libHS_cbits */    \
2298       SymX(malloc)                   \
2299       Sym(__errno_location)          \
2300       SymX(close)                    \
2301       Sym(__xstat)                   \
2302       Sym(__fxstat)                  \
2303       Sym(__lxstat)                  \
2304       Sym(mkdir)                     \
2305       SymX(close)                    \
2306       Sym(opendir)                   \
2307       Sym(closedir)                  \
2308       Sym(readdir)                   \
2309       Sym(tcgetattr)                 \
2310       Sym(tcsetattr)                 \
2311       SymX(isatty)                   \
2312       SymX(read)                     \
2313       SymX(lseek)                    \
2314       SymX(write)                    \
2315       Sym(getrusage)                 \
2316       Sym(gettimeofday)              \
2317       SymX(realloc)                  \
2318       SymX(getcwd)                   \
2319       SymX(free)                     \
2320       SymX(strcpy)                   \
2321       SymX(select)                   \
2322       Sym(fcntl)                     \
2323       SymX(stderr)                   \
2324       SymX(fprintf)                  \
2325       SymX(exit)                     \
2326       Sym(open)                      \
2327       SymX(unlink)                   \
2328       SymX(memcpy)                   \
2329       SymX(memchr)                   \
2330       SymX(rmdir)                    \
2331       SymX(rename)                   \
2332       SymX(chdir)                    \
2333       Sym(localtime)                 \
2334       Sym(strftime)                  \
2335       SymX(vfork)                    \
2336       SymX(execl)                    \
2337       SymX(_exit)                    \
2338       Sym(waitpid)                   \
2339       Sym(tzname)                    \
2340       Sym(timezone)                  \
2341       Sym(mktime)                    \
2342       Sym(gmtime)                    \
2343
2344
2345 /* entirely bogus claims about types of these symbols */
2346 #define Sym(vvv)  extern int vvv;
2347 #define SymX(vvv) /* nothing */
2348 EXTERN_SYMS
2349 #undef Sym
2350 #undef SymX
2351
2352 #define Sym(vvv) { #vvv, &vvv },
2353 #define SymX(vvv) { #vvv, &vvv },
2354 OSym rtsTab[]
2355    = {
2356        EXTERN_SYMS
2357        {0,0}
2358      };
2359 #undef Sym
2360 #undef SymX
2361
2362 void* lookupObjName ( char* nm )
2363 {
2364    int    k;
2365    char*  pp;
2366    void*  a;
2367    Text   t;
2368    Module m;
2369    char   nm2[200];
2370
2371    nm2[199] = 0;
2372    strncpy(nm2,nm,200);
2373
2374    /*  first see if it's an RTS name */
2375    for (k = 0; rtsTab[k].nm; k++)
2376       if (0==strcmp(nm2,rtsTab[k].nm))
2377          return rtsTab[k].ad;
2378
2379    /* perhaps an extra-symbol ? */
2380    a = lookupOExtraTabName ( nm );
2381    if (a) return a;
2382
2383    /* if not an RTS name, look in the
2384       relevant module's object symbol table
2385    */
2386    pp = strchr(nm2, '_');
2387    if (!pp || !isupper(nm2[0])) goto not_found;
2388    *pp = 0;
2389    t = unZcodeThenFindText(nm2);
2390    m = findModule(t);
2391    if (isNull(m)) goto not_found;
2392
2393    a = lookupOTabName ( m, nm );  /* RATIONALISE */
2394    if (a) return a;
2395
2396   not_found:
2397    fprintf ( stderr,
2398              "lookupObjName: can't resolve name `%s'\n",
2399              nm );
2400 assert(4-4);
2401    return NULL;
2402 }
2403
2404
2405 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
2406 {
2407    OSectionKind sk = lookupSection(p);
2408    assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2409    return (sk == HUGS_SECTIONKIND_CODE_OR_RODATA);
2410 }
2411
2412
2413 int is_dynamically_loaded_rwdata_ptr ( char* p )
2414 {
2415    OSectionKind sk = lookupSection(p);
2416    assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2417    return (sk == HUGS_SECTIONKIND_RWDATA);
2418 }
2419
2420
2421 int is_not_dynamically_loaded_ptr ( char* p )
2422 {
2423    OSectionKind sk = lookupSection(p);
2424    assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2425    return (sk == HUGS_SECTIONKIND_OTHER);
2426 }
2427
2428
2429 /* --------------------------------------------------------------------------
2430  * Control:
2431  * ------------------------------------------------------------------------*/
2432
2433 Void interface(what)
2434 Int what; {
2435     switch (what) {
2436        case POSTPREL: break;
2437
2438        case PREPREL:
2439        case RESET:
2440           ifaces_outstanding  = NIL;
2441           break;
2442        case MARK:
2443           mark(ifaces_outstanding);
2444           break;
2445     }
2446 }
2447
2448 /*-------------------------------------------------------------------------*/