* 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.7 $
- * $Date: 1999/04/27 10:07:08 $
+ * $Revision: 1.30 $
+ * $Date: 2000/03/23 14:54:21 $
* ------------------------------------------------------------------------*/
-#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"
/* ---------------------------------------------------------------- */
-static StgVar local stgOffset Args((Offset,List));
-static StgVar local stgText Args((Text,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 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 );
/* ---------------------------------------------------------------- */
/* dictionaries, tuples, etc */
List stgGlobals = NIL;
-static StgVar local getSTGTupleVar Args((Cell));
-
-static StgVar local getSTGTupleVar( Cell d )
+static StgVar local getSTGTupleVar ( Cell d )
{
Pair p = cellAssoc(d,stgGlobals);
/* Yoiks - only the Prelude sees Tuple decls! */
}
}
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
* ==>
dIntegral = mkStgVar(dIntegral,NIL);
binds = cons(dIntegral,binds);
}
+
/* box number */
- n = mkStgVar(mkStgCon(nameMkInteger,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) */
failExpr)),
failExpr));
}
-#endif /* NPLUSK */
assert(isName(h) && argCount == 2);
{
);
}
}
-#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;
}
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;
/* Arguments must be StgAtoms */
for(as=args; nonNull(as); as=tl(as)) {
StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
-#if 1 /* optional flattening of let bindings */
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)
+ ||
+ (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,namePMFail);
if (!isStgVar(e) && !isName(e)) {
}
}
-#if 0 /* apparently not used */
-static Void ppExp( Name n, Int arity, Cell e )
-{
- if (1 || 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 )
{
}
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;
- }
}
Void implementCfun(c,scs) /* Build implementation for constr */
Name c; /* fun c. scs lists integers (1..)*/
-List scs; { /* in incr order of strict comps. */
+List scs; { /* in incr order of strict fields. */
Int a = name(c).arity;
if (a > 0) {
StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
name(c).stgVar = v;
}
- 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");
+ /* printStg(stderr, name(c).stgVar); 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);
+#if 0
else if (t == typeInteger)return mkChar(INTEGER_REP);
+#endif
else if (t == typeWord) return mkChar(WORD_REP);
else if (t == typeAddr) return mkChar(ADDR_REP);
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! */
#endif
+#if 0
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);
- 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;
- 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;
-#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)) {
}
}
-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;
- name(n).stgSize = stgSize(stgVarBody(v));
- name(n).inlineMe = TRUE;
stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
}
* ::
* 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(mkPtr(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(mkPtr(descriptor),mkPtr(funPtr));
}
- //ppStg(v);
+
+ rhs = makeStgPrim(n,addState,extra_args,
+ descriptor->arg_tys,
+ descriptor->result_tys);
+ v = mkStgVar(rhs,NIL);
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 */
+ stgGlobals = cons(pair(n,v),stgGlobals);
+ }
+
+ /* At this point the descriptor contains a tags for all args,
+ 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
+ */
+Void implementForeignExport ( Name n )
{
- internal("implementForeignExport: not implemented");
+ Type t = name(n).type;
+ List argTys = NIL;
+ List resultTys = NIL;
+ Char cc_char;
+
+ if (getHead(t)==typeArrow && argCount==2) {
+ t = arg(fun(t));
+ } else {
+ ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
+ ERRTEXT " \"" ETHEN ERRTYPE(t);
+ ERRTEXT "\""
+ EEND;
+ }
+
+ 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 {
+ ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN
+ ERRTEXT " \"" ETHEN ERRTYPE(t);
+ ERRTEXT "\""
+ EEND;
+ }
+ resultTys = fullExpand(resultTys);
+
+ mapOver(foreignInboundTy,argTys);
+
+ /* 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");
+
+ {
+ List tdList;
+ Text tdText;
+ List args;
+ StgVar e1, e2, e3, v;
+ StgExpr fun;
+
+ tdList = cons(mkChar(':'),argTys);
+ if (resultTys != typeUnit)
+ tdList = cons(foreignOutboundTy(resultTys),tdList);
+
+ tdText = findText(charListToString ( tdList ));
+ 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).stgVar = v;
+ stgGlobals = cons(pair(n,v),stgGlobals);
+ }
}
-// ToDo: figure out how to set inlineMe for these (non-Name) things
Void implementTuple(size)
Int size; {
if (size > 0) {
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:
+ stgGlobals=NIL;
+ break;
+ case MARK:
+ mark(stgGlobals);
+ break;
}
}
projects / ghc-hetmet.git / blobdiff