* included in the distribution.
*
* $RCSfile: translate.c,v $
- * $Revision: 1.26 $
- * $Date: 2000/03/10 14:53:00 $
+ * $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,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 */
-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 );
/* ---------------------------------------------------------------- */
case VAROPCELL:
return stgText(textOf(e),sc);
case TUPLE:
- return getSTGTupleVar(e);
+ return e;
case NAME:
return e;
/* Literals */
length_args = length(args);
if ( (isName(e) && isCfun(e)
&& name(e).arity > 0
- && name(e).arity == length_args)
+ && name(e).arity == length_args
+ && !name(e).hasStrict
+ && numQualifiers(name(e).type) == 0)
||
(isTuple(e) && tycon(e).tuple == length_args)
) {
}
}
-#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 )
{
vs = cons(nv,vs);
sc = cons(pair(mkOffset(i),nv),sc);
}
- stgVarBody(name(n).stgVar)
+ stgVarBody(name(n).closure)
= makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
}
Void implementCfun(c,scs) /* Build implementation for constr */
Name c; /* fun c. scs lists integers (1..)*/
List scs; { /* in incr order of strict fields. */
- Int a = name(c).arity;
+ Int a = name(c).arity; /* arity, not incl dictionaries */
+ Int ad = numQualifiers(name(c).type); /* the number of dictionaries */
+ Type t = name(c).type;
- if (a > 0) {
+ /* 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);
}
binds = rev(binds);
e1 = mkStgLet(binds,vcurr);
- v = mkStgVar(mkStgLambda(args,e1),NIL);
- name(c).stgVar = v;
+ 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;
}
- stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
- /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */
+ addToCodeList ( currentModule, c );
+ /* printStg(stderr, name(c).closure); fprintf(stderr,"\n\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.
if (dynamic) {
funPtr = NULL;
- extra_args = singleton(mkPtr(descriptor));
+ extra_args = singleton(mkAddr(descriptor));
/* and we know that the first arg will be the function pointer */
} else {
extName = name(n).defn;
textToStr(textOf(fst(extName)))
EEND;
}
- extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
+ extra_args = doubleton(mkAddr(descriptor),mkAddr(funPtr));
}
rhs = makeStgPrim(n,addState,extra_args,
descriptor->result_tys);
v = mkStgVar(rhs,NIL);
name(n).defn = NIL;
- name(n).stgVar = v;
- stgGlobals = cons(pair(n,v),stgGlobals);
+ name(n).closure = v;
+ addToCodeList ( currentModule, n );
}
- /* At this point the descriptor contains a tags for all args,
+ /* 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
}
+
/* Generate code:
*
* \ fun ->
we require, and check that,
fun :: prim_arg* -> IO prim_result
*/
-Void implementForeignExport ( Name n )
+Text makeTypeDescrText ( Type t )
{
- Type t = name(n).type;
List argTys = NIL;
List resultTys = NIL;
- Char cc_char;
+ List tdList;
+#if 0
+ // I don't understand what this achieves.
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;
+ return NIL;
}
-
+#endif
while (getHead(t)==typeArrow && argCount==2) {
Type ta = fullExpand(arg(fun(t)));
Type tr = arg(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;
+ 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) {
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))),
v = mkStgVar(fun,NIL);
name(n).defn = NIL;
- name(n).stgVar = v;
- stgGlobals = cons(pair(n,v),stgGlobals);
- }
+ 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); /* ditto */
+ addToCodeList ( currentModule, nameUnit );
}
}
case POSTPREL: break;
case PREPREL:
case RESET:
- stgGlobals=NIL;
break;
case MARK:
- mark(stgGlobals);
break;
}
}
projects / ghc-hetmet.git / blobdiff