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