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