interface.c 81.5 KB
Newer Older
1
2
3
4
5
6
7
8
9

/* --------------------------------------------------------------------------
 * GHC interface file processing for Hugs
 *
 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
 * All rights reserved. See NOTICE for details and conditions of use etc...
 * Hugs version 1.4, December 1997
 *
 * $RCSfile: interface.c,v $
10
11
 * $Revision: 1.24 $
 * $Date: 2000/01/11 14:09:17 $
12
13
14
15
16
17
18
19
 * ------------------------------------------------------------------------*/

#include "prelude.h"
#include "storage.h"
#include "backend.h"
#include "connect.h"
#include "errors.h"
#include "link.h"
20
#include "Assembler.h"  /* for wrapping GHC objects */
21
22
#include "object.h"

23

24
#define DEBUG_IFACE
25
#define VERBOSE FALSE
26

27
28
extern void print ( Cell, Int );

29
/* --------------------------------------------------------------------------
30
 * (This comment is now out of date.  JRS, 991216).
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
 * The "addGHC*" functions act as "impedence matchers" between GHC
 * interface files and Hugs.  Their main job is to convert abstract
 * syntax trees into Hugs' internal representations.
 *
 * The main trick here is how we deal with mutually recursive interface 
 * files:
 *
 * o As we read an import decl, we add it to a list of required imports
 *   (unless it's already loaded, of course).
 *
 * o Processing of declarations is split into two phases:
 *
 *   1) While reading the interface files, we construct all the Names,
 *      Tycons, etc declared in the interface file but we don't try to
 *      resolve references to any entities the declaration mentions.
 *
 *      This is done by the "addGHC*" functions.
 *
 *   2) After reading all the interface files, we finish processing the
 *      declarations by resolving any references in the declarations
 *      and doing any other processing that may be required.
 *
 *      This is done by the "finishGHC*" functions which use the 
 *      "fixup*" functions to assist them.
 *
 *   The interface between these two phases are the "ghc*Decls" which
 *   contain lists of decls that haven't been completed yet.
 *
 * ------------------------------------------------------------------------*/

61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119

/*
New comment, 991216, explaining roughly how it all works.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Interfaces can contain references to unboxed types, and these need to
be handled carefully.  The following is a summary of how the interface
loader now works.  It is applied to groups of interfaces simultaneously,
viz, the entire Prelude at once:

0.  Parse interfaces, chasing imports until a complete
    strongly-connected-component of ifaces has been parsed.
    All interfaces in this scc are processed together, in
    steps 1 .. 8 below.

1.  Throw away any entity not mentioned in the export lists.

2.  Delete type (not data or newtype) definitions which refer to 
    unknown types in their right hand sides.  Because Hugs doesn't
    know of any unboxed types, this has the side effect of removing
    all type defns referring to unboxed types.  Repeat step 2 until
    a fixed point is reached.

3.  Make abstract all data/newtype defns which refer to an unknown
    type.  eg, data Word = MkW Word# becomes data Word, because 
    Word# is unknown.  Hugs is happy to know about abstract boxed
    Words, but not about Word#s.

4.  Step 2 could delete types referred to by values, instances and
    classes.  So filter all entities, and delete those referring to
    unknown types _or_ classes.  This could cause other entities
    to become invalid, so iterate step 4 to a fixed point.

    After step 4, the interfaces no longer contain anything
    unpalatable to Hugs.

5.  Steps 1-4 operate purely on the iface syntax trees.  We now start
    creating symbol table entries.  First, create a module table
    entry for each interface, and locate and read in the corresponding
    object file.  This is done by the startGHCModule function.

6.  Traverse all interfaces.  For each entity, create an entry in
    the name, tycon, class or instance table, and fill in relevant
    fields, but do not attempt to link tycon/class/instance/name uses
    to their symbol table entries.  This is done by the startGHC*
    functions.

7.  Revisit all symbol table entries created in step 6.  We should
    now be able to replace all references to tycons/classes/instances/
    names with the relevant symbol table entries.  This is done by
    the finishGHC* functions.

8.  Traverse all interfaces.  For each iface, examine the export lists
    and use it to build export lists in the module table.  Do the
    implicit 'import Prelude' thing if necessary.  Finally, resolve
    references in the object code for this module.  This is done
    by the finishGHCModule function.
*/

120
/* --------------------------------------------------------------------------
121
 * local function prototypes:
122
123
 * ------------------------------------------------------------------------*/

124
125
static Void startGHCValue       Args((Int,VarId,Type));
static Void finishGHCValue      Args((VarId));
126

127
128
static Void startGHCSynonym     Args((Int,Cell,List,Type));
static Void finishGHCSynonym    Args((Tycon)); 
129

130
131
static Void startGHCClass       Args((Int,List,Cell,List,List));
static Void finishGHCClass      Args((Class)); 
132

133
static Inst startGHCInstance    Args((Int,List,Pair,VarId));
134
static Void finishGHCInstance   Args((Inst));
135

136
137
static Void startGHCImports     Args((ConId,List));
static Void finishGHCImports    Args((ConId,List));
138

139
140
static Void startGHCExports     Args((ConId,List));
static Void finishGHCExports    Args((ConId,List));
141

142
static Void finishGHCModule     Args((Cell));
143
static Void startGHCModule      Args((Text, Int, Text));
144

145
146
static Void startGHCDataDecl    Args((Int,List,Cell,List,List));
static Void finishGHCDataDecl   ( ConId tyc );
147

148
149
static Void startGHCNewType     Args((Int,List,Cell,List,Cell));
static Void finishGHCNewType    ( ConId tyc );
150
151


152
153
154
155
156
157
158
159
160
161
/* Supporting stuff for {start|finish}GHCDataDecl */
static List startGHCConstrs Args((Int,List,List));
static Name startGHCSel     Args((Int,Pair));
static Name startGHCConstr  Args((Int,Int,Triple));



static Kinds tvsToKind             Args((List));
static Int   arityFromType         Args((Type));
static Int   arityInclDictParams   Args((Type));
162
static Bool  allTypesKnown ( Type type, List aktys /* [QualId] */, ConId thisMod );
163
164
165
166
167
168
169
                                         
static List       ifTyvarsIn       Args((Type));

static Type       tvsToOffsets       Args((Int,Type,List));
static Type       conidcellsToTycons Args((Int,Type));

static void*      lookupObjName ( char* );
170
171
172
173




174
175
176
177
178

/* --------------------------------------------------------------------------
 * Top-level interface processing
 * ------------------------------------------------------------------------*/

179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
/* getIEntityName :: I_IMPORT..I_VALUE -> ConVarId | NIL */
ConVarId getIEntityName ( Cell c )
{
   switch (whatIs(c)) {
      case I_IMPORT:     return NIL;
      case I_INSTIMPORT: return NIL;
      case I_EXPORT:     return NIL;
      case I_FIXDECL:    return zthd3(unap(I_FIXDECL,c));
      case I_INSTANCE:   return NIL;
      case I_TYPE:       return zsel24(unap(I_TYPE,c));
      case I_DATA:       return zsel35(unap(I_DATA,c));
      case I_NEWTYPE:    return zsel35(unap(I_NEWTYPE,c));
      case I_CLASS:      return zsel35(unap(I_CLASS,c));
      case I_VALUE:      return zsnd3(unap(I_VALUE,c));
      default:           internal("getIEntityName");
   }
}


/* Filter the contents of an interface, using the supplied predicate.
   For flexibility, the predicate is passed as a second arg the value
   extraArgs.  This is a hack to get round the lack of partial applications
   in C.  Pred should not have any side effects.  The dumpaction param
   gives us the chance to print a message or some such for dumped items.
   When a named entity is deleted, filterInterface also deletes the name
   in the export lists.
*/
Cell filterInterface ( Cell root, 
                       Bool (*pred)(Cell,Cell), 
                       Cell extraArgs,
                       Void (*dumpAction)(Cell) )
{
   List tops;
   Cell iface       = unap(I_INTERFACE,root);
   List tops2       = NIL;
   List deleted_ids = NIL; /* :: [ConVarId] */

   for (tops = zsnd(iface); nonNull(tops); tops=tl(tops)) {
      if (pred(hd(tops),extraArgs)) {
         tops2 = cons( hd(tops), tops2 );
      } else {
         ConVarId deleted_id = getIEntityName ( hd(tops) );
         if (nonNull(deleted_id))
            deleted_ids = cons ( deleted_id, deleted_ids );
         if (dumpAction)
            dumpAction ( hd(tops) );
      }
   }
   tops2 = reverse(tops2);

   /* Clean up the export list now. */
   for (tops=tops2; nonNull(tops); tops=tl(tops)) {
      if (whatIs(hd(tops))==I_EXPORT) {
         Cell exdecl  = unap(I_EXPORT,hd(tops));
         List exlist  = zsnd(exdecl);
         List exlist2 = NIL;
         for (; nonNull(exlist); exlist=tl(exlist)) {
            Cell ex       = hd(exlist);
            ConVarId exid = isZPair(ex) ? zfst(ex) : ex;
            assert (isCon(exid) || isVar(exid));
            if (!varIsMember(textOf(exid),deleted_ids))
               exlist2 = cons(ex, exlist2);
	 }
         hd(tops) = ap(I_EXPORT,zpair(zfst(exdecl),exlist2));
      }
   }

   return ap(I_INTERFACE, zpair(zfst(iface),tops2));
}


250
251
252
253
254
255
256
ZPair readInterface(String fname, Long fileSize)
{
    List  tops;
    List  imports = NIL;
    ZPair iface   = parseInterface(fname,fileSize);
    assert (whatIs(iface)==I_INTERFACE);

257
    for (tops = zsnd(unap(I_INTERFACE,iface)); nonNull(tops); tops=tl(tops))
258
259
260
261
262
263
264
265
266
       if (whatIs(hd(tops)) == I_IMPORT) {
          ZPair imp_decl = unap(I_IMPORT,hd(tops));
          ConId m_to_imp = zfst(imp_decl);
          if (textOf(m_to_imp) != findText("PrelGHC")) {
             imports = cons(m_to_imp,imports);
             /* fprintf(stderr, "add iface %s\n", textToStr(textOf(m_to_imp))); */
          }
       }
    return zpair(iface,imports);
267
268
}

269

270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
/* getExportDeclsInIFace :: I_INTERFACE -> [I_EXPORT] */
static List getExportDeclsInIFace ( Cell root )
{
   Cell  iface   = unap(I_INTERFACE,root);
   List  decls   = zsnd(iface);
   List  exports = NIL;
   List  ds;
   for (ds=decls; nonNull(ds); ds=tl(ds))
      if (whatIs(hd(ds))==I_EXPORT)
         exports = cons(hd(ds), exports);
   return exports;
}



static Bool isExportedIFaceEntity ( Cell ife, List exlist_list )
286
{
287
   /* ife         :: I_IMPORT..I_VALUE                      */
288
   /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
289
   Text  tnm;
290
291
   List  exlist;
   List  t;
292
293
294
295
296
297

   ConVarId ife_id = getIEntityName ( ife );

   if (isNull(ife_id)) return TRUE;

   tnm = textOf(ife_id);
298
299
300
301
302
303

   /* for each export list ... */
   for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
      exlist = hd(exlist_list);

      /* for each entity in an export list ... */
304
      for (t=exlist; nonNull(t); t=tl(t)) {
305
306
307
         if (isZPair(hd(t))) {
            /* A pair, which means an export entry 
               of the form ClassName(foo,bar). */
308
            List subents = cons(zfst(hd(t)),zsnd(hd(t)));
309
            for (; nonNull(subents); subents=tl(subents))
310
               if (textOf(hd(subents)) == tnm) goto retain;
311
312
         } else {
            /* Single name in the list. */
313
            if (textOf(hd(t)) == tnm) goto retain;
314
         }
315
      }
316

317
   }
318
   fprintf ( stderr, "     dump %s\n", textToStr(tnm) );
319
   return FALSE;
320
321
322
323

 retain:
   fprintf ( stderr, "   retain %s\n", textToStr(tnm) );
   return TRUE;
324
325
}

326

327
static Bool isExportedAbstractly ( ConId ife_id, List exlist_list )
328
{
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
   /* ife_id      :: ConId                                  */
   /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
   Text  tnm;
   List  exlist;
   List  t;

   assert (isCon(ife_id));
   tnm = textOf(ife_id);

   /* for each export list ... */
   for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
      exlist = hd(exlist_list);

      /* for each entity in an export list ... */
      for (t=exlist; nonNull(t); t=tl(t)) {
         if (isZPair(hd(t))) {
            /* A pair, which means an export entry 
               of the form ClassName(foo,bar). */
            if (textOf(zfst(hd(t))) == tnm) return FALSE;
         } else {
            if (textOf(hd(t)) == tnm) return TRUE;
         }
      }
   }
   internal("isExportedAbstractly");
   return FALSE; /*notreached*/
355
356
357
}


358
359
/* Remove entities not mentioned in any of the export lists. */
static Cell deleteUnexportedIFaceEntities ( Cell root )
360
361
362
363
364
365
366
367
{
   Cell  iface       = unap(I_INTERFACE,root);
   ConId iname       = zfst(iface);
   List  decls       = zsnd(iface);
   List  decls2      = NIL;
   List  exlist_list = NIL;
   List  t;

368
   fprintf(stderr, "\ncleanIFace: %s\n", textToStr(textOf(iname)));
369
370
371
372
373
374
375
376
377
378

   exlist_list = getExportDeclsInIFace ( root );
   /* exlist_list :: [I_EXPORT] */
   
   for (t=exlist_list; nonNull(t); t=tl(t))
      hd(t) = zsnd(unap(I_EXPORT,hd(t)));
   /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */

   if (isNull(exlist_list)) {
      ERRMSG(0) "Can't find any export lists in interface file"
379
380
381
      EEND;
   }

382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
   return filterInterface ( root, isExportedIFaceEntity, 
                            exlist_list, NULL );
}


/* addTyconsAndClassesFromIFace :: I_INTERFACE -> [QualId] -> [QualId] */
List addTyconsAndClassesFromIFace ( Cell root, List aktys )
{
   Cell iface = unap(I_INTERFACE,root);
   Text mname = textOf(zfst(iface));
   List defns = zsnd(iface);
   for (; nonNull(defns); defns = tl(defns)) {
      Cell defn = hd(defns);
      Cell what = whatIs(defn);
      if (what==I_TYPE || what==I_DATA 
          || what==I_NEWTYPE || what==I_CLASS) {
         QualId q = mkQCon ( mname, textOf(getIEntityName(defn)) );
         if (!qualidIsMember ( q, aktys ))
            aktys = cons ( q, aktys );
      }
   }
   return aktys;
}


Void ifentityAllTypesKnown_dumpmsg ( Cell entity )
{
   ConVarId id = getIEntityName ( entity );
   fprintf ( stderr, 
             "dumping %s because of unknown type(s)\n",
             isNull(id) ? "(nameless entity?!)" : textToStr(textOf(id)) );
}

/* ifentityAllTypesKnown :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
/* mod is the current module being processed -- so we can qualify unqual'd
   names.  Strange calling convention for aktys and mod is so we can call this
   from filterInterface.
*/
Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod )
{
   List  t, u;
   List  aktys = zfst ( aktys_mod );
   ConId mod   = zsnd ( aktys_mod );
   switch (whatIs(entity)) {
      case I_IMPORT:
      case I_INSTIMPORT:
      case I_EXPORT:
      case I_FIXDECL: 
         return TRUE;
      case I_INSTANCE: {
         Cell inst = unap(I_INSTANCE,entity);
         List ctx  = zsel25 ( inst ); /* :: [((QConId,VarId))] */
         Type cls  = zsel35 ( inst ); /* :: Type */
         for (t = ctx; nonNull(t); t=tl(t))
            if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
         if (!allTypesKnown(cls, aktys,mod)) return FALSE;
         return TRUE;
      }
      case I_TYPE:
         return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
      case I_DATA: {
         Cell data    = unap(I_DATA,entity);
         List ctx     = zsel25 ( data ); /* :: [((QConId,VarId))] */
         List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
         for (t = ctx; nonNull(t); t=tl(t))
            if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
         for (t = constrs; nonNull(t); t=tl(t))
            for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
               if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) return FALSE;
         return TRUE;
      }
      case I_NEWTYPE: {
         Cell  newty  = unap(I_NEWTYPE,entity);
         List  ctx    = zsel25(newty);    /* :: [((QConId,VarId))] */
         ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
         for (t = ctx; nonNull(t); t=tl(t))
            if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
         if (nonNull(constr)
             && !allTypesKnown(zsnd(constr),aktys,mod)) return FALSE;
         return TRUE;
      }
      case I_CLASS: {
         Cell klass = unap(I_CLASS,entity);
         List ctx   = zsel25(klass);  /* :: [((QConId,VarId))] */
         List sigs  = zsel55(klass);  /* :: [((VarId,Type))] */
         for (t = ctx; nonNull(t); t=tl(t))
            if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
         for (t = sigs; nonNull(t); t=tl(t)) 
            if (!allTypesKnown(zsnd(hd(t)),aktys,mod)) return FALSE;
         return TRUE;
      }
      case I_VALUE: 
         return allTypesKnown( zthd3(unap(I_VALUE,entity)), aktys,mod );
      default: 
         internal("ifentityAllTypesKnown");
   }
}


/* ifTypeDoesntRefUnknownTycon :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
/* mod is the current module being processed -- so we can qualify unqual'd
   names.  Strange calling convention for aktys and mod is so we can call this
   from filterInterface.
*/
Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod )
{
   List  t, u;
   List  aktys = zfst ( aktys_mod );
   ConId mod   = zsnd ( aktys_mod );
   if (whatIs(entity) != I_TYPE) {
      return TRUE;
   } else {
      return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
   }
}

Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity )
{
   ConVarId id = getIEntityName ( entity );
   assert (whatIs(entity)==I_TYPE);
   assert (isCon(id));
   fprintf ( stderr, 
             "dumping type %s because of unknown tycon(s)\n",
             textToStr(textOf(id)) );
}


/* abstractifyExport :: I_EXPORT -> ConId -> I_EXPORT
*/
List abstractifyExDecl ( Cell root, ConId toabs )
{
   ZPair exdecl = unap(I_EXPORT,root);
   List  exlist = zsnd(exdecl);
   List  res    = NIL;
   for (; nonNull(exlist); exlist = tl(exlist)) {
      if (isZPair(hd(exlist)) 
          && textOf(toabs) == textOf(zfst(hd(exlist)))) {
         /* it's toabs, exported non-abstractly */
         res = cons ( zfst(hd(exlist)), res );
521
      } else {
522
         res = cons ( hd(exlist), res );
523
524
      }
   }
525
526
   return ap(I_EXPORT,zpair(zfst(exdecl),reverse(res)));
}
527

528
529
530
531
532
533

Void ppModule ( Text modt )
{
   fflush(stderr); fflush(stdout);
   fprintf(stderr, "---------------- MODULE %s ----------------\n", 
                   textToStr(modt) );
534
535
536
}


537
538
539
/* ifaces_outstanding holds a list of parsed interfaces
   for which we need to load objects and create symbol
   table entries.
540
541

   Return TRUE if Prelude `elem` ifaces_outstanding, else FALSE.
542
*/
543
Bool processInterfaces ( void )
544
{
545
546
547
548
549
550
551
552
553
    List    tmp;
    List    xs;
    ZTriple tr;
    Cell    iface;
    Int     sizeObj;
    Text    nameObj;
    Text    mname;
    List    decls;
    Module  mod;
554
555
    List    all_known_types;
    Int     num_known_types;
556
    Bool    didPrelude;
557
558
559
560

    List ifaces       = NIL;  /* :: List I_INTERFACE */
    List iface_sizes  = NIL;  /* :: List Int         */
    List iface_onames = NIL;  /* :: List Text        */
561

562
    if (isNull(ifaces_outstanding)) return FALSE;
563

564
565
566
567
    fprintf ( stderr, 
              "processInterfaces: %d interfaces to process\n", 
              length(ifaces_outstanding) );

568
569
570
571
572
    /* unzip3 ifaces_outstanding into ifaces, iface_sizes, iface_onames */
    for (xs = ifaces_outstanding; nonNull(xs); xs=tl(xs)) {
       ifaces       = cons ( zfst3(hd(xs)), ifaces       );
       iface_onames = cons ( zsnd3(hd(xs)), iface_onames );
       iface_sizes  = cons ( zthd3(hd(xs)), iface_sizes  );
573
574
    }

575
576
577
    ifaces       = reverse(ifaces);
    iface_onames = reverse(iface_onames);
    iface_sizes  = reverse(iface_sizes);
578

579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
    /* Clean up interfaces -- dump non-exported value, class, type decls */
    for (xs = ifaces; nonNull(xs); xs = tl(xs))
       hd(xs) = deleteUnexportedIFaceEntities(hd(xs));


    /* Iteratively delete any type declarations which refer to unknown
       tycons. 
    */
    num_known_types = 999999999;
    while (TRUE) {
       Int i;

       /* Construct a list of all known tycons.  This is a list of QualIds. 
          Unfortunately it also has to contain all known class names, since
          allTypesKnown cannot distinguish between tycons and classes -- a
          deficiency of the iface abs syntax.
       */
       all_known_types = getAllKnownTyconsAndClasses();
       for (xs = ifaces; nonNull(xs); xs=tl(xs))
          all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );

       /* Have we reached a fixed point? */
       i = length(all_known_types);
       printf ( "\n============= %d known types =============\n", i );
       if (num_known_types == i) break;
       num_known_types = i;

       /* Delete all entities which refer to unknown tycons. */
       for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
          ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
          assert(nonNull(mod));
          hd(xs) = filterInterface ( hd(xs), 
                                     ifTypeDoesntRefUnknownTycon,
                                     zpair(all_known_types,mod),
                                     ifTypeDoesntRefUnknownTycon_dumpmsg );
       }
    }

    /* Now abstractify any datas and newtypes which refer to unknown tycons
       -- including, of course, the type decls just deleted.
    */
    for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
       List  absify = NIL;                      /* :: [ConId] */
       ZPair iface  = unap(I_INTERFACE,hd(xs)); /* ((ConId, [I_IMPORT..I_VALUE])) */
       ConId mod    = zfst(iface);
       List  aktys  = all_known_types;          /* just a renaming */
       List  es,t,u;
       List  exlist_list;

       /* Compute into absify the list of all ConIds (tycons) we need to
          abstractify. 
       */
       for (es = zsnd(iface); nonNull(es); es=tl(es)) {
          Cell ent      = hd(es);
          Bool allKnown = TRUE;

          if (whatIs(ent)==I_DATA) {
             Cell data    = unap(I_DATA,ent);
             List ctx     = zsel25 ( data ); /* :: [((QConId,VarId))] */
             List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
             for (t = ctx; nonNull(t); t=tl(t))
                if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
             for (t = constrs; nonNull(t); t=tl(t))
                for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
                    if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE;          
          }
          else if (whatIs(ent)==I_NEWTYPE) {
             Cell  newty  = unap(I_NEWTYPE,ent);
             List  ctx    = zsel25(newty);    /* :: [((QConId,VarId))] */
             ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
             for (t = ctx; nonNull(t); t=tl(t))
                if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
             if (!allTypesKnown(zsnd(constr),aktys,mod)) allKnown = FALSE;
          }

          if (!allKnown) {
             absify = cons ( getIEntityName(ent), absify );
             fprintf ( stderr, 
                       "abstractifying %s because it uses an unknown type\n",
                       textToStr(textOf(getIEntityName(ent))) );
          }
       }

       /* mark in exports as abstract all names in absify (modifies iface) */
       for (; nonNull(absify); absify=tl(absify)) {
          ConId toAbs = hd(absify);
          for (es = zsnd(iface); nonNull(es); es=tl(es)) {
             if (whatIs(hd(es)) != I_EXPORT) continue;
             hd(es) = abstractifyExDecl ( hd(es), toAbs );
          }
       }

       /* For each data/newtype in the export list marked as abstract,
          remove the constructor lists.  This catches all abstractification
          caused by the code above, and it also catches tycons which really
          were exported abstractly.
       */

       exlist_list = getExportDeclsInIFace ( ap(I_INTERFACE,iface) );
       /* exlist_list :: [I_EXPORT] */
       for (t=exlist_list; nonNull(t); t=tl(t))
          hd(t) = zsnd(unap(I_EXPORT,hd(t)));
       /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */

       for (es = zsnd(iface); nonNull(es); es=tl(es)) {
          Cell ent = hd(es);
          if (whatIs(ent)==I_DATA
              && isExportedAbstractly ( getIEntityName(ent),
                                        exlist_list )) {
             Cell data = unap(I_DATA,ent);
             data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
                            zsel45(data), NIL /* the constr list */ );
             hd(es) = ap(I_DATA,data);
fprintf(stderr, "abstractify data %s\n", textToStr(textOf(getIEntityName(ent))) );
	  }
          else if (whatIs(ent)==I_NEWTYPE
              && isExportedAbstractly ( getIEntityName(ent), 
                                        exlist_list )) {
             Cell data = unap(I_NEWTYPE,ent);
             data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
                            zsel45(data), NIL /* the constr-type pair */ );
             hd(es) = ap(I_NEWTYPE,data);
fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent))) );
          }
       }

       /* We've finally finished mashing this iface.  Update the iface list. */
       hd(xs) = ap(I_INTERFACE,iface);
    }


    /* At this point, the interfaces are cleaned up so that no type, data or
       newtype defn refers to a non-existant type.  However, there still may
       be value defns, classes and instances which refer to unknown types.
       Delete iteratively until a fixed point is reached.
    */
715
    printf("\n");
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755

    num_known_types = 999999999;
    while (TRUE) {
       Int i;

       /* Construct a list of all known tycons.  This is a list of QualIds. 
          Unfortunately it also has to contain all known class names, since
          allTypesKnown cannot distinguish between tycons and classes -- a
          deficiency of the iface abs syntax.
       */
       all_known_types = getAllKnownTyconsAndClasses();
       for (xs = ifaces; nonNull(xs); xs=tl(xs))
          all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );

       /* Have we reached a fixed point? */
       i = length(all_known_types);
       printf ( "\n------------- %d known types -------------\n", i );
       if (num_known_types == i) break;
       num_known_types = i;

       /* Delete all entities which refer to unknown tycons. */
       for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
          ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
          assert(nonNull(mod));

          hd(xs) = filterInterface ( hd(xs),
                                     ifentityAllTypesKnown,
                                     zpair(all_known_types,mod), 
                                     ifentityAllTypesKnown_dumpmsg );
       }
    }


    /* Allocate module table entries and read in object code. */
    for (xs=ifaces; 
         nonNull(xs);
         xs=tl(xs), iface_sizes=tl(iface_sizes), iface_onames=tl(iface_onames)) {
       startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))),
                        intOf(hd(iface_sizes)),
                        hd(iface_onames) );
756
    }
757
758
759
    assert (isNull(iface_sizes));
    assert (isNull(iface_onames));

760

761
762
763
764
    /* Now work through the decl lists of the modules, and call the
       startGHC* functions on the entities.  This creates names in
       various tables but doesn't bind them to anything.
    */
765

766
767
    for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
       iface   = unap(I_INTERFACE,hd(xs));
768
769
770
771
       mname   = textOf(zfst(iface));
       mod     = findModule(mname);
       if (isNull(mod)) internal("processInterfaces(4)");
       setCurrModule(mod);
772
       ppModule ( module(mod).text );
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790

       for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
          Cell decl = hd(decls);
          switch(whatIs(decl)) {
             case I_EXPORT: {
                Cell exdecl = unap(I_EXPORT,decl);
                startGHCExports ( zfst(exdecl), zsnd(exdecl) );
                break;
             }
             case I_IMPORT: {
                Cell imdecl = unap(I_IMPORT,decl);
                startGHCImports ( zfst(imdecl), zsnd(imdecl) );
                break;
             }
             case I_FIXDECL: {
                break;
             }
             case I_INSTANCE: {
791
792
793
794
                /* Trying to find the instance table location allocated by
                   startGHCInstance in subsequent processing is a nightmare, so
                   cache it on the tree. 
                */
795
                Cell instance = unap(I_INSTANCE,decl);
796
797
798
799
800
                Inst in = startGHCInstance ( zsel15(instance), zsel25(instance),
                                             zsel35(instance), zsel45(instance) );
                hd(decls) = ap(I_INSTANCE,
                               z5ble( zsel15(instance), zsel25(instance),
                                      zsel35(instance), zsel45(instance), in ));
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
                break;
             }
             case I_TYPE: {
                Cell tydecl = unap(I_TYPE,decl);
                startGHCSynonym ( zsel14(tydecl), zsel24(tydecl),
                                  zsel34(tydecl), zsel44(tydecl) );
                break;
             }
             case I_DATA: {
                Cell ddecl = unap(I_DATA,decl);
                startGHCDataDecl ( zsel15(ddecl), zsel25(ddecl), 
                                   zsel35(ddecl), zsel45(ddecl), zsel55(ddecl) );
                break;
             }
             case I_NEWTYPE: {
                Cell ntdecl = unap(I_NEWTYPE,decl);
                startGHCNewType ( zsel15(ntdecl), zsel25(ntdecl), 
                                  zsel35(ntdecl), zsel45(ntdecl), 
                                  zsel55(ntdecl) );
                break;
             }
             case I_CLASS: {
                Cell klass = unap(I_CLASS,decl);
                startGHCClass ( zsel15(klass), zsel25(klass), 
                                zsel35(klass), zsel45(klass), 
                                zsel55(klass) );
                break;
             }
             case I_VALUE: {
                Cell value = unap(I_VALUE,decl);
                startGHCValue ( zfst3(value), zsnd3(value), zthd3(value) );
                break;
             }
             default:
                internal("processInterfaces(1)");
          }
       }       
    }
839

840
841
    fprintf(stderr, "\n=========================================================\n");
    fprintf(stderr, "=========================================================\n");
842

843
    /* Traverse again the decl lists of the modules, this time 
844
       calling the finishGHC* functions.  But don't process
845
846
       the export lists; those must wait for later.
    */
847
    didPrelude = FALSE;
848
849
    for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
       iface   = unap(I_INTERFACE,hd(xs));
850
851
852
853
       mname   = textOf(zfst(iface));
       mod     = findModule(mname);
       if (isNull(mod)) internal("processInterfaces(3)");
       setCurrModule(mod);
854
       ppModule ( module(mod).text );
855

856
857
       if (mname == textPrelude) didPrelude = TRUE;

858
859
860
861
862
863
864
865
866
867
868
869
870
871
       for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
          Cell decl = hd(decls);
          switch(whatIs(decl)) {
             case I_EXPORT: {
                break;
             }
             case I_IMPORT: {
                break;
             }
             case I_FIXDECL: {
                break;
             }
             case I_INSTANCE: {
                Cell instance = unap(I_INSTANCE,decl);
872
                finishGHCInstance ( zsel55(instance) );
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
                break;
             }
             case I_TYPE: {
                Cell tydecl = unap(I_TYPE,decl);
                finishGHCSynonym ( zsel24(tydecl) );
                break;
             }
             case I_DATA: {
                Cell ddecl = unap(I_DATA,decl);
                finishGHCDataDecl ( zsel35(ddecl) );
                break;
             }
             case I_NEWTYPE: {
                Cell ntdecl = unap(I_NEWTYPE,decl);
                finishGHCNewType ( zsel35(ntdecl) );
                break;
             }
             case I_CLASS: {
                Cell klass = unap(I_CLASS,decl);
                finishGHCClass ( zsel35(klass) );
                break;
             }
             case I_VALUE: {
                Cell value = unap(I_VALUE,decl);
                finishGHCValue ( zsnd3(value) );
                break;
             }
             default:
                internal("processInterfaces(2)");
          }
       }       
    }
905
906
    fprintf(stderr, "\n+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
    fprintf(stderr, "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
907

908
909
910
911
912
    /* Build the module(m).export lists for each module, by running
       through the export lists in the iface.  Also, do the implicit
       'import Prelude' thing.  And finally, do the object code 
       linking.
    */
913
    for (xs = ifaces; nonNull(xs); xs = tl(xs))
914
       finishGHCModule(hd(xs));
915

916
917
    /* Finished! */
    ifaces_outstanding = NIL;
918
919

    return didPrelude;
920
921
}

922
923
924
925
926

/* --------------------------------------------------------------------------
 * Modules
 * ------------------------------------------------------------------------*/

927
928
929
930
931
932
void startGHCModule_errMsg ( char* msg )
{
   fprintf ( stderr, "object error: %s\n", msg );
}

void* startGHCModule_clientLookup ( char* sym )
933
{
934
   /* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */
935
936
   return lookupObjName ( sym );
}
937

938
ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
939
{
940
941
942
943
   ObjectCode* oc
      = ocNew ( startGHCModule_errMsg,
                startGHCModule_clientLookup,
                objNm, objSz );
944
    
945
946
    if (!oc) {
       ERRMSG(0) "Storage allocation for object file \"%s\" failed", objNm
947
948
       EEND;
    }
949
950
    if (!ocLoadImage(oc,VERBOSE)) {
       ERRMSG(0) "Reading of object file \"%s\" failed", objNm
951
952
       EEND;
    }
953
954
    if (!ocVerifyImage(oc,VERBOSE)) {
       ERRMSG(0) "Validation of object file \"%s\" failed", objNm
955
956
       EEND;
    }
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
    if (!ocGetNames(oc,0||VERBOSE)) {
       ERRMSG(0) "Reading of symbol names in object file \"%s\" failed", objNm
       EEND;
    }
    return oc;
}

Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
{
   List   xts;
   Module m = findModule(mname);

   if (isNull(m)) {
      m = newModule(mname);
      fprintf ( stderr, "startGHCIface: name %16s   objsize %d\n", 
                         textToStr(mname), sizeObj );
   } else {
      if (module(m).fake) {
         module(m).fake = FALSE;
      } else {
         ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname)
         EEND;
      }
   }

   /* Get hold of the primary object for the module. */
   module(m).object
      = startGHCModule_partial_load ( textToStr(nameObj), sizeObj );

   /* and any extras ... */
   for (xts = module(m).objectExtraNames; nonNull(xts); xts=tl(xts)) {
      Int         size;
      ObjectCode* oc;
      Text        xtt = hd(xts);
      String      nm  = getExtraObjectInfo ( textToStr(nameObj),
                                             textToStr(xtt),
                                             &size );
      if (size == -1) {
         ERRMSG(0) "Can't find extra object file \"%s\"", nm
         EEND;
      }
      oc = startGHCModule_partial_load ( nm, size );
      oc->next = module(m).objectExtras;
      module(m).objectExtras = oc;
   }
1002
1003
}

1004

1005
1006
1007
/* For the module mod, augment both the export environment (.exports) 
   and the eval environment (.names, .tycons, .classes)
   with the symbols mentioned in exlist.  We don't actually need
1008
1009
   to modify the names, tycons, classes or instances in the eval 
   environment, since previous processing of the
1010
1011
1012
1013
1014
1015
1016
1017
   top-level decls in the iface should have done this already.

   mn is the module mentioned in the export list; it is the "original"
   module for the symbols in the export list.  We should also record
   this info with the symbols, since references to object code need to
   refer to the original module in which a symbol was defined, rather
   than to some module it has been imported into and then re-exported.

1018
1019
1020
1021
1022
1023
1024
1025
1026
   We take the policy that if something mentioned in an export list
   can't be found in the symbol tables, it is simply ignored.  After all,
   previous processing of the iface syntax trees has already removed 
   everything which Hugs can't handle, so if there is mention of these
   things still lurking in export lists somewhere, about the only thing
   to do is to ignore it.

   Also do an implicit 'import Prelude' thingy for the module,
   if appropriate.
1027
*/
1028
1029


1030
1031
1032
Void finishGHCModule ( Cell root ) 
{
   /* root :: I_INTERFACE */
1033
1034
1035
1036
1037
1038
   Cell        iface       = unap(I_INTERFACE,root);
   ConId       iname       = zfst(iface);
   Module      mod         = findModule(textOf(iname));
   List        exlist_list = NIL;
   List        t;
   ObjectCode* oc;
1039

1040
   fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
1041
1042
1043
1044
1045
1046
1047
1048

   if (isNull(mod)) internal("finishExports(1)");
   setCurrModule(mod);

   exlist_list = getExportDeclsInIFace ( root );
   /* exlist_list :: [I_EXPORT] */
   
   for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
1049
1050
1051
      ZPair exdecl = unap(I_EXPORT,hd(exlist_list));
      ConId exmod  = zfst(exdecl);
      List  exlist = zsnd(exdecl);
1052
      /* exlist :: [ ConVarId | ((ConId, [ConVarId])) ] */
1053

1054
      for (; nonNull(exlist); exlist=tl(exlist)) {
1055
1056
1057
1058
1059
         Bool   abstract;
         List   subents;
         Cell   c;
         QualId q;
         Cell   ex = hd(exlist);
1060
1061
1062
1063

         switch (whatIs(ex)) {

            case VARIDCELL: /* variable */
1064
1065
1066
1067
               q = mkQualId(exmod,ex);
               c = findQualNameWithoutConsultingExportList ( q );
               if (isNull(c)) goto notfound;
               fprintf(stderr, "   var %s\n", textToStr(textOf(ex)) );
1068
               module(mod).exports = cons(c, module(mod).exports);
1069
               addName(c);
1070
1071
1072
               break;

            case CONIDCELL: /* non data tycon */
1073
1074
1075
1076
               q = mkQualId(exmod,ex);
               c = findQualTyconWithoutConsultingExportList ( q );
               if (isNull(c)) goto notfound;
               fprintf(stderr, "   type %s\n", textToStr(textOf(ex)) );
1077
               module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1078
               addTycon(c);
1079
1080
1081
1082
1083
               break;

            case ZTUP2: /* data T = C1 ... Cn  or class C where f1 ... fn */
               subents = zsnd(ex);  /* :: [ConVarId] */
               ex      = zfst(ex);  /* :: ConId */
1084
1085
               q       = mkQualId(exmod,ex);
               c       = findQualTyconWithoutConsultingExportList ( q );
1086
1087

               if (nonNull(c)) { /* data */
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
                  fprintf(stderr, "   data/newtype %s = { ", textToStr(textOf(ex)) );
                  assert(tycon(c).what == DATATYPE || tycon(c).what==NEWTYPE);
                  abstract = isNull(tycon(c).defn);
                  /* This data/newtype could be abstract even tho the export list
                     says to export it non-abstractly.  That happens if it was 
                     imported from some other module and is now being re-exported,
                     and previous cleanup phases have abstractified it in the 
                     original (defining) module.
		  */
                  if (abstract) {
1098
                     module(mod).exports = cons(pair(c,NIL), module(mod).exports);
1099
                     addTycon(c);
1100
1101
1102
                     fprintf ( stderr, "(abstract) ");
		  } else {
                     module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1103
                     addTycon(c);
1104
1105
1106
1107
1108
1109
1110
1111
                     for (; nonNull(subents); subents = tl(subents)) {
                        Cell ent2 = hd(subents);
                        assert(isCon(ent2) || isVar(ent2)); 
                                              /* isVar since could be a field name */
                        q = mkQualId(exmod,ent2);
                        c = findQualNameWithoutConsultingExportList ( q );
                        fprintf(stderr, "%s ", textToStr(name(c).text));
                        assert(nonNull(c));
1112
                        /* module(mod).exports = cons(c, module(mod).exports); */
1113
                        addName(c);
1114
                     }
1115
                  }
1116
                  fprintf(stderr, "}\n" );
1117
               } else { /* class */
1118
1119
1120
1121
                  q = mkQualId(exmod,ex);
                  c = findQualClassWithoutConsultingExportList ( q );
                  if (isNull(c)) goto notfound;
                  fprintf(stderr, "   class %s { ", textToStr(textOf(ex)) );
1122
                  module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
1123
                  addClass(c);
1124
1125
1126
                  for (; nonNull(subents); subents = tl(subents)) {
                     Cell ent2 = hd(subents);
                     assert(isVar(ent2));
1127
1128
                     q = mkQualId(exmod,ent2);
                     c = findQualNameWithoutConsultingExportList ( q );
1129
                     fprintf(stderr, "%s ", textToStr(name(c).text));
1130
                     if (isNull(c)) goto notfound;
1131
                     /* module(mod).exports = cons(c, module(mod).exports); */
1132
                     addName(c);
1133
                  }
1134
                  fprintf(stderr, "}\n" );
1135
1136
1137
1138
1139
1140
1141
               }
               break;

            default:
               internal("finishExports(2)");

         } /* switch */
1142
1143
1144
1145
1146
1147
1148
1149
         continue;  /* so notfound: can be placed after this */
  
        notfound:
         /* q holds what ain't found */
         assert(whatIs(q)==QUALIDENT);
         fprintf( stderr, "   ------ IGNORED: %s.%s\n",
                  textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
         continue;
1150
1151
1152
      }
   }

1153
#if 0
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
   if (preludeLoaded) {
      /* do the implicit 'import Prelude' thing */
      List pxs = module(modulePrelude).exports;
      for (; nonNull(pxs); pxs=tl(pxs)) {
         Cell px = hd(pxs);
         again:
         switch (whatIs(px)) {
            case AP: 
               px = fst(px); 
               goto again;
            case NAME: 
               module(mod).names = cons ( px, module(mod).names );
               break;
            case TYCON: 
               module(mod).tycons = cons ( px, module(mod).tycons );
               break;
            case CLASS: 
               module(mod).classes = cons ( px, module(mod).classes );
               break;
            default:               
               fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
               internal("finishGHCModule -- implicit import Prelude");
               break;
         }
      }
   }
1180
#endif
1181
1182

   /* Last, but by no means least ... */
1183
   if (!ocResolve(module(mod).object,0||VERBOSE))
1184
      internal("finishGHCModule: object resolution failed");
1185
1186
1187
1188
1189

   for (oc=module(mod).objectExtras; oc; oc=oc->next) {
      if (!ocResolve(oc, 0||VERBOSE))
         internal("finishGHCModule: extra object resolution failed");
   }
1190
1191
1192
}


1193
1194
1195
1196
1197
1198
/* --------------------------------------------------------------------------
 * Exports
 * ------------------------------------------------------------------------*/

Void startGHCExports ( ConId mn, List exlist )
{
1199
#   ifdef DEBUG_IFACE
1200
    printf("startGHCExports %s\n", textToStr(textOf(mn)) );
1201
#   endif
1202
   /* Nothing to do. */
1203
1204
}

1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
Void finishGHCExports ( ConId mn, List exlist )
{
#   ifdef DEBUG_IFACE
    printf("finishGHCExports %s\n", textToStr(textOf(mn)) );
#   endif
   /* Nothing to do. */
}


/* --------------------------------------------------------------------------
 * Imports
 * ------------------------------------------------------------------------*/

Void startGHCImports ( ConId mn, List syms )
/* nm     the module to import from */
/* syms   [ConId | VarId] -- the names to import */
{
#  ifdef DEBUG_IFACE
   printf("startGHCImports %s\n", textToStr(textOf(mn)) );
#  endif
   /* Nothing to do. */
}


Void finishGHCImports ( ConId nm, List syms )
/* nm     the module to import from */
/* syms   [ConId | VarId] -- the names to import */
{
#  ifdef DEBUG_IFACE
   printf("finishGHCImports %s\n", textToStr(textOf(nm)) );
#  endif
  /* Nothing to do. */
}


/* --------------------------------------------------------------------------
 * Vars (values)
 * ------------------------------------------------------------------------*/

1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
/* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
   { C1 a } -> { C2 b } -> T            into
   ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
*/
static Type dictapsToQualtype ( Type ty )
{
   List pieces = NIL;
   List preds, dictaps;

   /* break ty into pieces at the top-level arrows */
   while (isAp(ty) && isAp(fun(ty)) && fun(fun(ty))==typeArrow) {
      pieces = cons ( arg(fun(ty)), pieces );
      ty     = arg(ty);
   }
   pieces = cons ( ty, pieces );
   pieces = reverse ( pieces );

   dictaps = NIL;
   while (nonNull(pieces) && whatIs(hd(pieces))==DICTAP) {
      dictaps = cons ( hd(pieces), dictaps );
      pieces = tl(pieces);
   }

   /* dictaps holds the predicates, backwards */
   /* pieces holds the remainder of the type, forwards */
   assert(nonNull(pieces));
   pieces = reverse(pieces);
   ty = hd(pieces);
   pieces = tl(pieces);
   for (; nonNull(pieces); pieces=tl(pieces)) 
      ty = fn(hd(pieces),ty);

   preds = NIL;
   for (; nonNull(dictaps); dictaps=tl(dictaps)) {
      Cell da = hd(dictaps);
      QualId cl = fst(unap(DICTAP,da));
      Cell   arg = snd(unap(DICTAP,da));
      preds = cons ( pair(cl,arg), preds );
   }

   if (nonNull(preds)) ty = ap(QUAL, pair(preds,ty));
   return ty;
}



1290
void startGHCValue ( Int line, VarId vid, Type ty )
1291
1292
1293
{
    Name   n;
    List   tmp, tvs;
1294
1295
    Text   v = textOf(vid);

1296
#   ifdef DEBUG_IFACE
1297
    printf("begin startGHCValue %s\n", textToStr(v));
1298
#   endif
1299

1300
1301
1302
1303
1304
1305
1306
    n = findName(v);
    if (nonNull(n)) {
        ERRMSG(0) "Attempt to redefine variable \"%s\"", textToStr(v)
        EEND;
    }
    n = newName(v,NIL);

1307
1308
    ty = dictapsToQualtype(ty);

1309
    tvs = ifTyvarsIn(ty);
1310
    for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
1311
       hd(tmp) = zpair(hd(tmp),STAR);
1312
1313
1314
1315
    if (nonNull(tvs))
       ty = mkPolyType(tvsToKind(tvs),ty);

    ty = tvsToOffsets(line,ty,tvs);
1316
    name(n).type  = ty;
1317
    name(n).arity = arityInclDictParams(ty);
1318
    name(n).line  = line;
1319
1320
}

1321
1322

void finishGHCValue ( VarId vid )
1323
{
1324
    Name n    = findName ( textOf(vid) );
1325
1326
    Int  line = name(n).line;
#   ifdef DEBUG_IFACE
1327
    fprintf(stderr, "begin finishGHCValue %s\n", textToStr(name(n).text) );
1328
#   endif
1329
    assert(currentModule == name(n).mod);
1330
    name(n).type = conidcellsToTycons(line,name(n).type);
1331
1332
}

1333
1334
1335
1336
1337
1338
1339
1340
1341
1342

/* --------------------------------------------------------------------------
 * Type synonyms
 * ------------------------------------------------------------------------*/

Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
{
    /* tycon :: ConId             */
    /* tvs   ::  [((VarId,Kind))] */
    /* ty    :: Type              */ 
1343
    Text t = textOf(tycon);
1344
#   ifdef DEBUG_IFACE
1345
    fprintf(stderr, "begin startGHCSynonym %s\n", textToStr(t) );
1346
#   endif
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
    if (nonNull(findTycon(t))) {
        ERRMSG(line) "Repeated definition of type constructor \"%s\"",
                     textToStr(t)
        EEND;
    } else {
        Tycon tc        = newTycon(t);
        tycon(tc).line  = line;
        tycon(tc).arity = length(tvs);
        tycon(tc).what  = SYNONYM;
        tycon(tc).kind  = tvsToKind(tvs);

        /* prepare for finishGHCSynonym */
        tycon(tc).defn  = tvsToOffsets(line,ty,tvs);
    }
}

1363
1364

static Void  finishGHCSynonym ( ConId tyc )
1365
{
1366
1367
    Tycon tc   = findTycon(textOf(tyc)); 
    Int   line = tycon(tc).line;
1368
1369
1370
#   ifdef DEBUG_IFACE
    fprintf(stderr, "begin finishGHCSynonym %s\n", textToStr(textOf(tyc)) );
#   endif
1371

1372
1373
    assert (currentModule == tycon(tc).mod);
    //    setCurrModule(tycon(tc).mod);
1374
1375
    tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);

1376
    /* (ADR) ToDo: can't really do this until I've done all synonyms
1377
1378
     * and then I have to do them in order
     * tycon(tc).defn = fullExpand(ty);
1379
     * (JRS) What?!?!  i don't understand
1380
1381
1382
     */
}

1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395

/* --------------------------------------------------------------------------
 * Data declarations
 * ------------------------------------------------------------------------*/

Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
Int   line;
List  ctx0;      /* [((QConId,VarId))]                */
Cell  tycon;     /* ConId                             */
List  ktyvars;   /* [((VarId,Kind))]                  */
List  constrs0;  /* [((ConId,[((Type,VarId,Int))]))]  */
                 /* The Text is an optional field name
                    The Int indicates strictness */
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
    /* ToDo: worry about being given a decl for (->) ?
     * and worry about qualidents for ()
     */
{
    Type    ty, resTy, selTy, conArgTy;
    List    tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
    List    ctx, ctx2;
    Triple  constr;
    Cell    conid;
    Pair    conArg, ctxElem;
    Text    conArgNm;
1407
    Int     conArgStrictness;
1408
1409
1410

    Text t = textOf(tycon);
#   ifdef DEBUG_IFACE
1411
    fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
1412
#   endif
1413

1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
    if (nonNull(findTycon(t))) {
        ERRMSG(line) "Repeated definition of type constructor \"%s\"",
                     textToStr(t)
        EEND;
    } else {
        Tycon tc        = newTycon(t);
        tycon(tc).text  = t;
        tycon(tc).line  = line;
        tycon(tc).arity = length(ktyvars);
        tycon(tc).kind  = tvsToKind(ktyvars);
        tycon(tc).what  = DATATYPE;

1426
        /* a list to accumulate selectors in :: [((VarId,Type))] */
1427
1428
1429
1430
1431
        sels = NIL;

        /* make resTy the result type of the constr, T v1 ... vn */
        resTy = tycon;
        for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
1432
           resTy = ap(resTy,zfst(hd(tmp)));
1433
1434
1435
1436

        /* for each constructor ... */
        for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
           constr = hd(constrs);
1437
1438
           conid  = zfst(constr);
           fields = zsnd(constr);
1439
1440
1441
1442
1443
1444
1445

           /* Build type of constr and handle any selectors found.
              Also collect up tyvars occurring in the constr's arg
              types, so we can throw away irrelevant parts of the
              context later.
           */
           ty = resTy;
1446
1447
1448
           tyvarsMentioned = NIL;  
           /* tyvarsMentioned :: [VarId] */

1449
1450
           conArgs = reverse(fields);
           for (; nonNull(conArgs); conArgs=tl(conArgs)) {
1451
              conArg           = hd(conArgs); /* (Type,Text) */
1452
1453
1454
              conArgTy         = zfst3(conArg);
              conArgNm         = zsnd3(conArg);
              conArgStrictness = intOf(zthd3(conArg));
1455
1456
              tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
                                            tyvarsMentioned);
1457
              if (conArgStrictness > 0) conArgTy = bang(conArgTy);
1458
1459
              ty = fn(conArgTy,ty);
              if (nonNull(conArgNm)) {
1460
                 /* a field name is mentioned too */
1461
1462
1463
1464
                 selTy = fn(resTy,conArgTy);
                 if (whatIs(tycon(tc).kind) != STAR)
                    selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
                 selTy = tvsToOffsets(line,selTy, ktyvars);
1465
                 sels = cons( zpair(conArgNm,selTy), sels);
1466
1467
1468
1469
1470
1471
1472
1473
1474
              }
           }

           /* Now ty is the constructor's type, not including context.
              Throw away any parts of the context not mentioned in 
              tyvarsMentioned, and use it to qualify ty.
	   */
           ctx2 = NIL;
           for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
1475
1476
1477
              ctxElem = hd(ctx);     
              /* ctxElem :: ((QConId,VarId)) */
              if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
1478
1479
1480
1481
1482
1483
1484
                 ctx2 = cons(ctxElem, ctx2);
           }
           if (nonNull(ctx2))
              ty = ap(QUAL,pair(ctx2,ty));

           /* stick the tycon's kind on, if not simply STAR */
           if (whatIs(tycon(tc).kind) != STAR)
1485
              ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
1486
1487
1488
1489

           ty = tvsToOffsets(line,ty, ktyvars);

           /* Finally, stick the constructor's type onto it. */
1490
           hd(constrs) = ztriple(conid,fields,ty);
1491
1492
1493
        }

        /* Final result is that 
1494
           constrs :: [((ConId,[((Type,Text))],Type))]   
1495
                      lists the constructors and their types
1496
           sels :: [((VarId,Type))]
1497
1498
                   lists the selectors and their types
	*/
1499
        tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
1500
1501
1502
1503
    }
}


1504
1505
1506
1507
1508
static List startGHCConstrs ( Int line, List cons, List sels )
{
    /* cons :: [((ConId,[((Type,Text,Int))],Type))] */
    /* sels :: [((VarId,Type))]                     */
    /* returns [Name]                               */
1509
    List cs, ss;
1510
    Int  conNo = length(cons)>1 ? 1 : 0;
1511
    for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
1512
        Name c  = startGHCConstr(line,conNo,hd(cs));
1513
1514
        hd(cs)  = c;
    }