ghc/interpreter/interface.c

   1 /* -*- mode: hugs-c; -*- */
   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.2 $
  11  * $Date: 1998/12/02 13:22:15 $
  12  * ------------------------------------------------------------------------*/
  13
  14 /* ToDo:
  15  * o use Z encoding
  16  * o use vectored CONSTR_entry when appropriate
  17  * o generate export list
  18  *
  19  * Needs GHC changes to generate member selectors,
  20  * superclass selectors, etc
  21  * o instance decls
  22  * o dictionary constructors ?
  23  *
  24  * o Get Hugs/GHC to agree on what interface files look like.
  25  * o figure out how to replace the Hugs Prelude with the GHC Prelude
  26  */
  27
  28 #include "prelude.h"
  29 #include "storage.h"
  30 #include "connect.h"
  31 #include "static.h"
  32 #include "errors.h"
  33 #include "link.h"
  34 #include "modules.h"
  35 #include "machdep.h"   /* for Time                 */
  36 #include "input.h"     /* for parseInterface       */
  37 #include "type.h"      /* for offsetTyVarsIn       */
  38 #include "stg.h"       /* for wrapping GHC objects */
  39 #include "Assembler.h" /* for wrapping GHC objects */
  40 #include "interface.h"
  41 #include "dynamic.h"
  42
  43 /* --------------------------------------------------------------------------
  44  * The "addGHC*" functions act as "impedence matchers" between GHC
  45  * interface files and Hugs.  Their main job is to convert abstract
  46  * syntax trees into Hugs' internal representations.
  47  *
  48  * The main trick here is how we deal with mutually recursive interface
  49  * files:
  50  *
  51  * o As we read an import decl, we add it to a list of required imports
  52  *   (unless it's already loaded, of course).
  53  *
  54  * o Processing of declarations is split into two phases:
  55  *
  56  *   1) While reading the interface files, we construct all the Names,
  57  *      Tycons, etc declared in the interface file but we don't try to
  58  *      resolve references to any entities the declaration mentions.
  59  *
  60  *      This is done by the "addGHC*" functions.
  61  *
  62  *   2) After reading all the interface files, we finish processing the
  63  *      declarations by resolving any references in the declarations
  64  *      and doing any other processing that may be required.
  65  *
  66  *      This is done by the "finishGHC*" functions which use the
  67  *      "fixup*" functions to assist them.
  68  *
  69  *   The interface between these two phases are the "ghc*Decls" which
  70  *   contain lists of decls that haven't been completed yet.
  71  *
  72  * ------------------------------------------------------------------------*/
  73
  74 /* --------------------------------------------------------------------------
  75  * local variables:
  76  * ------------------------------------------------------------------------*/
  77
  78 static List ghcVarDecls;
  79 static List ghcConDecls;
  80 static List ghcSynonymDecls;
  81 static List ghcClassDecls;
  82 static List ghcInstanceDecls;
  83
  84 /* --------------------------------------------------------------------------
  85  * local function prototypes:
  86  * ------------------------------------------------------------------------*/
  87
  88 static List local addGHCConstrs Args((Int,List,List));
  89 static Name local addGHCSel     Args((Int,Pair,List));
  90 static Name local addGHCConstr  Args((Int,Int,Triple));
  91
  92
  93 static Void  local finishGHCVar      Args((Name));
  94 static Void  local finishGHCCon      Args((Name));
  95 static Void  local finishGHCSynonym  Args((Tycon));
  96 static Void  local finishGHCClass    Args((Class));
  97 static Void  local finishGHCInstance Args((Inst));
  98
  99 static Name  local fixupSel              Args((Int,Pair,List));
 100 static Name  local fixupConstr           Args((Int,Int,Triple));
 101 static Name  local fixupMember           Args((Int,Int,Pair));
 102 static List  local fixupMembers          Args((Int,List));
 103 static Type  local fixupTypeVar          Args((Int,List,Text));
 104 static Class local fixupClass            Args((Int,Text));
 105 static Cell  local fixupPred             Args((Int,List,Pair));
 106 static List  local fixupContext          Args((Int,List,List));
 107 static Type  local fixupType             Args((Int,List,Type));
 108 static Type  local fixupConType          Args((Int,Type));
 109
 110 static Void  local bindNameToClosure     Args((Name,AsmClosure));
 111 static Kinds local tvsToKind             Args((List));
 112 static Int   local arityFromType         Args((Type));
 113
 114 static AsmClosure local lookupGHCClosure Args((Module,Text));
 115
 116 /* --------------------------------------------------------------------------
 117  * code:
 118  * ------------------------------------------------------------------------*/
 119
 120 static List interfaces; /* Interface files that haven't been loaded yet */
 121
 122 Void loadInterface(String fname)
 123 {
 124     ghcVarDecls      = NIL;
 125     ghcConDecls      = NIL;
 126     ghcSynonymDecls  = NIL;
 127     ghcClassDecls    = NIL;
 128     ghcInstanceDecls = NIL;
 129
 130     /* Note: interfaces is added to by addGHCImport which is called by
 131      * parseInterface so each time round the loop we remove the
 132      * current interface from the list before calling parseInterface again.
 133      */
 134     interfaces=singleton(mkCon(findText(fname)));
 135     while (nonNull(interfaces)) {
 136         String fname = textToStr(textOf(hd(interfaces)));
 137         Time timeStamp; /* not used */
 138         Long fileSize;
 139         getFileInfo(fname, &timeStamp, &fileSize);
 140         interfaces=tl(interfaces);
 141         parseInterface(fname,fileSize);
 142     }
 143
 144     /* the order of these doesn't matter
 145      * (ToDo: unless synonyms have to be eliminated??)
 146      */
 147     mapProc(finishGHCVar,      ghcVarDecls);
 148     mapProc(finishGHCCon,      ghcConDecls);
 149     mapProc(finishGHCSynonym,  ghcSynonymDecls);
 150     mapProc(finishGHCClass,    ghcClassDecls);
 151     mapProc(finishGHCInstance, ghcInstanceDecls);
 152     ghcVarDecls      = NIL;
 153     ghcConDecls      = NIL;
 154     ghcSynonymDecls  = NIL;
 155     ghcClassDecls    = NIL;
 156     ghcInstanceDecls = NIL;
 157 }
 158
 159 Void openGHCIface(t)
 160 Text t; {
 161     Module m = findModule(t);
 162     if (isNull(m)) {
 163         m = newModule(t);
 164     } else if (m != modulePreludeHugs) {
 165         ERRMSG(0) "Module \"%s\" already loaded", textToStr(t)
 166         EEND;
 167     }
 168     setCurrModule(m);
 169 }
 170
 171 Void addGHCImport(line,mn,fn)
 172 Int  line;
 173 Text mn;
 174 String fn; {
 175 #if 1 /* new */
 176     Text   t = findText(fn);
 177     Module m = findModule(mn);
 178     if (isNull(m)) {
 179         if (isNull(varIsMember(t,interfaces))) {
 180             interfaces = cons(mkCon(t),interfaces);
 181         }
 182     }
 183 #else /* old - and probably wrong */
 184     Module m = findModule(t);
 185     if (isNull(m)) {
 186         ERRMSG(0) "Unknown module \"%s\"", textToStr(t)
 187         EEND;
 188     }
 189     /* ToDo: what to do if there's a name conflict? */
 190     {   /* copied from resolveImportList */
 191         List es      = module(m).exports;
 192         List imports = NIL;
 193         for(; nonNull(es); es=tl(es)) {
 194             Cell e = hd(es);
 195             if (isName(e)) {
 196                 imports = cons(e,imports);
 197             } else {
 198                 Cell c = fst(e);
 199                 List subentities = NIL;
 200                 imports = cons(c,imports);
 201                 if (isTycon(c)
 202                     && (tycon(c).what == DATATYPE
 203                         || tycon(c).what == NEWTYPE)) {
 204                     subentities = tycon(c).defn;
 205                 } else if (isClass(c)) {
 206                     subentities = cclass(c).members;
 207                 }
 208                 if (DOTDOT == snd(e)) {
 209                     imports = revDupOnto(subentities,imports);
 210                 }
 211             }
 212         }
 213         map1Proc(importEntity,m,imports);
 214     }
 215 #endif
 216 }
 217
 218 void addGHCVar(line,v,ty)
 219 Int  line;
 220 Text v;
 221 Type ty;
 222 {
 223     Name n = findName(v);
 224     if (nonNull(n)) {
 225         ERRMSG(0) "Attempt to redefine variable \"%s\"", textToStr(v)
 226         EEND;
 227     }
 228     n = newName(v);
 229     bindNameToClosure(n, lookupGHCClosure(name(n).mod,name(n).text));
 230
 231     /* prepare for finishGHCVar */
 232     name(n).type = ty;
 233     ghcVarDecls = cons(n,ghcVarDecls);
 234 }
 235
 236 static Void local finishGHCVar(Name n)
 237 {
 238     Int  line = name(n).line;
 239     Type ty   = name(n).type;
 240     setCurrModule(name(n).mod);
 241     name(n).type = fixupType(line,NIL,ty);
 242 }
 243
 244 Void addGHCSynonym(line,tycon,tvs,ty)
 245 Int  line;
 246 Cell tycon;  /* ConId          */
 247 List tvs;    /* [(VarId,Kind)] */
 248 Type ty; {
 249     /* ToDo: worry about being given a decl for (->) ?
 250      * and worry about qualidents for ()
 251      */
 252     Text t = textOf(tycon);
 253     if (nonNull(findTycon(t))) {
 254         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
 255                      textToStr(t)
 256         EEND;
 257     } else {
 258         Tycon tc        = newTycon(t);
 259         tycon(tc).line  = line;
 260         tycon(tc).arity = length(tvs);
 261         tycon(tc).what  = SYNONYM;
 262         tycon(tc).kind  = tvsToKind(tvs);
 263
 264         /* prepare for finishGHCSynonym */
 265         tycon(tc).defn  = pair(tvs,ty);
 266         ghcSynonymDecls = cons(tc,ghcSynonymDecls);
 267     }
 268 }
 269
 270 static Void  local finishGHCSynonym(Tycon tc)
 271 {
 272     Int  line = tycon(tc).line;
 273     List tvs  = fst(tycon(tc).defn);
 274     Type ty   = snd(tycon(tc).defn);
 275
 276     setCurrModule(tycon(tc).mod);
 277     tycon(tc).defn = fixupType(line,singleton(tvs),ty);
 278
 279     /* ToDo: can't really do this until I've done all synonyms
 280      * and then I have to do them in order
 281      * tycon(tc).defn = fullExpand(ty);
 282      */
 283 }
 284
 285 Void addGHCDataDecl(line,tycon,tvs,constrs,sels)
 286 Int  line;
 287 Cell tycon;     /* ConId | QualConId      */
 288 List tvs;       /* [(VarId,Kind)]         */
 289 List constrs;   /* [(ConId,[VarId],Type)] */
 290 List sels; {    /* [(VarId,Type)]         */
 291     /* ToDo: worry about being given a decl for (->) ?
 292      * and worry about qualidents for ()
 293      */
 294     Text t = textOf(tycon);
 295     if (nonNull(findTycon(t))) {
 296         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
 297                      textToStr(t)
 298         EEND;
 299     } else {
 300         Tycon tc        = newTycon(t);
 301         tycon(tc).line  = line;
 302         tycon(tc).arity = length(tvs);
 303         tycon(tc).what  = DATATYPE;
 304         tycon(tc).kind  = tvsToKind(tvs);
 305         tycon(tc).defn  = addGHCConstrs(line,constrs,sels);
 306     }
 307 }
 308
 309 static List local addGHCConstrs(line,cons,sels)
 310 Int  line;
 311 List cons;   /* [(ConId,[VarId],Type)] */
 312 List sels; { /* [(VarId,Type)]         */
 313     List uses = NIL; /* [(ConName,[VarId])] */
 314     if (nonNull(cons) && isNull(tl(cons))) { /* Single constructor datatype? */
 315         List fs  = snd3(hd(cons));
 316         Name c   = addGHCConstr(line,0,hd(cons));
 317         uses     = cons(pair(c,fs),uses);
 318         hd(cons) = c;
 319     } else {
 320         Int  conNo = 0; /*  or maybe 1? */
 321         List cs    = cons;
 322         for(; nonNull(cs); cs=tl(cs), conNo++) {
 323             List fs = snd3(hd(cs));
 324             Name c  = addGHCConstr(line,conNo,hd(cs));
 325             uses    = cons(pair(c,fs),uses);
 326             hd(cs)  = c;
 327         }
 328     }
 329     {
 330         List ss    = sels;
 331         for(; nonNull(ss); ss=tl(ss)) {
 332             hd(ss) = addGHCSel(line,hd(ss),uses);
 333         }
 334     }
 335     return appendOnto(cons,sels);
 336 }
 337
 338 static Name local addGHCSel(line,sel,uses)
 339 Int  line;
 340 Pair sel;    /* (VarId,Type)        */
 341 List uses; { /* [(ConName,[VarId])] */
 342     Text t      = textOf(fst(sel));
 343     Type type   = snd(sel);
 344     List fields = NIL;
 345
 346     Name n = findName(t);
 347     if (nonNull(n)) {
 348         ERRMSG(line) "Repeated definition for selector \"%s\"",
 349             textToStr(t)
 350         EEND;
 351     }
 352
 353     n              = newName(t);
 354     name(n).line   = line;
 355     name(n).number = SELNAME;
 356     name(n).arity  = 1;
 357
 358     for(; nonNull(uses); uses=tl(uses)) {
 359         Int  fNo = 1;
 360         Name c   = fst(hd(uses));
 361         List fs  = snd(hd(uses));
 362         for(; nonNull(fs); fs=tl(fs), fNo++) {
 363             if (textOf(hd(fs)) == t) {
 364                 fields = cons(pair(c,mkInt(fNo)),fields);
 365             }
 366         }
 367     }
 368     name(n).defn   = fields;
 369
 370     /* prepare for finishGHCVar */
 371     name(n).type = type;
 372     ghcVarDecls = cons(n,ghcVarDecls);
 373
 374     return n;
 375 }
 376
 377 static Name local addGHCConstr(line,conNo,constr)
 378 Int    line;
 379 Int    conNo;
 380 Triple constr; { /* (ConId,[VarId],Type) */
 381     /* ToDo: add rank2 annotation and existential annotation
 382      * these affect how constr can be used.
 383      */
 384     Text con   = textOf(fst3(constr));
 385     Type type  = thd3(constr);
 386     Int  arity = arityFromType(type);
 387     Name n = findName(con);     /* Allocate constructor fun name   */
 388     if (isNull(n)) {
 389         n = newName(con);
 390     } else if (name(n).defn!=PREDEFINED) {
 391         ERRMSG(line) "Repeated definition for constructor \"%s\"",
 392             textToStr(con)
 393         EEND;
 394     }
 395     name(n).arity  = arity;     /* Save constructor fun details    */
 396     name(n).line   = line;
 397     name(n).number = cfunNo(conNo);
 398     bindNameToClosure(n, lookupGHCClosure(name(n).mod,name(n).text));
 399
 400     /* prepare for finishGHCCon */
 401     name(n).type   = type;
 402     ghcConDecls = cons(n,ghcConDecls);
 403
 404     return n;
 405 }
 406
 407 static Void local finishGHCCon(Name n)
 408 {
 409     Int  line = name(n).line;
 410     Type ty   = name(n).type;
 411     setCurrModule(name(n).mod);
 412     name(n).type = fixupConType(line,ty);
 413 }
 414
 415 Void addGHCNewType(line,tycon,tvs,constr)
 416 Int  line;
 417 Cell tycon;     /* ConId | QualConId     */
 418 List tvs;       /* [(VarId,Kind)]        */
 419 Cell constr; {
 420     /* ToDo: worry about being given a decl for (->) ?
 421      * and worry about qualidents for ()
 422      */
 423     Text t = textOf(tycon);
 424     if (nonNull(findTycon(t))) {
 425         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
 426                      textToStr(t)
 427         EEND;
 428     } else {
 429         Tycon tc        = newTycon(t);
 430         tycon(tc).line  = line;
 431         tycon(tc).arity = length(tvs);
 432         tycon(tc).what  = NEWTYPE;
 433         tycon(tc).kind  = tvsToKind(tvs);
 434         /* can't really do this until I've read in all synonyms */
 435
 436         if (isNull(constr)) {
 437             tycon(tc).defn = NIL;
 438         } else {
 439             /* constr :: (ConId,Type) */
 440             Text con   = textOf(fst(constr));
 441             Type type  = snd(constr);
 442             Name n = findName(con);     /* Allocate constructor fun name   */
 443             if (isNull(n)) {
 444                 n = newName(con);
 445             } else if (name(n).defn!=PREDEFINED) {
 446                 ERRMSG(line) "Repeated definition for constructor \"%s\"",
 447                     textToStr(con)
 448                 EEND;
 449             }
 450             name(n).arity  = 1;         /* Save constructor fun details    */
 451             name(n).line   = line;
 452             name(n).number = cfunNo(0);
 453             name(n).defn   = nameId;
 454             tycon(tc).defn = singleton(n);
 455
 456             /* prepare for finishGHCCon */
 457             /* ToDo: we use finishGHCCon instead of finishGHCVar in case
 458              * there's any existential quantification in the newtype -
 459              * but I don't think that's allowed in newtype constrs.
 460              * Still, no harm done by doing it this way...
 461              */
 462             name(n).type   = type;
 463             ghcConDecls = cons(n,ghcConDecls);
 464         }
 465     }
 466 }
 467
 468 Void addGHCClass(line,ctxt,tc_name,tvs,mems)
 469 Int  line;
 470 List ctxt;      /* [(ConId, [Type])]     */
 471 Cell tc_name;   /* ConId | QualConId     */
 472 List tvs;       /* [(VarId,Kind)]        */
 473 List mems; {
 474     Text ct   = textOf(tc_name);
 475     if (nonNull(findClass(ct))) {
 476         ERRMSG(line) "Repeated definition of class \"%s\"",
 477                      textToStr(ct)
 478         EEND;
 479     } else if (nonNull(findTycon(ct))) {
 480         ERRMSG(line) "\"%s\" used as both class and type constructor",
 481                      textToStr(ct)
 482         EEND;
 483     } else {
 484         Class nw    = newClass(ct);
 485         Int   arity = length(tvs);
 486         Cell  head  = nw;
 487         Int   i;
 488         for(i=0; i < arity; ++i) {
 489             head = ap(head,mkOffset(i));
 490         }
 491         cclass(nw).line       = line;
 492         cclass(nw).arity      = arity;
 493         cclass(nw).head       = head;
 494         cclass(nw).kinds      = tvsToKind(tvs);  /* ToDo: I don't think this is right */
 495         cclass(nw).instances  = NIL;
 496
 497         /* prepare for finishGHCClass */
 498         cclass(nw).supers  = pair(tvs,ctxt);
 499         cclass(nw).members = mems;
 500         ghcClassDecls = cons(nw,ghcClassDecls);
 501
 502         /* ToDo:
 503          * cclass(nw).dsels    = ?;
 504          * cclass(nw).dbuild   = ?;
 505          * cclass(nm).dcon     = ?;
 506          * cclass(nm).defaults = ?;
 507          */
 508     }
 509 }
 510
 511 static Void  local finishGHCClass(Class nw)
 512 {
 513     Int  line = cclass(nw).line;
 514     List tvs  = fst(cclass(nw).supers);
 515     List ctxt = snd(cclass(nw).supers);
 516     List mems = cclass(nw).members;
 517
 518     setCurrModule(cclass(nw).mod);
 519
 520     cclass(nw).supers     = fixupContext(line,singleton(tvs),ctxt);
 521     cclass(nw).numSupers  = length(cclass(nw).supers);
 522     cclass(nw).members    = fixupMembers(line,mems);
 523     cclass(nw).numMembers = length(cclass(nw).members);
 524     cclass(nw).level      = 0;  /* ToDo: level = 1 + max (map level supers) */
 525 }
 526
 527 Void addGHCInstance (line,quant,cls,var)
 528 Int  line;
 529 Cell quant;
 530 Pair cls;   /* :: (ConId, [Type]) */
 531 Text var; {
 532     Inst in = newInst();
 533
 534     List ctxt   = nonNull(quant) ? snd(quant) : NIL; /* [(ConId, [Type])] */
 535
 536     inst(in).line         = line;
 537     inst(in).implements   = NIL;
 538
 539     {
 540         Name b         = newName(inventText());
 541         name(b).line   = line;
 542         name(b).arity  = length(ctxt); /* unused? */
 543         name(b).number = DFUNNAME;
 544         inst(in).builder = b;
 545         bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
 546     }
 547
 548     /* prepare for finishGHCInstance */
 549     inst(in).head      = cls;
 550     inst(in).specifics = quant;
 551     ghcInstanceDecls = cons(in,ghcInstanceDecls);
 552 }
 553
 554 static Void  local finishGHCInstance(Inst in)
 555 {
 556     Int  line   = inst(in).line;
 557     Cell cl     = fst(inst(in).head);
 558     List tys    = snd(inst(in).head);
 559     Cell quant  = inst(in).specifics;
 560     List tvs    = nonNull(quant) ? fst(quant) : NIL; /* [(VarId,Kind)]    */
 561     List ctxt   = nonNull(quant) ? snd(quant) : NIL; /* [(ConId, [Type])] */
 562     List tyvars = singleton(tvs);
 563     Class c;
 564
 565     setCurrModule(inst(in).mod);
 566     c = findClass(textOf(cl));
 567     if (isNull(c)) {
 568         ERRMSG(line) "Unknown class \"%s\" in instance",
 569                      textToStr(textOf(cl))
 570         EEND;
 571     }
 572     map2Over(fixupType,line,tyvars,tys);
 573     inst(in).head         = applyToArgs(c,tys);
 574     inst(in).specifics    = fixupContext(line,tyvars,ctxt);
 575     inst(in).numSpecifics = length(inst(in).specifics);
 576     cclass(c).instances = cons(in,cclass(c).instances);
 577 }
 578
 579 /* --------------------------------------------------------------------------
 580  *
 581  * ------------------------------------------------------------------------*/
 582
 583 static Name local fixupMember(line,memNo,mem)
 584 Int  line;
 585 Int  memNo;
 586 Pair mem; { /* :: (Text,Type) */
 587     Text t    = textOf(fst(mem));
 588     Type type = snd(mem);
 589     Name m    = findName(t);
 590
 591     if (isNull(m)) {
 592         m = newName(t);
 593     } else if (name(m).defn!=PREDEFINED) {
 594         ERRMSG(line) "Repeated definition for member function \"%s\"",
 595                      textToStr(t)
 596         EEND;
 597     }
 598
 599     name(m).line   = line;
 600     name(m).arity  = 1;
 601     name(m).number = mfunNo(memNo);
 602     name(m).type   = fixupType(line,NIL,type);
 603
 604     /* ToDo: name(m).stgVar = ?; */
 605
 606     return m;
 607 }
 608
 609
 610 static List  local fixupMembers(line,ms)
 611 Int line;
 612 List ms; {
 613     Int  memNo = 1;
 614     List mems  = ms;
 615     for(; nonNull(mems); mems=tl(mems), memNo++) {
 616         hd(mems) = fixupMember(line,memNo,hd(mems));
 617     }
 618     return ms;
 619 }
 620
 621 static Type local fixupTypeVar(line,tyvars,tv)
 622 Int  line;
 623 List tyvars; /* [[(VarId,Kind)]] */
 624 Text tv; {
 625     Int  offset = 0;
 626     for (; nonNull(tyvars); tyvars=tl(tyvars)) {
 627         List tvs = hd(tyvars);
 628         for (; nonNull(tvs); offset++, tvs=tl(tvs)) {
 629             if (tv == textOf(fst(hd(tvs)))) {
 630                 return mkOffset(offset);
 631             }
 632         }
 633     }
 634     ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
 635     EEND;
 636 }
 637
 638 static Class local fixupClass(line,cls)
 639 Int  line;
 640 Text cls; {
 641     Class c = findClass(cls);
 642     if (isNull(c)) {
 643         ERRMSG(line)
 644             "Undefined class \"%s\"", textToStr(cls)
 645         EEND;
 646     }
 647     return c;
 648 }
 649
 650 static Cell local fixupPred(line,tyvars,pred)
 651 Int  line;
 652 List tyvars; /* [[(VarId,Kind)]] */
 653 Pair pred; { /* (ConId,[Type])   */
 654     Class c   = fixupClass(line,textOf(fst(pred)));
 655     List  tys = snd(pred);
 656
 657     map2Over(fixupType,line,tyvars,tys);
 658     return applyToArgs(c,tys);
 659 }
 660
 661 static List local fixupContext(line,tyvars,ctxt)
 662 Int  line;
 663 List tyvars; /* [[(VarId,Kind)]] */
 664 List ctxt; { /* [(ConId,[Type])] */
 665     map2Over(fixupPred,line,tyvars,ctxt);
 666     return ctxt;
 667 }
 668
 669 static Type local fixupType(line,tyvars,type)
 670 Int  line;
 671 List tyvars; /* [[(VarId,Kind)]] */
 672 Type type; {
 673     switch (whatIs(type)) {
 674     case AP:
 675         {
 676             fst(type) = fixupType(line,tyvars,fst(type));
 677             snd(type) = fixupType(line,tyvars,snd(type));
 678             break;
 679         }
 680     case DICTAP:
 681         {
 682             /* Alternatively: raise an error.  These can only
 683              * occur in the types of instance variables which
 684              * we could easily separate from "real variables".
 685              */
 686             snd(type) = fixupPred(line,tyvars,snd(type));
 687             break;
 688         }
 689     case VARIDCELL:
 690             return fixupTypeVar(line,tyvars,textOf(type));
 691     case CONIDCELL:
 692         {
 693             Tycon tc = findQualTycon(type);
 694             if (isNull(tc)) {
 695                 ERRMSG(line)
 696                     "Undefined type constructor \"%s\"",
 697                     identToStr(type)
 698                 EEND;
 699             }
 700             return tc;
 701         }
 702 #if TREX
 703     case EXT:
 704 #endif
 705     case TYCON:
 706     case TUPLE:
 707             break;
 708     case POLYTYPE:
 709         {
 710             List  tvs  = fst3(snd(type)); /* [(VarId, Kind)]   */
 711             List  ctxt = snd3(snd(type)); /* [(ConId, [Type])] */
 712             Type  ty   = thd3(snd(type));
 713
 714             if (nonNull(tvs)) {
 715                 tyvars = cons(tvs,tyvars);
 716             }
 717             type = fixupType(line,tyvars,ty);
 718
 719             if (nonNull(ctxt)) {
 720                 type = ap(QUAL,pair(fixupContext(line,tyvars,ctxt),type));
 721             }
 722             if (nonNull(tvs)) {
 723                 type = mkPolyType(tvsToKind(tvs),type);
 724             }
 725         }
 726         break;
 727     default:
 728             internal("fixupType");
 729     }
 730     return type;
 731 }
 732
 733 /*    forall as bs. C1 as, C2 as bs => Ts as bs -> T as
 734  * => forall as. C1 as => exists bs. C2 as bs => Ts as bs -> T as
 735  */
 736 static Type local fixupConType(line,type)
 737 Int  line;
 738 Type type; {
 739     List sig  = NIL;
 740     List ctxt = NIL;
 741     type = fixupType(line,NIL,type);
 742
 743     if (isPolyType(type)) {
 744         sig = polySigOf(type);
 745         type = monotypeOf(type);
 746     }
 747     if (whatIs(type) == QUAL) {
 748         ctxt = fst(snd(type));
 749         type = snd(snd(type));
 750     }
 751     {
 752         Type r_ty = type;
 753         Int  nr2 = 0; /* maximum argnum which is a polytype */
 754         Int  argnum = 1;
 755         while (isAp(r_ty) && getHead(r_ty)==typeArrow) {
 756             if (isPolyType(arg(fun(r_ty)))) {
 757                 nr2 = argnum;
 758             }
 759             argnum++;
 760             r_ty = arg(r_ty);
 761         }
 762
 763         if (nr2>0) {
 764             type = ap(RANK2,pair(mkInt(nr2),type));
 765         }
 766         {   /* tyvars which don't appear in result are existentially quant'd */
 767             List result_tvs = offsetTyvarsIn(r_ty,NIL);
 768             List all_tvs    = offsetTyvarsIn(type,NIL);
 769             Int etvs = length(all_tvs);
 770             Int ntvs = length(result_tvs);
 771             if (etvs>ntvs) {
 772                 /* ToDo: split the context into two parts */
 773                 type = ap(EXIST,pair(mkInt(etvs-ntvs),type));
 774             }
 775         }
 776     }
 777     if (nonNull(ctxt)) {
 778         type = ap(QUAL,pair(ctxt,type));
 779     }
 780     if (nonNull(sig)) {
 781         type = mkPolyType(sig,type);
 782     }
 783     return type;
 784 }
 785
 786 /* --------------------------------------------------------------------------
 787  * Utilities
 788  *
 789  * None of these do lookups or require that lookups have been resolved
 790  * so they can be performed while reading interfaces.
 791  * ------------------------------------------------------------------------*/
 792
 793 static Kinds local tvsToKind(tvs)
 794 List tvs; { /* [(VarId,Kind)] */
 795     List  rs = NIL;
 796     Kinds r  = STAR; /* ToDo: hope this works */
 797     for(; nonNull(tvs); tvs=tl(tvs)) { /* make reversed list of kinds */
 798         rs = cons(snd(hd(tvs)),rs);
 799     }
 800     for(; nonNull(rs); rs=tl(rs)) { /* build full kind */
 801         r = ap(hd(rs),r);
 802     }
 803     return r;
 804 }
 805
 806 static Int local arityFromType(type) /* arity of a constructor with this type */
 807 Type type; {
 808     Int arity = 0;
 809     if (isPolyType(type)) {
 810         type = monotypeOf(type);
 811     }
 812     if (whatIs(type) == QUAL) {
 813         type = snd(snd(type));
 814     }
 815     if (whatIs(type) == EXIST) {
 816         type = snd(snd(type));
 817     }
 818     if (whatIs(type)==RANK2) {
 819         type = snd(snd(type));
 820     }
 821     while (isAp(type) && getHead(type)==typeArrow) {
 822         arity++;
 823         type = arg(type);
 824     }
 825     return arity;
 826 }
 827
 828 /* --------------------------------------------------------------------------
 829  * Dynamic loading code (probably shouldn't be here)
 830  *
 831  * o .hi file explicitly says which .so file to load.
 832  *   This avoids the need for a 1-to-1 relationship between .hi and .so files.
 833  *
 834  *   ToDo: when doing a :reload, we ought to check the modification date
 835  *         on the .so file.
 836  *
 837  * o module handles are unloaded (dlclosed) when we call dropScriptsFrom.
 838  *
 839  *   ToDo: do the same for foreign functions - but with complication that
 840  *         there may be multiple .so files
 841  * ------------------------------------------------------------------------*/
 842
 843 /* ToDo: move some of this code (back) into dynamic.c and make it portable */
 844 #include <stdio.h>
 845
 846 static AsmClosure local lookupGHCClosure( Module m, Text t )
 847 {
 848     char symbol[100]; /* ToDo: arbitrary constants must die */
 849     void *c;
 850     sprintf(symbol,"%s_%s_closure",textToStr(module(m).text),textToStr(t));
 851     if (module(m).objectFile == NULL) {
 852         ERRMSG(0) "Interface file must \"require\" at least one file"
 853         EEND;
 854     }
 855     c = lookupSymbol(module(m).objectFile,symbol);
 856     if (NULL == c) {
 857         ERRMSG(0) "Error %s while importing symbol \"%s\"", dlerror(), symbol
 858         EEND;
 859     }
 860     return ((AsmClosure)c);
 861 }
 862
 863 Void loadSharedLib( String fn )
 864 {
 865     if (module(currentModule).objectFile != NULL) {
 866         ERRMSG(0) "Interface file \"require\"s two files"
 867         EEND;
 868     }
 869     module(currentModule).objectFile = loadLibrary(fn);
 870     if (NULL == module(currentModule).objectFile) {
 871         ERRMSG(0) "Error %s while importing DLL \"%s\"", dlerror(), fn
 872         EEND;
 873     }
 874 }
 875
 876 static void bindNameToClosure(n,c)
 877 Name n;
 878 AsmClosure c; {
 879     StgVar v = mkStgVar(NIL,mkPtr(asmMkObject(c)));
 880     name(n).stgVar = v;
 881 }
 882
 883 /* --------------------------------------------------------------------------
 884  * Control:
 885  * ------------------------------------------------------------------------*/
 886
 887 Void interface(what)
 888 Int what; {
 889     switch (what) {
 890     case RESET:
 891             interfaces       = NIL;
 892             ghcVarDecls      = NIL;
 893             ghcConDecls      = NIL;
 894             ghcSynonymDecls  = NIL;
 895             ghcClassDecls    = NIL;
 896             ghcInstanceDecls = NIL;
 897             break;
 898     case MARK:
 899             mark(interfaces);
 900             mark(ghcVarDecls);
 901             mark(ghcConDecls);
 902             mark(ghcSynonymDecls);
 903             mark(ghcClassDecls);
 904             mark(ghcInstanceDecls);
 905             break;
 906     }
 907 }
 908
 909 /*-------------------------------------------------------------------------*/
 910