Commit 73be9570 authored by sewardj's avatar sewardj
Browse files

[project @ 2000-03-22 18:14:22 by sewardj]

Initial commit of major changes to module chasing and storage management:

* Total reimplementation of module chasing (see achieveTargetModules
  in hugs.c).  Build, maintain and use module dependency graphs
  to decide what needs reloading when.  The old mechanism with a
  stack of scripts, etc, is gone forever.  All the rest of these points
  are in support of the module-chasing change:

* The result of parsing a module is now a parse tree, rather than a
  half-baked parse tree and a bunch of side-effects.  Hooray!

* Redo symbol tables for Names, Tycons, Classes, Instances and
  Modules.  They are now dynamically expandable, doubling in size
  automatically when full, and use a freelist system to keep track
  of available slots.

* Allow arbitrary modules to be deleted from the system.  The
  main honcho here is nukeModule().

* Not strictly necessary, but ... unify the address space for all
  compile-time entities.  See revised whatIs().  Text is part of
  the unified address space.  This is very convenient for debugging.
  print() can now print practically anything.  Generally simplify
  storage management as much as possible, and zap the years of
  elaborate hacks needed to make Hugs work well in 16-bit systems.
  Added a load of sanity-checking support to storage.[ch].

* We don't support project files any more.  They were useful for a
  while, but no longer seem relevant.

* Nuked a large bunch of irrelevant options in rts/options.h.

As of this commit, the system can load and chase modules, both in
standalone and combined modes.  The :l (load), :a (also), :r (refresh),
:i (info), :t (show type) and :m (set eval module) commands appear
to work.  There are also several temporary limitations which will
be fixed soon:

* Anything to do with external editors, etc, doesn't work.

* The downward-closure-of-object-code (if M is object, all
  modules below M must be too) is not enforced nor checked for.
  It needs to be.

* Module M _must_ reside in M.hs/M.o (sigh).  To be fixed.

* Error handling is probably flaky, and interrupt handling
  very likely is.

* Error messages don't have line numbers.  (A 5-minute fix).

* Progress messages are all at sea; needs re-thinking now that
  the order in which things are done is radically different.

* Compile-time GC is temporarily disabled whilst I figure out how
  to stress-test the GC.

* Freed-up symbol table entries are never re-entered on the free
  lists -- a debugging measure.

* :% is given a bad type in combined mode.  To be investigated.
parent 048117fe
# --------------------------------------------------------------------------- #
# $Id: Makefile,v 1.27 2000/02/24 14:40:38 sewardj Exp $ #
# $Id: Makefile,v 1.28 2000/03/22 18:14:22 sewardj Exp $ #
# --------------------------------------------------------------------------- #
TOP = ..
......@@ -44,7 +44,7 @@ C_SRCS = link.c type.c static.c storage.c derive.c input.c compiler.c subst.c \
translate.c codegen.c lift.c free.c stgSubst.c output.c \
hugs.c dynamic.c stg.c sainteger.c object.c interface.c
SRC_CC_OPTS = -g -O -I$(GHC_INTERPRETER_DIR) -I$(GHC_INCLUDE_DIR) -I$(GHC_RUNTIME_DIR) -D__HUGS__ -DCOMPILING_RTS -Wall -Wstrict-prototypes -Wno-unused -DDEBUG -Winline
SRC_CC_OPTS = -g -I$(GHC_INTERPRETER_DIR) -I$(GHC_INCLUDE_DIR) -I$(GHC_RUNTIME_DIR) -D__HUGS__ -DCOMPILING_RTS -Wall -Wstrict-prototypes -Wno-unused -DDEBUG -Winline
GHC_LIBS_NEEDED = $(GHC_RUNTIME_DIR)/libHSrts.a
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: codegen.c,v $
* $Revision: 1.18 $
* $Date: 2000/03/10 20:03:36 $
* $Revision: 1.19 $
* $Date: 2000/03/22 18:14:22 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -88,31 +88,20 @@ char* lookupHugsName( void* closure )
{
extern Name nameHw;
Name nm;
for( nm=NAMEMIN; nm<nameHw; ++nm ) {
StgVar v = name(nm).stgVar;
if (isStgVar(v)
&& isPtr(stgVarInfo(v))
&& varHasClosure(v)
&& closureOfVar(v) == closure) {
return textToStr(name(nm).text);
}
for( nm = NAME_BASE_ADDR;
nm < NAME_BASE_ADDR+tabNameSz; ++nm )
if (name(nm).inUse) {
StgVar v = name(nm).stgVar;
if (isStgVar(v)
&& isPtr(stgVarInfo(v))
&& varHasClosure(v)
&& closureOfVar(v) == closure) {
return textToStr(name(nm).text);
}
}
return 0;
}
/* called at the start of GC */
void markHugsObjects( void )
{
extern Name nameHw;
Name nm;
for( nm=NAMEMIN; nm<nameHw; ++nm ) {
StgVar v = name(nm).stgVar;
if (isStgVar(v) && isPtr(stgVarInfo(v))) {
asmMarkObject((AsmClosure*)ptrOf(stgVarInfo(v)));
}
}
}
static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
{
setPos(v,asmBind(bco,rep));
......@@ -218,7 +207,7 @@ static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
con = stgCaseAltCon(hd(alts));
/* special case: dictionary constructors */
if (strncmp(":D",textToStr(name(con).text),2)==0) {
if (isName(con) && strncmp(":D",textToStr(name(con).text),2)==0) {
omit_test = TRUE;
goto xyzzy;
}
......@@ -752,15 +741,33 @@ Void cgBinds( List binds )
#endif
for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
/* printStg( stdout, hd(b) ); printf( "\n\n"); */
beginTop(hd(b));
}
for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
//printStg( stdout, hd(b) ); printf( "\n\n");
/* printStg( stdout, hd(b) ); printf( "\n\n"); */
endTop(hd(b));
}
//mapProc(zap,binds);
/* mapProc(zap,binds); */
}
/* Called by the evaluator's GC to tell Hugs to mark stuff in the
run-time heap.
*/
void markHugsObjects( void )
{
extern Name nameHw;
Name nm;
for ( nm = NAME_BASE_ADDR;
nm < NAME_BASE_ADDR+tabNameSz; ++nm )
if (tabName[nm-NAME_BASE_ADDR].inUse) {
StgVar v = name(nm).stgVar;
if (isStgVar(v) && isPtr(stgVarInfo(v))) {
asmMarkObject(ptrOf(stgVarInfo(v)));
}
}
}
/* --------------------------------------------------------------------------
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: connect.h,v $
* $Revision: 1.31 $
* $Date: 2000/03/20 04:26:23 $
* $Revision: 1.32 $
* $Date: 2000/03/22 18:14:22 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
......@@ -375,7 +375,7 @@ extern Void input ( Int );
extern Void consoleInput ( String );
extern Void projInput ( String );
extern Void stringInput ( String );
extern Void parseScript ( String,Long );
extern Cell parseModule ( String,Long );
extern Void parseExp ( Void );
#if EXPLAIN_INSTANCE_RESOLUTION
extern Void parseContext ( Void );
......@@ -389,7 +389,7 @@ extern Void printString ( String );
extern Void staticAnalysis ( Int );
extern Void startModule ( Cell );
extern Void startModule ( Module );
extern Void setExportList ( List );
extern Void setExports ( List );
extern Void addQualImport ( Text,Text );
......@@ -427,7 +427,7 @@ extern Int visitClass ( Class );
#if EXPLAIN_INSTANCE_RESOLUTION
extern Void checkContext ( Void );
#endif
extern Void checkDefns ( Void );
extern Void checkDefns ( Module );
extern Bool h98Pred ( Bool,Cell );
extern Cell h98Context ( Bool,List );
extern Void h98CheckCtxt ( Int,String,Bool,List,Inst );
......@@ -568,21 +568,18 @@ extern Bool broken; /* indicates interrupt received */
* ctrlbrk: set control break handler
*/
#if HUGS_FOR_WINDOWS
# define ctrlbrk(bh)
# define allowBreak() kbhit()
#else /* !HUGS_FOR_WINDOWS */
# if HAVE_SIGPROCMASK
# include <signal.h>
# define ctrlbrk(bh) { sigset_t mask; \
#if HAVE_SIGPROCMASK
#include <signal.h>
#define ctrlbrk(bh) { sigset_t mask; \
signal(SIGINT,bh); \
sigemptyset(&mask); \
sigaddset(&mask, SIGINT); \
sigprocmask(SIG_UNBLOCK, &mask, NULL); \
}
# else
#else
# define ctrlbrk(bh) signal(SIGINT,bh)
# endif
#endif
#if SYMANTEC_C
extern int time_release;
extern int allow_break_count;
......@@ -592,7 +589,6 @@ extern int allow_break_count;
#else
# define allowBreak() if (broken) { broken=FALSE; sigRaise(breakHandler); }
#endif
#endif /* !HUGS_FOR_WINDOWS */
/*---------------------------------------------------------------------------
......@@ -623,10 +619,10 @@ extern char installDir[N_INSTALLDIR];
#if HAVE_UNISTD_H
# include <sys/types.h>
# include <unistd.h>
#elif !HUGS_FOR_WINDOWS
extern int chdir ( const char* );
#endif
extern int chdir ( const char* );
#if HAVE_STDLIB_H
# include <stdlib.h>
#else
......@@ -712,8 +708,8 @@ extern Void gcCStack ( Void );
*-------------------------------------------------------------------------*/
extern Cell parseInterface ( String,Long );
extern ZPair readInterface ( String,Long );
extern Bool processInterfaces ( Void );
extern List getInterfaceImports ( Cell );
extern void processInterfaces ( List );
extern Void getFileSize ( String, Long * );
extern Void ifLinkConstrItbl ( Name n );
extern Void hi_o_namesFromSrcName ( String,String*,String* oName );
......@@ -928,11 +924,7 @@ typedef struct { /* Each type variable contains: */
Kind kind; /* kind annotation */
} Tyvar;
#if FIXED_SUBST /* storage for type variables */
extern Tyvar tyvars[];
#else
extern Tyvar *tyvars; /* storage for type variables */
#endif
extern Int typeOff; /* offset of result type */
extern Type typeIs; /* skeleton of result type */
extern Int typeFree; /* freedom in instantiated type */
......
......@@ -9,25 +9,20 @@
* included in the distribution.
*
* $RCSfile: errors.h,v $
* $Revision: 1.7 $
* $Date: 2000/03/15 23:27:16 $
* $Revision: 1.8 $
* $Date: 2000/03/22 18:14:22 $
* ------------------------------------------------------------------------*/
extern Void internal ( String) HUGS_noreturn;
extern Void fatal ( String) HUGS_noreturn;
#if HUGS_FOR_WINDOWS
#define Hilite() WinTextcolor(hWndText,RED);
#define Lolite() WinTextcolor(hWndText,BLACK);
#define errorStream stderr
#else
#define Hilite() doNothing()
#define Lolite() doNothing()
#define errorStream stdout
#endif
#define ERRMSG(l) Hilite(); errHead(l); FPrintf(errorStream,
#define EEND ); Lolite(); errFail()
#define EEND_NO_LONGJMP ); Lolite(); errFail_no_longjmp()
#define ETHEN );
#define ERRTEXT Hilite(); FPrintf(errorStream,
#define ERREXPR(e) Hilite(); printExp(errorStream,e); Lolite()
......@@ -38,9 +33,10 @@ extern Void fatal ( String) HUGS_noreturn;
#define ERRKINDS(ks) Hilite(); printKinds(errorStream,ks); Lolite()
#define ERRFD(fd) Hilite(); printFD(errorStream,fd); Lolite()
extern Void errHead ( Int ); /* in main.c */
extern Void errFail ( Void) HUGS_noreturn;
extern Void errAbort ( Void );
extern Void errHead ( Int ); /* in main.c */
extern Void errFail ( Void ) HUGS_noreturn;
extern Void errFail_no_longjmp ( Void );
extern Void errAbort ( Void );
extern Cell errAssert ( Int );
extern sigProto(breakHandler);
......
This diff is collapsed.
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: input.c,v $
* $Revision: 1.21 $
* $Date: 2000/03/13 11:37:16 $
* $Revision: 1.22 $
* $Date: 2000/03/22 18:14:22 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -27,7 +27,7 @@
#include <windows.h>
#endif
#if IS_WIN32 || HUGS_FOR_WINDOWS
#if IS_WIN32
#undef IN
#endif
......@@ -567,7 +567,7 @@ static Void local skip() { /* move forward one char in input */
c1 = EOF;
else {
c1 = nextConsoleChar();
#if IS_WIN32 && !HUGS_FOR_WINDOWS
#if IS_WIN32
Sleep(0);
#endif
/* On Win32, hitting ctrl-C causes the next getchar to
......@@ -1263,7 +1263,7 @@ String readLine() { /* Read command line from input */
* - Otherwise, if no `{' follows the keywords WHERE/LET or OF, a SOFT `{'
* is inserted with the column number of the first token after the
* WHERE/LET/OF keyword.
* - When a soft indentation is uppermost on the indetation stack with
* - When a soft indentation is uppermost on the indentation stack with
* column col' we insert:
* `}' in front of token with column<col' and pop indentation off stack,
* `;' in front of token with column==col'.
......@@ -1611,66 +1611,20 @@ Int startWith; { /* determining whether to read a */
ERRMSG(row) "Parser overflow" /* as all syntax errors are caught */
EEND; /* in the parser... */
}
if (startWith==SCRIPT) pop(); /* zap spurious closing } token */
final = pop();
if (!stackEmpty()) /* stack should now be empty */
internal("parseInput");
return final;
}
#ifdef HSCRIPT
static String memPrefix = "@mem@";
static Int lenMemPrefix = 5; /* strlen(memPrefix)*/
Void makeMemScript(mem,fname)
String mem;
String fname; {
strcat(fname,memPrefix);
itoa((int)mem, fname+strlen(fname), 10);
}
Bool isMemScript(fname)
String fname; {
return (strstr(fname,memPrefix) != NULL);
}
String memScriptString(fname)
String fname; {
String p = strstr(fname,memPrefix);
if (p) {
return (String)atoi(p+lenMemPrefix);
} else {
return NULL;
}
}
Void parseScript(fname,len) /* Read a script, possibly from mem */
String fname;
Long len; {
input(RESET);
if (isMemScript(fname)) {
char* s = memScriptString(fname);
stringInput(s);
} else {
fileInput(fname,len);
}
parseInput(SCRIPT);
}
#else
Void parseScript(nm,len) /* Read a script */
String nm;
Long len; { /* Used to set a target for reading */
input(RESET);
fileInput(nm,len);
parseInput(SCRIPT);
}
#endif
Void parseExp() { /* Read an expression to evaluate */
parseInput(EXPR);
setLastExpr(inputExpr);
}
#if EXPLAIN_INSTANCE_RESOLUTION
Void parseContext() { /* Read a context to prove */
parseInput(CONTEXT);
......@@ -1681,10 +1635,20 @@ Cell parseInterface(nm,len) /* Read a GHC interface file */
String nm;
Long len; { /* Used to set a target for reading */
input(RESET);
Printf("Reading interface \"%s\"\n", nm );
fileInput(nm,len);
return parseInput(INTERFACE);
}
Cell parseModule(nm,len) /* Read a module */
String nm;
Long len; { /* Used to set a target for reading */
input(RESET);
Printf("Reading source file \"%s\"\n", nm );
fileInput(nm,len);
return parseInput(SCRIPT);
}
/* --------------------------------------------------------------------------
* Input control:
......
......@@ -7,8 +7,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
* $Revision: 1.39 $
* $Date: 2000/03/14 14:34:47 $
* $Revision: 1.40 $
* $Date: 2000/03/22 18:14:22 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -139,7 +139,7 @@ static Void finishGHCExports ( ConId,List );
static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name );
static Void finishGHCModule ( Cell );
static Void startGHCModule ( Text, Int, Text );
static Void startGHCModule ( Text );
static Void startGHCDataDecl ( Int,List,Cell,List,List );
static List finishGHCDataDecl ( ConId tyc );
......@@ -243,12 +243,10 @@ static Cell filterInterface ( Cell root,
}
ZPair readInterface(String fname, Long fileSize)
List /* of CONID */ getInterfaceImports ( Cell iface )
{
List tops;
List imports = NIL;
ZPair iface = parseInterface(fname,fileSize);
assert (whatIs(iface)==I_INTERFACE);
for (tops = zsnd(unap(I_INTERFACE,iface)); nonNull(tops); tops=tl(tops))
if (whatIs(hd(tops)) == I_IMPORT) {
......@@ -262,7 +260,7 @@ ZPair readInterface(String fname, Long fileSize)
# endif
}
}
return zpair(iface,imports);
return imports;
}
......@@ -670,13 +668,7 @@ static void ifSetClassDefaultsAndDCon ( Class c )
}
/* ifaces_outstanding holds a list of parsed interfaces
for which we need to load objects and create symbol
table entries.
Return TRUE if Prelude `elem` ifaces_outstanding, else FALSE.
*/
Bool processInterfaces ( void )
void processInterfaces ( List /* of CONID */ iface_modnames )
{
List tmp;
List xs;
......@@ -689,15 +681,12 @@ Bool processInterfaces ( void )
Module mod;
List all_known_types;
Int num_known_types;
Bool didPrelude;
List cls_list; /* :: List Class */
List constructor_list; /* :: List Name */
List ifaces = NIL; /* :: List I_INTERFACE */
List iface_sizes = NIL; /* :: List Int */
List iface_onames = NIL; /* :: List Text */
if (isNull(ifaces_outstanding)) return FALSE;
if (isNull(iface_modnames)) return;
# ifdef DEBUG_IFACE
fprintf ( stderr,
......@@ -705,16 +694,13 @@ Bool processInterfaces ( void )
length(ifaces_outstanding) );
# endif
/* 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 );
for (xs = iface_modnames; nonNull(xs); xs=tl(xs)) {
mod = findModule(textOf(hd(xs)));
assert(nonNull(mod));
assert(!module(mod).fromSrc);
ifaces = cons ( module(mod).tree, ifaces );
}
ifaces = reverse(ifaces);
iface_onames = reverse(iface_onames);
iface_sizes = reverse(iface_sizes);
ifaces = reverse(ifaces);
/* Clean up interfaces -- dump non-exported value, class, type decls */
for (xs = ifaces; nonNull(xs); xs = tl(xs))
......@@ -735,7 +721,8 @@ Bool processInterfaces ( void )
*/
all_known_types = getAllKnownTyconsAndClasses();
for (xs = ifaces; nonNull(xs); xs=tl(xs))
all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
all_known_types
= addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
/* Have we reached a fixed point? */
i = length(all_known_types);
......@@ -902,15 +889,8 @@ Bool processInterfaces ( void )
/* 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) );
}
assert (isNull(iface_sizes));
assert (isNull(iface_onames));
for (xs=ifaces; nonNull(xs); xs=tl(xs))
startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))) );
/* Now work through the decl lists of the modules, and call the
......@@ -1003,7 +983,6 @@ Bool processInterfaces ( void )
calling the finishGHC* functions. But don't process
the export lists; those must wait for later.
*/
didPrelude = FALSE;
cls_list = NIL;
constructor_list = NIL;
for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
......@@ -1014,8 +993,6 @@ Bool processInterfaces ( void )
setCurrModule(mod);
ppModule ( module(mod).text );
if (mname == textPrelude) didPrelude = TRUE;
for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
Cell decl = hd(decls);
switch(whatIs(decl)) {
......@@ -1088,8 +1065,6 @@ Bool processInterfaces ( void )
/* Finished! */
ifaces_outstanding = NIL;
return didPrelude;
}
......@@ -1136,38 +1111,34 @@ static ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
return oc;
}
static Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
static Void startGHCModule ( Text mname )
{
List xts;
Module m = findModule(mname);
assert(nonNull(m));
if (isNull(m)) {
m = newModule(mname);
# ifdef DEBUG_IFACE
fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
textToStr(mname), sizeObj );
# endif
} else {
if (module(m).fake) {
module(m).fake = FALSE;
} else {
ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname)
EEND;
}
}
# ifdef DEBUG_IFACE
fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
textToStr(mname), module(m).objSize );
# endif
if (module(m).fake)
module(m).fake = FALSE;
/* Get hold of the primary object for the module. */
module(m).object
= startGHCModule_partial_load ( textToStr(nameObj), sizeObj );
= startGHCModule_partial_load ( textToStr(module(m).objName),
module(m).objSize );
/* 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 );
String nm = getExtraObjectInfo (
textToStr(module(m).objName),
textToStr(xtt),
&size
);
if (size == -1) {
ERRMSG(0) "Can't find extra object file \"%s\"", nm
EEND;
......@@ -2487,6 +2458,7 @@ Type type; {
* ------------------------------------------------------------------------*/
#define EXTERN_SYMS_ALLPLATFORMS \
Sym(MainRegTable) \
Sym(stg_gc_enter_1) \
Sym(stg_gc_noregs) \
Sym(stg_gc_seq_1) \
......@@ -2518,7 +2490,6 @@ Type type; {
Sym(__sel_10_upd_info) \
Sym(__sel_11_upd_info) \
Sym(__sel_12_upd_info) \
Sym(MainRegTable) \
Sym(Upd_frame_info) \
Sym(seq_frame_info) \
Sym(CAF_BLACKHOLE_info) \
......@@ -2625,13 +2596,8 @@ Type type; {
SymX(rmdir) \
SymX(rename) \
SymX(chdir) \
Sym(localtime) \
Sym(strftime) \
SymX(execl) \
Sym(waitpid) \
Sym(timezone) \
Sym(mktime) \
Sym(gmtime) \
SymX(getenv)
#define EXTERN_SYMS_cygwin32 \
......@@ -2674,7 +2640,12 @@ Type type; {
SymX(stderr) \
SymX(vfork) \