X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Ftranslate.c;h=a4e3b9d1efac7ce7eddaabe9809e1f66e5d94ee7;hb=17d74e648ce41fb08368d2886a54f4ee74f38efe;hp=54b01b9a6e045574983da99022b2571b536872dc;hpb=ad9bc691f47d26c56fbea4d83d49468708438905;p=ghc-hetmet.git diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c index 54b01b9..a4e3b9d 100644 --- a/ghc/interpreter/translate.c +++ b/ghc/interpreter/translate.c @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: translate.c,v $ - * $Revision: 1.31 $ - * $Date: 2000/04/05 10:25:09 $ + * $Revision: 1.35 $ + * $Date: 2000/05/12 11:59:39 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -19,6 +19,7 @@ #include "connect.h" #include "errors.h" +#include "Rts.h" /* to make StgPtr visible in Assembler.h */ #include "Assembler.h" @@ -32,24 +33,6 @@ static StgExpr local stgExpr ( Cell,Int,List,StgExpr ); /* ---------------------------------------------------------------- */ -/* Association list storing globals assigned to */ -/* dictionaries, tuples, etc */ -List stgGlobals = NIL; - -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 Cell local stgOffset(Offset o, List sc) { Cell r = cellAssoc(o,sc); @@ -86,7 +69,7 @@ StgExpr failExpr; { case VAROPCELL: return stgText(textOf(e),sc); case TUPLE: - return getSTGTupleVar(e); + return e; case NAME: return e; /* Literals */ @@ -410,7 +393,8 @@ StgExpr failExpr; if ( (isName(e) && isCfun(e) && name(e).arity > 0 && name(e).arity == length_args - && !name(e).hasStrict) + && !name(e).hasStrict + && numQualifiers(name(e).type) == 0) || (isTuple(e) && tycon(e).tuple == length_args) ) { @@ -447,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 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); @@ -470,14 +458,14 @@ List scs; { /* in incr order of strict fields. */ } 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"); */ } /* -------------------------------------------------------------------------- @@ -740,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. @@ -842,7 +830,7 @@ Void implementForeignImport ( Name n ) 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; @@ -856,7 +844,7 @@ Void implementForeignImport ( Name n ) 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, @@ -864,11 +852,11 @@ Void implementForeignImport ( Name n ) 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 @@ -881,6 +869,7 @@ Void implementForeignImport ( Name n ) } + /* Generate code: * * \ fun -> @@ -891,22 +880,20 @@ Void implementForeignImport ( Name n ) 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); @@ -919,15 +906,36 @@ Void implementForeignExport ( Name n ) 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) { @@ -943,18 +951,6 @@ 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(1); e1 = mkStgVar( mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))), @@ -982,23 +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 ); } 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 ); } } @@ -1012,10 +1007,8 @@ Int what; { case POSTPREL: break; case PREPREL: case RESET: - stgGlobals=NIL; break; case MARK: - mark(stgGlobals); break; } }