X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Ftranslate.c;h=d20fd7b253754be7813747390f2ea625c3cd2c05;hb=7007351bb709611fbb259aae2eb286d107355486;hp=8c11034a8f44afa6cd9e5987c81190bc585ed13d;hpb=dfb12323d9fd0c8fb717b8e548592f20163b4ed0;p=ghc-hetmet.git diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c index 8c11034..d20fd7b 100644 --- a/ghc/interpreter/translate.c +++ b/ghc/interpreter/translate.c @@ -3,32 +3,32 @@ * 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.8 $ - * $Date: 1999/10/15 11:02:35 $ + * $Revision: 1.33 $ + * $Date: 2000/04/06 15:05:30 $ * ------------------------------------------------------------------------*/ -#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 ); /* ---------------------------------------------------------------- */ @@ -36,9 +36,7 @@ static StgExpr local stgExpr Args((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! */ @@ -201,7 +199,6 @@ StgExpr failExpr; } } case NUMCASE: -#if OVERLOADED_CONSTANTS { Triple nc = snd(e); Offset o = fst3(nc); @@ -210,8 +207,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 * ==> @@ -232,8 +229,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) */ @@ -256,7 +255,6 @@ StgExpr failExpr; failExpr)), failExpr)); } -#endif /* NPLUSK */ assert(isName(h) && argCount == 2); { @@ -314,46 +312,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; @@ -399,11 +358,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)) { @@ -415,11 +376,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; @@ -437,13 +394,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); @@ -451,6 +405,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)) { @@ -463,22 +437,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,21 +450,20 @@ 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. */ - 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); @@ -518,16 +475,14 @@ List scs; { /* in incr order of strict comps. */ } binds = rev(binds); e1 = mkStgLet(binds,vcurr); - v = mkStgVar(mkStgLambda(args,e1),NIL); + v = mkStgVar(mkStgLambda(dupOnto(argsd,args),e1),NIL); name(c).stgVar = v; } else { 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"); */ } /* -------------------------------------------------------------------------- @@ -568,6 +523,7 @@ static Cell foreignTy ( Bool outBound, Type t ) 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! */ @@ -608,29 +564,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; } } @@ -656,10 +610,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; @@ -703,7 +661,6 @@ static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e ) 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)) { @@ -789,8 +746,6 @@ Name n; { 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 */ } @@ -821,7 +776,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); @@ -829,6 +785,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); @@ -848,38 +815,83 @@ Void implementForeignImport ( Name n ) } mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */ mapOver(foreignInboundTy,resultTys); /* doesn't */ - descriptor = mkDescriptor(charListToString(argTys), - charListToString(resultTys)); - name(n).primop = addState ? &ccall_IO : &ccall_Id; + 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--; } } /* Generate code: * - * \ fun s0 -> + * \ fun -> let e1 = A# "...." - in primMkAdjThunk fun s0 e1 + e3 = C# 'c' -- (ccall), or 's' (stdcall) + in primMkAdjThunk fun e1 e3 we require, and check that, fun :: prim_arg* -> IO prim_result @@ -889,11 +901,12 @@ Void implementForeignExport ( Name n ) 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(0) "foreign export has illegal type" ETHEN + ERRMSG(name(n).line) "foreign export has illegal type" ETHEN ERRTEXT " \"" ETHEN ERRTYPE(t); ERRTEXT "\"" EEND; @@ -911,7 +924,7 @@ Void implementForeignExport ( Name n ) assert(length(resultTys) == 1); resultTys = hd(resultTys); } else { - ERRMSG(0) "foreign export doesn't return an IO type" ETHEN + ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN ERRTEXT " \"" ETHEN ERRTYPE(t); ERRTEXT "\"" EEND; @@ -920,11 +933,26 @@ Void implementForeignExport ( Name n ) 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, v; + StgVar e1, e2, e3, v; StgExpr fun; tdList = cons(mkChar(':'),argTys); @@ -932,39 +960,38 @@ Void implementForeignExport ( Name n ) tdList = cons(foreignOutboundTy(resultTys),tdList); tdText = findText(charListToString ( tdList )); - args = makeArgs(2); + args = makeArgs(1); e1 = mkStgVar( mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))), NIL ); - e2 = mkStgVar( + e2 = mkStgVar( mkStgApp(nameUnpackString,singleton(e1)), NIL ); - + e3 = mkStgVar( + mkStgCon(nameMkC,singleton(mkChar(cc_char))), + NIL + ); fun = mkStgLambda( args, mkStgLet( - doubleton(e1,e2), + tripleton(e1,e2,e3), mkStgApp( nameCreateAdjThunk, - tripleton(hd(args),e2,hd(tl(args))) + 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); } } -// ToDo: figure out how to set inlineMe for these (non-Name) things Void implementTuple(size) Int size; { if (size > 0) { @@ -987,16 +1014,14 @@ 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: + stgGlobals=NIL; + break; + case MARK: + mark(stgGlobals); + break; } }