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