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