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.45 $
  11  * $Date: 2000/04/05 09:22:28 $
  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
1624     Text t = textOf(tycon);
1625 #   ifdef DEBUG_IFACE
1626     fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
1627 #   endif
1628
1629     line = intOf(line);
1630     if (nonNull(findTycon(t))) {
1631         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1632                      textToStr(t)
1633         EEND;
1634     } else {
1635         Tycon tc        = newTycon(t);
1636         tycon(tc).text  = t;
1637         tycon(tc).line  = line;
1638         tycon(tc).arity = length(ktyvars);
1639         tycon(tc).kind  = tvsToKind(ktyvars);
1640         tycon(tc).what  = DATATYPE;
1641
1642         /* a list to accumulate selectors in :: [((VarId,Type))] */
1643         sels = NIL;
1644
1645         /* make resTy the result type of the constr, T v1 ... vn */
1646         resTy = tycon;
1647         for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
1648            resTy = ap(resTy,zfst(hd(tmp)));
1649
1650         /* for each constructor ... */
1651         for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
1652            constr = hd(constrs);
1653            conid  = zfst(constr);
1654            fields = zsnd(constr);
1655
1656            /* Build type of constr and handle any selectors found.
1657               Also collect up tyvars occurring in the constr's arg
1658               types, so we can throw away irrelevant parts of the
1659               context later.
1660            */
1661            ty = resTy;
1662            tyvarsMentioned = NIL;
1663            /* tyvarsMentioned :: [VarId] */
1664
1665            conArgs = reverse(fields);
1666            for (; nonNull(conArgs); conArgs=tl(conArgs)) {
1667               conArg           = hd(conArgs); /* (Type,Text) */
1668               conArgTy         = zfst3(conArg);
1669               conArgNm         = zsnd3(conArg);
1670               conArgStrictness = intOf(zthd3(conArg));
1671               tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
1672                                             tyvarsMentioned);
1673               /* Not sure what the deal is with strictness.  Do we need
1674                  to notify the symbol table, or not?  The Hugs desugarer?
1675                  Currently disabled. */
1676               /* if (conArgStrictness > 0) conArgTy = bang(conArgTy); */
1677               ty = fn(conArgTy,ty);
1678               if (nonNull(conArgNm)) {
1679                  /* a field name is mentioned too */
1680                  selTy = fn(resTy,conArgTy);
1681                  if (whatIs(tycon(tc).kind) != STAR)
1682                     selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
1683                  selTy = tvsToOffsets(line,selTy, ktyvars);
1684                  sels = cons( zpair(conArgNm,selTy), sels);
1685               }
1686            }
1687
1688            /* Now ty is the constructor's type, not including context.
1689               Throw away any parts of the context not mentioned in
1690               tyvarsMentioned, and use it to qualify ty.
1691            */
1692            ctx2 = NIL;
1693            for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
1694               ctxElem = hd(ctx);
1695               /* ctxElem :: ((QConId,VarId)) */
1696               if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
1697                  ctx2 = cons(ctxElem, ctx2);
1698            }
1699            if (nonNull(ctx2))
1700               ty = ap(QUAL,pair(ctx2,ty));
1701
1702            /* stick the tycon's kind on, if not simply STAR */
1703            if (whatIs(tycon(tc).kind) != STAR)
1704               ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
1705
1706            ty = tvsToOffsets(line,ty, ktyvars);
1707
1708            /* Finally, stick the constructor's type onto it. */
1709            hd(constrs) = ztriple(conid,fields,ty);
1710         }
1711
1712         /* Final result is that
1713            constrs :: [((ConId,[((Type,Text))],Type))]
1714                       lists the constructors and their types
1715            sels :: [((VarId,Type))]
1716                    lists the selectors and their types
1717         */
1718         tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
1719     }
1720 }
1721
1722
1723 static List startGHCConstrs ( Int line, List cons, List sels )
1724 {
1725     /* cons :: [((ConId,[((Type,Text,Int))],Type))] */
1726     /* sels :: [((VarId,Type))]                     */
1727     /* returns [Name]                               */
1728     List cs, ss;
1729     Int  conNo = length(cons)>1 ? 1 : 0;
1730     for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
1731         Name c  = startGHCConstr(line,conNo,hd(cs));
1732         hd(cs)  = c;
1733     }
1734     /* cons :: [Name] */
1735
1736     for(ss=sels; nonNull(ss); ss=tl(ss)) {
1737         hd(ss) = startGHCSel(line,hd(ss));
1738     }
1739     /* sels :: [Name] */
1740     return appendOnto(cons,sels);
1741 }
1742
1743
1744 static Name startGHCSel ( Int line, ZPair sel )
1745 {
1746     /* sel :: ((VarId, Type))  */
1747     Text t      = textOf(zfst(sel));
1748     Type type   = zsnd(sel);
1749
1750     Name n = findName(t);
1751     if (nonNull(n)) {
1752         ERRMSG(line) "Repeated definition for selector \"%s\"",
1753             textToStr(t)
1754         EEND;
1755     }
1756
1757     n              = newName(t,NIL);
1758     name(n).line   = line;
1759     name(n).number = SELNAME;
1760     name(n).arity  = 1;
1761     name(n).defn   = NIL;
1762     name(n).type = type;
1763     return n;
1764 }
1765
1766
1767 static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
1768 {
1769     /* constr :: ((ConId,[((Type,Text,Int))],Type)) */
1770     /* (ADR) ToDo: add rank2 annotation and existential annotation
1771      * these affect how constr can be used.
1772      */
1773     Text con   = textOf(zfst3(constr));
1774     Type type  = zthd3(constr);
1775     Int  arity = arityFromType(type);
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     return n;
1789 }
1790
1791
1792 static List finishGHCDataDecl ( ConId tyc )
1793 {
1794     List  nms;
1795     Tycon tc = findTycon(textOf(tyc));
1796 #   ifdef DEBUG_IFACE
1797     fprintf ( stderr, "begin finishGHCDataDecl %s\n",
1798               textToStr(textOf(tyc)) );
1799 #   endif
1800     if (isNull(tc)) internal("finishGHCDataDecl");
1801
1802     for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) {
1803        Name n    = hd(nms);
1804        Int  line = name(n).line;
1805        assert(currentModule == name(n).mod);
1806        name(n).type   = conidcellsToTycons(line,name(n).type);
1807        name(n).parent = tc; //---????
1808     }
1809
1810     return tycon(tc).defn;
1811 }
1812
1813
1814 /* --------------------------------------------------------------------------
1815  * Newtype decls
1816  * ------------------------------------------------------------------------*/
1817
1818 static Void startGHCNewType ( Int line, List ctx0,
1819                               ConId tycon, List tvs, Cell constr )
1820 {
1821     /* ctx0   :: [((QConId,VarId))]                */
1822     /* tycon  :: ConId                             */
1823     /* tvs    :: [((VarId,Kind))]                  */
1824     /* constr :: ((ConId,Type)) or NIL if abstract */
1825     List tmp;
1826     Type resTy;
1827     Text t = textOf(tycon);
1828 #   ifdef DEBUG_IFACE
1829     fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
1830 #   endif
1831
1832     line = intOf(line);
1833
1834     if (nonNull(findTycon(t))) {
1835         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
1836                      textToStr(t)
1837         EEND;
1838     } else {
1839         Tycon tc        = newTycon(t);
1840         tycon(tc).line  = line;
1841         tycon(tc).arity = length(tvs);
1842         tycon(tc).what  = NEWTYPE;
1843         tycon(tc).kind  = tvsToKind(tvs);
1844         /* can't really do this until I've read in all synonyms */
1845
1846         if (isNull(constr)) {
1847            tycon(tc).defn = NIL;
1848         } else {
1849            /* constr :: ((ConId,Type)) */
1850            Text con   = textOf(zfst(constr));
1851            Type type  = zsnd(constr);
1852            Name n = findName(con);     /* Allocate constructor fun name   */
1853            if (isNull(n)) {
1854                n = newName(con,NIL);
1855            } else if (name(n).defn!=PREDEFINED) {
1856                ERRMSG(line) "Repeated definition for constructor \"%s\"",
1857                   textToStr(con)
1858                EEND;
1859            }
1860            name(n).arity  = 1;         /* Save constructor fun details    */
1861            name(n).line   = line;
1862            name(n).number = cfunNo(0);
1863            name(n).defn   = nameId;
1864            tycon(tc).defn = singleton(n);
1865
1866            /* make resTy the result type of the constr, T v1 ... vn */
1867            resTy = tycon;
1868            for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1869               resTy = ap(resTy,zfst(hd(tmp)));
1870            type = fn(type,resTy);
1871            if (nonNull(ctx0))
1872               type = ap(QUAL,pair(ctx0,type));
1873            type = tvsToOffsets(line,type,tvs);
1874            name(n).type   = type;
1875         }
1876     }
1877 }
1878
1879
1880 static Void finishGHCNewType ( ConId tyc )
1881 {
1882     Tycon tc = findTycon(textOf(tyc));
1883 #   ifdef DEBUG_IFACE
1884     fprintf ( stderr, "begin finishGHCNewType %s\n",
1885               textToStr(textOf(tyc)) );
1886 #   endif
1887
1888     if (isNull(tc)) internal("finishGHCNewType");
1889
1890     if (isNull(tycon(tc).defn)) {
1891        /* it's an abstract type */
1892     }
1893     else if (length(tycon(tc).defn) == 1) {
1894        /* As we expect, has a single constructor */
1895        Name n    = hd(tycon(tc).defn);
1896        Int  line = name(n).line;
1897        assert(currentModule == name(n).mod);
1898        name(n).type = conidcellsToTycons(line,name(n).type);
1899     } else {
1900        internal("finishGHCNewType(2)");
1901     }
1902 }
1903
1904
1905 /* --------------------------------------------------------------------------
1906  * Class declarations
1907  * ------------------------------------------------------------------------*/
1908
1909 static Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
1910 Int   line;
1911 List  ctxt;       /* [((QConId, VarId))]   */
1912 ConId tc_name;    /* ConId                 */
1913 List  kinded_tvs; /* [((VarId, Kind))]     */
1914 List  mems0; {    /* [((VarId, Type))]     */
1915
1916     List mems;    /* [((VarId, Type))]     */
1917     List tvsInT;  /* [VarId] and then [((VarId,Kind))] */
1918     List tvs;     /* [((VarId,Kind))]      */
1919     List ns;      /* [Name]                */
1920     Int  mno;
1921
1922     ZPair kinded_tv = hd(kinded_tvs);
1923     Text ct         = textOf(tc_name);
1924     Pair newCtx     = pair(tc_name, zfst(kinded_tv));
1925 #   ifdef DEBUG_IFACE
1926     fprintf ( stderr, "begin startGHCClass %s\n", textToStr(ct) );
1927 #   endif
1928
1929     line = intOf(line);
1930     if (length(kinded_tvs) != 1) {
1931         ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
1932         EEND;
1933     }
1934
1935     if (nonNull(findClass(ct))) {
1936         ERRMSG(line) "Repeated definition of class \"%s\"",
1937                      textToStr(ct)
1938         EEND;
1939     } else if (nonNull(findTycon(ct))) {
1940         ERRMSG(line) "\"%s\" used as both class and type constructor",
1941                      textToStr(ct)
1942         EEND;
1943     } else {
1944         Class nw              = newClass(ct);
1945         cclass(nw).text       = ct;
1946         cclass(nw).line       = line;
1947         cclass(nw).arity      = 1;
1948         cclass(nw).head       = ap(nw,mkOffset(0));
1949         cclass(nw).kinds      = singleton( zsnd(kinded_tv) );
1950         cclass(nw).instances  = NIL;
1951         cclass(nw).numSupers  = length(ctxt);
1952
1953         /* Kludge to map the single tyvar in the context to Offset 0.
1954            Need to do something better for multiparam type classes.
1955         */
1956         cclass(nw).supers     = tvsToOffsets(line,ctxt,
1957                                              singleton(kinded_tv));
1958
1959
1960         for (mems=mems0; nonNull(mems); mems=tl(mems)) {
1961            ZPair mem  = hd(mems);
1962            Type  memT = zsnd(mem);
1963            Text  mnt  = textOf(zfst(mem));
1964            Name  mn;
1965
1966            /* Stick the new context on the member type */
1967            memT = dictapsToQualtype(memT);
1968            if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
1969            if (whatIs(memT)==QUAL) {
1970               memT = pair(QUAL,
1971                           pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
1972            } else {
1973               memT = pair(QUAL,
1974                           pair(singleton(newCtx),memT));
1975            }
1976
1977            /* Cook up a kind for the type. */
1978            tvsInT = ifTyvarsIn(memT);
1979            /* tvsInT :: [VarId] */
1980
1981            /* ToDo: maximally bogus.  We allow the class tyvar to
1982               have the kind as supplied by the parser, but we just
1983               assume that all others have kind *.  It's a kludge.
1984            */
1985            for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) {
1986               Kind k;
1987               if (textOf(hd(tvs)) == textOf(zfst(kinded_tv)))
1988                  k = zsnd(kinded_tv); else
1989                  k = STAR;
1990               hd(tvs) = zpair(hd(tvs),k);
1991            }
1992            /* tvsIntT :: [((VarId,Kind))] */
1993
1994            memT = mkPolyType(tvsToKind(tvsInT),memT);
1995            memT = tvsToOffsets(line,memT,tvsInT);
1996
1997            /* Park the type back on the member */
1998            mem = zpair(zfst(mem),memT);
1999
2000            /* Bind code to the member */
2001            mn = findName(mnt);
2002            if (nonNull(mn)) {
2003               ERRMSG(line)
2004                  "Repeated definition for class method \"%s\"",
2005                  textToStr(mnt)
2006               EEND;
2007            }
2008            mn = newName(mnt,NIL);
2009
2010            hd(mems) = mem;
2011         }
2012
2013         cclass(nw).members    = mems0;
2014         cclass(nw).numMembers = length(mems0);
2015
2016         ns = NIL;
2017         for (mno=0; mno<cclass(nw).numSupers; mno++) {
2018            ns = cons(newDSel(nw,mno),ns);
2019         }
2020         cclass(nw).dsels = rev(ns);
2021     }
2022 }
2023
2024
2025 static Class finishGHCClass ( Tycon cls_tyc )
2026 {
2027     List  mems;
2028     Int   line;
2029     Int   ctr;
2030     Class nw = findClass ( textOf(cls_tyc) );
2031 #   ifdef DEBUG_IFACE
2032     fprintf ( stderr, "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
2033 #   endif
2034     if (isNull(nw)) internal("finishGHCClass");
2035
2036     line = cclass(nw).line;
2037     ctr = -2;
2038     assert (currentModule == cclass(nw).mod);
2039
2040     cclass(nw).level   = 0;
2041     cclass(nw).head    = conidcellsToTycons(line,cclass(nw).head);
2042     cclass(nw).supers  = conidcellsToTycons(line,cclass(nw).supers);
2043     cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
2044
2045     for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
2046        Pair mem = hd(mems); /* (VarId, Type) */
2047        Text txt = textOf(fst(mem));
2048        Type ty  = snd(mem);
2049        Name n   = findName(txt);
2050        assert(nonNull(n));
2051        name(n).text   = txt;
2052        name(n).line   = cclass(nw).line;
2053        name(n).type   = ty;
2054        name(n).number = ctr--;
2055        name(n).arity  = arityInclDictParams(name(n).type);
2056        name(n).parent = nw;
2057        hd(mems) = n;
2058     }
2059
2060     return nw;
2061 }
2062
2063
2064 /* --------------------------------------------------------------------------
2065  * Instances
2066  * ------------------------------------------------------------------------*/
2067
2068 static Inst startGHCInstance (line,ktyvars,cls,var)
2069 Int   line;
2070 List  ktyvars; /* [((VarId,Kind))] */
2071 Type  cls;     /* Type  */
2072 VarId var; {   /* VarId */
2073     List tmp, tvs, ks, spec;
2074
2075     List xs1, xs2;
2076     Kind k;
2077
2078     Inst in = newInst();
2079 #   ifdef DEBUG_IFACE
2080     fprintf ( stderr, "begin startGHCInstance\n" );
2081 #   endif
2082
2083     line = intOf(line);
2084
2085     tvs = ifTyvarsIn(cls);  /* :: [VarId] */
2086     /* tvs :: [VarId].
2087        The order of tvs is important for tvsToOffsets.
2088        tvs should be a permutation of ktyvars.  Fish the tyvar kinds
2089        out of ktyvars and attach them to tvs.
2090     */
2091     for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
2092        k = NIL;
2093        for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
2094           if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
2095              k = zsnd(hd(xs2));
2096        if (isNull(k)) internal("startGHCInstance: finding kinds");
2097        hd(xs1) = zpair(hd(xs1),k);
2098     }
2099
2100     cls = tvsToOffsets(line,cls,tvs);
2101     spec = NIL;
2102     while (isAp(cls)) {
2103        spec = cons(fun(cls),spec);
2104        cls  = arg(cls);
2105     }
2106     spec = reverse(spec);
2107
2108     inst(in).line         = line;
2109     inst(in).implements   = NIL;
2110     inst(in).kinds        = simpleKind(length(tvs)); /* do this right */
2111     inst(in).specifics    = spec;
2112     inst(in).numSpecifics = length(spec);
2113     inst(in).head         = cls;
2114
2115     /* Figure out the name of the class being instanced, and store it
2116        at inst(in).c.  finishGHCInstance will resolve it to a real Class. */
2117     {
2118        Cell cl = inst(in).head;
2119        assert(whatIs(cl)==DICTAP);
2120        cl = unap(DICTAP,cl);
2121        cl = fst(cl);
2122        assert ( isQCon(cl) );
2123        inst(in).c = cl;
2124     }
2125
2126     {
2127         Name b         = newName( /*inventText()*/ textOf(var),NIL);
2128         name(b).line   = line;
2129         name(b).arity  = length(spec); /* unused? */ /* and surely wrong */
2130         name(b).number = DFUNNAME;
2131         name(b).parent = in;
2132         inst(in).builder = b;
2133         /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
2134     }
2135
2136     return in;
2137 }
2138
2139
2140 static Void finishGHCInstance ( Inst in )
2141 {
2142     Int    line;
2143     Class  c;
2144     Type   cls;
2145
2146 #   ifdef DEBUG_IFACE
2147     fprintf ( stderr, "begin finishGHCInstance\n" );
2148 #   endif
2149
2150     assert (nonNull(in));
2151     line = inst(in).line;
2152     assert (currentModule==inst(in).mod);
2153
2154     /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
2155        since startGHCInstance couldn't possibly have resolved it to
2156        a Class at that point.  We convert it to a Class now.
2157     */
2158     c = inst(in).c;
2159     assert(isQCon(c));
2160     c = findQualClassWithoutConsultingExportList(c);
2161     assert(nonNull(c));
2162     inst(in).c = c;
2163
2164     inst(in).head         = conidcellsToTycons(line,inst(in).head);
2165     inst(in).specifics    = conidcellsToTycons(line,inst(in).specifics);
2166     cclass(c).instances   = cons(in,cclass(c).instances);
2167 }
2168
2169
2170 /* --------------------------------------------------------------------------
2171  * Helper fns
2172  * ------------------------------------------------------------------------*/
2173
2174 /* This is called from the startGHC* functions.  It traverses a structure
2175    and converts varidcells, ie, type variables parsed by the interface
2176    parser, into Offsets, which is how Hugs wants to see them internally.
2177    The Offset for a type variable is determined by its place in the list
2178    passed as the second arg; the associated kinds are irrelevant.
2179
2180    ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
2181 */
2182
2183 /* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
2184 static Type tvsToOffsets(line,type,ktyvars)
2185 Int  line;
2186 Type type;
2187 List ktyvars; { /* [((VarId,Kind))] */
2188    switch (whatIs(type)) {
2189       case NIL:
2190       case TUPLE:
2191       case QUALIDENT:
2192       case CONIDCELL:
2193       case TYCON:
2194          return type;
2195       case ZTUP2: /* convert to the untyped representation */
2196          return ap( tvsToOffsets(line,zfst(type),ktyvars),
2197                     tvsToOffsets(line,zsnd(type),ktyvars) );
2198       case AP:
2199          return ap( tvsToOffsets(line,fun(type),ktyvars),
2200                     tvsToOffsets(line,arg(type),ktyvars) );
2201       case POLYTYPE:
2202          return mkPolyType (
2203                    polySigOf(type),
2204                    tvsToOffsets(line,monotypeOf(type),ktyvars)
2205                 );
2206          break;
2207       case QUAL:
2208          return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
2209                                tvsToOffsets(line,snd(snd(type)),ktyvars)));
2210       case DICTAP: /* bogus ?? */
2211          return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
2212       case UNBOXEDTUP:  /* bogus?? */
2213          return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
2214       case BANG:  /* bogus?? */
2215          return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
2216       case VARIDCELL: /* Ha! some real work to do! */
2217        { Int i = 0;
2218          Text tv = textOf(type);
2219          for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
2220             Cell varid;
2221             Text tt;
2222             assert(isZPair(hd(ktyvars)));
2223             varid = zfst(hd(ktyvars));
2224             tt    = textOf(varid);
2225             if (tv == tt) return mkOffset(i);
2226          }
2227          ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
2228          EEND;
2229          break;
2230        }
2231       default:
2232          fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
2233          print(type,20);
2234          fprintf(stderr,"\n");
2235          assert(0);
2236    }
2237    assert(0);
2238    return NIL; /* NOTREACHED */
2239 }
2240
2241
2242 /* This is called from the finishGHC* functions.  It traverses a structure
2243    and converts conidcells, ie, type constructors parsed by the interface
2244    parser, into Tycons (or Classes), which is how Hugs wants to see them
2245    internally.  Calls to this fn have to be deferred to the second phase
2246    of interface loading (finishGHC* rather than startGHC*) so that all relevant
2247    Tycons or Classes have been loaded into the symbol tables and can be
2248    looked up.
2249 */
2250 static Type conidcellsToTycons ( Int line, Type type )
2251 {
2252    switch (whatIs(type)) {
2253       case NIL:
2254       case OFFSET:
2255       case TYCON:
2256       case CLASS:
2257       case VARIDCELL:
2258       case TUPLE:
2259       case STAR:
2260          return type;
2261       case QUALIDENT:
2262        { Cell t;  /* Tycon or Class */
2263          Text m     = qmodOf(type);
2264          Module mod = findModule(m);
2265          if (isNull(mod)) {
2266             ERRMSG(line)
2267                "Undefined module in qualified name \"%s\"",
2268                identToStr(type)
2269             EEND;
2270             return NIL;
2271          }
2272          t = findQualTyconWithoutConsultingExportList(type);
2273          if (nonNull(t)) return t;
2274          t = findQualClassWithoutConsultingExportList(type);
2275          if (nonNull(t)) return t;
2276          ERRMSG(line)
2277               "Undefined qualified class or type \"%s\"",
2278               identToStr(type)
2279          EEND;
2280          return NIL;
2281        }
2282       case CONIDCELL:
2283        { Tycon tc;
2284          Class cl;
2285          cl = findQualClass(type);
2286          if (nonNull(cl)) return cl;
2287          if (textOf(type)==findText("[]"))
2288             /* a hack; magically qualify [] into PrelBase.[] */
2289             return conidcellsToTycons(line,
2290                                       mkQualId(mkCon(findText("PrelBase")),type));
2291          tc = findQualTycon(type);
2292          if (nonNull(tc)) return tc;
2293          ERRMSG(line)
2294              "Undefined class or type constructor \"%s\"",
2295              identToStr(type)
2296          EEND;
2297          return NIL;
2298        }
2299       case AP:
2300          return ap( conidcellsToTycons(line,fun(type)),
2301                     conidcellsToTycons(line,arg(type)) );
2302       case ZTUP2: /* convert to std pair */
2303          return ap( conidcellsToTycons(line,zfst(type)),
2304                     conidcellsToTycons(line,zsnd(type)) );
2305
2306       case POLYTYPE:
2307          return mkPolyType (
2308                    polySigOf(type),
2309                    conidcellsToTycons(line,monotypeOf(type))
2310                 );
2311          break;
2312       case QUAL:
2313          return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
2314                                conidcellsToTycons(line,snd(snd(type)))));
2315       case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
2316                       Not sure if this is really the right place to
2317                       convert it to the form Hugs wants, but will do so anyway.
2318                     */
2319          /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
2320         {
2321            Class cl   = fst(unap(DICTAP,type));
2322            List  args = snd(unap(DICTAP,type));
2323            return
2324               conidcellsToTycons(line,pair(cl,args));
2325         }
2326       case UNBOXEDTUP:
2327          return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
2328       case BANG:
2329          return ap(BANG, conidcellsToTycons(line, snd(type)));
2330       default:
2331          fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
2332                  whatIs(type));
2333          print(type,20);
2334          fprintf(stderr,"\n");
2335          assert(0);
2336    }
2337    assert(0);
2338    return NIL; /* NOTREACHED */
2339 }
2340
2341
2342 /* Find out if a type mentions a type constructor not present in
2343    the supplied list of qualified tycons.
2344 */
2345 static Bool allTypesKnown ( Type  type,
2346                             List  aktys /* [QualId] */,
2347                             ConId thisMod )
2348 {
2349    switch (whatIs(type)) {
2350       case NIL:
2351       case OFFSET:
2352       case VARIDCELL:
2353       case TUPLE:
2354          return TRUE;
2355       case AP:
2356          return allTypesKnown(fun(type),aktys,thisMod)
2357                 && allTypesKnown(arg(type),aktys,thisMod);
2358       case ZTUP2:
2359          return allTypesKnown(zfst(type),aktys,thisMod)
2360                 && allTypesKnown(zsnd(type),aktys,thisMod);
2361       case DICTAP:
2362          return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
2363
2364       case CONIDCELL:
2365         if (textOf(type)==findText("[]"))
2366             /* a hack; magically qualify [] into PrelBase.[] */
2367             type = mkQualId(mkCon(findText("PrelBase")),type); else
2368             type = mkQualId(thisMod,type);
2369          /* fall through */
2370       case QUALIDENT:
2371          if (isNull(qualidIsMember(type,aktys))) goto missing;
2372          return TRUE;
2373       case TYCON:
2374          return TRUE;
2375
2376       default:
2377          fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
2378          print(type,10);printf("\n");
2379          internal("allTypesKnown");
2380          return TRUE; /*notreached*/
2381    }
2382   missing:
2383 #  ifdef DEBUG_IFACE
2384    fprintf ( stderr,"allTypesKnown: unknown " ); print(type,10);
2385    fprintf(stderr,"\n");
2386 #  endif
2387    return FALSE;
2388 }
2389
2390
2391 /* --------------------------------------------------------------------------
2392  * Utilities
2393  *
2394  * None of these do lookups or require that lookups have been resolved
2395  * so they can be performed while reading interfaces.
2396  * ------------------------------------------------------------------------*/
2397
2398 /* tvsToKind :: [((VarId,Kind))] -> Kinds */
2399 static Kinds tvsToKind(tvs)
2400 List tvs; { /* [((VarId,Kind))] */
2401     List  rs;
2402     Kinds r  = STAR;
2403     for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
2404         if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)");
2405         if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)");
2406         r = ap(zsnd(hd(rs)),r);
2407     }
2408     return r;
2409 }
2410
2411
2412 static Int arityInclDictParams ( Type type )
2413 {
2414    Int arity = 0;
2415    if (isPolyType(type)) type = monotypeOf(type);
2416
2417    if (whatIs(type) == QUAL)
2418    {
2419       arity += length ( fst(snd(type)) );
2420       type = snd(snd(type));
2421    }
2422    while (isAp(type) && getHead(type)==typeArrow) {
2423       arity++;
2424       type = arg(type);
2425    }
2426    return arity;
2427 }
2428
2429 /* arity of a constructor with this type */
2430 static Int arityFromType(type)
2431 Type type; {
2432     Int arity = 0;
2433     if (isPolyType(type)) {
2434         type = monotypeOf(type);
2435     }
2436     if (whatIs(type) == QUAL) {
2437         type = snd(snd(type));
2438     }
2439     if (whatIs(type) == EXIST) {
2440         type = snd(snd(type));
2441     }
2442     if (whatIs(type)==RANK2) {
2443         type = snd(snd(type));
2444     }
2445     while (isAp(type) && getHead(type)==typeArrow) {
2446         arity++;
2447         type = arg(type);
2448     }
2449     return arity;
2450 }
2451
2452
2453 /* ifTyvarsIn :: Type -> [VarId]
2454    The returned list has no duplicates -- is a set.
2455 */
2456 static List ifTyvarsIn(type)
2457 Type type; {
2458     List vs = typeVarsIn(type,NIL,NIL,NIL);
2459     List vs2 = vs;
2460     for (; nonNull(vs2); vs2=tl(vs2))
2461        if (whatIs(hd(vs2)) != VARIDCELL)
2462           internal("ifTyvarsIn");
2463     return vs;
2464 }
2465
2466
2467
2468 /* --------------------------------------------------------------------------
2469  * General object symbol query stuff
2470  * ------------------------------------------------------------------------*/
2471
2472 #define EXTERN_SYMS_ALLPLATFORMS     \
2473       Sym(MainRegTable)              \
2474       Sym(stg_gc_enter_1)            \
2475       Sym(stg_gc_noregs)             \
2476       Sym(stg_gc_seq_1)              \
2477       Sym(stg_gc_d1)                 \
2478       Sym(stg_gc_f1)                 \
2479       Sym(stg_chk_0)                 \
2480       Sym(stg_chk_1)                 \
2481       Sym(stg_gen_chk)               \
2482       Sym(stg_exit)                  \
2483       Sym(stg_update_PAP)            \
2484       Sym(stg_error_entry)           \
2485       Sym(__ap_2_upd_info)           \
2486       Sym(__ap_3_upd_info)           \
2487       Sym(__ap_4_upd_info)           \
2488       Sym(__ap_5_upd_info)           \
2489       Sym(__ap_6_upd_info)           \
2490       Sym(__ap_7_upd_info)           \
2491       Sym(__ap_8_upd_info)           \
2492       Sym(__sel_0_upd_info)          \
2493       Sym(__sel_1_upd_info)          \
2494       Sym(__sel_2_upd_info)          \
2495       Sym(__sel_3_upd_info)          \
2496       Sym(__sel_4_upd_info)          \
2497       Sym(__sel_5_upd_info)          \
2498       Sym(__sel_6_upd_info)          \
2499       Sym(__sel_7_upd_info)          \
2500       Sym(__sel_8_upd_info)          \
2501       Sym(__sel_9_upd_info)          \
2502       Sym(__sel_10_upd_info)         \
2503       Sym(__sel_11_upd_info)         \
2504       Sym(__sel_12_upd_info)         \
2505       Sym(Upd_frame_info)            \
2506       Sym(seq_frame_info)            \
2507       Sym(CAF_BLACKHOLE_info)        \
2508       Sym(IND_STATIC_info)           \
2509       Sym(EMPTY_MVAR_info)           \
2510       Sym(MUT_ARR_PTRS_FROZEN_info)  \
2511       Sym(newCAF)                    \
2512       Sym(putMVarzh_fast)            \
2513       Sym(newMVarzh_fast)            \
2514       Sym(takeMVarzh_fast)           \
2515       Sym(catchzh_fast)              \
2516       Sym(raisezh_fast)              \
2517       Sym(delayzh_fast)              \
2518       Sym(yieldzh_fast)              \
2519       Sym(killThreadzh_fast)         \
2520       Sym(waitReadzh_fast)           \
2521       Sym(waitWritezh_fast)          \
2522       Sym(CHARLIKE_closure)          \
2523       Sym(INTLIKE_closure)           \
2524       Sym(suspendThread)             \
2525       Sym(resumeThread)              \
2526       Sym(stackOverflow)             \
2527       Sym(int2Integerzh_fast)        \
2528       Sym(stg_gc_unbx_r1)            \
2529       Sym(ErrorHdrHook)              \
2530       Sym(makeForeignObjzh_fast)     \
2531       Sym(__encodeDouble)            \
2532       Sym(decodeDoublezh_fast)       \
2533       Sym(isDoubleNaN)               \
2534       Sym(isDoubleInfinite)          \
2535       Sym(isDoubleDenormalized)      \
2536       Sym(isDoubleNegativeZero)      \
2537       Sym(__encodeFloat)             \
2538       Sym(decodeFloatzh_fast)        \
2539       Sym(isFloatNaN)                \
2540       Sym(isFloatInfinite)           \
2541       Sym(isFloatDenormalized)       \
2542       Sym(isFloatNegativeZero)       \
2543       Sym(__int_encodeFloat)         \
2544       Sym(__int_encodeDouble)        \
2545       Sym(mpz_cmp_si)                \
2546       Sym(mpz_cmp)                   \
2547       Sym(__mpn_gcd_1)               \
2548       Sym(gcdIntegerzh_fast)         \
2549       Sym(newArrayzh_fast)           \
2550       Sym(unsafeThawArrayzh_fast)    \
2551       Sym(newDoubleArrayzh_fast)     \
2552       Sym(newFloatArrayzh_fast)      \
2553       Sym(newAddrArrayzh_fast)       \
2554       Sym(newWordArrayzh_fast)       \
2555       Sym(newIntArrayzh_fast)        \
2556       Sym(newCharArrayzh_fast)       \
2557       Sym(newMutVarzh_fast)          \
2558       Sym(quotRemIntegerzh_fast)     \
2559       Sym(quotIntegerzh_fast)        \
2560       Sym(remIntegerzh_fast)         \
2561       Sym(divExactIntegerzh_fast)    \
2562       Sym(divModIntegerzh_fast)      \
2563       Sym(timesIntegerzh_fast)       \
2564       Sym(minusIntegerzh_fast)       \
2565       Sym(plusIntegerzh_fast)        \
2566       Sym(addr2Integerzh_fast)       \
2567       Sym(mkWeakzh_fast)             \
2568       Sym(prog_argv)                 \
2569       Sym(prog_argc)                 \
2570       Sym(resetNonBlockingFd)        \
2571       Sym(getStablePtr)              \
2572       Sym(stable_ptr_table)          \
2573       Sym(createAdjThunk)            \
2574       Sym(shutdownHaskellAndExit)    \
2575       Sym(stg_enterStackTop)         \
2576       Sym(CAF_UNENTERED_entry)       \
2577       Sym(stg_yield_to_Hugs)         \
2578       Sym(StgReturn)                 \
2579       Sym(init_stack)                \
2580                                      \
2581       /* needed by libHS_cbits */    \
2582       SymX(malloc)                   \
2583       SymX(close)                    \
2584       Sym(mkdir)                     \
2585       SymX(close)                    \
2586       Sym(opendir)                   \
2587       Sym(closedir)                  \
2588       Sym(readdir)                   \
2589       Sym(tcgetattr)                 \
2590       Sym(tcsetattr)                 \
2591       SymX(isatty)                   \
2592       SymX(read)                     \
2593       SymX(lseek)                    \
2594       SymX(write)                    \
2595       Sym(getrusage)                 \
2596       Sym(gettimeofday)              \
2597       SymX(realloc)                  \
2598       SymX(getcwd)                   \
2599       SymX(free)                     \
2600       SymX(strcpy)                   \
2601       Sym(fcntl)                     \
2602       SymX(fprintf)                  \
2603       SymX(exit)                     \
2604       Sym(open)                      \
2605       SymX(unlink)                   \
2606       SymX(memcpy)                   \
2607       SymX(memchr)                   \
2608       SymX(rmdir)                    \
2609       SymX(rename)                   \
2610       SymX(chdir)                    \
2611       SymX(execl)                    \
2612       Sym(waitpid)                   \
2613       SymX(getenv)
2614
2615 #define EXTERN_SYMS_cygwin32         \
2616       SymX(GetCurrentProcess)        \
2617       SymX(GetProcessTimes)          \
2618       Sym(__udivdi3)                 \
2619       SymX(bzero)                    \
2620       Sym(select)                    \
2621       SymX(_impure_ptr)              \
2622       Sym(lstat)                     \
2623       Sym(setmode)                   \
2624       SymX(system)                   \
2625       SymX(sleep)                    \
2626       SymX(__imp__tzname)            \
2627       SymX(__imp__timezone)          \
2628       SymX(tzset)                    \
2629       Sym(log)                       \
2630       Sym(exp)                       \
2631       Sym(sqrt)                      \
2632       Sym(sin)                       \
2633       Sym(cos)                       \
2634       Sym(tan)                       \
2635       Sym(asin)                      \
2636       Sym(acos)                      \
2637       Sym(atan)                      \
2638       Sym(sinh)                      \
2639       Sym(cosh)                      \
2640       Sym(tanh)                      \
2641       Sym(pow)                       \
2642       Sym(__errno)                   \
2643       Sym(stat)                      \
2644       Sym(fstat)
2645
2646 #define EXTERN_SYMS_linux            \
2647       Sym(__errno_location)          \
2648       Sym(__xstat)                   \
2649       Sym(__fxstat)                  \
2650       Sym(__lxstat)                  \
2651       SymX(select)                   \
2652       SymX(stderr)                   \
2653       SymX(vfork)                    \
2654       SymX(_exit)                    \
2655       SymX(tzname)                   \
2656       SymX(localtime)                \
2657       SymX(strftime)                 \
2658       SymX(timezone)                 \
2659       SymX(mktime)                   \
2660       SymX(gmtime)                   \
2661       Sym(setitimer)                 \
2662
2663
2664
2665 #if defined(linux_TARGET_OS)
2666 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_linux
2667 #endif
2668
2669 #if defined(solaris2_TARGET_OS)
2670 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_solaris2
2671 #endif
2672
2673 #if defined(cygwin32_TARGET_OS)
2674 #define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_cygwin32
2675 #endif
2676
2677
2678
2679
2680 /* entirely bogus claims about types of these symbols */
2681 #define Sym(vvv)  extern void (vvv);
2682 #define SymX(vvv) /**/
2683 EXTERN_SYMS_ALLPLATFORMS
2684 EXTERN_SYMS_THISPLATFORM
2685 #undef Sym
2686 #undef SymX
2687
2688
2689 #define Sym(vvv)  { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2690                     &(vvv) },
2691 #define SymX(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
2692                     &(vvv) },
2693 OSym rtsTab[]
2694    = {
2695        EXTERN_SYMS_ALLPLATFORMS
2696        EXTERN_SYMS_THISPLATFORM
2697        {0,0}
2698      };
2699 #undef Sym
2700 #undef SymX
2701
2702
2703 void init_stack;
2704
2705
2706 /* A kludge to assist Win32 debugging. */
2707 char* nameFromStaticOPtr ( void* ptr )
2708 {
2709    int k;
2710    for (k = 0; rtsTab[k].nm; k++)
2711       if (ptr == rtsTab[k].ad)
2712          return rtsTab[k].nm;
2713    return NULL;
2714 }
2715
2716
2717 void* lookupObjName ( char* nm )
2718 {
2719    int    k;
2720    char*  pp;
2721    void*  a;
2722    Text   t;
2723    Module m;
2724    char   nm2[200];
2725    int    first_real_char;
2726
2727    nm2[199] = 0;
2728    strncpy(nm2,nm,200);
2729
2730    /*  first see if it's an RTS name */
2731    for (k = 0; rtsTab[k].nm; k++)
2732       if (0==strcmp(nm2,rtsTab[k].nm))
2733          return rtsTab[k].ad;
2734
2735    /* perhaps an extra-symbol ? */
2736    a = lookupOExtraTabName ( nm );
2737    if (a) return a;
2738
2739 #  if LEADING_UNDERSCORE
2740    first_real_char = 1;
2741 #  else
2742    first_real_char = 0;
2743 #  endif
2744
2745    /* Maybe it's an __init_Module thing? */
2746    if (strlen(nm2+first_real_char) > 7
2747        && strncmp(nm2+first_real_char, "__init_", 7)==0) {
2748       t = unZcodeThenFindText(nm2+first_real_char+7);
2749       if (t == findText("PrelGHC")) return (4+NULL); /* kludge */
2750       m = findModule(t);
2751       if (isNull(m)) goto not_found;
2752       a = lookupOTabName ( m, nm );
2753       if (a) return a;
2754       goto not_found;
2755    }
2756
2757    /* if not an RTS name, look in the
2758       relevant module's object symbol table
2759    */
2760    pp = strchr(nm2+first_real_char, '_');
2761    if (!pp || !isupper(nm2[first_real_char])) goto not_found;
2762    *pp = 0;
2763    t = unZcodeThenFindText(nm2+first_real_char);
2764    m = findModule(t);
2765    if (isNull(m)) goto not_found;
2766
2767    a = lookupOTabName ( m, nm );  /* RATIONALISE */
2768    if (a) return a;
2769
2770   not_found:
2771    fprintf ( stderr,
2772              "lookupObjName: can't resolve name `%s'\n",
2773              nm );
2774    assert(4-4);
2775    return NULL;
2776 }
2777
2778
2779 int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
2780 {
2781    OSectionKind sk = lookupSection(p);
2782    assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2783    return (sk == HUGS_SECTIONKIND_CODE_OR_RODATA);
2784 }
2785
2786
2787 int is_dynamically_loaded_rwdata_ptr ( char* p )
2788 {
2789    OSectionKind sk = lookupSection(p);
2790    assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2791    return (sk == HUGS_SECTIONKIND_RWDATA);
2792 }
2793
2794
2795 int is_not_dynamically_loaded_ptr ( char* p )
2796 {
2797    OSectionKind sk = lookupSection(p);
2798    assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
2799    return (sk == HUGS_SECTIONKIND_OTHER);
2800 }
2801
2802
2803 /* --------------------------------------------------------------------------
2804  * Control:
2805  * ------------------------------------------------------------------------*/
2806
2807 Void interface(what)
2808 Int what; {
2809     switch (what) {
2810        case POSTPREL: break;
2811
2812        case PREPREL:
2813        case RESET:
2814           ifaces_outstanding  = NIL;
2815           break;
2816        case MARK:
2817           mark(ifaces_outstanding);
2818           break;
2819     }
2820 }
2821
2822 /*-------------------------------------------------------------------------*/