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