X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Ftranslate.c;h=a4e3b9d1efac7ce7eddaabe9809e1f66e5d94ee7;hb=71a983960c5372ddf382ad02c75afb967e0ea2df;hp=2c2717ed81b917f6f1fc2cbf406ffb0e24bdea0d;hpb=6642714ec59883c1edd31e9e5b485e99f0edd952;p=ghc-hetmet.git diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c index 2c2717e..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.11 $ - * $Date: 1999/10/26 17:27:36 $ + * $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 */ @@ -203,7 +182,6 @@ StgExpr failExpr; } } case NUMCASE: -#if OVERLOADED_CONSTANTS { Triple nc = snd(e); Offset o = fst3(nc); @@ -212,8 +190,8 @@ StgExpr failExpr; 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 * ==> @@ -234,8 +212,10 @@ StgExpr failExpr; 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) */ @@ -258,7 +238,6 @@ StgExpr failExpr; failExpr)), failExpr)); } -#endif /* NPLUSK */ assert(isName(h) && argCount == 2); { @@ -316,46 +295,7 @@ StgExpr 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; @@ -401,11 +341,13 @@ StgExpr failExpr; } 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)) { @@ -417,11 +359,7 @@ StgExpr failExpr; /* 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; @@ -439,13 +377,10 @@ StgExpr failExpr; /* 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); @@ -453,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)) { @@ -465,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 ) { @@ -492,23 +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)); - 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. */ - 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); @@ -520,16 +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; } - 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"); */ + addToCodeList ( currentModule, c ); + /* printStg(stderr, name(c).closure); fprintf(stderr,"\n\n"); */ } /* -------------------------------------------------------------------------- @@ -611,29 +547,27 @@ static Cell foreignInboundTy ( Type 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; - case STABLE_REP: return nameMkStable; + 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; } } @@ -659,10 +593,14 @@ static StgPrimAlt boxResults( String reps, StgVar state ) } 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; @@ -790,10 +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; - name(n).stgSize = stgSize(stgVarBody(v)); - name(n).inlineMe = TRUE; - 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. @@ -823,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); @@ -831,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); @@ -850,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; @@ -873,55 +822,78 @@ Void implementForeignImport ( Name n ) 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(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)); } - /* 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 */ + 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); @@ -934,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) { @@ -958,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 @@ -990,35 +970,30 @@ 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))) ) ) ); v = mkStgVar(fun,NIL); - ppStg(v); name(n).defn = NIL; - name(n).stgVar = v; - name(n).stgSize = stgSize(stgVarBody(v)); - name(n).inlineMe = FALSE; - 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 ); } } @@ -1029,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; } }