Commit 89311160 authored by sewardj's avatar sewardj
Browse files

[project @ 1999-03-01 14:46:42 by sewardj]

Mods to make STG-hugs able to compile and run small examples.  This
commit also includes proper implementations of seq, raise and catch.
parent e0a630ed
/* -*- mode: hugs-c; -*- */
/* -----------------------------------------------------------------------------
* $Id: Assembler.h,v 1.4 1999/02/05 16:02:18 simonm Exp $
* $Id: Assembler.h,v 1.5 1999/03/01 14:47:09 sewardj Exp $
*
* (c) The GHC Team 1994-1998.
*
......@@ -139,10 +139,10 @@ typedef enum {
* Allocating (top level) heap objects
* ------------------------------------------------------------------------*/
extern AsmBCO asmBeginBCO ( void );
extern AsmBCO asmBeginBCO ( int /*StgExpr*/ e );
extern void asmEndBCO ( AsmBCO bco );
extern AsmBCO asmBeginContinuation ( AsmSp sp );
extern AsmBCO asmBeginContinuation ( AsmSp sp, int /*List*/ alts );
extern void asmEndContinuation ( AsmBCO bco );
extern AsmObject asmMkObject ( AsmClosure c );
......@@ -180,7 +180,7 @@ extern void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep );
extern AsmSp asmBeginCase ( AsmBCO bco );
extern void asmEndCase ( AsmBCO bco );
extern AsmSp asmContinuation ( AsmBCO bco, AsmBCO ret_addr );
extern AsmSp asmBeginAlt ( AsmBCO bco );
extern void asmEndAlt ( AsmBCO bco, AsmSp sp );
extern AsmPc asmTest ( AsmBCO bco, AsmWord tag );
......@@ -233,6 +233,11 @@ extern const AsmPrim* asmFindPrimop ( AsmInstr prefix, AsmInstr op );
extern AsmSp asmBeginPrim ( AsmBCO bco );
extern void asmEndPrim ( AsmBCO bco, const AsmPrim* prim, AsmSp base );
extern AsmBCO asm_BCO_catch ( void );
extern AsmBCO asm_BCO_raise ( void );
extern AsmBCO asm_BCO_seq ( void );
/* --------------------------------------------------------------------------
* Heap manipulation
* ------------------------------------------------------------------------*/
......
......@@ -13,8 +13,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: options.h,v $
* $Revision: 1.3 $
* $Date: 1999/01/13 16:26:37 $
* $Revision: 1.4 $
* $Date: 1999/03/01 14:47:09 $
* ------------------------------------------------------------------------*/
......@@ -104,7 +104,7 @@
#define LARGE_HUGS 1
#define NUM_SYNTAX 100
#define NUM_TUPLES 100
#define NUM_TUPLES /*100*/ 10
#define NUM_OFFSETS 1024
#define NUM_CHARS 256
#if TREX
......@@ -124,7 +124,7 @@
#define MINIMUMHEAP Pick(7500, 19000, 19000)
#define MAXIMUMHEAP Pick(32765, 0, 0)
#define DEFAULTHEAP Pick(28000, 50000, 300000)
#define DEFAULTHEAP Pick(28000, 50000, 1500000 /*300000*/ )
#define NUM_SCRIPTS Pick(64, 100, 100)
#define NUM_MODULE NUM_SCRIPTS
......@@ -189,16 +189,16 @@
*/
#define PROVIDE_INTEGER
#define PROVIDE_INT64
#define PROVIDE_WORD
#undef PROVIDE_INT64
#undef PROVIDE_WORD
#define PROVIDE_ADDR
#define PROVIDE_STABLE
#undef PROVIDE_STABLE
#define PROVIDE_FOREIGN
#define PROVIDE_WEAK
#undef PROVIDE_WEAK
#define PROVIDE_ARRAY
#define PROVIDE_CONCURRENT
#define PROVIDE_PTREQUALITY
#define PROVIDE_COERCE
#undef PROVIDE_CONCURRENT
#undef PROVIDE_PTREQUALITY
#undef PROVIDE_COERCE
/* The following aren't options at the moment - but could be
* #define PROVIDE_FLOAT
......@@ -229,12 +229,12 @@
/* Should lambda lifter lift constant expressions out to top level?
* Experimental optimisation.
*/
#define LIFT_CONSTANTS 1
#define LIFT_CONSTANTS 0
/* Should we run optimizer on Hugs code?
* Experimental optimisation.
*/
#define USE_HUGS_OPTIMIZER 1
#define USE_HUGS_OPTIMIZER 0
/* Are things being used in an interactive setting or a batch setting?
* In an interactive setting, System.exitWith should not call _exit
......@@ -250,13 +250,13 @@
/* Turn on debugging output and some sanity checks
*/
/*#define DEBUG */
#define DEBUG 1
/*#define NDEBUG */
/* Make stack tags more informative than just their size.
* Helps when printing the stack and when running sanity checks.
*/
/*#define DEBUG_EXTRA */
#define DEBUG_EXTRA 1
/* Turn lazy blackholing on/off.
* Warning: Lazy blackholing can't be disabled in GHC generated code.
......
......@@ -7,8 +7,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: backend.h,v $
* $Revision: 1.1 $
* $Date: 1999/02/03 17:05:14 $
* $Revision: 1.2 $
* $Date: 1999/03/01 14:46:42 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
......@@ -20,8 +20,8 @@
*
* Expr -> LETREC ([Var],Expr) -- Vars contain their bound value
* | LAMBDA ([Var],Expr) -- all vars bound to NIL
* | CASE (Expr,[Alt])
* | PRIMCASE (Expr,[PrimAlt])
* | CASE (Expr,[Alt]) -- algebraic case
* | PRIMCASE (Expr,[PrimAlt]) -- primitive case
* | STGPRIM (Prim,[Atom])
* | STGAPP (Var, [Atom]) -- tail call
* | Var -- Abbreviation for STGAPP(Var,[])
......
......@@ -7,8 +7,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: codegen.c,v $
* $Revision: 1.3 $
* $Date: 1999/02/03 17:08:25 $
* $Revision: 1.4 $
* $Date: 1999/03/01 14:46:42 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -19,6 +19,8 @@
#include "Assembler.h"
#include "link.h"
#include "Rts.h" /* IF_DEBUG */
#include "RtsFlags.h"
/* --------------------------------------------------------------------------
* Local function prototypes:
......@@ -40,7 +42,7 @@ static Void cgExpr ( AsmBCO bco, AsmSp root, StgExpr e );
static AsmBCO cgAlts ( AsmSp root, AsmSp sp, List alts );
static void testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e );
static void cgPrimAlt ( AsmBCO bco, AsmSp root, List vs, StgExpr e );
//static void cgPrimAlt ( AsmBCO bco, AsmSp root, List vs, StgExpr e );
static AsmBCO cgLambda ( StgExpr e );
static AsmBCO cgRhs ( StgRhs rhs );
static void beginTop ( StgVar v );
......@@ -103,7 +105,11 @@ static void cgBind( AsmBCO bco, StgVar v )
static Void pushVar( AsmBCO bco, StgVar v )
{
Cell info = stgVarInfo(v);
assert(isStgVar(v));
// if (!isStgVar(v)) {
//printf("\n\nprefail\n");
//print(v,1000);
assert(isStgVar(v));
//}
if (isPtr(info)) {
asmClosure(bco,ptrOf(info));
} else if (isInt(info)) {
......@@ -169,14 +175,14 @@ static Void pushAtom( AsmBCO bco, StgAtom e )
static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
{
AsmBCO bco = asmBeginContinuation(sp);
AsmBCO bco = asmBeginContinuation(sp,alts);
/* ppStgAlts(alts); */
for(; nonNull(alts); alts=tl(alts)) {
StgCaseAlt alt = hd(alts);
StgPat pat = stgCaseAltPat(alt);
StgExpr body = stgCaseAltBody(alt);
if (isDefaultPat(pat)) {
AsmSp begin = asmBeginAlt(bco);
//AsmSp begin = asmBeginAlt(bco);
cgBind(bco,pat);
cgExpr(bco,root,body);
asmEndContinuation(bco);
......@@ -191,7 +197,7 @@ static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
} else {
asmBeginUnpack(bco);
map1Proc(cgBind,bco,rev(vs));
map1Proc(cgBind,bco,reverse(vs));
asmEndUnpack(bco);
}
cgExpr(bco,root,body);
......@@ -223,19 +229,22 @@ static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
}
}
#if 0 /* appears to be unused */
static void cgPrimAlt( AsmBCO bco, AsmSp root, List vs, StgExpr e )
{
assert(0); /* ToDo: test for patterns */
map1Proc(cgBind,bco,vs); /* ToDo: are these in right order? */
cgExpr(bco,root,e);
}
#endif
static AsmBCO cgLambda( StgExpr e )
{
AsmBCO bco = asmBeginBCO();
AsmBCO bco = asmBeginBCO(e);
AsmSp root = asmBeginArgCheck(bco);
map1Proc(cgBind,bco,rev(stgLambdaArgs(e)));
map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
asmEndArgCheck(bco,root);
/* ppStgExpr(e); */
......@@ -247,7 +256,7 @@ static AsmBCO cgLambda( StgExpr e )
static AsmBCO cgRhs( StgRhs rhs )
{
AsmBCO bco = asmBeginBCO( );
AsmBCO bco = asmBeginBCO(rhs );
AsmSp root = asmBeginArgCheck(bco);
asmEndArgCheck(bco,root);
......@@ -259,8 +268,10 @@ static AsmBCO cgRhs( StgRhs rhs )
return bco;
}
static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
{
//printf("cgExpr:");ppStgExpr(e);printf("\n");
switch (whatIs(e)) {
case LETREC:
{
......@@ -294,7 +305,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
/* No need to use return address or to Slide */
AsmSp beginPrim = asmBeginPrim(bco);
map1Proc(pushAtom,bco,rev(stgPrimArgs(scrut)));
map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
for(; nonNull(alts); alts=tl(alts)) {
......@@ -302,7 +313,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
List pats = stgPrimAltPats(alt);
StgExpr body = stgPrimAltBody(alt);
AsmSp altBegin = asmBeginAlt(bco);
map1Proc(cgBind,bco,rev(pats));
map1Proc(cgBind,bco,reverse(pats));
testPrimPats(bco,root,pats,body);
asmEndAlt(bco,altBegin);
}
......@@ -341,7 +352,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
case STGAPP: /* Tail call */
{
AsmSp env = asmBeginEnter(bco);
map1Proc(pushAtom,bco,rev(stgAppArgs(e)));
map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
pushAtom(bco,stgAppFun(e));
asmEndEnter(bco,env,root);
break;
......@@ -376,7 +387,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
case STGPRIM: /* Tail call again */
{
AsmSp beginPrim = asmBeginPrim(bco);
map1Proc(pushAtom,bco,rev(stgPrimArgs(e)));
map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
/* map1Proc(cgBind,bco,rs_vars); */
assert(0); /* asmReturn_retty(); */
......@@ -388,6 +399,9 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
}
}
void* itblNames[1000];
int nItblNames = 0;
/* allocate space for top level variable
* any change requires a corresponding change in 'build'.
*/
......@@ -404,7 +418,23 @@ static Void alloc( AsmBCO bco, StgVar v )
pushAtom(bco,hd(args));
setPos(v,asmBox(bco,boxingConRep(con)));
} else {
setPos(v,asmAllocCONSTR(bco,stgConInfo(con)));
void* vv = stgConInfo(con);
assert (nItblNames < (1000-2));
if (isName(con)) {
itblNames[nItblNames++] = vv;
itblNames[nItblNames++] = textToStr(name(con).text);
} else
if (isTuple(con)) {
char* cc = malloc(10);
assert(cc);
sprintf(cc, "Tuple%d", tupleOf(con) );
itblNames[nItblNames++] = vv;
itblNames[nItblNames++] = cc;
} else
assert ( /* cant identify constructor name */ 0 );
setPos(v,asmAllocCONSTR(bco, vv));
}
break;
}
......@@ -424,6 +454,7 @@ static Void build( AsmBCO bco, StgVar v )
{
StgRhs rhs = stgVarBody(v);
assert(isStgVar(v));
switch (whatIs(rhs)) {
case STGCON:
{
......@@ -433,7 +464,7 @@ static Void build( AsmBCO bco, StgVar v )
doNothing(); /* already done in alloc */
} else {
AsmSp start = asmBeginPack(bco);
map1Proc(pushAtom,bco,rev(args));
map1Proc(pushAtom,bco,reverse(args));
asmEndPack(bco,getPos(v),start,stgConInfo(con));
}
return;
......@@ -449,12 +480,12 @@ static Void build( AsmBCO bco, StgVar v )
&& whatIs(stgVarBody(fun)) == LAMBDA
&& length(stgLambdaArgs(stgVarBody(fun))) > length(args)) {
AsmSp start = asmBeginMkPAP(bco);
map1Proc(pushAtom,bco,rev(args));
map1Proc(pushAtom,bco,reverse(args));
pushAtom(bco,fun);
asmEndMkPAP(bco,getPos(v),start); /* optimisation */
} else {
AsmSp start = asmBeginMkAP(bco);
map1Proc(pushAtom,bco,rev(args));
map1Proc(pushAtom,bco,reverse(args));
pushAtom(bco,fun);
asmEndMkAP(bco,getPos(v),start);
}
......@@ -498,6 +529,7 @@ static Void build( AsmBCO bco, StgVar v )
* for each top level variable - this should be simpler!
* ------------------------------------------------------------------------*/
#if 0 /* appears to be unused */
static void cgAddVar( AsmObject obj, StgAtom v )
{
if (isName(v)) {
......@@ -506,6 +538,8 @@ static void cgAddVar( AsmObject obj, StgAtom v )
assert(isStgVar(v));
asmAddPtr(obj,getObj(v));
}
#endif
/* allocate AsmObject for top level variables
* any change requires a corresponding change in endTop
......@@ -518,12 +552,12 @@ static void beginTop( StgVar v )
switch (whatIs(rhs)) {
case STGCON:
{
List as = stgConArgs(rhs);
//List as = stgConArgs(rhs);
setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
break;
}
case LAMBDA:
setObj(v,asmBeginBCO());
setObj(v,asmBeginBCO(rhs));
break;
default:
setObj(v,asmBeginCAF());
......@@ -534,7 +568,7 @@ static void beginTop( StgVar v )
static void endTop( StgVar v )
{
StgRhs rhs = stgVarBody(v);
ppStgRhs(rhs);
//ppStgRhs(rhs);
switch (whatIs(rhs)) {
case STGCON:
{
......@@ -573,7 +607,7 @@ static void endTop( StgVar v )
/* ToDo: merge this code with cgLambda */
AsmBCO bco = (AsmBCO)getObj(v);
AsmSp root = asmBeginArgCheck(bco);
map1Proc(cgBind,bco,rev(stgLambdaArgs(rhs)));
map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
asmEndArgCheck(bco,root);
cgExpr(bco,root,stgLambdaBody(rhs));
......@@ -592,16 +626,48 @@ static void endTop( StgVar v )
static void zap( StgVar v )
{
stgVarBody(v) = NIL;
// ToDo: reinstate
// stgVarBody(v) = NIL;
}
/* external entry point */
Void cgBinds( List binds )
{
List b;
int i;
//if (lastModule() != modulePrelude) {
// printf("\n\ncgBinds: before ll\n\n" );
// for (b=binds; nonNull(b); b=tl(b)) {
// printStg ( stdout, hd(b) ); printf("\n\n");
// }
//}
binds = liftBinds(binds);
mapProc(beginTop,binds);
mapProc(endTop,binds);
mapProc(zap,binds);
//if (lastModule() != modulePrelude) {
// printf("\n\ncgBinds: after ll\n\n" );
// for (b=binds; nonNull(b); b=tl(b)) {
// printStg ( stdout, hd(b) ); printf("\n\n");
// }
//}
//mapProc(beginTop,binds);
for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
//printf("beginTop %d\n", i);
beginTop(hd(b));
}
//mapProc(endTop,binds);
for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
endTop(hd(b));
//if (lastModule() != modulePrelude) {
// printStg ( stdout, hd(b) ); printf("\n\n");
//}
}
//mapProc(zap,binds);
}
/* --------------------------------------------------------------------------
......
......@@ -10,8 +10,8 @@
* in the distribution for details.
*
* $RCSfile: compiler.c,v $
* $Revision: 1.3 $
* $Date: 1999/02/03 17:08:26 $
* $Revision: 1.4 $
* $Date: 1999/03/01 14:46:43 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -24,8 +24,6 @@
#include "Schedule.h"
#include "link.h"
/*#define DEBUG_SHOWSC*/ /* Must also be set in output.c */
Addr inputCode; /* Addr of compiled code for expr */
static Name currentName; /* Top level name being processed */
#if DEBUG_CODE
......@@ -80,26 +78,9 @@ static Bool local isExtDiscr Args((Cell));
static Bool local eqExtDiscr Args((Cell,Cell));
#endif
static Cell local lift Args((Int,List,Cell));
static Void local liftPair Args((Int,List,Pair));
static Void local liftTriple Args((Int,List,Triple));
static Void local liftAlt Args((Int,List,Cell));
static Void local liftNumcase Args((Int,List,Triple));
static Cell local liftVar Args((List,Cell));
static Cell local liftLetrec Args((Int,List,Cell));
static Void local liftFundef Args((Int,List,Triple));
static Void local solve Args((List));
static Cell local preComp Args((Cell));
static Cell local preCompPair Args((Pair));
static Cell local preCompTriple Args((Triple));
static Void local preCompCase Args((Pair));
static Cell local preCompOffset Args((Int));
static Void local compileGlobalFunction Args((Pair));
static Void local compileGenFunction Args((Name));
static Name local compileSelFunction Args((Pair));
static Void local newGlobalFunction Args((Name,Int,List,Int,Cell));
/* --------------------------------------------------------------------------
* Translation: Convert input expressions into a less complex language
......@@ -1487,14 +1468,15 @@ Void evalExp() { /* compile and run input expression */
* get inserted in the symbol table but never get removed.
*/
Name n = newName(inventText(),NIL);
Cell e;
StgVar v = mkStgVar(NIL,NIL);
name(n).stgVar = v;
compiler(RESET);
stgDefn(n,0,pmcTerm(0,NIL,translate(inputExpr)));
e = pmcTerm(0,NIL,translate(inputExpr));
stgDefn(n,0,e); //ppStg(name(n).stgVar);
inputExpr = NIL;
stgCGBinds(addGlobals(singleton(v)));
/* Run thread (and any other runnable threads) */
/* Re-initialise the scheduler - ToDo: do I need this? */
......@@ -1535,7 +1517,7 @@ static List local addStgVar( List binds, Pair bind )
StgVar nv = mkStgVar(NIL,NIL);
Text t = textOf(fst(bind));
Name n = findName(t);
//printf ( "addStgVar %s\n", textToStr(t));
if (isNull(n)) { /* Lookup global name - the only way*/
n = newName(t,NIL); /* this (should be able to happen) */
} /* is with new global var introduced*/
......@@ -1548,8 +1530,17 @@ static List local addStgVar( List binds, Pair bind )
Void compileDefns() { /* compile script definitions */
Target t = length(valDefns) + length(genDefns) + length(selDefns);
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) {
//printf ( "------ Adding cons (:) [] () \n" );
implementCfun ( nameCons, NIL );
implementCfun ( nameNil, NIL );
implementCfun ( nameUnit, NIL );
}
{
List vss;
List vs;
......@@ -1593,6 +1584,7 @@ Void compileDefns() { /* compile script definitions */
binds = addGlobals(binds);
#if USE_HUGS_OPTIMIZER
mapProc(optimiseBind,binds);
#error optimiser
#endif
stgCGBinds(binds);
......@@ -1605,6 +1597,20 @@ Pair bind; {
List defs = snd(bind);
Int arity = length(fst(hd(defs)));
assert(isName(n));
//{ Cell cc;
// printf ( "compileGlobalFunction %s\n", textToStr(name(n).text));
// cc = defs;
// while (nonNull(cc)) {
// printExp(stdout, fst(hd(cc)));
// printf ( "\n = " );
// printExp(stdout, snd(hd(cc)));
// printf( "\n" );
// cc = tl(cc);
// }
// printf ( "\n\n\n" );
//}
compiler(RESET);
stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
}
......@@ -1614,6 +1620,19 @@ Name n; { /* generated function */
List defs = name(n).defn;
Int arity = length(fst(hd(defs)));
//{ Cell cc;
// printf ( "compileGenFunction %s\n", textToStr(name(n).text));
// cc = defs;
// while (nonNull(cc)) {
// printExp(stdout, fst(hd(cc)));
// printf ( "\n = " );
// printExp(stdout, snd(hd(cc)));
// printf( "\n" );
// cc = tl(cc);
// }
// printf ( "\n\n\n" );
//}
compiler(RESET);
currentName = n;
mapProc(transAlt,defs);
......@@ -1634,32 +1653,6 @@ Pair p; { /* Should be merged with genDefns, */
}
#if 0
I think this is 98-specific.
static Void local newGlobalFunction(n,arity,fvs,co,e)
Name n;
Int arity;
List fvs;
Int co;
Cell e; {
#ifdef DEBUG_SHOWSC
extern Void printSc Args((FILE*, Text, Int, Cell));
#endif
extraVars = fvs;
numExtraVars = length(extraVars);
localOffset = co;
localArity = arity;
name(n).arity = arity+numExtraVars;
e = preComp(e);
#ifdef DEBUG_SHOWSC
if (debugCode) {
printSc(stdout,name(n).text,name(n).arity,e);
}
#endif
name(n).code = codeGen(n,name(n).arity,e);
}
#endif
/* --------------------------------------------------------------------------
* Compiler control:
* ------------------------------------------------------------------------*/
......
......@@ -7,8 +7,8 @@
* in the distribution for details.
*
* $RCSfile: connect.h,v $
* $Revision: 1.3 $
* $Date: 1999/02/03 17:08:27 $