X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Ftranslate.c;h=a4e3b9d1efac7ce7eddaabe9809e1f66e5d94ee7;hb=9f0b4b7582b3e98ea80c20a142e1b97825c92a99;hp=3af2fd54dbc6807fb0c6e94a22f738c2c7b8dc58;hpb=a084f34d1e3d67d2a9fa1da36f2da5aa99657777;p=ghc-hetmet.git diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c index 3af2fd5..a4e3b9d 100644 --- a/ghc/interpreter/translate.c +++ b/ghc/interpreter/translate.c @@ -10,47 +10,26 @@ * included in the distribution. * * $RCSfile: translate.c,v $ - * $Revision: 1.19 $ - * $Date: 1999/11/23 18:08:19 $ + * $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 ); /* ---------------------------------------------------------------- */ @@ -90,7 +69,7 @@ StgExpr failExpr; { case VAROPCELL: return stgText(textOf(e),sc); case TUPLE: - return getSTGTupleVar(e); + return e; case NAME: return e; /* Literals */ @@ -213,7 +192,6 @@ StgExpr failExpr; Int da = discrArity(discr); char str[30]; -#if NPLUSK if (whatIs(h) == ADDPAT && argCount == 1) { /* ADDPAT num dictIntegral * ==> @@ -260,7 +238,6 @@ StgExpr failExpr; failExpr)), failExpr)); } -#endif /* NPLUSK */ assert(isName(h) && argCount == 2); { @@ -370,6 +347,7 @@ StgExpr failExpr; List args = NIL; List binds = NIL; List as = NIL; + Int length_args; /* Unwind args */ while (isAp(e)) { @@ -410,6 +388,26 @@ StgExpr failExpr; 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,namePMFail); if (!isStgVar(e) && !isName(e)) { @@ -422,22 +420,6 @@ StgExpr failExpr; } } -#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 ) { @@ -449,18 +431,22 @@ 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 comps. */ - Int a = name(c).arity; +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; - 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); @@ -472,14 +458,14 @@ List scs; { /* in incr order of strict comps. */ } 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"); */ } /* -------------------------------------------------------------------------- @@ -742,8 +728,8 @@ 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. @@ -773,7 +759,8 @@ Void implementForeignImport ( Name n ) 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); @@ -781,6 +768,17 @@ Void implementForeignImport ( Name n ) 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); @@ -800,8 +798,9 @@ Void implementForeignImport ( Name n ) } mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */ mapOver(foreignInboundTy,resultTys); /* doesn't */ - descriptor = mkDescriptor(charListToString(argTys), - charListToString(resultTys)); + descriptor + = mkDescriptor(charListToString(argTys), + charListToString(resultTys)); if (!descriptor) { ERRMSG(name(n).line) "Can't allocate memory for call descriptor" EEND; @@ -823,53 +822,78 @@ Void implementForeignImport ( Name n ) internal ( "implementForeignImport: unknown calling convention"); { - Pair extName = name(n).defn; - void* funPtr = getDLLSymbol(name(n).line, - 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(name(n).line) "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)); } + + rhs = makeStgPrim(n,addState,extra_args, + descriptor->arg_tys, + descriptor->result_tys); + v = mkStgVar(rhs,NIL); name(n).defn = NIL; - name(n).stgVar = v; - stgGlobals=cons(pair(n,v),stgGlobals);/*so it will get codegen'd */ + 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--; } } + /* Generate code: * - * \ fun s0 -> + * \ fun -> let e1 = A# "...." e3 = C# 'c' -- (ccall), or 's' (stdcall) - in primMkAdjThunk fun e1 e3 s0 + in primMkAdjThunk fun e1 e3 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); @@ -882,15 +906,36 @@ Void implementForeignExport ( Name n ) assert(length(resultTys) == 1); resultTys = hd(resultTys); } else { - ERRMSG(name(n).line) "foreign export 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) { @@ -906,20 +951,7 @@ Void implementForeignExport ( Name n ) 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(2); + args = makeArgs(1); e1 = mkStgVar( mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))), NIL @@ -938,7 +970,7 @@ Void implementForeignExport ( Name n ) tripleton(e1,e2,e3), mkStgApp( nameCreateAdjThunk, - cons(hd(args),cons(e2,cons(e3,cons(hd(tl(args)),NIL)))) + cons(hd(args),cons(e2,cons(e3,NIL))) ) ) ); @@ -946,24 +978,22 @@ Void implementForeignExport ( Name n ) 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 ); } -// ToDo: figure out how to set inlineMe for these (non-Name) things 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 ); } } @@ -974,16 +1004,12 @@ Int size; { 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; } }