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