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