* Translator: generates stg code from output of pattern matching
* compiler.
*
- * 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: translate.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/02/03 17:08:44 $
+ * $Revision: 1.35 $
+ * $Date: 2000/05/12 11:59:39 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
-#include "backend.h"
#include "connect.h"
#include "errors.h"
-#include "link.h"
-#include "dynamic.h"
-#include "Assembler.h"
-/* ---------------------------------------------------------------- */
+#include "Rts.h" /* to make StgPtr visible in Assembler.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 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 */
-List stgGlobals = NIL;
-
-static StgVar local getSTGTupleVar Args((Cell));
-
-static StgVar local getSTGTupleVar( Cell d )
-{
- Pair p = cellAssoc(d,stgGlobals);
- /* Yoiks - only the Prelude sees Tuple decls! */
- if (isNull(p)) {
- implementTuple(tupleOf(d));
- p = cellAssoc(d,stgGlobals);
- }
- assert(nonNull(p));
- return snd(p);
-}
+static StgVar local stgOffset ( Offset,List );
+static StgVar local stgText ( Text,List );
+static StgRhs local stgRhs ( Cell,Int,List,StgExpr );
+static StgCaseAlt local stgCaseAlt ( Cell,Int,List,StgExpr );
+static StgExpr local stgExpr ( 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 VAROPCELL:
return stgText(textOf(e),sc);
case TUPLE:
- return getSTGTupleVar(e);
+ return e;
case NAME:
return e;
/* Literals */
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*/);
}
}
}
case GUARDED:
{
- List guards = rev(snd(e));
+ List guards = reverse(snd(e));
e = failExpr;
for(; nonNull(guards); guards=tl(guards)) {
Cell g = hd(guards);
} 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:
-#if OVERLOADED_CONSTANTS
{
Triple nc = snd(e);
Offset o = fst3(nc);
Cell scrut = stgOffset(o,sc);
Cell h = getHead(discr);
Int da = discrArity(discr);
+ char str[30];
-#if NPLUSK
if (whatIs(h) == ADDPAT && argCount == 1) {
/* ADDPAT num dictIntegral
* ==>
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);
+ sprintf(str, "%d", n);
+ n = mkStgVar(mkStgCon(nameMkInteger,singleton(stringToBignum(str))),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 */
assert(isName(h) && argCount == 2);
{
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 */
- {
- Triple nc = snd(e);
- Offset o = fst3(nc);
- Cell discr = snd3(nc);
- Cell r = thd3(nc);
- Cell scrut = stgOffset(o,sc);
- Cell h = getHead(discr);
- Int da = discrArity(discr);
- Cell n = discr;
- List binds = NIL;
- Name eq
- = isInt(discr) ? nameEqInt
- : isBignum(discr) ? nameEqInteger
- : nameEqDouble;
- Name box
- = isInt(discr) ? nameMkI
- : isBignum(discr) ? nameMkBignum
- : nameMkD;
- StgExpr test = NIL;
- Cell altsc = sc;
- Cell vs = NIL;
- Int i;
-
- for(i=1; i<=da; ++i) {
- Cell nv = mkStgVar(NIL,NIL);
- vs = cons(nv,vs);
- altsc = cons(pair(mkOffset(co+i),nv),altsc);
- }
- /* bind number */
- n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
- binds = cons(n,binds);
-
- test = mkStgLet(binds, mkStgApp(eq, doubleton(n,scrut)));
- return makeStgIf(test,
- stgExpr(r,co+da,altsc,failExpr),
- failExpr);
- }
-#endif /* ! OVERLOADED_CONSTANTS */
case LETREC:
{
List binds = NIL;
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 */
{
List args = NIL;
List binds = NIL;
List as = NIL;
+ Int length_args;
/* Unwind args */
while (isAp(e)) {
/* Special cases */
if (e == nameSel && length(args) == 3) {
Cell con = hd(args);
-#if 0
- StgVar v = stgOffset(hd(tl(args)),sc);
-#else
StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
-#endif
Int ix = intOf(hd(tl(tl(args))));
Int da = discrArity(con);
List vs = NIL;
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);
-#if 1 /* optional flattening of let bindings */
+ StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
if (whatIs(a) == LETREC) {
binds = appendOnto(stgLetBinds(a),binds);
a = stgLetBody(a);
}
-#endif
-
if (!isAtomic(a)) {
a = mkStgVar(a,NIL);
binds = cons(a,binds);
hd(as) = a;
}
+ /* Special case: saturated constructor application */
+ length_args = length(args);
+ if ( (isName(e) && isCfun(e)
+ && name(e).arity > 0
+ && name(e).arity == length_args
+ && !name(e).hasStrict
+ && numQualifiers(name(e).type) == 0)
+ ||
+ (isTuple(e) && tycon(e).tuple == length_args)
+ ) {
+ StgVar v;
+ /* fprintf ( stderr, "saturated application of %s\n",
+ textToStr(isTuple(e) ? tycon(e).text : name(e).text)); */
+ v = mkStgVar(mkStgCon(e,args),NIL);
+ binds = cons(v,binds);
+ return mkStgLet(binds,v);
+
+
+ }
+
/* 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 );
-static Void ppExp( Name n, Int arity, Cell e )
-{
-#if DEBUG_CODE
- if (debugCode) {
- Int i;
- printf("%s", textToStr(name(n).text));
- for (i = arity; i > 0; i--) {
- printf(" o%d", i);
- }
- printf(" = ");
- printExp(stdout,e);
- printf("\n");
- }
-#endif
-}
Void stgDefn( Name n, Int arity, Cell e )
{
List vs = NIL;
List sc = NIL;
- Int i;
-//printf("\nBEGIN --------------- stgDefn-ppExp ----------------\n" );
-// ppExp(n,arity,e);
-//printf("\nEND ----------------- stgDefn-ppExp ----------------\n" );
+ 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));
-//printf("\nBEGIN --------------- stgDefn-ppStg ----------------\n" );
-// ppStg(name(n).stgVar);
-//printf("\nEND ----------------- stgDefn-ppStg ----------------\n" );
-}
-
-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;
-}
-
-#if 0
-ToDo: reinstate eventually
-/* \ 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)) {
- String etxt;
- String tyconname;
- List cs;
- Name nm;
- StgVar v1;
- StgVar v2;
- Cell txt0;
- StgVar bind1;
- StgVar bind2;
- StgVar bind3;
- List alts;
-
- assert(nameMkA);
- assert(nameUnpackString);
- assert(nameError);
- assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE));
-
- tyconname = textToStr(tycon(t).text);
- etxt = malloc(100+strlen(tyconname));
- assert(etxt);
- sprintf(etxt,
- "out-of-range arg for `toEnum' in (derived) `instance Enum %s'",
- tyconname);
-
- cs = tycon(t).defn;
- nm = newName(inventText());
- v1 = mkStgVar(NIL,NIL);
- v2 = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
-
- txt0 = mkStr(findText(etxt));
- bind1 = mkStgVar(mkStgCon(nameMkA,singleton(txt0)),NIL);
- bind2 = mkStgVar(mkStgApp(nameUnpackString,singleton(bind1)), NIL);
- bind3 = mkStgVar(mkStgApp(nameError,singleton(bind2)), NIL);
-
- alts = singleton(
- mkStgPrimAlt(
- singleton(
- mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)
- ),
- makeStgLet ( tripleton(bind1,bind2,bind3), bind3 )
- )
- );
-
- 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);
- if (etxt) free(etxt);
- }
+ stgVarBody(name(n).closure)
+ = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
}
-#endif
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;
- 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);
- name(c).stgVar = v;
+List scs; { /* in incr order of strict fields. */
+ Int a = name(c).arity; /* arity, not incl dictionaries */
+ Int ad = numQualifiers(name(c).type); /* the number of dictionaries */
+ Type t = name(c).type;
+
+ /* a+ad is total arity for this fn */
+ if (a+ad > 0) {
+ StgVar vcurr, e1, v, vsi;
+ List args = makeArgs(a);
+ List argsd = makeArgs(ad);
+ 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(dupOnto(argsd,args),e1),NIL);
+ name(c).closure = v;
} else {
StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
- name(c).stgVar = v;
+ name(c).closure = v;
}
- /* hack to make it print out */
- stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
+ addToCodeList ( currentModule, c );
+ /* printStg(stderr, name(c).closure); fprintf(stderr,"\n\n"); */
}
/* --------------------------------------------------------------------------
* Foreign function calls and primops
* ------------------------------------------------------------------------*/
-static String charListToString( List cs );
-static Cell foreignResultTy( Type t );
-static Cell foreignArgTy( Type t );
-static Name repToBox Args(( char c ));
-static StgRhs makeStgPrim Args(( Name,Bool,List,String,String ));
+/* Outbound denotes data moving from Haskell world to elsewhere.
+ Inbound denotes data moving from elsewhere to Haskell world.
+*/
+static String charListToString ( List cs );
+static Cell foreignTy ( Bool outBound, Type t );
+static Cell foreignOutboundTy ( Type t );
+static Cell foreignInboundTy ( Type t );
+static Name repToBox ( char c );
+static StgRhs makeStgPrim ( Name,Bool,List,String,String );
static String charListToString( List cs )
{
return textToStr(findText(s));
}
-static Cell foreignResultTy( Type t )
+static Cell foreignTy ( Bool outBound, Type t )
{
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
+#if 0
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);
+ else if (t == typeStable) return mkChar(STABLE_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! */
+#if 0
+ 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);
- ERRTEXT "\""
- EEND;
+ if (outBound) {
+ ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
+ ERRTEXT " \"" ETHEN ERRTYPE(t);
+ ERRTEXT "\""
+ EEND;
+ } else {
+ ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
+ ERRTEXT " \"" ETHEN ERRTYPE(t);
+ ERRTEXT "\""
+ EEND;
+ }
}
-static Cell foreignArgTy( Type t )
+static Cell foreignOutboundTy ( Type t )
{
- return foreignResultTy( t );
+ return foreignTy ( TRUE, t );
+}
+
+static Cell foreignInboundTy ( Type t )
+{
+ return foreignTy ( FALSE, t );
}
static Name repToBox( char c )
{
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
+ case CHAR_REP: return nameMkC;
+ case INT_REP: return nameMkI;
+ case INTEGER_REP: return nameMkInteger;
+ case WORD_REP: return nameMkW;
+ case ADDR_REP: return nameMkA;
+ case FLOAT_REP: return nameMkF;
+ case DOUBLE_REP: return nameMkD;
+ 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;
+ case STABLE_REP: return nameMkStable;
+ case THREADID_REP: return nameMkThreadId;
+ case MVAR_REP: return nameMkPrimMVar;
#ifdef PROVIDE_WEAK
case WEAK_REP: return nameMkWeak;
#endif
#ifdef PROVIDE_FOREIGN
case FOREIGN_REP: return nameMkForeign;
#endif
-#ifdef PROVIDE_CONCURRENT
- case THREADID_REP: return nameMkThreadId;
- case MVAR_REP: return nameMkMVar;
-#endif
default: return NIL;
}
}
}
rs = cons(v,rs);
}
+
/* Construct tuple of results */
+ if (i == 0) {
+ e = nameUnit;
+ } else
if (i == 1) {
e = hd(bs);
- } else { /* includes i==0 case */
+ } else {
StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
rbinds = cons(r,rbinds);
e = r;
if (nonNull(b_args)) {
StgVar b_arg = hd(b_args); /* boxed arg */
StgVar u_arg = hd(u_args); /* unboxed arg */
- 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,dupOnto(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))
+ );
}
}
-Void implementPrim( n )
+Void implementPrim ( n )
Name n; {
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;
- stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
+ name(n).closure = v;
+ addToCodeList ( currentModule, n );
}
/* Generate wrapper code from (in,out) type lists.
* }}})
* in primMkIO m
* ::
- * Addr -> (Int -> Float -> IO (Char,Addr)
+ * Addr -> (Int -> Float -> IO (Char,Addr))
*/
-Void implementForeignImport( Name n )
+Void implementForeignImport ( Name n )
{
- Type t = name(n).type;
+ Type t = name(n).type;
List argTys = NIL;
List resultTys = NIL;
CFunDescriptor* descriptor = 0;
- Bool addState = TRUE;
+ Bool addState = TRUE;
+ Bool dynamic = isNull(name(n).defn);
while (getHead(t)==typeArrow && argCount==2) {
Type ta = fullExpand(arg(fun(t)));
Type tr = arg(t);
t = tr;
}
argTys = rev(argTys);
+
+ /* argTys now holds the argument tys. If this is a dynamic call,
+ the first one had better be an Addr.
+ */
+ if (dynamic) {
+ if (isNull(argTys) || hd(argTys) != typeAddr) {
+ ERRMSG(name(n).line) "First argument in f-i-dynamic must be an Addr"
+ EEND;
+ }
+ }
+
if (getHead(t) == typeIO) {
resultTys = getArgs(t);
assert(length(resultTys) == 1);
} else {
resultTys = singleton(resultTys);
}
- 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;
+ mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */
+ mapOver(foreignInboundTy,resultTys); /* doesn't */
+ descriptor
+ = mkDescriptor(charListToString(argTys),
+ charListToString(resultTys));
+ if (!descriptor) {
+ ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
+ EEND;
+ }
+
+ /* ccall is the default convention, if it wasn't specified */
+ if (isNull(name(n).callconv)
+ || name(n).callconv == textCcall) {
+ name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
+ }
+ else if (name(n).callconv == textStdcall) {
+ if (!stdcallAllowed()) {
+ ERRMSG(name(n).line) "stdcall is not supported on this platform"
+ EEND;
+ }
+ name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
+ }
+ else
+ internal ( "implementForeignImport: unknown calling convention");
+
{
- Pair extName = name(n).defn;
- 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);
- StgVar v = mkStgVar(rhs,NIL);
- if (funPtr == 0) {
- ERRMSG(0) "Could not find foreign function \"%s\" in \"%s\"",
- textToStr(textOf(snd(extName))),
- textToStr(textOf(fst(extName)))
- EEND;
+ Pair extName;
+ void* funPtr;
+ List extra_args;
+ StgRhs rhs;
+ StgVar v;
+
+ if (dynamic) {
+ funPtr = NULL;
+ extra_args = singleton(mkAddr(descriptor));
+ /* and we know that the first arg will be the function pointer */
+ } else {
+ extName = name(n).defn;
+ funPtr = getDLLSymbol(name(n).line,
+ textToStr(textOf(fst(extName))),
+ textToStr(textOf(snd(extName))));
+ if (funPtr == 0) {
+ ERRMSG(name(n).line)
+ "Could not find foreign function \"%s\" in \"%s\"",
+ textToStr(textOf(snd(extName))),
+ textToStr(textOf(fst(extName)))
+ EEND;
+ }
+ extra_args = doubleton(mkAddr(descriptor),mkAddr(funPtr));
}
- ppStg(v);
- name(n).defn = NIL;
- name(n).stgVar = v;
- stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
+
+ rhs = makeStgPrim(n,addState,extra_args,
+ descriptor->arg_tys,
+ descriptor->result_tys);
+ v = mkStgVar(rhs,NIL);
+ name(n).defn = NIL;
+ name(n).closure = v;
+ addToCodeList ( currentModule, n );
+ }
+
+ /* At this point the descriptor contains a tag for each arg,
+ because that makes makeStgPrim generate the correct unwrap
+ code. From now on, the descriptor is only used at the time
+ the actual ccall is made. So we need to zap the leading
+ addr arg IF this is a f-i-dynamic call.
+ */
+ if (dynamic) {
+ descriptor->arg_tys++;
+ descriptor->num_args--;
}
}
-Void implementForeignExport( Name n )
+
+
+/* Generate code:
+ *
+ * \ fun ->
+ let e1 = A# "...."
+ e3 = C# 'c' -- (ccall), or 's' (stdcall)
+ in primMkAdjThunk fun e1 e3
+
+ we require, and check that,
+ fun :: prim_arg* -> IO prim_result
+ */
+Text makeTypeDescrText ( Type t )
{
- internal("implementForeignExport: not implemented");
+ List argTys = NIL;
+ List resultTys = NIL;
+ List tdList;
+
+#if 0
+ // I don't understand what this achieves.
+ if (getHead(t)==typeArrow && argCount==2) {
+ t = arg(fun(t));
+ } else {
+ return NIL;
+ }
+#endif
+ while (getHead(t)==typeArrow && argCount==2) {
+ Type ta = fullExpand(arg(fun(t)));
+ Type tr = arg(t);
+ argTys = cons(ta,argTys);
+ t = tr;
+ }
+ argTys = rev(argTys);
+ if (getHead(t) == typeIO) {
+ resultTys = getArgs(t);
+ assert(length(resultTys) == 1);
+ resultTys = hd(resultTys);
+ } else {
+ return NIL;
+ }
+ resultTys = fullExpand(resultTys);
+
+ mapOver(foreignInboundTy,argTys);
+
+ tdList = cons(mkChar(':'),argTys);
+ if (resultTys != typeUnit)
+ tdList = cons(foreignOutboundTy(resultTys),tdList);
+
+ return findText(charListToString ( tdList ));
+}
+
+
+Void implementForeignExport ( Name n )
+{
+ Text tdText;
+ List args;
+ StgVar e1, e2, e3, v;
+ StgExpr fun;
+ Char cc_char;
+
+ tdText = makeTypeDescrText ( name(n).type );
+ if (isNull(tdText)) {
+ ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
+ ERRTEXT " \"" ETHEN ERRTYPE(name(n).type);
+ ERRTEXT "\""
+ EEND;
+ }
+
+ /* ccall is the default convention, if it wasn't specified */
+ if (isNull(name(n).callconv)
+ || name(n).callconv == textCcall) {
+ cc_char = 'c';
+ }
+ else if (name(n).callconv == textStdcall) {
+ if (!stdcallAllowed()) {
+ ERRMSG(name(n).line) "stdcall is not supported on this platform"
+ EEND;
+ }
+ cc_char = 's';
+ }
+ else
+ internal ( "implementForeignExport: unknown calling convention");
+
+ args = makeArgs(1);
+ e1 = mkStgVar(
+ mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
+ NIL
+ );
+ e2 = mkStgVar(
+ mkStgApp(nameUnpackString,singleton(e1)),
+ NIL
+ );
+ e3 = mkStgVar(
+ mkStgCon(nameMkC,singleton(mkChar(cc_char))),
+ NIL
+ );
+ fun = mkStgLambda(
+ args,
+ mkStgLet(
+ tripleton(e1,e2,e3),
+ mkStgApp(
+ nameCreateAdjThunk,
+ cons(hd(args),cons(e2,cons(e3,NIL)))
+ )
+ )
+ );
+
+ v = mkStgVar(fun,NIL);
+
+ name(n).defn = NIL;
+ name(n).closure = v;
+ addToCodeList ( currentModule, n );
}
Void implementTuple(size)
Int size; {
if (size > 0) {
- Cell t = mkTuple(size);
- List args = makeArgs(size);
- StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
- StgExpr e = mkStgLet(singleton(tv),tv);
- StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
- stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
+ Tycon t = mkTuple(size);
+ List args = makeArgs(size);
+ StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
+ StgExpr e = mkStgLet(singleton(tv),tv);
+ StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
+ tycon(t).closure = v;
+ addToCodeList ( currentModule, t );
} else {
- StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
- stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* so we can see it */
+ addToCodeList ( currentModule, nameUnit );
}
}
Void translateControl(what)
Int what; {
switch (what) {
- case INSTALL:
- {
- /* deliberate fall through */
- }
- case RESET:
- stgGlobals=NIL;
- break;
- case MARK:
- mark(stgGlobals);
- break;
+ case POSTPREL: break;
+ case PREPREL:
+ case RESET:
+ break;
+ case MARK:
+ break;
}
}
projects / ghc-hetmet.git / blobdiff