Commit 0c97d649 authored by sewardj's avatar sewardj
Browse files

[project @ 1999-12-16 16:34:40 by sewardj]

Further major improvements in interface processing, mostly in the
handling of types.

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:

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.

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.

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.

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.

I'm sure the number of passes could be reduced.  For the moment,
understandability is of much higher priority.

Hugs can now complete stages 1 through 8 for the whole GHC Prelude,
excepting doing the object linking, which needs further work.
parent 4c7cb198
This diff is collapsed.
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: link.c,v $
* $Revision: 1.21 $
* $Date: 1999/12/10 15:59:48 $
* $Revision: 1.22 $
* $Date: 1999/12/16 16:34:42 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -496,16 +496,39 @@ break;
case PREPREL :
modulePrelude = newModule(textPrelude);
setCurrModule(modulePrelude);
for (i=0; i<NUM_TUPLES; ++i) {
allocTupleTycon(i);
}
if (combined) {
nameMkC = addWiredInBoxingTycon("PrelBase","Char", "C#",1,0,CHAR_REP );
nameMkI = addWiredInBoxingTycon("PrelBase","Int", "I#",1,0,INT_REP );
nameMkW = addWiredInBoxingTycon("PrelAddr","Word", "W#",1,0,WORD_REP );
nameMkA = addWiredInBoxingTycon("PrelAddr","Addr", "A#",1,0,ADDR_REP );
nameMkF = addWiredInBoxingTycon("PrelBase","Float", "F#",1,0,FLOAT_REP );
nameMkD = addWiredInBoxingTycon("PrelBase","Double","D#",1,0,DOUBLE_REP);
nameMkInteger
= addWiredInBoxingTycon("PrelBase","Integer","Integer#",1,0,0);
nameMkPrimByteArray
= addWiredInBoxingTycon("PrelGHC","ByteArray","PrimByteArray#",1,0,0);
for (i=0; i<NUM_TUPLES; ++i) {
addTupleTycon(i);
}
addWiredInEnumTycon("PrelBase","Bool",
doubleton(findText("False"),findText("True")));
//nameMkThreadId
// = addWiredInBoxingTycon("PrelConc","ThreadId","ThreadId#"
// ,1,0,THREADID_REP);
} else {
modulePrelude = newModule(textPrelude);
setCurrModule(modulePrelude);
for (i=0; i<NUM_TUPLES; ++i) {
addTupleTycon(i);
}
setCurrModule(modulePrelude);
typeArrow = addPrimTycon(findText("(->)"),
pair(STAR,pair(STAR,STAR)),
2,DATATYPE,NIL);
......
......@@ -12,8 +12,8 @@
* included in the distribution.
*
* $RCSfile: parser.y,v $
* $Revision: 1.18 $
* $Date: 1999/12/10 15:59:49 $
* $Revision: 1.19 $
* $Date: 1999/12/16 16:34:42 $
* ------------------------------------------------------------------------*/
%{
......@@ -150,7 +150,7 @@ ifTopDecl
| TINSTANCE ifCtxInst ifInstHdL '=' ifVar
{$$=gc5(ap(I_INSTANCE,
z4ble($1,$2,$3,$5)));}
z5ble($1,$2,$3,$5,NIL)));}
| NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType
{$$=gc6(ap(I_TYPE,
......@@ -236,7 +236,7 @@ ifInstHd /* { Class aType } :: (ConId, Type) */
ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: Type */
: ifInstHd ARROW ifInstHdL {$$=gc3(fn($1,$3));}
| ifInstHd {$$=gc1(NIL);}
| ifInstHd {$$=gc1($1);}
;
ifCtxDecl /* {M.C1 a, C2 b} => :: [(QConId, VarId)] */
......@@ -265,36 +265,36 @@ ifCtxDeclLE /* M.C1 a :: (QConId,VarId) */
mkInt(2) indicates unpacked -- a GHC extension.
*/
ifConstrs /* = Con1 | ... | ConN :: [(ConId,[(Type,VarId,Int)])] */
ifConstrs /* = Con1 | ... | ConN :: [((ConId,[((Type,VarId,Int))]))] */
: {$$ = gc0(NIL);}
| '=' ifConstrL {$$ = gc2($2);}
;
ifConstrL /* [(ConId,[(Type,VarId,Int)])] */
ifConstrL /* [((ConId,[((Type,VarId,Int))]))] */
: ifConstr {$$ = gc1(singleton($1));}
| ifConstr '|' ifConstrL {$$ = gc3(cons($1,$3));}
;
ifConstr /* (ConId,[(Type,VarId,Int)]) */
ifConstr /* ((ConId,[((Type,VarId,Int))])) */
: ifConData ifDataAnonFieldL {$$ = gc2(zpair($1,$2));}
| ifConData '{' ifDataNamedFieldL '}'
{$$ = gc4(zpair($1,$3));}
;
ifDataAnonFieldL /* [(Type,VarId,Int)] */
ifDataAnonFieldL /* [((Type,VarId,Int))] */
: {$$=gc0(NIL);}
| ifDataAnonField ifDataAnonFieldL
{$$=gc2(cons($1,$2));}
;
ifDataNamedFieldL /* [(Type,VarId,Int)] */
ifDataNamedFieldL /* [((Type,VarId,Int))] */
: {$$=gc0(NIL);}
| ifDataNamedField {$$=gc1(cons($1,NIL));}
| ifDataNamedField ',' ifDataNamedFieldL
{$$=gc3(cons($1,$3));}
;
ifDataAnonField /* (Type,VarId,Int) */
ifDataAnonField /* ((Type,VarId,Int)) */
: ifAType {$$=gc1(ztriple($1,NIL,mkInt(0)));}
| '!' ifAType {$$=gc2(ztriple($2,NIL,mkInt(1)));}
| '!' '!' ifAType {$$=gc3(ztriple($3,NIL,mkInt(2)));}
;
ifDataNamedField /* (Type,VarId,Int) */
ifDataNamedField /* ((Type,VarId,Int)) */
: ifVar COCO ifAType {$$=gc3(ztriple($3,$1,mkInt(0)));}
| ifVar COCO '!' ifAType {$$=gc4(ztriple($4,$1,mkInt(1)));}
| ifVar COCO '!' '!' ifAType {$$=gc5(ztriple($5,$1,mkInt(2)));}
......@@ -302,15 +302,15 @@ ifDataNamedField /* (Type,VarId,Int) */
/*- Interface class declarations - methods ----------------*/
ifCmeths /* [(VarId,Type)] */
ifCmeths /* [((VarId,Type))] */
: { $$ = gc0(NIL); }
| WHERE '{' ifCmethL '}' { $$ = gc4($3); }
;
ifCmethL /* [(VarId,Type)] */
ifCmethL /* [((VarId,Type))] */
: ifCmeth { $$ = gc1(singleton($1)); }
| ifCmeth ';' ifCmethL { $$ = gc3(cons($1,$3)); }
;
ifCmeth /* (VarId,Type) */
ifCmeth /* ((VarId,Type)) */
: ifVar COCO ifType { $$ = gc3(zpair($1,$3)); }
| ifVar '=' COCO ifType { $$ = gc4(zpair($1,$4)); }
/* has default method */
......@@ -318,7 +318,7 @@ ifCmeth /* (VarId,Type) */
/*- Interface newtype declararions ------------------------*/
ifNewTypeConstr /* (ConId,Type) */
ifNewTypeConstr /* ((ConId,Type)) */
: '=' ifCon ifAType { $$ = gc3(zpair($2,$3)); }
;
......@@ -356,7 +356,8 @@ ifAType : ifQTCName { $$ = gc1($1); }
| ifTyvar { $$ = gc1($1); }
| '(' ')' { $$ = gc2(typeUnit); }
| '(' ifTypeL2 ')' { $$ = gc3(buildTuple($2)); }
| '[' ifType ']' { $$ = gc3(ap(typeList,$2));}
| '[' ifType ']' { $$ = gc3(ap(mkCon(tycon(typeList).text),
$2));}
| '{' ifQTCName ifATypes '}' { $$ = gc4(ap(DICTAP,
pair($2,$3))); }
| '(' ifType ')' { $$ = gc3($2); }
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: storage.c,v $
* $Revision: 1.25 $
* $Date: 1999/12/10 15:59:53 $
* $Revision: 1.26 $
* $Date: 1999/12/16 16:34:43 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -581,18 +581,20 @@ List ts; { /* Null pattern matches every tycon*/
Text ghcTupleText_n ( Int n )
{
Int i;
char buf[103];
char buf[104];
if (n < 0 || n >= 100) internal("ghcTupleText_n");
buf[0] = '(';
for (i = 1; i <= n; i++) buf[i] = ',';
buf[i] = ')';
buf[i+1] = 0;
buf[n+1] = ')';
buf[n+2] = 0;
return findText(buf);
}
Text ghcTupleText(tup)
Tycon tup; {
assert(isTuple(tup));
if (!isTuple(tup)) {
assert(isTuple(tup));
}
return ghcTupleText_n ( tupleOf(tup) );
}
......@@ -607,23 +609,6 @@ Tycon mkTuple ( Int n )
internal("mkTuple: request for non-existent tuple");
}
Void allocTupleTycon ( Int n )
{
Int i;
Kind k;
Tycon t;
for (i = TYCMIN; i < tyconHw; i++)
if (tycon(i).tuple == n) return;
//t = addPrimTycon(findText(buf),simpleKind(n),n, DATATYPE,NIL);
k = STAR;
for (i = 0; i < n; i++) k = ap(STAR,k);
t = newTycon(ghcTupleText_n(n));
tycon(t).kind = k;
tycon(t).tuple = n;
tycon(t).what = DATATYPE;
}
/* --------------------------------------------------------------------------
* Name storage:
......@@ -771,6 +756,95 @@ void* getHugs_AsmObject_for ( char* s )
* Primitive functions:
* ------------------------------------------------------------------------*/
Module findFakeModule ( Text t )
{
Module m = findModule(t);
if (nonNull(m)) {
if (!module(m).fake) internal("findFakeModule");
} else {
m = newModule(t);
module(m).fake = TRUE;
}
return m;
}
Name addWiredInBoxingTycon
( String modNm, String typeNm, String constrNm,
Int arity, Int no, Int rep )
{
Name n;
Tycon t;
Text modT = findText(modNm);
Text typeT = findText(typeNm);
Text conT = findText(constrNm);
Module m = findFakeModule(modT);
setCurrModule(m);
n = newName(conT,NIL);
name(n).arity = arity;
name(n).number = cfunNo(no);
name(n).type = NIL;
name(n).primop = (void*)rep;
t = newTycon(typeT);
tycon(t).what = DATATYPE;
return n;
}
Tycon addTupleTycon ( Int n )
{
Int i;
Kind k;
Tycon t;
Module m;
for (i = TYCMIN; i < tyconHw; i++)
if (tycon(i).tuple == n) return i;
if (combined)
m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else
m = findModule(findText("Prelude"));
setCurrModule(m);
k = STAR;
for (i = 0; i < n; i++) k = ap(STAR,k);
t = newTycon(ghcTupleText_n(n));
tycon(t).kind = k;
tycon(t).tuple = n;
tycon(t).what = DATATYPE;
return t;
}
Tycon addWiredInEnumTycon ( String modNm, String typeNm,
List /*of Text*/ constrs )
{
Int i;
Tycon t;
Text modT = findText(modNm);
Text typeT = findText(typeNm);
Module m = findFakeModule(modT);
setCurrModule(m);
t = newTycon(typeT);
tycon(t).kind = STAR;
tycon(t).what = DATATYPE;
constrs = reverse(constrs);
i = length(constrs);
for (; nonNull(constrs); constrs=tl(constrs),i--) {
Text conT = hd(constrs);
Name con = newName(conT,t);
name(con).number = cfunNo(i);
name(con).type = t;
tycon(t).defn = cons(con, tycon(t).defn);
}
return t;
}
Name addPrimCfunREP(t,arity,no,rep) /* add primitive constructor func */
Text t; /* sets rep, not type */
Int arity;
......@@ -1052,20 +1126,123 @@ Type tc; {
|| typeInvolves(arg(ty),tc)));
}
Inst findSimpleInstance ( ConId klass, ConId dataty )
/* Needed by finishGHCInstance to find classes, before the
export list has been built -- so we can't use
findQualClass.
*/
Class findQualClassWithoutConsultingExportList ( QualId q )
{
Class cl;
Text t_mod;
Text t_class;
assert(isQCon(q));
if (isCon(q)) {
t_mod = NIL;
t_class = textOf(q);
} else {
t_mod = qmodOf(q);
t_class = qtextOf(q);
}
for (cl = CLASSMIN; cl < classHw; cl++) {
if (cclass(cl).text == t_class) {
/* Class name is ok, but is this the right module? */
if (isNull(t_mod) /* no module name specified */
|| (nonNull(t_mod)
&& t_mod == module(cclass(cl).mod).text)
)
return cl;
}
}
return NIL;
}
/* Same deal, except for Tycons. */
Tycon findQualTyconWithoutConsultingExportList ( QualId q )
{
Inst in;
for (in = INSTMIN; in < instHw; in++) {
Cell head = inst(in).head;
if (isClass(fun(head))
&& cclass(fun(head)).text==textOf(klass)
&& typeInvolves(arg(head), findTycon(textOf(dataty)) )
)
return in;
Tycon tc;
Text t_mod;
Text t_tycon;
assert(isQCon(q));
if (isCon(q)) {
t_mod = NIL;
t_tycon = textOf(q);
} else {
t_mod = qmodOf(q);
t_tycon = qtextOf(q);
}
for (tc = TYCMIN; tc < tyconHw; tc++) {
if (tycon(tc).text == t_tycon) {
/* Tycon name is ok, but is this the right module? */
if (isNull(t_mod) /* no module name specified */
|| (nonNull(t_mod)
&& t_mod == module(tycon(tc).mod).text)
)
return tc;
}
}
return NIL;
}
/* Same deal, except for Names. */
Name findQualNameWithoutConsultingExportList ( QualId q )
{
Name nm;
Text t_mod;
Text t_name;
assert(isQVar(q) || isQCon(q));
if (isCon(q) || isVar(q)) {
t_mod = NIL;
t_name = textOf(q);
} else {
t_mod = qmodOf(q);
t_name = qtextOf(q);
}
for (nm = NAMEMIN; nm < nameHw; nm++) {
if (name(nm).text == t_name) {
/* Name is ok, but is this the right module? */
if (isNull(t_mod) /* no module name specified */
|| (nonNull(t_mod)
&& t_mod == module(name(nm).mod).text)
)
return nm;
}
}
return NIL;
}
/* returns List of QualId */
List getAllKnownTyconsAndClasses ( void )
{
Tycon tc;
Class nw;
List xs = NIL;
for (tc = TYCMIN; tc < tyconHw; tc++) {
/* almost certainly undue paranoia about duplicate avoidance, but .. */
QualId q = mkQCon( module(tycon(tc).mod).text, tycon(tc).text );
if (!qualidIsMember(q,xs))
xs = cons ( q, xs );
}
for (nw = CLASSMIN; nw < classHw; nw++) {
QualId q = mkQCon( module(cclass(nw).mod).text, cclass(nw).text );
if (!qualidIsMember(q,xs))
xs = cons ( q, xs );
}
return xs;
}
/* --------------------------------------------------------------------------
* Control stack:
*
......@@ -1153,6 +1330,7 @@ Text t; {
}
module(moduleHw).text = t; /* clear new module record */
module(moduleHw).qualImports = NIL;
module(moduleHw).fake = FALSE;
module(moduleHw).exports = NIL;
module(moduleHw).tycons = NIL;
module(moduleHw).names = NIL;
......@@ -1306,7 +1484,7 @@ void* lookupOTabName ( Module m, char* nm )
{
int i;
for (i = 0; i < module(m).usedoTab; i++) {
if (1)
if (0)
fprintf ( stderr,
"lookupOTabName: request %s, table has %s\n",
nm, module(m).oTab[i].nm );
......@@ -1969,7 +2147,7 @@ Int depth; {
Printf("Offset %d", offsetOf(c));
break;
case TUPLE:
Printf("%s", textToStr(ghcTupleText(tupleOf(c))));
Printf("%s", textToStr(ghcTupleText(c)));
break;
case POLYTYPE:
Printf("Polytype");
......@@ -2103,8 +2281,20 @@ Int depth; {
break;
case ZTUP2:
Printf("<ZPair ");
print(snd(c),depth-1);
print(zfst(c),depth-1);
Putchar(' ');
print(zsnd(c),depth-1);
Putchar('>');
break;
case ZTUP3:
Printf("<ZTriple ");
print(zfst3(c),depth-1);
Putchar(' ');
print(zsnd3(c),depth-1);
Putchar(' ');
print(zthd3(c),depth-1);
Putchar('>');
break;
case BANG:
Printf("(BANG,");
print(snd(c),depth-1);
......@@ -2172,6 +2362,16 @@ Cell c; {
return isPair(c) && (fst(c)==QUALIDENT);
}
Bool eqQualIdent ( QualId c1, QualId c2 )
{
assert(isQualIdent(c1));
if (!isQualIdent(c2)) {
assert(isQualIdent(c2));
}
return qmodOf(c1)==qmodOf(c2) &&
qtextOf(c1)==qtextOf(c2);
}
Bool isIdent(c) /* is cell an identifier? */
Cell c; {
if (!isPair(c)) return FALSE;
......@@ -2349,6 +2549,15 @@ List xs, ys; { /* list xs onto list ys... */
return ys;
}
QualId qualidIsMember ( QualId q, List xs )
{
for (; nonNull(xs); xs=tl(xs)) {
if (eqQualIdent(q, hd(xs)))
return hd(xs);
}
return NIL;
}
Cell varIsMember(t,xs) /* Test if variable is a member of */
Text t; /* given list of variables */
List xs; {
......
......@@ -10,8 +10,8 @@
* included in the distribution.
*
* $RCSfile: storage.h,v $
* $Revision: 1.20 $
* $Date: 1999/12/10 15:59:54 $
* $Revision: 1.21 $
* $Date: 1999/12/16 16:34:45 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
......@@ -49,6 +49,8 @@ typedef Cell Ext; /* extension label */
typedef Cell ConId;
typedef Cell VarId;
typedef Cell QualId;
typedef Cell ConVarId;
/* --------------------------------------------------------------------------
* Text storage:
......@@ -177,6 +179,7 @@ extern Cell whatIs Args((Cell));
#define mkQCon(m,t) ap(QUALIDENT,pair(mkCon(m),mkCon(t)))
#define mkQVarOp(m,t) ap(QUALIDENT,pair(mkCon(m),mkVarop(t)))
#define mkQConOp(m,t) ap(QUALIDENT,pair(mkCon(m),mkConop(t)))
#define mkQualId(m,t) ap(QUALIDENT,pair(m,t))
#define intValOf(c) (snd(c))
#define inventVar() mkVar(inventText())
#define mkDictVar(t) ap(DICTVAR,t)
......@@ -196,6 +199,7 @@ extern Bool isCon Args((Cell));
extern Bool isQVar Args((Cell));
extern Bool isQCon Args((Cell));
extern Bool isQualIdent Args((Cell));
extern Bool eqQualIdent ( QualId c1, QualId c2 );
extern Bool isIdent Args((Cell));
extern String stringNegate Args((String));
extern Text textOf Args((Cell));
......@@ -318,63 +322,67 @@ extern Ptr cptrOf Args((Cell));
type <a> = ZList a
type ExportListEntry = ConVarId | (ConId, <ConVarId>)
type Associativity = mkInt of LEFT_ASS | RIGHT_ASS | NON_ASS
type Constr = (ConId, <(Type,VarId,Int)>)
(constr name, list of (type, field name if any, strictness))
type Constr = ((ConId, [((Type,VarId,Int))]))
((constr name, [((type, field name if any, strictness))]))
strictness: 0 => none, 1 => !, 2 => !! (unpacked)
All 2/3/4/5 tuples in the interface abstract syntax are done with
z-tuples.
*/
#define I_INTERFACE 109 /* snd :: (ConId, <I_IMPORT..I_VALUE>)
#define I_INTERFACE 109 /* snd :: ((ConId, [I_IMPORT..I_VALUE]))
interface name, list of iface entities */
#define I_IMPORT 110 /* snd :: (ConId, <ConVarId>)
#define I_IMPORT 110 /* snd :: ((ConId, [ConVarId]))
module name, list of entities */
#define I_INSTIMPORT 111 /* snd :: NIL -- not used at present */
#define I_EXPORT 112 /* snd :: (ConId, <ExportListEntry>
#define I_EXPORT 112 /* snd :: ((ConId, [ExportListEntry]))
this module name?, entities to export */
#define I_FIXDECL 113 /* snd :: (NIL|Int, Associativity, ConVarId)
#define I_FIXDECL 113 /* snd :: ((NIL|Int, Associativity, ConVarId))
fixity, associativity, name */
#define I_INSTANCE 114 /* snd :: (Line, <(QConId,VarId)>, Type, VarId)
#define I_INSTANCE 114 /* snd :: ((Line, [((QConId,VarId))],
Type, VarId, Inst))
lineno,
forall-y bit (eg __forall [a b] {M.C1 a, M.C2 b} =>),
other bit, eg { C a1 } -> { C2 a2 } -> ... -> { Cn an },
name of dictionary builder */
name of dictionary builder,
(after startGHCInstance) the instance table location */
#define I_TYPE 115 /* snd :: (Line, ConId, <(VarId,Kind)>, Type)
#define I_TYPE 115 /* snd :: ((Line, ConId, [((VarId,Kind))], Type))
lineno, tycon, kinded tyvars, the type expr */
#define I_DATA 116 /* snd :: (Line, <(QConId,VarId)>, ConId,
<(VarId,Kind)>, <Constr>)
lineno, context, tycon, kinded tyvars, constrs */
#define I_DATA 116 /* snd :: ((Line, [((QConId,VarId))], ConId,
[((VarId,Kind))], [Constr])
lineno, context, tycon, kinded tyvars, constrs
An empty constr list means exported abstractly. */
#define I_NEWTYPE 117 /* snd :: (Line, <(QConId,VarId)>, ConId,
<(VarId,Kind)>, (ConId,Type))