X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Ftranslate.c;h=d20fd7b253754be7813747390f2ea625c3cd2c05;hb=c78b1aa635719e66b98136e8e0f015c69f428e21;hp=5bac3c1c3d5b5ea31d997e8ab70d1847877482b0;hpb=dc49719c45797614110483c9bb74c1d271578226;p=ghc-hetmet.git diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c index 5bac3c1..d20fd7b 100644 --- a/ghc/interpreter/translate.c +++ b/ghc/interpreter/translate.c @@ -3,46 +3,40 @@ * 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.3 $ - * $Date: 1999/01/13 16:47:26 $ + * $Revision: 1.33 $ + * $Date: 2000/04/06 15:05:30 $ * ------------------------------------------------------------------------*/ -#include "prelude.h" +#include "hugsbasictypes.h" #include "storage.h" #include "connect.h" #include "errors.h" -#include "stg.h" -#include "compiler.h" -#include "pmc.h" /* for discrArity */ -#include "hugs.h" /* for debugCode */ -#include "type.h" /* for conToTagType, tagToConType */ -#include "link.h" -#include "pp.h" -#include "dynamic.h" + #include "Assembler.h" -#include "translate.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)); +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 ); /* ---------------------------------------------------------------- */ -/* Association list storing globals assigned to dictionaries, tuples, etc */ +/* Association list storing globals assigned to */ +/* 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! */ @@ -78,10 +72,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 */ @@ -100,7 +95,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: @@ -118,7 +113,7 @@ List sc; { case NIL: internal("stgRhs2"); default: - return stgExpr(e,co,sc,namePMFail); + return stgExpr(e,co,sc,failExpr/*namePMFail*/); } } @@ -180,22 +175,30 @@ StgExpr failExpr; } else if (isChar(fst(hd(alts)))) { Cell alt = hd(alts); StgDiscr d = fst(alt); - StgVar c = mkStgVar(mkStgCon(nameMkC,singleton(d)),NIL); + StgVar c = mkStgVar( + mkStgCon(nameMkC,singleton(d)),NIL); StgExpr test = nameEqChar; /* duplicates scrut but it should be atomic */ - return makeStgIf(makeStgLet(singleton(c),makeStgApp(test,doubleton(scrut,c))), - stgExpr(snd(alt),co,sc,failExpr), - stgExpr(ap(CASE,pair(fst(snd(e)),tl(alts))),co,sc,failExpr)); + return makeStgIf( + makeStgLet(singleton(c), + makeStgApp(test,doubleton(scrut,c))), + stgExpr(snd(alt),co,sc,failExpr), + stgExpr(ap(CASE,pair(fst(snd(e)), + tl(alts))),co,sc,failExpr)); } else { List as = NIL; for(; nonNull(alts); alts=tl(alts)) { as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as); } - return mkStgCase(scrut, revOnto(as, singleton(mkStgDefault(mkStgVar(NIL,NIL),failExpr)))); + return mkStgCase( + scrut, + revOnto( + as, + singleton(mkStgDefault(mkStgVar(NIL,NIL), + failExpr)))); } } case NUMCASE: -#if OVERLOADED_CONSTANTS { Triple nc = snd(e); Offset o = fst3(nc); @@ -204,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 * ==> @@ -221,31 +224,37 @@ 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) */ - n = mkStgVar(mkStgApp(namePmFromInteger,doubleton(dIntegral,n)),NIL); + n = mkStgVar(mkStgApp( + namePmFromInteger,doubleton(dIntegral,n)),NIL); binds = cons(n,binds); ++co; - v = mkStgVar(mkStgApp(namePmSubtract,tripleton(dIntegral,scrut,n)),NIL); - return mkStgLet(binds, - makeStgIf(mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)), - mkStgLet(singleton(v), - stgExpr(r, - co, - cons(pair(mkOffset(co),v),sc), - failExpr)), - failExpr)); + v = mkStgVar(mkStgApp( + namePmSubtract,tripleton(dIntegral,scrut,n)),NIL); + return + mkStgLet( + binds, + makeStgIf( + mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)), + mkStgLet(singleton(v), + stgExpr(r, + co, + cons(pair(mkOffset(co),v),sc), + failExpr)), + failExpr)); } -#endif /* NPLUSK */ assert(isName(h) && argCount == 2); { @@ -266,10 +275,10 @@ StgExpr failExpr; Cell dict = arg(fun(discr)); StgExpr d = NIL; List binds = NIL; - StgExpr m = NIL; + //StgExpr m = NIL; Name box = h == nameFromInt ? nameMkI - : h == nameFromInteger ? nameMkBignum + : h == nameFromInteger ? nameMkInteger : nameMkD; Name testFun = h == nameFromInt ? namePmInt @@ -285,7 +294,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); @@ -294,52 +303,16 @@ StgExpr failExpr; n = mkStgVar(mkStgCon(box,singleton(n)),NIL); binds = cons(n,binds); - return makeStgIf(mkStgLet(binds, - mkStgApp(testFun,tripleton(d,n,scrut))), - stgExpr(r,co+da,altsc,failExpr), - failExpr); + return + makeStgIf( + mkStgLet(binds, + mkStgApp(testFun,tripleton(d,n,scrut))), + stgExpr(r,co+da,altsc,failExpr), + 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; @@ -372,21 +345,26 @@ StgExpr failExpr; as = cons(v,as); funsc = cons(pair(mkOffset(co+i),v),funsc); } - stgVarBody(nv) = mkStgLambda(as,stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail)); + stgVarBody(nv) + = mkStgLambda( + as, + stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail)); } /* transform expressions */ 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)) { @@ -398,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; @@ -411,21 +385,19 @@ StgExpr failExpr; Cell nv = mkStgVar(NIL,NIL); vs=cons(nv,vs); } - return mkStgCase(v, - doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)), - mkStgDefault(mkStgVar(NIL,NIL),namePMFail))); + return + mkStgCase(v, + doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)), + mkStgDefault(mkStgVar(NIL,NIL),namePMFail))); } /* 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); @@ -433,8 +405,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); @@ -445,182 +437,67 @@ StgExpr failExpr; } } -static Void ppExp( Name n, Int arity, Cell e ); -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 -} Void stgDefn( Name n, Int arity, Cell e ) { List vs = NIL; List sc = NIL; - Int i; -//printf("\nBEGIN --------------- stgDefn-ppExp ----------------\n" ); -// ppExp(n,arity,e); -//printf("\nEND ----------------- stgDefn-ppExp ----------------\n" ); + 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) = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail)); -//printf("\nBEGIN --------------- stgDefn-ppStg ----------------\n" ); -// ppStg(name(n).stgVar); -//printf("\nEND ----------------- stgDefn-ppStg ----------------\n" ); -} - -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; -} - -/* \ v -> case v of { ...; Ci _ _ -> i; ... } */ -Void implementConToTag(t) -Tycon t; { - if (isNull(tycon(t).conToTag)) { - List cs = tycon(t).defn; - Name nm = newName(inventText()); - StgVar v = mkStgVar(NIL,NIL); - List alts = NIL; /* can't fail */ - - assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE)); - for (; hasCfun(cs); cs=tl(cs)) { - Name c = hd(cs); - Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1; - StgVar r = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),NIL); - StgExpr tag = mkStgLet(singleton(r),r); - List vs = NIL; - Int i; - for(i=0; i < name(c).arity; ++i) { - vs = cons(mkStgVar(NIL,NIL),vs); - } - alts = cons(mkStgCaseAlt(c,vs,tag),alts); - } - - name(nm).line = tycon(t).line; - name(nm).type = conToTagType(t); - name(nm).arity = 1; - name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),NIL); - tycon(t).conToTag = nm; - /* hack to make it print out */ - stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals); - } -} - -/* \ v -> case v of { ...; i -> Ci; ... } */ -Void implementTagToCon(t) -Tycon t; { - if (isNull(tycon(t).tagToCon)) { - String etxt; - String tyconname; - List cs; - Name nm; - StgVar v1; - StgVar v2; - Cell txt0; - StgVar bind1; - StgVar bind2; - StgVar bind3; - List alts; - - assert(nameMkA); - assert(nameUnpackString); - assert(nameError); - assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE)); - - tyconname = textToStr(tycon(t).text); - etxt = malloc(100+strlen(tyconname)); - assert(etxt); - sprintf(etxt, - "out-of-range arg for `toEnum' in (derived) `instance Enum %s'", - tyconname); - - cs = tycon(t).defn; - nm = newName(inventText()); - v1 = mkStgVar(NIL,NIL); - v2 = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL); - - txt0 = mkStr(findText(etxt)); - bind1 = mkStgVar(mkStgCon(nameMkA,singleton(txt0)),NIL); - bind2 = mkStgVar(mkStgApp(nameUnpackString,singleton(bind1)), NIL); - bind3 = mkStgVar(mkStgApp(nameError,singleton(bind2)), NIL); - - alts = singleton( - mkStgPrimAlt( - singleton( - mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL) - ), - makeStgLet ( tripleton(bind1,bind2,bind3), bind3 ) - ) - ); - - for (; hasCfun(cs); cs=tl(cs)) { - Name c = hd(cs); - Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1; - StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL); - assert(name(c).arity==0); - alts = cons(mkStgPrimAlt(singleton(pat),c),alts); - } - - name(nm).line = tycon(t).line; - name(nm).type = tagToConType(t); - name(nm).arity = 1; - name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v1), - mkStgCase(v1,singleton(mkStgCaseAlt(nameMkI,singleton(v2), - mkStgPrimCase(v2,alts))))),NIL); - tycon(t).tagToCon = nm; - /* hack to make it print out */ - stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals); - if (etxt) free(etxt); - } + stgVarBody(name(n).stgVar) + = 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; - 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); +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).stgVar = v; } else { StgVar v = mkStgVar(mkStgCon(c,NIL),NIL); name(c).stgVar = v; } - /* hack to make it print out */ stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals); + /* printStg(stderr, name(c).stgVar); 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 ) { @@ -635,85 +512,79 @@ 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! */ + else if (t == typeForeign)return mkChar(FOREIGN_REP); + /* ToDo: argty only! */ #endif -#ifdef PROVIDE_ARRAY - else if (t == typePrimByteArray) return mkChar(BARR_REP); /* ToDo: argty only! */ +#if 0 + else if (t == typePrimByteArray) return mkChar(BARR_REP); + /* ToDo: argty only! */ else if (whatIs(t) == AP) { Type h = getHead(t); - if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP); /* ToDo: argty only! */ + if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP); + /* ToDo: argty only! */ } #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; } } @@ -739,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; @@ -786,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)) { @@ -826,10 +700,16 @@ String r_reps; { /* box results */ if (strcmp(r_reps,"B") == 0) { - StgPrimAlt altF = mkStgPrimAlt(singleton(mkStgPrimVar(mkInt(0),mkStgRep(INT_REP),NIL)), - nameFalse); - StgPrimAlt altT = mkStgPrimAlt(singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)), - nameTrue); + StgPrimAlt altF + = mkStgPrimAlt(singleton( + mkStgPrimVar(mkInt(0), + mkStgRep(INT_REP),NIL) + ), + nameFalse); + StgPrimAlt altT + = mkStgPrimAlt( + singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)), + nameTrue); alts = doubleton(altF,altT); assert(nonNull(nameTrue)); assert(!addState); @@ -839,28 +719,33 @@ String r_reps; { b_args = mkBoxedVars(a_reps); u_args = mkUnboxedVars(a_reps); if (addState) { - List actual_args = appendOnto(extra_args,dupListOnto(u_args,singleton(s0))); - StgRhs rhs = makeStgLambda(singleton(s0), - unboxVars(a_reps,b_args,u_args, - mkStgPrimCase(mkStgPrim(op,actual_args), - alts))); + List actual_args + = appendOnto(extra_args,dupListOnto(u_args,singleton(s0))); + StgRhs rhs + = makeStgLambda(singleton(s0), + unboxVars(a_reps,b_args,u_args, + mkStgPrimCase(mkStgPrim(op,actual_args), + alts))); StgVar m = mkStgVar(rhs,NIL); return makeStgLambda(b_args, mkStgLet(singleton(m), mkStgApp(nameMkIO,singleton(m)))); } else { List actual_args = appendOnto(extra_args,u_args); - return makeStgLambda(b_args, - unboxVars(a_reps,b_args,u_args,mkStgPrimCase(mkStgPrim(op,actual_args),alts))); + return makeStgLambda( + b_args, + unboxVars(a_reps,b_args,u_args, + mkStgPrimCase(mkStgPrim(op,actual_args),alts)) + ); } } -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; + name(n).stgVar = v; stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */ } @@ -883,15 +768,16 @@ Name n; { * }}}) * in primMkIO m * :: - * Addr -> (Int -> Float -> IO (Char,Addr) + * 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); @@ -899,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); @@ -916,34 +813,183 @@ 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(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); - name(n).defn = NIL; - name(n).stgVar = v; - stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */ + + 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); + } + + /* 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--; } } -Void implementForeignExport( Name n ) + +/* 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 + */ +Void implementForeignExport ( Name n ) { - internal("implementForeignExport: not implemented"); + 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(name(n).line) "foreign export has illegal type" ETHEN + ERRTEXT " \"" ETHEN ERRTYPE(t); + ERRTEXT "\"" + EEND; + } + + 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 { + ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN + ERRTEXT " \"" ETHEN ERRTYPE(t); + ERRTEXT "\"" + EEND; + } + resultTys = fullExpand(resultTys); + + 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, 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))), + 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).stgVar = v; + stgGlobals = cons(pair(n,v),stgGlobals); + } } Void implementTuple(size) @@ -957,7 +1003,7 @@ Int size; { stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */ } else { StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL); - stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* so we can see it */ + stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* ditto */ } } @@ -968,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; } }