Commit 51c33894 authored by sewardj's avatar sewardj
Browse files

[project @ 1999-12-10 15:59:41 by sewardj]

Major improvements in interface processing, and minor supporting
improvements to CT-storage management.

* Make the iface parser return the complete interface as a single
  tree, which is processed later.  Added abs syntax tags
  I_INTERFACE .. I_VALUE to support this.

* Add tagged ("z") 2,3,4,5 tuples.  Because they are tagged, they can't
  be confused with lists, etc.  Selectors zfst, zsnd ... zsel45, zsel55
  check tags first.  Iface processing uses z-tuples wherever it can.

* Add unap as a safe "inverse" of ap; it checks tags.  So
  unap(TAG1, ap(TAG2,cell)) == cell but only if TAG1==TAG2, else
  assertion failure.

* In interface.c, clean up the startGHC*/endGHC* functions.
  processInterfaces() is the top-level driver; it makes 4
  passes over the supplied iface trees.

* Throw away iface symbols not mentioned in export lists.

* Use iface export lists to construct both the export and
  eval environments for a module.

* Don't use Texts to refer to things.  Instead use ConId and
  VarId.  Added ConId and VarId as synonyms for Cell in
  storage.h.

* Add findSimpleInstance in storage.c.
parent 0491574d
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: codegen.c,v $
* $Revision: 1.13 $
* $Date: 1999/12/06 16:25:23 $
* $Revision: 1.14 $
* $Date: 1999/12/10 15:59:41 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -476,10 +476,8 @@ static Void alloc( AsmBCO bco, StgVar v )
itblNames[nItblNames++] = textToStr(name(con).text);
} else
if (isTuple(con)) {
char cc[20];
sprintf(cc, "Tuple%d", tupleOf(con) );
itblNames[nItblNames++] = vv;
itblNames[nItblNames++] = cc;
itblNames[nItblNames++] = textToStr(ghcTupleText(con));
} else
assert ( /* cant identify constructor name */ 0 );
setPos(v,asmAllocCONSTR(bco, vv));
......@@ -757,12 +755,11 @@ Void cgBinds( List binds )
Void codegen(what)
Int what; {
switch (what) {
case INSTALL:
/* deliberate fall though */
case RESET:
break;
case MARK:
break;
case PREPREL:
case RESET:
case MARK:
case POSTPREL:
break;
}
liftControl(what);
}
......
......@@ -11,8 +11,8 @@
* included in the distribution.
*
* $RCSfile: compiler.c,v $
* $Revision: 1.15 $
* $Date: 1999/11/22 16:00:21 $
* $Revision: 1.16 $
* $Date: 1999/12/10 15:59:42 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -1557,14 +1557,6 @@ Void compileDefns() { /* compile script definitions */
Target i = 0;
List binds = NIL;
/* a nasty hack. But I don't know an easier way to make */
/* these things appear. */
if (lastModule() == modulePrelude) {
implementCfun ( nameCons, NIL );
implementCfun ( nameNil, NIL );
implementCfun ( nameUnit, NIL );
}
{
List vss;
List vs;
......@@ -1653,20 +1645,17 @@ Pair p; { /* Should be merged with genDefns, */
Void compiler(what)
Int what; {
switch (what) {
case INSTALL :
case PREPREL :
case RESET : freeVars = NIL;
freeFuns = NIL;
freeBegin = mkOffset(0);
//extraVars = NIL;
//numExtraVars = 0;
//localOffset = 0;
//localArity = 0;
break;
case MARK : mark(freeVars);
mark(freeFuns);
//mark(extraVars);
break;
case POSTPREL: break;
}
}
......
......@@ -8,8 +8,8 @@
* included in the distribution.
*
* $RCSfile: connect.h,v $
* $Revision: 1.20 $
* $Date: 1999/12/03 17:56:04 $
* $Revision: 1.21 $
* $Date: 1999/12/10 15:59:43 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
......@@ -17,6 +17,7 @@
* ------------------------------------------------------------------------*/
extern Bool haskell98; /* TRUE => Haskell 98 compatibility*/
extern Bool combined; /* TRUE => combined operation */
extern Module modulePrelude;
/* --------------------------------------------------------------------------
......@@ -177,12 +178,19 @@ extern Bool allowOverlap; /* TRUE => allow overlapping insts */
extern Void everybody Args((Int));
#define RESET 1 /* reset subsystem */
#define MARK 2 /* mark parts of graph in use by subsystem */
#define INSTALL 3 /* install subsystem (executed once only) */
#define EXIT 4 /* Take action immediately before exit() */
#define BREAK 5 /* Take action after program break */
#define GCDONE 6 /* Restore subsystem invariantss after GC */
#define RESET 1 /* reset subsystem */
#define MARK 2 /* mark parts of graph in use by subsystem */
#define PREPREL 3 /* do startup actions before Prelude loading */
#define POSTPREL 4 /* do startup actions after Prelude loading */
#define EXIT 5 /* Take action immediately before exit() */
#define BREAK 6 /* Take action after program break */
#define GCDONE 7 /* Restore subsystem invariantss after GC */
/* PREPREL was formerly called INSTALL. POSTPREL doesn't have an analogy
in the old Hugs.
*/
typedef long Target;
extern Void setGoal Args((String, Target));
......@@ -545,29 +553,16 @@ extern Void interface Args((Int));
extern Void getFileSize Args((String, Long *));
extern Void loadInterface Args((String,Long));
extern ZPair readInterface Args((String,Long));
extern Void processInterfaces Args((Void));
extern Void openGHCIface Args((Text));
extern Void loadSharedLib Args((String));
extern Void addGHCImports Args((Int,Text,List));
extern Void addGHCExports Args((Cell,List));
extern Void addGHCVar Args((Int,Text,Type));
extern Void addGHCSynonym Args((Int,Cell,List,Type));
extern Void addGHCDataDecl Args((Int,List,Cell,List,List));
extern Void addGHCNewType Args((Int,List,Cell,List,Cell));
extern Void addGHCClass Args((Int,List,Cell,List,List));
extern Void addGHCInstance Args((Int,List,Pair,Text));
extern Void finishInterfaces Args((Void));
extern List /* of ZTriple(I_INTERFACE,
Text--name of obj file,
Int--size of obj file) */
ifaces_outstanding;
extern Void hi_o_namesFromSrcName Args((String,String*,String* oName));
extern Void parseInterface Args((String,Long));
#define SMALL_INLINE_SIZE 9
extern Void hi_o_namesFromSrcName Args((String,String*,String* oName));
extern Cell parseInterface Args((String,Long));
// nasty hack, but seems an easy to convey the object name
// and size to openGHCIface
char nameObj[FILENAME_MAX+1];
int sizeObj;
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: derive.c,v $
* $Revision: 1.10 $
* $Date: 1999/12/01 10:22:53 $
* $Revision: 1.11 $
* $Date: 1999/12/10 15:59:43 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -1010,8 +1010,7 @@ Tycon t; {
Void deriveControl(what)
Int what; {
switch (what) {
case INSTALL :
/* deliberate fall through */
case PREPREL :
case RESET :
diVars = NIL;
diNum = 0;
......@@ -1022,6 +1021,8 @@ Int what; {
mark(diVars);
mark(cfunSfuns);
break;
case POSTPREL: break;
}
}
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: hugs.c,v $
* $Revision: 1.29 $
* $Date: 1999/12/06 16:25:24 $
* $Revision: 1.30 $
* $Date: 1999/12/10 15:59:44 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
......@@ -158,6 +158,8 @@ static Int hpSize = DEFAULTHEAP; /* Desired heap size */
String hugsEdit = 0; /* String for editor command */
String hugsPath = 0; /* String for file search path */
List ifaces_outstanding = NIL;
#if REDIRECT_OUTPUT
static Bool disableOutput = FALSE; /* redirect output to buffer? */
#endif
......@@ -364,7 +366,8 @@ String argv[]; {
Printf("Standalone mode: Restart with command line +c for combined mode\n\n" );
}
everybody(INSTALL);
everybody(PREPREL);
evalModule = findText(""); /* evaluate wrt last module by default */
if (proj) {
if (namesUpto>1) {
......@@ -972,7 +975,6 @@ Int stacknum; {
// setLastEdit(name,0);
nameObj[0] = 0;
strcpy(name, scriptInfo[stacknum].path);
strcat(name, scriptInfo[stacknum].modName);
if (scriptInfo[stacknum].fromSource)
......@@ -982,7 +984,7 @@ Int stacknum; {
scriptFile = name;
if (scriptInfo[stacknum].fromSource) {
if (lastWasObject) finishInterfaces();
if (lastWasObject) processInterfaces();
lastWasObject = FALSE;
Printf("Reading script \"%s\":\n",name);
needsImports = FALSE;
......@@ -992,6 +994,12 @@ Int stacknum; {
typeCheckDefns();
compileDefns();
} else {
Cell iface;
List imports;
ZTriple iface_info;
char nameObj[FILENAME_MAX+1];
Int sizeObj;
Printf("Reading iface \"%s\":\n", name);
scriptFile = name;
needsImports = FALSE;
......@@ -1002,14 +1010,25 @@ Int stacknum; {
strcat(nameObj, DLL_ENDING);
sizeObj = scriptInfo[stacknum].oSize;
loadInterface(name,len);
iface = readInterface(name,len);
imports = zsnd(iface); iface = zfst(iface);
if (nonNull(imports)) chase(imports);
scriptFile = 0;
lastWasObject = TRUE;
iface_info = ztriple(iface, findText(nameObj), mkInt(sizeObj) );
ifaces_outstanding = cons(iface_info,ifaces_outstanding);
if (needsImports) return FALSE;
}
scriptFile = 0;
preludeLoaded = TRUE;
if (strcmp(scriptInfo[stacknum].modName, "Prelude")==0) {
preludeLoaded = TRUE;
everybody(POSTPREL);
}
return TRUE;
}
......@@ -1186,7 +1205,7 @@ Int n; { /* loading everything after and */
//numScripts = 0;
while (numScripts < namesUpto) {
ppSmStack ( "readscripts-loop2" );
ppSmStack ( "readscripts-loop2" );
if (scriptInfo[numScripts].fromSource) {
......@@ -1195,7 +1214,7 @@ ppSmStack ( "readscripts-loop2" );
nextNumScripts = NUM_SCRIPTS; //bogus initialisation
if (addScript(numScripts)) {
numScripts++;
assert(nextNumScripts==NUM_SCRIPTS);
assert(nextNumScripts==NUM_SCRIPTS);
}
else
dropScriptsFrom(numScripts-1);
......@@ -1213,21 +1232,21 @@ assert(nextNumScripts==NUM_SCRIPTS);
nextNumScripts = NUM_SCRIPTS;
if (addScript(numScripts)) {
numScripts++;
assert(nextNumScripts==NUM_SCRIPTS);
assert(nextNumScripts==NUM_SCRIPTS);
} else {
//while (!scriptInfo[numScripts].fromSource && numScripts > 0)
// numScripts--;
//if (scriptInfo[numScripts].fromSource)
// numScripts++;
numScripts = nextNumScripts;
assert(nextNumScripts<NUM_SCRIPTS);
assert(nextNumScripts<NUM_SCRIPTS);
}
}
}
if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
}
finishInterfaces();
processInterfaces();
{ Int m = namesUpto-1;
Text mtext = findText(scriptInfo[m].modName);
......@@ -2387,8 +2406,9 @@ FILE* fp; {
Void everybody(what) /* send command `what' to each component of*/
Int what; { /* system to respond as appropriate ... */
fprintf ( stderr, "EVERYBODY %d\n", what );
machdep(what); /* The order of calling each component is */
storage(what); /* important for the INSTALL command */
storage(what); /* important for the PREPREL command */
substitution(what);
input(what);
translateControl(what);
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: input.c,v $
* $Revision: 1.17 $
* $Date: 1999/12/06 16:20:26 $
* $Revision: 1.18 $
* $Date: 1999/12/10 15:59:45 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -121,7 +121,7 @@ static Void local skipWhitespace Args((Void));
static Int local yylex Args((Void));
static Int local repeatLast Args((Void));
static Void local parseInput Args((Int));
static Cell local parseInput Args((Int));
static Bool local doesNotExceed Args((String,Int,Int));
static Int local stringToInt Args((String,Int));
......@@ -1595,9 +1595,10 @@ Name n; {
* main entry points to parser/lexer:
* ------------------------------------------------------------------------*/
static Void local parseInput(startWith)/* Parse input with given first tok,*/
static Cell local parseInput(startWith)/* Parse input with given first tok,*/
Int startWith; { /* determining whether to read a */
firstToken = TRUE; /* script or an expression */
Cell final = NIL; /* script or an expression */
firstToken = TRUE;
firstTokenIs = startWith;
if (startWith==INTERFACE) {
offsideON = FALSE; readingInterface = TRUE;
......@@ -1610,9 +1611,10 @@ Int startWith; { /* determining whether to read a */
ERRMSG(row) "Parser overflow" /* as all syntax errors are caught */
EEND; /* in the parser... */
}
drop();
final = pop();
if (!stackEmpty()) /* stack should now be empty */
internal("parseInput");
return final;
}
#ifdef HSCRIPT
......@@ -1675,12 +1677,12 @@ Void parseContext() { /* Read a context to prove */
}
#endif
Void parseInterface(nm,len) /* Read a GHC interface file */
Cell parseInterface(nm,len) /* Read a GHC interface file */
String nm;
Long len; { /* Used to set a target for reading */
input(RESET);
fileInput(nm,len);
parseInput(INTERFACE);
input(RESET);
fileInput(nm,len);
return parseInput(INTERFACE);
}
......@@ -1691,7 +1693,9 @@ Long len; { /* Used to set a target for reading */
Void input(what)
Int what; {
switch (what) {
case INSTALL : initCharTab();
case POSTPREL: break;
case PREPREL : initCharTab();
textCase = findText("case");
textOfK = findText("of");
textData = findText("data");
......@@ -1770,7 +1774,6 @@ Int what; {
instDefns = NIL;
selDefns = NIL;
genDefns = NIL;
//primDefns = NIL;
unqualImports= NIL;
foreignImports= NIL;
foreignExports= NIL;
......@@ -1792,7 +1795,6 @@ Int what; {
mark(instDefns);
mark(selDefns);
mark(genDefns);
//mark(primDefns);
mark(unqualImports);
mark(foreignImports);
mark(foreignExports);
......
This diff is collapsed.
......@@ -12,8 +12,8 @@
* included in the distribution.
*
* $RCSfile: lift.c,v $
* $Revision: 1.9 $
* $Date: 1999/11/29 18:59:29 $
* $Revision: 1.10 $
* $Date: 1999/12/10 15:59:47 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -200,14 +200,15 @@ List liftBinds( List binds )
Void liftControl(what)
Int what; {
switch (what) {
case INSTALL:
/* deliberate fall though */
case RESET:
liftedBinds = NIL;
break;
case MARK:
mark(liftedBinds);
break;
case POSTPREL: break;
case PREPREL:
case RESET:
liftedBinds = NIL;
break;
case MARK:
mark(liftedBinds);
break;
}
}
......
This diff is collapsed.
......@@ -13,8 +13,8 @@
* included in the distribution.
*
* $RCSfile: machdep.c,v $
* $Revision: 1.16 $
* $Date: 1999/12/03 14:38:39 $
* $Revision: 1.17 $
* $Date: 1999/12/10 15:59:48 $
* ------------------------------------------------------------------------*/
#ifdef HAVE_SIGNAL_H
......@@ -1543,7 +1543,8 @@ Void machdep(what) /* Handle machine specific */
Int what; { /* initialisation etc.. */
switch (what) {
case MARK : break;
case INSTALL : installHandlers();
case POSTPREL: break;
case PREPREL : installHandlers();
break;
case RESET :
case BREAK :
......
......@@ -12,8 +12,8 @@
* included in the distribution.
*
* $RCSfile: parser.y,v $
* $Revision: 1.17 $
* $Date: 1999/12/03 17:01:22 $
* $Revision: 1.18 $
* $Date: 1999/12/10 15:59:49 $
* ------------------------------------------------------------------------*/
%{
......@@ -120,80 +120,74 @@ start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;}
*/
/*- Top-level interface files -----------------------------*/
iface : INTERFACE ifName NUMLIT orphans checkVersion WHERE ifDecls
{$$ = gc7(NIL); }
iface : INTERFACE ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls
{$$ = gc7(ap(I_INTERFACE,
zpair($2,$7))); }
| INTERFACE error {syntaxError("interface file");}
;
ifDecls: {$$=gc0(NIL);}
| ifDecl ';' ifDecls {$$=gc3(cons($1,$3));}
;
varid_or_conid
: VARID { $$=gc1($1); }
| CONID { $$=gc1($1); }
;
ifName : CONID {openGHCIface(textOf($1));
$$ = gc1(NIL);}
checkVersion
: NUMLIT {$$ = gc1(NIL); }
ifTopDecls: {$$=gc0(NIL);}
| ifTopDecl ';' ifTopDecls {$$=gc3(cons($1,$3));}
;
ifDecl
: IMPORT CONID NUMLIT orphans opt_COCO version_list_junk
{ addGHCImports(intOf($3),textOf($2),
$6);
$$ = gc6(NIL);
}
| INSTIMPORT CONID {$$=gc2(NIL);}
ifTopDecl
: IMPORT CONID NUMLIT ifOrphans ifOptCOCO ifVersionList
{$$=gc6(ap(I_IMPORT,zpair($2,$6))); }
| INSTIMPORT CONID {$$=gc2(ap(I_INSTIMPORT,NIL));}
| UUEXPORT CONID ifEntities { addGHCExports($2,$3);
$$=gc3(NIL);}
| UUEXPORT CONID ifEntities {$$=gc3(ap(I_EXPORT,zpair($2,$3)));}
| NUMLIT INFIXL optDigit varid_or_conid
{$$ = gc4(fixdecl($2,singleton($4),
LEFT_ASS,$3)); }
| NUMLIT INFIXR optDigit varid_or_conid
{$$ = gc4(fixdecl($2,singleton($4),
RIGHT_ASS,$3)); }
| NUMLIT INFIXN optDigit varid_or_conid
{$$ = gc4(fixdecl($2,singleton($4),
NON_ASS,$3)); }
| NUMLIT INFIXL optDigit ifVarCon
{$$=gc4(ap(I_FIXDECL,
ztriple($3,mkInt(LEFT_ASS),$4)));}
| NUMLIT INFIXR optDigit ifVarCon
{$$=gc4(ap(I_FIXDECL,
ztriple($3,mkInt(RIGHT_ASS),$4)));}
| NUMLIT INFIXN optDigit ifVarCon
{$$=gc4(ap(I_FIXDECL,
ztriple($3,mkInt(NON_ASS),$4)));}
| TINSTANCE ifCtxInst ifInstHdL '=' ifVar
{ addGHCInstance(intOf($1),$2,$3,
textOf($5));
$$ = gc5(NIL); }
{$$=gc5(ap(I_INSTANCE,
z4ble($1,$2,$3,$5)));}
| NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType
{ addGHCSynonym(intOf($2),$3,$4,$6);
$$ = gc6(NIL); }
{$$=gc6(ap(I_TYPE,
z4ble($2,$3,$4,$6)));}
| NUMLIT DATA ifCtxDecl ifConData ifKindedTyvarL ifConstrs
{ addGHCDataDecl(intOf($2),
$3,$4,$5,$6);
$$ = gc6(NIL); }
{$$=gc6(ap(I_DATA,
z5ble($2,$3,$4,$5,$6)));}
| NUMLIT TNEWTYPE ifCtxDecl ifConData ifKindedTyvarL ifNewTypeConstr
{ addGHCNewType(intOf($2),
$3,$4,$5,$6);
$$ = gc6(NIL); }
{$$=gc6(ap(I_NEWTYPE,
z5ble($2,$3,$4,$5,$6)));}
| NUMLIT TCLASS ifCtxDecl ifCon ifKindedTyvar ifCmeths
{ addGHCClass(intOf($2),$3,$4,$5,$6);
$$ = gc6(NIL); }
{$$=gc6(ap(I_CLASS,
z5ble($2,$3,$4,
singleton($5),$6)));}
| NUMLIT ifVar COCO ifType
{ addGHCVar(intOf($3),textOf($2),$4);
$$ = gc4(NIL); }
{$$=gc4(ap(I_VALUE,
ztriple($3,$2,$4)));}
| error { syntaxError(
"interface declaration"); }
;
/*- Top-level misc interface stuff ------------------------*/
orphans : '!' {$$=gc1(NIL);}
ifOrphans : '!' {$$=gc1(NIL);}
| {$$=gc0(NIL);}
;
opt_COCO : COCO {$$=gc1(NIL);}
ifOptCOCO : COCO {$$=gc1(NIL);}
| {$$=gc0(NIL);}
;
ifCheckVersion
: NUMLIT {$$ = gc1(NIL); }
;
......@@ -204,6 +198,11 @@ ifVar : VARID {$$ = gc1($1);}
;
ifCon : CONID {$$ = gc1($1);}
;
ifVarCon : VARID {$$ = gc1($1);}
| CONID {$$ = gc1($1);}
;
ifQCon : CONID {$$ = gc1($1);}
| QCONID {$$ = gc1($1);}
;
......@@ -231,74 +230,74 @@ ifCtxInst /* __forall [a b] {M.C1 a, M.C2 b} => */
| {$$=gc0(NIL);}