-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Code generator
*
- * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
- * All rights reserved. See NOTICE for details and conditions of use etc...
- * Hugs version 1.4, December 1997
+ * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
+ * Yale Haskell Group, and the Oregon Graduate Institute of Science and
+ * Technology, 1994-1999, All rights reserved. It is distributed as
+ * free software under the license in the file "License", which is
+ * included in the distribution.
*
* $RCSfile: codegen.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:21:59 $
+ * $Revision: 1.21 $
+ * $Date: 2000/04/05 10:25:08 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
#include "connect.h"
#include "errors.h"
-#include "stg.h"
+
#include "Assembler.h"
-#include "lift.h"
-#include "link.h"
-#include "pp.h"
-#include "codegen.h"
+#include "Rts.h" /* IF_DEBUG */
+#include "RtsFlags.h"
+
+/*#define DEBUG_CODEGEN*/
/* --------------------------------------------------------------------------
* Local function prototypes:
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 AsmBCO cgLambda ( StgExpr e );
static AsmBCO cgRhs ( StgRhs rhs );
static void beginTop ( StgVar v );
static void endTop ( StgVar v );
+static StgVar currentTop;
+
/* --------------------------------------------------------------------------
*
* ------------------------------------------------------------------------*/
+static Cell cptrFromName ( Name n )
+{
+ char buf[1000];
+ void* p;
+ Module m = name(n).mod;
+ Text mt = module(m).text;
+ sprintf(buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_closure"),
+ textToStr(mt),
+ textToStr( enZcodeThenFindText (
+ textToStr (name(n).text) ) ) );
+ p = lookupOTabName ( m, buf );
+ if (!p) {
+ ERRMSG(0) "Can't find object symbol %s", buf
+ EEND;
+ }
+ return mkCPtr(p);
+}
+
static Bool varHasClosure( StgVar v )
{
return asmObjectHasClosure((AsmClosure*)ptrOf(stgVarInfo(v)));
{
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 (tabName[nm-NAME_BASE_ADDR].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));
static Void pushVar( AsmBCO bco, StgVar v )
{
- Cell info = stgVarInfo(v);
- assert(isStgVar(v));
- if (isPtr(info)) {
- asmClosure(bco,ptrOf(info));
- } else if (isInt(info)) {
- asmVar(bco,intOf(info),repOf(v));
+ Cell info;
+#if 0
+printf ( "pushVar: %d ", v ); fflush(stdout);
+print(v,10);printf("\n");
+#endif
+ assert(isStgVar(v) || isCPtr(v));
+
+ if (isCPtr(v)) {
+ asmGHCClosure(bco, cptrOf(v));
} else {
- internal("pushVar");
- }
+ info = stgVarInfo(v);
+ if (isPtr(info)) {
+ asmClosure(bco,ptrOf(info));
+ } else if (isInt(info)) {
+ asmVar(bco,intOf(info),repOf(v));
+ } else {
+ internal("pushVar");
+ }
+ }
}
static Void pushAtom( AsmBCO bco, StgAtom e )
{
+#if 0
+printf ( "pushAtom: %d ", e ); fflush(stdout);
+print(e,10);printf("\n");
+#endif
switch (whatIs(e)) {
case STGVAR:
pushVar(bco,e);
break;
case NAME:
- pushVar(bco,name(e).stgVar);
+ if (nonNull(name(e).stgVar)) {
+ pushVar(bco,name(e).stgVar);
+ } else {
+ Cell /*CPtr*/ addr = cptrFromName(e);
+# if DEBUG_CODEGEN
+ fprintf ( stderr, "nativeAtom: name %s\n",
+ nameFromOPtr(cptrOf(addr)) );
+# endif
+ pushVar(bco,addr);
+ }
break;
case CHARCELL:
asmConstChar(bco,charOf(e));
case INTCELL:
asmConstInt(bco,intOf(e));
break;
-#if BIGNUM_IS_INTEGER
case BIGCELL:
asmConstInteger(bco,bignumToString(e));
break;
-#elif BIGNUM_IS_INT64
- case BIGCELL:
- asmConstInt64(bco,bignumOf(e));
- break;
-#else
-#warning What is BIGNUM?
-#endif
case FLOATCELL:
-#if 0
- asmConstFloat(bco,e); /* ToDo: support both float and double! */
-#else
asmConstDouble(bco,floatOf(e));
-#endif
- break;
-#if DOUBLES
- case DOUBLECELL:
- asmConstDouble(bco,doubleOf(e));
break;
-#endif
case STRCELL:
#if USE_ADDR_FOR_STRINGS
asmConstAddr(bco,textToStr(textOf(e)));
asmClosure(bco,asmStringObj(textToStr(textOf(e))));
#endif
break;
+ case CPTRCELL:
+ asmGHCClosure(bco,cptrOf(e));
+ break;
case PTRCELL:
asmConstAddr(bco,ptrOf(e));
break;
default:
- fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
+ fprintf(stderr,"\nYoiks1: "); printExp(stderr,e);
internal("pushAtom");
}
}
static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
{
- AsmBCO bco = asmBeginContinuation(sp);
- /* ppStgAlts(alts); */
+#ifdef CRUDE_PROFILING
+ AsmBCO bco = asmBeginContinuation(sp, currentTop + 1000000000);
+#else
+ AsmBCO bco = asmBeginContinuation(sp, alts);
+#endif
+ Bool omit_test
+ = length(alts) == 2 &&
+ isDefaultAlt(hd(tl(alts))) &&
+ !isDefaultAlt(hd(alts));
+ if (omit_test) {
+ /* refine the condition */
+ Name con;
+ Tycon t;
+ omit_test = FALSE;
+ con = stgCaseAltCon(hd(alts));
+
+ /* special case: dictionary constructors */
+ if (isName(con) && strncmp(":D",textToStr(name(con).text),2)==0) {
+ omit_test = TRUE;
+ goto xyzzy;
+ }
+ /* special case: Tuples */
+ if (isTuple(con) || (isName(con) && con==nameUnit)) {
+ omit_test = TRUE;
+ goto xyzzy;
+ }
+
+ t = name(con).parent;
+ if (tycon(t).what == DATATYPE) {
+ if (length(tycon(t).defn) == 1) omit_test = TRUE;
+ }
+ }
+
+ xyzzy:
+
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);
- cgBind(bco,pat);
- cgExpr(bco,root,body);
+ if (isDefaultAlt(alt)) {
+ cgBind(bco,stgDefaultVar(alt));
+ cgExpr(bco,root,stgDefaultBody(alt));
asmEndContinuation(bco);
return bco; /* ignore any further alternatives */
} else {
- StgDiscr con = stgPatDiscr(pat);
- List vs = stgPatVars(pat);
+ StgDiscr con = stgCaseAltCon(alt);
+ List vs = stgCaseAltVars(alt);
AsmSp begin = asmBeginAlt(bco);
- AsmPc fix = asmTest(bco,stgDiscrTag(con)); /* ToDo: omit in single constructor types! */
- cgBind(bco,pat);
+ AsmPc fix;
+ if (omit_test) fix=-1; else fix = asmTest(bco,stgDiscrTag(con));
+
+ asmBind(bco,PTR_REP); /* Adjust simulated sp to acct for return value */
if (isBoxingCon(con)) {
setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
} else {
map1Proc(cgBind,bco,reverse(vs));
asmEndUnpack(bco);
}
- cgExpr(bco,root,body);
+ cgExpr(bco,root,stgCaseAltBody(alt));
asmEndAlt(bco,begin);
- asmFixBranch(bco,fix);
+ if (fix != -1) asmFixBranch(bco,fix);
}
}
/* if we got this far and didn't match, panic! */
if (isNull(pats)) {
cgExpr(bco,root,e);
} else {
- StgPrimPat pat = hd(pats);
+ StgVar pat = hd(pats);
if (isInt(stgVarBody(pat))) {
/* asmTestInt leaves stack unchanged - so no need to adjust it */
AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
}
}
-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);
-}
static AsmBCO cgLambda( StgExpr e )
{
- AsmBCO bco = asmBeginBCO();
+ AsmBCO bco = asmBeginBCO(e);
AsmSp root = asmBeginArgCheck(bco);
map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
static AsmBCO cgRhs( StgRhs rhs )
{
- AsmBCO bco = asmBeginBCO( );
+ AsmBCO bco = asmBeginBCO(rhs );
AsmSp root = asmBeginArgCheck(bco);
asmEndArgCheck(bco,root);
return bco;
}
+
static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
{
+#if 0
+ printf("cgExpr:");ppStgExpr(e);printf("\n");
+#endif
switch (whatIs(e)) {
case LETREC:
{
for(; nonNull(alts); alts=tl(alts)) {
StgPrimAlt alt = hd(alts);
- List pats = stgPrimAltPats(alt);
+ List pats = stgPrimAltVars(alt);
StgExpr body = stgPrimAltBody(alt);
AsmSp altBegin = asmBeginAlt(bco);
map1Proc(cgBind,bco,reverse(pats));
for(; nonNull(alts); alts=tl(alts)) {
StgPrimAlt alt = hd(alts);
- List pats = stgPrimAltPats(alt);
+ List pats = stgPrimAltVars(alt);
StgExpr body = stgPrimAltBody(alt);
AsmSp altBegin = asmBeginAlt(bco);
map1Proc(cgBind,bco,pats);
} else {
/* ToDo: implement this code... */
assert(0);
- /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e), stgPrimCaseBody(e))); */
+ /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e),
+ stgPrimCaseBody(e))); */
/* cgExpr( bco,root,scrut ); */
}
break;
case NAME: /* Tail call (with no args) */
{
AsmSp env = asmBeginEnter(bco);
- pushVar(bco,name(e).stgVar);
+ /* JRS 000112: next line used to be: pushVar(bco,name(e).stgVar); */
+ pushAtom(bco,e);
asmEndEnter(bco,env,root);
break;
}
break;
}
default:
- fprintf(stderr,"\nYoiks: "); printExp(stderr,e);
+ fprintf(stderr,"\nYoiks2: "); printExp(stderr,e);
internal("cgExpr");
}
}
+#define M_ITBLNAMES 35000
+
+void* itblNames[M_ITBLNAMES];
+int nItblNames = 0;
+
/* allocate space for top level variable
* any change requires a corresponding change in 'build'.
*/
{
StgRhs rhs = stgVarBody(v);
assert(isStgVar(v));
+#if 0
+ printf("alloc: ");ppStgExpr(v);
+#endif
switch (whatIs(rhs)) {
case STGCON:
{
pushAtom(bco,hd(args));
setPos(v,asmBox(bco,boxingConRep(con)));
} else {
- setPos(v,asmAllocCONSTR(bco,stgConInfo(con)));
+
+ void* vv = stgConInfo(con);
+ if (!(nItblNames < (M_ITBLNAMES-2)))
+ internal("alloc -- M_ITBLNAMES too small");
+ if (isName(con)) {
+ itblNames[nItblNames++] = vv;
+ itblNames[nItblNames++] = textToStr(name(con).text);
+ } else
+ if (isTuple(con)) {
+ itblNames[nItblNames++] = vv;
+ itblNames[nItblNames++] = textToStr(ghcTupleText(con));
+ } else
+ assert ( /* cant identify constructor name */ 0 );
+ setPos(v,asmAllocCONSTR(bco, vv));
}
break;
}
- case STGAPP:
- setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs))));
+ case STGAPP: {
+ Int totSizeW = 0;
+ List bs = stgAppArgs(rhs);
+ for (; nonNull(bs); bs=tl(bs)) {
+ if (isName(hd(bs))) {
+ totSizeW += 1;
+ } else {
+ ASSERT(whatIs(hd(bs))==STGVAR);
+ totSizeW += asmRepSizeW( charOf(stgVarRep(hd(bs))) );
+ }
+ }
+ setPos(v,asmAllocAP(bco,totSizeW));
+ //ORIGINALLY:setPos(v,asmAllocAP(bco,length(stgAppArgs(rhs))));
break;
+ }
case LAMBDA: /* optimisation */
setObj(v,cgLambda(rhs));
break;
{
StgRhs rhs = stgVarBody(v);
assert(isStgVar(v));
+ //ppStg(v);
switch (whatIs(rhs)) {
case STGCON:
{
}
case STGAPP:
{
+ Bool itsaPAP;
StgVar fun = stgAppFun(rhs);
+ StgVar fun0 = fun;
List args = stgAppArgs(rhs);
if (isName(fun)) {
- fun = name(fun).stgVar;
+ if (nonNull(name(fun).stgVar))
+ fun = name(fun).stgVar; else
+ fun = cptrFromName(fun);
+ }
+
+ if (isCPtr(fun)) {
+ assert(isName(fun0));
+ itsaPAP = name(fun0).arity > length(args);
+# if DEBUG_CODEGEN
+ fprintf ( stderr, "nativeCall: name %s, arity %d, args %d\n",
+ nameFromOPtr(cptrOf(fun)), name(fun0).arity,
+ length(args) );
+# endif
+ } else {
+ itsaPAP = FALSE;
+ if (nonNull(stgVarBody(fun))
+ && whatIs(stgVarBody(fun)) == LAMBDA
+ && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
+ )
+ itsaPAP = TRUE;
}
- if (nonNull(stgVarBody(fun))
- && whatIs(stgVarBody(fun)) == LAMBDA
- && length(stgLambdaArgs(stgVarBody(fun))) > length(args)) {
+
+ if (itsaPAP) {
AsmSp start = asmBeginMkPAP(bco);
map1Proc(pushAtom,bco,reverse(args));
pushAtom(bco,fun);
* of this except "let x = x in ..."
*/
case NAME:
- rhs = name(rhs).stgVar;
+ if (nonNull(name(rhs).stgVar))
+ rhs = name(rhs).stgVar; else
+ rhs = cptrFromName(rhs);
+ /* fall thru */
case STGVAR:
{
AsmSp start = asmBeginMkAP(bco);
* 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)) {
assert(isStgVar(v));
asmAddPtr(obj,getObj(v));
}
+#endif
+
/* allocate AsmObject for top level variables
* any change requires a corresponding change in endTop
{
StgRhs rhs;
assert(isStgVar(v));
+ currentTop = v;
rhs = stgVarBody(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());
+#ifdef CRUDE_PROFILING
+ setObj(v,asmBeginBCO(currentTop));
+#else
+ setObj(v,asmBeginBCO(rhs));
+#endif
break;
default:
setObj(v,asmBeginCAF());
static void endTop( StgVar v )
{
StgRhs rhs = stgVarBody(v);
- ppStgRhs(rhs);
+ currentTop = v;
switch (whatIs(rhs)) {
case STGCON:
{
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 0
+ 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");
+ }
+ }
+#endif
+
binds = liftBinds(binds);
- mapProc(beginTop,binds);
- mapProc(endTop,binds);
- mapProc(zap,binds);
+
+#if 0
+ 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");
+ }
+ }
+#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"); */
+ endTop(hd(b));
+ }
+
+ /* 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)));
+ }
+ }
}
/* --------------------------------------------------------------------------
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);
}
projects / ghc-hetmet.git / blobdiff