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