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