* Hugs version 1.4, December 1997
*
* $RCSfile: translate.c,v $
- * $Revision: 1.5 $
- * $Date: 1999/03/01 14:46:57 $
+ * $Revision: 1.7 $
+ * $Date: 1999/04/27 10:07:08 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "dynamic.h"
#include "Assembler.h"
+
/* ---------------------------------------------------------------- */
static StgVar local stgOffset Args((Offset,List));
static StgVar local stgText Args((Text,List));
-static StgRhs local stgRhs Args((Cell,Int,List));
+static StgRhs local stgRhs Args((Cell,Int,List,StgExpr));
static StgCaseAlt local stgCaseAlt Args((Cell,Int,List,StgExpr));
static StgExpr local stgExpr Args((Cell,Int,List,StgExpr));
/* ---------------------------------------------------------------- */
-static StgRhs local stgRhs(e,co,sc)
+static StgRhs local stgRhs(e,co,sc,failExpr)
Cell e;
Int co;
-List sc; {
+List sc;
+StgExpr failExpr; {
switch (whatIs(e)) {
/* Identifiers */
case INTCELL:
return mkStgCon(nameMkI,singleton(e));
case BIGCELL:
- return mkStgCon(nameMkBignum,singleton(e));
+ return mkStgCon(nameMkInteger,singleton(e));
case FLOATCELL:
return mkStgCon(nameMkD,singleton(e));
case STRCELL:
case NIL:
internal("stgRhs2");
default:
- return stgExpr(e,co,sc,namePMFail);
+ return stgExpr(e,co,sc,failExpr/*namePMFail*/);
}
}
StgVar dIntegral = NIL;
/* bind dictionary */
- dIntegral = stgRhs(dictIntegral,co,sc);
+ dIntegral = stgRhs(dictIntegral,co,sc,namePMFail);
if (!isAtomic(dIntegral)) { /* wasn't atomic */
dIntegral = mkStgVar(dIntegral,NIL);
binds = cons(dIntegral,binds);
}
/* box number */
- n = mkStgVar(mkStgCon(nameMkBignum,singleton(n)),NIL);
+ n = mkStgVar(mkStgCon(nameMkInteger,singleton(n)),NIL);
binds = cons(n,binds);
/* coerce number to right type (using Integral dict) */
//StgExpr m = NIL;
Name box
= h == nameFromInt ? nameMkI
- : h == nameFromInteger ? nameMkBignum
+ : h == nameFromInteger ? nameMkInteger
: nameMkD;
Name testFun
= h == nameFromInt ? namePmInt
altsc = cons(pair(mkOffset(co+i),nv),altsc);
}
/* bind dictionary */
- d = stgRhs(dict,co,sc);
+ d = stgRhs(dict,co,sc,namePMFail);
if (!isAtomic(d)) { /* wasn't atomic */
d = mkStgVar(d,NIL);
binds = cons(d,binds);
for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
Cell rhs = hd(bs);
Cell nv = hd(vs);
- stgVarBody(nv) = stgRhs(rhs,co,sc);
+ stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail);
}
- return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc));
+ return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
}
default: /* convert to an StgApp or StgVar plus some bindings */
{
/* Arguments must be StgAtoms */
for(as=args; nonNull(as); as=tl(as)) {
- StgRhs a = stgRhs(hd(as),co,sc);
+ StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
#if 1 /* optional flattening of let bindings */
if (whatIs(a) == LETREC) {
binds = appendOnto(stgLetBinds(a),binds);
}
/* Function must be StgVar or Name */
- e = stgRhs(e,co,sc);
+ e = stgRhs(e,co,sc,namePMFail);
if (!isStgVar(e) && !isName(e)) {
e = mkStgVar(e,NIL);
binds = cons(e,binds);
#if 0 /* apparently not used */
static Void ppExp( Name n, Int arity, Cell e )
{
-#if DEBUG_CODE
- if (debugCode) {
+ if (1 || debugCode) {
Int i;
printf("%s", textToStr(name(n).text));
for (i = arity; i > 0; i--) {
printExp(stdout,e);
printf("\n");
}
-#endif
}
#endif
{
List vs = NIL;
List sc = NIL;
- Int i;
- // ppExp(n,arity,e);
+ Int i, s;
for (i = 1; i <= arity; ++i) {
Cell nv = mkStgVar(NIL,NIL);
vs = cons(nv,vs);
}
stgVarBody(name(n).stgVar)
= makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
- //ppStg(name(n).stgVar);
- //printStg(stdout, name(n).stgVar);
-}
-
-static StgExpr forceArgs( List is, List args, StgExpr e );
-
-/* force the args numbered in is */
-static StgExpr forceArgs( List is, List args, StgExpr e )
-{
- for(; nonNull(is); is=tl(is)) {
- e = mkSeq(nth(intOf(hd(is))-1,args),e);
+ s = stgSize(stgVarBody(name(n).stgVar));
+ name(n).stgSize = s;
+ if (s <= SMALL_INLINE_SIZE && !name(n).inlineMe) {
+ name(n).inlineMe = TRUE;
}
- return e;
}
-
Void implementCfun(c,scs) /* Build implementation for constr */
Name c; /* fun c. scs lists integers (1..)*/
List scs; { /* in incr order of strict comps. */
Int a = name(c).arity;
- //printf ( "implementCfun %s\n", textToStr(name(c).text) );
- if (name(c).arity > 0) {
- List args = makeArgs(a);
- StgVar tv = mkStgVar(mkStgCon(c,args),NIL);
- StgExpr e1 = mkStgLet(singleton(tv),tv);
- StgExpr e2 = forceArgs(scs,args,e1);
- StgVar v = mkStgVar(mkStgLambda(args,e2),NIL);
+
+ if (a > 0) {
+ StgVar vcurr, e1, v, vsi;
+ List args = makeArgs(a);
+ StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
+ List binds = singleton(v0);
+
+ vcurr = v0;
+ for (; nonNull(scs); scs=tl(scs)) {
+ vsi = nth(intOf(hd(scs))-1,args);
+ vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
+ binds = cons(vcurr,binds);
+ }
+ binds = rev(binds);
+ e1 = mkStgLet(binds,vcurr);
+ v = mkStgVar(mkStgLambda(args,e1),NIL);
name(c).stgVar = v;
} else {
StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
name(c).stgVar = v;
}
- /* hack to make it print out */
+ name(c).inlineMe = TRUE;
+ name(c).stgSize = stgSize(stgVarBody(name(c).stgVar));
stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
+ //printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n");
}
/* --------------------------------------------------------------------------
{
if (t == typeChar) return mkChar(CHAR_REP);
else if (t == typeInt) return mkChar(INT_REP);
-#ifdef PROVIDE_INT64
- else if (t == typeInt64) return mkChar(INT64_REP);
-#endif
-#ifdef PROVIDE_INTEGER
else if (t == typeInteger)return mkChar(INTEGER_REP);
-#endif
-#ifdef PROVIDE_WORD
else if (t == typeWord) return mkChar(WORD_REP);
-#endif
-#ifdef PROVIDE_ADDR
else if (t == typeAddr) return mkChar(ADDR_REP);
-#endif
else if (t == typeFloat) return mkChar(FLOAT_REP);
else if (t == typeDouble) return mkChar(DOUBLE_REP);
#ifdef PROVIDE_FOREIGN
else if (t == typeForeign)return mkChar(FOREIGN_REP);
/* ToDo: argty only! */
#endif
-#ifdef PROVIDE_ARRAY
else if (t == typePrimByteArray) return mkChar(BARR_REP);
/* ToDo: argty only! */
else if (whatIs(t) == AP) {
if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
/* ToDo: argty only! */
}
-#endif
/* ToDo: decent line numbers! */
ERRMSG(0) "Illegal foreign type" ETHEN
ERRTEXT " \"" ETHEN ERRTYPE(t);
switch (c) {
case CHAR_REP: return nameMkC;
case INT_REP: return nameMkI;
-#ifdef PROVIDE_INT64
- case INT64_REP: return nameMkInt64;
-#endif
-#ifdef PROVIDE_INTEGER
case INTEGER_REP: return nameMkInteger;
-#endif
-#ifdef PROVIDE_WORD
case WORD_REP: return nameMkW;
-#endif
-#ifdef PROVIDE_ADDR
case ADDR_REP: return nameMkA;
-#endif
case FLOAT_REP: return nameMkF;
case DOUBLE_REP: return nameMkD;
-#ifdef PROVIDE_ARRAY
case ARR_REP: return nameMkPrimArray;
case BARR_REP: return nameMkPrimByteArray;
case REF_REP: return nameMkRef;
case MUTARR_REP: return nameMkPrimMutableArray;
case MUTBARR_REP: return nameMkPrimMutableByteArray;
-#endif
#ifdef PROVIDE_STABLE
case STABLE_REP: return nameMkStable;
#endif
const AsmPrim* p = name(n).primop;
StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
StgVar v = mkStgVar(rhs,NIL);
- name(n).stgVar = v;
+ name(n).stgVar = v;
+ name(n).stgSize = stgSize(stgVarBody(v));
+ name(n).inlineMe = TRUE;
stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
}
EEND;
}
//ppStg(v);
- name(n).defn = NIL;
- name(n).stgVar = v;
+ name(n).defn = NIL;
+ name(n).stgVar = v;
+ name(n).stgSize = stgSize(stgVarBody(v));
+ name(n).inlineMe = TRUE;
stgGlobals=cons(pair(n,v),stgGlobals);/*so it will get codegen'd */
}
}
internal("implementForeignExport: not implemented");
}
+// ToDo: figure out how to set inlineMe for these (non-Name) things
Void implementTuple(size)
Int size; {
if (size > 0) {
projects / ghc-hetmet.git / blobdiff