-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Translator: generates stg code from output of pattern matching
* compiler.
* Hugs version 1.4, December 1997
*
* $RCSfile: translate.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:47 $
+ * $Revision: 1.7 $
+ * $Date: 1999/04/27 10:07:08 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
#include "errors.h"
-#include "stg.h"
-#include "compiler.h"
-#include "pmc.h" /* for discrArity */
-#include "hugs.h" /* for debugCode */
-#include "type.h" /* for conToTagType, tagToConType */
#include "link.h"
-#include "pp.h"
#include "dynamic.h"
#include "Assembler.h"
-#include "translate.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));
/* ---------------------------------------------------------------- */
-/* Association list storing globals assigned to dictionaries, tuples, etc */
+/* Association list storing globals assigned to */
+/* dictionaries, tuples, etc */
List stgGlobals = NIL;
static StgVar local getSTGTupleVar Args((Cell));
/* ---------------------------------------------------------------- */
-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*/);
}
}
} else if (isChar(fst(hd(alts)))) {
Cell alt = hd(alts);
StgDiscr d = fst(alt);
- StgVar c = mkStgVar(mkStgCon(nameMkC,singleton(d)),NIL);
+ StgVar c = mkStgVar(
+ mkStgCon(nameMkC,singleton(d)),NIL);
StgExpr test = nameEqChar;
/* duplicates scrut but it should be atomic */
- return makeStgIf(makeStgLet(singleton(c),makeStgApp(test,doubleton(scrut,c))),
- stgExpr(snd(alt),co,sc,failExpr),
- stgExpr(ap(CASE,pair(fst(snd(e)),tl(alts))),co,sc,failExpr));
+ return makeStgIf(
+ makeStgLet(singleton(c),
+ makeStgApp(test,doubleton(scrut,c))),
+ stgExpr(snd(alt),co,sc,failExpr),
+ stgExpr(ap(CASE,pair(fst(snd(e)),
+ tl(alts))),co,sc,failExpr));
} else {
List as = NIL;
for(; nonNull(alts); alts=tl(alts)) {
as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
}
- return mkStgCase(scrut, revOnto(as, singleton(mkStgDefault(mkStgVar(NIL,NIL),failExpr))));
+ return mkStgCase(
+ scrut,
+ revOnto(
+ as,
+ singleton(mkStgDefault(mkStgVar(NIL,NIL),
+ failExpr))));
}
}
case NUMCASE:
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) */
- n = mkStgVar(mkStgApp(namePmFromInteger,doubleton(dIntegral,n)),NIL);
+ n = mkStgVar(mkStgApp(
+ namePmFromInteger,doubleton(dIntegral,n)),NIL);
binds = cons(n,binds);
++co;
- v = mkStgVar(mkStgApp(namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
- return mkStgLet(binds,
- makeStgIf(mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
- mkStgLet(singleton(v),
- stgExpr(r,
- co,
- cons(pair(mkOffset(co),v),sc),
- failExpr)),
- failExpr));
+ v = mkStgVar(mkStgApp(
+ namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
+ return
+ mkStgLet(
+ binds,
+ makeStgIf(
+ mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
+ mkStgLet(singleton(v),
+ stgExpr(r,
+ co,
+ cons(pair(mkOffset(co),v),sc),
+ failExpr)),
+ failExpr));
}
#endif /* NPLUSK */
Cell dict = arg(fun(discr));
StgExpr d = NIL;
List binds = NIL;
- StgExpr m = NIL;
+ //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);
n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
binds = cons(n,binds);
- return makeStgIf(mkStgLet(binds,
- mkStgApp(testFun,tripleton(d,n,scrut))),
- stgExpr(r,co+da,altsc,failExpr),
- failExpr);
+ return
+ makeStgIf(
+ mkStgLet(binds,
+ mkStgApp(testFun,tripleton(d,n,scrut))),
+ stgExpr(r,co+da,altsc,failExpr),
+ failExpr
+ );
}
}
#else /* ! OVERLOADED_CONSTANTS */
as = cons(v,as);
funsc = cons(pair(mkOffset(co+i),v),funsc);
}
- stgVarBody(nv) = mkStgLambda(as,stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
+ stgVarBody(nv)
+ = mkStgLambda(
+ as,
+ stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
}
/* transform expressions */
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 */
{
Cell nv = mkStgVar(NIL,NIL);
vs=cons(nv,vs);
}
- return mkStgCase(v,
- doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
- mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
+ return
+ mkStgCase(v,
+ doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
+ mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
}
/* 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);
}
}
-static Void ppExp( Name n, Int arity, Cell e );
+#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("BEFORE: %s", textToStr(name(n).text));
+ printf("%s", textToStr(name(n).text));
for (i = arity; i > 0; i--) {
printf(" o%d", i);
}
printExp(stdout,e);
printf("\n");
}
-#endif
}
+#endif
+
Void stgDefn( Name n, Int arity, Cell e )
{
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);
sc = cons(pair(mkOffset(i),nv),sc);
}
- stgVarBody(name(n).stgVar) = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
- ppStg(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);
- }
- return e;
-}
-
-/* \ v -> case v of { ...; Ci _ _ -> i; ... } */
-Void implementConToTag(t)
-Tycon t; {
- if (isNull(tycon(t).conToTag)) {
- List cs = tycon(t).defn;
- Name nm = newName(inventText());
- StgVar v = mkStgVar(NIL,NIL);
- List alts = NIL; /* can't fail */
-
- assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE));
- for (; hasCfun(cs); cs=tl(cs)) {
- Name c = hd(cs);
- Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
- StgVar r = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),NIL);
- StgExpr tag = mkStgLet(singleton(r),r);
- List vs = NIL;
- Int i;
- for(i=0; i < name(c).arity; ++i) {
- vs = cons(mkStgVar(NIL,NIL),vs);
- }
- alts = cons(mkStgCaseAlt(c,vs,tag),alts);
- }
-
- name(nm).line = tycon(t).line;
- name(nm).type = conToTagType(t);
- name(nm).arity = 1;
- name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),NIL);
- tycon(t).conToTag = nm;
- /* hack to make it print out */
- stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
- }
-}
-
-/* \ v -> case v of { ...; i -> Ci; ... } */
-Void implementTagToCon(t)
-Tycon t; {
- if (isNull(tycon(t).tagToCon)) {
- List cs = tycon(t).defn;
- Name nm = newName(inventText());
- StgVar v1 = mkStgVar(NIL,NIL);
- StgVar v2 = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
- List alts = singleton(mkStgPrimAlt(singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),namePMFail));
-
- assert(namePMFail);
- assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE));
- for (; hasCfun(cs); cs=tl(cs)) {
- Name c = hd(cs);
- Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
- StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL);
- assert(name(c).arity==0);
- alts = cons(mkStgPrimAlt(singleton(pat),c),alts);
- }
-
- name(nm).line = tycon(t).line;
- name(nm).type = tagToConType(t);
- name(nm).arity = 1;
- name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v1),
- mkStgCase(v1,singleton(mkStgCaseAlt(nameMkI,singleton(v2),
- mkStgPrimCase(v2,alts))))),NIL);
- tycon(t).tagToCon = nm;
- /* hack to make it print out */
- stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
+ stgVarBody(name(n).stgVar)
+ = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
+ s = stgSize(stgVarBody(name(n).stgVar));
+ name(n).stgSize = s;
+ if (s <= SMALL_INLINE_SIZE && !name(n).inlineMe) {
+ name(n).inlineMe = TRUE;
}
}
Name c; /* fun c. scs lists integers (1..)*/
List scs; { /* in incr order of strict comps. */
Int a = name(c).arity;
- 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! */
+ 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 (t == typePrimByteArray) return mkChar(BARR_REP);
+ /* ToDo: argty only! */
else if (whatIs(t) == AP) {
Type h = getHead(t);
- if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP); /* ToDo: argty only! */
+ 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
if (nonNull(b_args)) {
StgVar b_arg = hd(b_args); /* boxed arg */
StgVar u_arg = hd(u_args); /* unboxed arg */
- StgRep k = mkStgRep(*reps);
+ //StgRep k = mkStgRep(*reps);
Name box = repToBox(*reps);
e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
if (isNull(box)) {
/* box results */
if (strcmp(r_reps,"B") == 0) {
- StgPrimAlt altF = mkStgPrimAlt(singleton(mkStgPrimVar(mkInt(0),mkStgRep(INT_REP),NIL)),
- nameFalse);
- StgPrimAlt altT = mkStgPrimAlt(singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
- nameTrue);
+ StgPrimAlt altF
+ = mkStgPrimAlt(singleton(
+ mkStgPrimVar(mkInt(0),
+ mkStgRep(INT_REP),NIL)
+ ),
+ nameFalse);
+ StgPrimAlt altT
+ = mkStgPrimAlt(
+ singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
+ nameTrue);
alts = doubleton(altF,altT);
assert(nonNull(nameTrue));
assert(!addState);
b_args = mkBoxedVars(a_reps);
u_args = mkUnboxedVars(a_reps);
if (addState) {
- List actual_args = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
- StgRhs rhs = makeStgLambda(singleton(s0),
- unboxVars(a_reps,b_args,u_args,
- mkStgPrimCase(mkStgPrim(op,actual_args),
- alts)));
+ List actual_args
+ = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
+ StgRhs rhs
+ = makeStgLambda(singleton(s0),
+ unboxVars(a_reps,b_args,u_args,
+ mkStgPrimCase(mkStgPrim(op,actual_args),
+ alts)));
StgVar m = mkStgVar(rhs,NIL);
return makeStgLambda(b_args,
mkStgLet(singleton(m),
mkStgApp(nameMkIO,singleton(m))));
} else {
List actual_args = appendOnto(extra_args,u_args);
- return makeStgLambda(b_args,
- unboxVars(a_reps,b_args,u_args,mkStgPrimCase(mkStgPrim(op,actual_args),alts)));
+ return makeStgLambda(
+ b_args,
+ unboxVars(a_reps,b_args,u_args,
+ mkStgPrimCase(mkStgPrim(op,actual_args),alts))
+ );
}
}
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 */
}
* }}})
* in primMkIO m
* ::
- * Addr -> (Int -> Float -> IO (Char,Addr)
+ * Addr -> (Int -> Float -> IO (Char,Addr))
*/
Void implementForeignImport( Name n )
{
} else {
resultTys = singleton(resultTys);
}
- mapOver(foreignArgTy,argTys); /* allows foreignObj, byteArrays, etc */
- mapOver(foreignResultTy,resultTys);/* doesn't */
+ mapOver(foreignArgTy,argTys); /* allows foreignObj, byteArrays, etc */
+ mapOver(foreignResultTy,resultTys); /* doesn't */
descriptor = mkDescriptor(charListToString(argTys),
charListToString(resultTys));
name(n).primop = addState ? &ccall_IO : &ccall_Id;
void* funPtr = getDLLSymbol(textToStr(textOf(fst(extName))),
textToStr(textOf(snd(extName))));
List extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
- StgRhs rhs = makeStgPrim(n,addState,extra_args,descriptor->arg_tys,descriptor->result_tys);
+ StgRhs rhs = makeStgPrim(n,addState,extra_args,descriptor->arg_tys,
+ descriptor->result_tys);
StgVar v = mkStgVar(rhs,NIL);
if (funPtr == 0) {
ERRMSG(0) "Could not find foreign function \"%s\" in \"%s\"",
textToStr(textOf(fst(extName)))
EEND;
}
- ppStg(v);
- name(n).defn = NIL;
- name(n).stgVar = v;
- stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
+ //ppStg(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) {
stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
} else {
StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
- stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* so we can see it */
+ stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* ditto */
}
}
projects / ghc-hetmet.git / blobdiff