X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Ftranslate.c;h=a4e3b9d1efac7ce7eddaabe9809e1f66e5d94ee7;hb=4b8c44044b7d54b0ca8e3585616bcf7d4dadb1d8;hp=b7074361b05196028266e1d882d4a7d6b0db77c1;hpb=8931116063aaf06ed2759e2b2ca2e554cfa7124f;p=ghc-hetmet.git diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c index b707436..a4e3b9d 100644 --- a/ghc/interpreter/translate.c +++ b/ghc/interpreter/translate.c @@ -3,51 +3,33 @@ * 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.5 $ - * $Date: 1999/03/01 14:46:57 $ + * $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)); -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 ); /* ---------------------------------------------------------------- */ @@ -73,10 +55,11 @@ static Cell local stgText(Text t,List sc) /* ---------------------------------------------------------------- */ -static StgRhs local stgRhs(e,co,sc) +static StgRhs local stgRhs(e,co,sc,failExpr) Cell e; Int co; -List sc; { +List sc; +StgExpr failExpr; { switch (whatIs(e)) { /* Identifiers */ @@ -86,7 +69,7 @@ List sc; { case VAROPCELL: return stgText(textOf(e),sc); case TUPLE: - return getSTGTupleVar(e); + return e; case NAME: return e; /* Literals */ @@ -95,7 +78,7 @@ List sc; { case INTCELL: return mkStgCon(nameMkI,singleton(e)); case BIGCELL: - return mkStgCon(nameMkBignum,singleton(e)); + return mkStgCon(nameMkInteger,singleton(e)); case FLOATCELL: return mkStgCon(nameMkD,singleton(e)); case STRCELL: @@ -113,7 +96,7 @@ List sc; { case NIL: internal("stgRhs2"); default: - return stgExpr(e,co,sc,namePMFail); + return stgExpr(e,co,sc,failExpr/*namePMFail*/); } } @@ -199,7 +182,6 @@ StgExpr failExpr; } } case NUMCASE: -#if OVERLOADED_CONSTANTS { Triple nc = snd(e); Offset o = fst3(nc); @@ -208,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 * ==> @@ -225,13 +207,15 @@ StgExpr failExpr; StgVar dIntegral = NIL; /* bind dictionary */ - dIntegral = stgRhs(dictIntegral,co,sc); + dIntegral = stgRhs(dictIntegral,co,sc,namePMFail); if (!isAtomic(dIntegral)) { /* wasn't atomic */ dIntegral = mkStgVar(dIntegral,NIL); binds = cons(dIntegral,binds); } + /* box number */ - n = mkStgVar(mkStgCon(nameMkBignum,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) */ @@ -254,7 +238,6 @@ StgExpr failExpr; failExpr)), failExpr)); } -#endif /* NPLUSK */ assert(isName(h) && argCount == 2); { @@ -278,7 +261,7 @@ StgExpr failExpr; //StgExpr m = NIL; Name box = h == nameFromInt ? nameMkI - : h == nameFromInteger ? nameMkBignum + : h == nameFromInteger ? nameMkInteger : nameMkD; Name testFun = h == nameFromInt ? namePmInt @@ -294,7 +277,7 @@ StgExpr failExpr; altsc = cons(pair(mkOffset(co+i),nv),altsc); } /* bind dictionary */ - d = stgRhs(dict,co,sc); + d = stgRhs(dict,co,sc,namePMFail); if (!isAtomic(d)) { /* wasn't atomic */ d = mkStgVar(d,NIL); binds = cons(d,binds); @@ -312,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; @@ -393,15 +337,17 @@ StgExpr failExpr; for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) { Cell rhs = hd(bs); Cell nv = hd(vs); - stgVarBody(nv) = stgRhs(rhs,co,sc); + stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail); } - return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc)); + 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)) { @@ -413,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; @@ -434,14 +376,11 @@ StgExpr failExpr; /* Arguments must be StgAtoms */ for(as=args; nonNull(as); as=tl(as)) { - StgRhs a = stgRhs(hd(as),co,sc); -#if 1 /* optional flattening of let bindings */ + StgRhs a = stgRhs(hd(as),co,sc,namePMFail); if (whatIs(a) == LETREC) { binds = appendOnto(stgLetBinds(a),binds); a = stgLetBody(a); } -#endif - if (!isAtomic(a)) { a = mkStgVar(a,NIL); binds = cons(a,binds); @@ -449,8 +388,28 @@ 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); + e = stgRhs(e,co,sc,namePMFail); if (!isStgVar(e) && !isName(e)) { e = mkStgVar(e,NIL); binds = cons(e,binds); @@ -461,83 +420,67 @@ StgExpr failExpr; } } -#if 0 /* apparently not used */ -static Void ppExp( Name n, Int arity, Cell e ) -{ -#if DEBUG_CODE - if (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 -} -#endif - Void stgDefn( Name n, Int arity, Cell e ) { List vs = NIL; List sc = NIL; - Int i; - // ppExp(n,arity,e); + Int i, s; for (i = 1; i <= arity; ++i) { Cell nv = mkStgVar(NIL,NIL); 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)); - //ppStg(name(n).stgVar); - //printStg(stdout, name(n).stgVar); -} - -static StgExpr forceArgs( List is, List args, StgExpr e ); - -/* force the args numbered in is */ -static StgExpr forceArgs( List is, List args, StgExpr e ) -{ - for(; nonNull(is); is=tl(is)) { - e = mkSeq(nth(intOf(hd(is))-1,args),e); - } - return e; } - 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; - //printf ( "implementCfun %s\n", textToStr(name(c).text) ); - if (name(c).arity > 0) { - List args = makeArgs(a); - StgVar tv = mkStgVar(mkStgCon(c,args),NIL); - StgExpr e1 = mkStgLet(singleton(tv),tv); - StgExpr e2 = forceArgs(scs,args,e1); - StgVar v = mkStgVar(mkStgLambda(args,e2),NIL); - name(c).stgVar = v; +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; + + /* 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); + + vcurr = v0; + for (; nonNull(scs); scs=tl(scs)) { + vsi = nth(intOf(hd(scs))-1,args); + vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL); + binds = cons(vcurr,binds); + } + binds = rev(binds); + e1 = mkStgLet(binds,vcurr); + 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; } - /* hack to make it print out */ - stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals); + addToCodeList ( currentModule, c ); + /* printStg(stderr, name(c).closure); fprintf(stderr,"\n\n"); */ } /* -------------------------------------------------------------------------- * Foreign function calls and primops * ------------------------------------------------------------------------*/ -static String charListToString( List cs ); -static Cell foreignResultTy( Type t ); -static Cell foreignArgTy( Type t ); -static Name repToBox Args(( char c )); -static StgRhs makeStgPrim Args(( Name,Bool,List,String,String )); +/* Outbound denotes data moving from Haskell world to elsewhere. + Inbound denotes data moving from elsewhere to Haskell world. +*/ +static String charListToString ( List cs ); +static Cell foreignTy ( Bool outBound, Type t ); +static Cell foreignOutboundTy ( Type t ); +static Cell foreignInboundTy ( Type t ); +static Name repToBox ( char c ); +static StgRhs makeStgPrim ( Name,Bool,List,String,String ); static String charListToString( List cs ) { @@ -552,29 +495,23 @@ static String charListToString( List cs ) return textToStr(findText(s)); } -static Cell foreignResultTy( Type t ) +static Cell foreignTy ( Bool outBound, Type t ) { if (t == typeChar) return mkChar(CHAR_REP); else if (t == typeInt) return mkChar(INT_REP); -#ifdef PROVIDE_INT64 - else if (t == typeInt64) return mkChar(INT64_REP); -#endif -#ifdef PROVIDE_INTEGER +#if 0 else if (t == typeInteger)return mkChar(INTEGER_REP); #endif -#ifdef PROVIDE_WORD else if (t == typeWord) return mkChar(WORD_REP); -#endif -#ifdef PROVIDE_ADDR else if (t == typeAddr) return mkChar(ADDR_REP); -#endif 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! */ #endif -#ifdef PROVIDE_ARRAY +#if 0 else if (t == typePrimByteArray) return mkChar(BARR_REP); /* ToDo: argty only! */ else if (whatIs(t) == AP) { @@ -584,56 +521,53 @@ static Cell foreignResultTy( Type t ) } #endif /* ToDo: decent line numbers! */ - ERRMSG(0) "Illegal foreign type" ETHEN - ERRTEXT " \"" ETHEN ERRTYPE(t); - ERRTEXT "\"" - EEND; + if (outBound) { + ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN + ERRTEXT " \"" ETHEN ERRTYPE(t); + ERRTEXT "\"" + EEND; + } else { + ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN + ERRTEXT " \"" ETHEN ERRTYPE(t); + ERRTEXT "\"" + EEND; + } } -static Cell foreignArgTy( Type t ) +static Cell foreignOutboundTy ( Type t ) { - return foreignResultTy( t ); + return foreignTy ( TRUE, t ); +} + +static Cell foreignInboundTy ( Type t ) +{ + return foreignTy ( FALSE, t ); } static Name repToBox( char c ) { switch (c) { - case CHAR_REP: return nameMkC; - case INT_REP: return nameMkI; -#ifdef PROVIDE_INT64 - case INT64_REP: return nameMkInt64; -#endif -#ifdef PROVIDE_INTEGER - case INTEGER_REP: return nameMkInteger; -#endif -#ifdef PROVIDE_WORD - case WORD_REP: return nameMkW; -#endif -#ifdef PROVIDE_ADDR - case ADDR_REP: return nameMkA; -#endif - case FLOAT_REP: return nameMkF; - case DOUBLE_REP: return nameMkD; -#ifdef PROVIDE_ARRAY - 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; -#endif -#ifdef PROVIDE_STABLE - case STABLE_REP: return nameMkStable; -#endif + 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; @@ -706,7 +644,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)) { @@ -786,13 +723,13 @@ String r_reps; { } } -Void implementPrim( n ) +Void implementPrim ( n ) 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. @@ -816,13 +753,14 @@ Name n; { * :: * Addr -> (Int -> Float -> IO (Char,Addr)) */ -Void implementForeignImport( Name n ) +Void implementForeignImport ( Name n ) { - Type t = name(n).type; + Type t = name(n).type; 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); @@ -830,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); @@ -847,49 +796,204 @@ Void implementForeignImport( Name n ) } else { resultTys = singleton(resultTys); } - mapOver(foreignArgTy,argTys); /* allows foreignObj, byteArrays, etc */ - mapOver(foreignResultTy,resultTys); /* doesn't */ - descriptor = mkDescriptor(charListToString(argTys), - charListToString(resultTys)); - name(n).primop = addState ? &ccall_IO : &ccall_Id; + mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */ + mapOver(foreignInboundTy,resultTys); /* doesn't */ + 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(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); - name(n).defn = NIL; - name(n).stgVar = v; - stgGlobals=cons(pair(n,v),stgGlobals);/*so it will get codegen'd */ + + rhs = makeStgPrim(n,addState,extra_args, + descriptor->arg_tys, + descriptor->result_tys); + v = mkStgVar(rhs,NIL); + name(n).defn = NIL; + 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 -> + let e1 = A# "...." + e3 = C# 'c' -- (ccall), or 's' (stdcall) + in primMkAdjThunk fun e1 e3 + + we require, and check that, + fun :: prim_arg* -> IO prim_result + */ +Text makeTypeDescrText ( Type t ) +{ + List argTys = NIL; + List resultTys = NIL; + List tdList; + +#if 0 + // I don't understand what this achieves. + if (getHead(t)==typeArrow && argCount==2) { + t = arg(fun(t)); + } else { + return NIL; + } +#endif + while (getHead(t)==typeArrow && argCount==2) { + Type ta = fullExpand(arg(fun(t))); + Type tr = arg(t); + argTys = cons(ta,argTys); + t = tr; + } + argTys = rev(argTys); + if (getHead(t) == typeIO) { + resultTys = getArgs(t); + assert(length(resultTys) == 1); + resultTys = hd(resultTys); + } else { + 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 ) + +Void implementForeignExport ( Name n ) { - internal("implementForeignExport: not implemented"); + 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) { + 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"); + + args = makeArgs(1); + e1 = mkStgVar( + mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))), + NIL + ); + e2 = mkStgVar( + mkStgApp(nameUnpackString,singleton(e1)), + NIL + ); + e3 = mkStgVar( + mkStgCon(nameMkC,singleton(mkChar(cc_char))), + NIL + ); + fun = mkStgLambda( + args, + mkStgLet( + tripleton(e1,e2,e3), + mkStgApp( + nameCreateAdjThunk, + cons(hd(args),cons(e2,cons(e3,NIL))) + ) + ) + ); + + v = mkStgVar(fun,NIL); + + name(n).defn = NIL; + 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 ); } } @@ -900,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; } }