2 /* --------------------------------------------------------------------------
3 * Translator: generates stg code from output of pattern matching
6 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
7 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
8 * Technology, 1994-1999, All rights reserved. It is distributed as
9 * free software under the license in the file "License", which is
10 * included in the distribution.
12 * $RCSfile: translate.c,v $
14 * $Date: 1999/10/28 14:32:07 $
15 * ------------------------------------------------------------------------*/
24 #include "Assembler.h"
27 /* ---------------------------------------------------------------- */
29 static StgVar local stgOffset Args((Offset,List));
30 static StgVar local stgText Args((Text,List));
31 static StgRhs local stgRhs Args((Cell,Int,List,StgExpr));
32 static StgCaseAlt local stgCaseAlt Args((Cell,Int,List,StgExpr));
33 static StgExpr local stgExpr Args((Cell,Int,List,StgExpr));
35 /* ---------------------------------------------------------------- */
37 /* Association list storing globals assigned to */
38 /* dictionaries, tuples, etc */
39 List stgGlobals = NIL;
41 static StgVar local getSTGTupleVar Args((Cell));
43 static StgVar local getSTGTupleVar( Cell d )
45 Pair p = cellAssoc(d,stgGlobals);
46 /* Yoiks - only the Prelude sees Tuple decls! */
48 implementTuple(tupleOf(d));
49 p = cellAssoc(d,stgGlobals);
55 /* ---------------------------------------------------------------- */
57 static Cell local stgOffset(Offset o, List sc)
59 Cell r = cellAssoc(o,sc);
64 static Cell local stgText(Text t,List sc)
67 for (; nonNull(xs); xs=tl(xs)) {
70 if (!isOffset(v) && t == textOf(v)) {
77 /* ---------------------------------------------------------------- */
79 static StgRhs local stgRhs(e,co,sc,failExpr)
88 return stgOffset(e,sc);
91 return stgText(textOf(e),sc);
93 return getSTGTupleVar(e);
98 return mkStgCon(nameMkC,singleton(e));
100 return mkStgCon(nameMkI,singleton(e));
102 return mkStgCon(nameMkInteger,singleton(e));
104 return mkStgCon(nameMkD,singleton(e));
106 #if USE_ADDR_FOR_STRINGS
108 StgVar v = mkStgVar(mkStgCon(nameMkA,singleton(e)),NIL);
109 return mkStgLet(singleton(v),
110 makeStgApp(nameUnpackString,singleton(v)));
113 return mkStgApp(nameUnpackString,singleton(e));
116 return stgExpr(e,co,sc,namePMFail);
120 return stgExpr(e,co,sc,failExpr/*namePMFail*/);
124 static StgCaseAlt local stgCaseAlt(alt,co,sc,failExpr)
130 StgDiscr d = fst(alt);
131 Int da = discrArity(d);
134 for(i=1; i<=da; ++i) {
135 StgVar nv = mkStgVar(NIL,NIL);
137 sc = cons(pair(mkOffset(co+i),nv),sc);
139 return mkStgCaseAlt(d,vs,stgExpr(snd(alt),co+da,sc,failExpr));
142 static StgExpr local stgExpr(e,co,sc,failExpr)
151 return makeStgIf(stgExpr(fst3(snd(e)),co,sc,namePMFail),
152 stgExpr(snd3(snd(e)),co,sc,failExpr),
153 stgExpr(thd3(snd(e)),co,sc,failExpr));
157 List guards = reverse(snd(e));
159 for(; nonNull(guards); guards=tl(guards)) {
161 Cell c = stgExpr(fst(g),co,sc,namePMFail);
162 Cell rhs = stgExpr(snd(g),co,sc,failExpr);
163 e = makeStgIf(c,rhs,e);
169 StgExpr e2 = stgExpr(snd(snd(e)),co,sc,failExpr);
170 StgVar alt = mkStgVar(e2,NIL);
171 return mkStgLet(singleton(alt),stgExpr(fst(snd(e)),co,sc,alt));
175 List alts = snd(snd(e));
176 Cell scrut = stgExpr(fst(snd(e)),co,sc,namePMFail);
179 } else if (isChar(fst(hd(alts)))) {
181 StgDiscr d = fst(alt);
183 mkStgCon(nameMkC,singleton(d)),NIL);
184 StgExpr test = nameEqChar;
185 /* duplicates scrut but it should be atomic */
187 makeStgLet(singleton(c),
188 makeStgApp(test,doubleton(scrut,c))),
189 stgExpr(snd(alt),co,sc,failExpr),
190 stgExpr(ap(CASE,pair(fst(snd(e)),
191 tl(alts))),co,sc,failExpr));
194 for(; nonNull(alts); alts=tl(alts)) {
195 as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
201 singleton(mkStgDefault(mkStgVar(NIL,NIL),
206 #if OVERLOADED_CONSTANTS
210 Cell discr = snd3(nc);
212 Cell scrut = stgOffset(o,sc);
213 Cell h = getHead(discr);
214 Int da = discrArity(discr);
217 if (whatIs(h) == ADDPAT && argCount == 1) {
218 /* ADDPAT num dictIntegral
220 * let n = fromInteger num in
221 * if pmLe dictIntegral n scrut
222 * then let v = pmSubtract dictIntegral scrut v
226 Cell dictIntegral = arg(discr); /* Integral dictionary */
229 StgVar dIntegral = NIL;
231 /* bind dictionary */
232 dIntegral = stgRhs(dictIntegral,co,sc,namePMFail);
233 if (!isAtomic(dIntegral)) { /* wasn't atomic */
234 dIntegral = mkStgVar(dIntegral,NIL);
235 binds = cons(dIntegral,binds);
238 n = mkStgVar(mkStgCon(nameMkInteger,singleton(n)),NIL);
239 binds = cons(n,binds);
241 /* coerce number to right type (using Integral dict) */
242 n = mkStgVar(mkStgApp(
243 namePmFromInteger,doubleton(dIntegral,n)),NIL);
244 binds = cons(n,binds);
247 v = mkStgVar(mkStgApp(
248 namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
253 mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
254 mkStgLet(singleton(v),
257 cons(pair(mkOffset(co),v),sc),
263 assert(isName(h) && argCount == 2);
265 /* This code is rather ugly.
266 * We ought to desugar it using one of the following:
267 * if (==) dEq (fromInt dNum pat) scrut
268 * if (==) dEq (fromInteger dNum pat) scrut
269 * if (==) dEq (fromFloat dFractional pat) scrut
270 * But it would be very hard to obtain the Eq dictionary
271 * from the Num or Fractional dictionary we have.
272 * Instead, we rely on the Prelude to supply 3 helper
273 * functions which do the test for us.
274 * primPmInt :: Num a => Int -> a -> Bool
275 * primPmInteger :: Num a => Integer -> a -> Bool
276 * primPmDouble :: Fractional a => Double -> a -> Bool
279 Cell dict = arg(fun(discr));
284 = h == nameFromInt ? nameMkI
285 : h == nameFromInteger ? nameMkInteger
288 = h == nameFromInt ? namePmInt
289 : h == nameFromInteger ? namePmInteger
295 for(i=1; i<=da; ++i) {
296 Cell nv = mkStgVar(NIL,NIL);
298 altsc = cons(pair(mkOffset(co+i),nv),altsc);
300 /* bind dictionary */
301 d = stgRhs(dict,co,sc,namePMFail);
302 if (!isAtomic(d)) { /* wasn't atomic */
304 binds = cons(d,binds);
307 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
308 binds = cons(n,binds);
313 mkStgApp(testFun,tripleton(d,n,scrut))),
314 stgExpr(r,co+da,altsc,failExpr),
319 #else /* ! OVERLOADED_CONSTANTS */
323 Cell discr = snd3(nc);
325 Cell scrut = stgOffset(o,sc);
326 Cell h = getHead(discr);
327 Int da = discrArity(discr);
331 = isInt(discr) ? nameEqInt
332 : isBignum(discr) ? nameEqInteger
335 = isInt(discr) ? nameMkI
336 : isBignum(discr) ? nameMkBignum
343 for(i=1; i<=da; ++i) {
344 Cell nv = mkStgVar(NIL,NIL);
346 altsc = cons(pair(mkOffset(co+i),nv),altsc);
350 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
351 binds = cons(n,binds);
353 test = mkStgLet(binds, mkStgApp(eq, doubleton(n,scrut)));
354 return makeStgIf(test,
355 stgExpr(r,co+da,altsc,failExpr),
358 #endif /* ! OVERLOADED_CONSTANTS */
364 /* allocate variables, extend scope */
365 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
366 Cell nv = mkStgVar(NIL,NIL);
367 sc = cons(pair(fst3(hd(bs)),nv),sc);
368 binds = cons(nv,binds);
371 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
372 Cell nv = mkStgVar(NIL,NIL);
373 sc = cons(pair(mkOffset(++co),nv),sc);
374 binds = cons(nv,binds);
378 /* transform functions */
379 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
384 Int arity = intOf(snd3(fun));
386 for(i=1; i<=arity; ++i) {
387 Cell v = mkStgVar(NIL,NIL);
389 funsc = cons(pair(mkOffset(co+i),v),funsc);
394 stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
396 /* transform expressions */
397 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
400 stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail);
402 return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
404 default: /* convert to an StgApp or StgVar plus some bindings */
414 args = cons(arg,args);
418 if (e == nameSel && length(args) == 3) {
421 StgVar v = stgOffset(hd(tl(args)),sc);
423 StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
425 Int ix = intOf(hd(tl(tl(args))));
426 Int da = discrArity(con);
429 for(i=1; i<=da; ++i) {
430 Cell nv = mkStgVar(NIL,NIL);
435 doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
436 mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
439 /* Arguments must be StgAtoms */
440 for(as=args; nonNull(as); as=tl(as)) {
441 StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
442 #if 1 /* optional flattening of let bindings */
443 if (whatIs(a) == LETREC) {
444 binds = appendOnto(stgLetBinds(a),binds);
451 binds = cons(a,binds);
456 /* Function must be StgVar or Name */
457 e = stgRhs(e,co,sc,namePMFail);
458 if (!isStgVar(e) && !isName(e)) {
460 binds = cons(e,binds);
463 return makeStgLet(binds,makeStgApp(e,args));
468 #if 0 /* apparently not used */
469 static Void ppExp( Name n, Int arity, Cell e )
471 if (1 || debugCode) {
473 printf("%s", textToStr(name(n).text));
474 for (i = arity; i > 0; i--) {
485 Void stgDefn( Name n, Int arity, Cell e )
490 for (i = 1; i <= arity; ++i) {
491 Cell nv = mkStgVar(NIL,NIL);
493 sc = cons(pair(mkOffset(i),nv),sc);
495 stgVarBody(name(n).stgVar)
496 = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
497 s = stgSize(stgVarBody(name(n).stgVar));
499 if (s <= SMALL_INLINE_SIZE && !name(n).inlineMe) {
500 name(n).inlineMe = TRUE;
504 Void implementCfun(c,scs) /* Build implementation for constr */
505 Name c; /* fun c. scs lists integers (1..)*/
506 List scs; { /* in incr order of strict comps. */
507 Int a = name(c).arity;
510 StgVar vcurr, e1, v, vsi;
511 List args = makeArgs(a);
512 StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
513 List binds = singleton(v0);
516 for (; nonNull(scs); scs=tl(scs)) {
517 vsi = nth(intOf(hd(scs))-1,args);
518 vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
519 binds = cons(vcurr,binds);
522 e1 = mkStgLet(binds,vcurr);
523 v = mkStgVar(mkStgLambda(args,e1),NIL);
526 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
529 name(c).inlineMe = TRUE;
530 name(c).stgSize = stgSize(stgVarBody(name(c).stgVar));
531 stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
532 /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */
535 /* --------------------------------------------------------------------------
536 * Foreign function calls and primops
537 * ------------------------------------------------------------------------*/
539 /* Outbound denotes data moving from Haskell world to elsewhere.
540 Inbound denotes data moving from elsewhere to Haskell world.
542 static String charListToString ( List cs );
543 static Cell foreignTy ( Bool outBound, Type t );
544 static Cell foreignOutboundTy ( Type t );
545 static Cell foreignInboundTy ( Type t );
546 static Name repToBox ( char c );
547 static StgRhs makeStgPrim ( Name,Bool,List,String,String );
549 static String charListToString( List cs )
554 assert( length(cs) < 100 );
555 for(; nonNull(cs); ++i, cs=tl(cs)) {
556 s[i] = charOf(hd(cs));
559 return textToStr(findText(s));
562 static Cell foreignTy ( Bool outBound, Type t )
564 if (t == typeChar) return mkChar(CHAR_REP);
565 else if (t == typeInt) return mkChar(INT_REP);
567 else if (t == typeInteger)return mkChar(INTEGER_REP);
569 else if (t == typeWord) return mkChar(WORD_REP);
570 else if (t == typeAddr) return mkChar(ADDR_REP);
571 else if (t == typeFloat) return mkChar(FLOAT_REP);
572 else if (t == typeDouble) return mkChar(DOUBLE_REP);
573 else if (t == typeStable) return mkChar(STABLE_REP);
574 #ifdef PROVIDE_FOREIGN
575 else if (t == typeForeign)return mkChar(FOREIGN_REP);
576 /* ToDo: argty only! */
579 else if (t == typePrimByteArray) return mkChar(BARR_REP);
580 /* ToDo: argty only! */
581 else if (whatIs(t) == AP) {
583 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
584 /* ToDo: argty only! */
587 /* ToDo: decent line numbers! */
589 ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
590 ERRTEXT " \"" ETHEN ERRTYPE(t);
594 ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
595 ERRTEXT " \"" ETHEN ERRTYPE(t);
601 static Cell foreignOutboundTy ( Type t )
603 return foreignTy ( TRUE, t );
606 static Cell foreignInboundTy ( Type t )
608 return foreignTy ( FALSE, t );
611 static Name repToBox( char c )
614 case CHAR_REP: return nameMkC;
615 case INT_REP: return nameMkI;
616 case INTEGER_REP: return nameMkInteger;
617 case WORD_REP: return nameMkW;
618 case ADDR_REP: return nameMkA;
619 case FLOAT_REP: return nameMkF;
620 case DOUBLE_REP: return nameMkD;
621 case ARR_REP: return nameMkPrimArray;
622 case BARR_REP: return nameMkPrimByteArray;
623 case REF_REP: return nameMkRef;
624 case MUTARR_REP: return nameMkPrimMutableArray;
625 case MUTBARR_REP: return nameMkPrimMutableByteArray;
626 case STABLE_REP: return nameMkStable;
628 case WEAK_REP: return nameMkWeak;
630 #ifdef PROVIDE_FOREIGN
631 case FOREIGN_REP: return nameMkForeign;
633 #ifdef PROVIDE_CONCURRENT
634 case THREADID_REP: return nameMkThreadId;
635 case MVAR_REP: return nameMkMVar;
641 static StgPrimAlt boxResults( String reps, StgVar state )
643 List rs = NIL; /* possibly unboxed results */
644 List bs = NIL; /* boxed results of wrapper */
645 List rbinds = NIL; /* bindings used to box results */
648 for(i=0; reps[i] != '\0'; ++i) {
649 StgRep k = mkStgRep(reps[i]);
650 Cell v = mkStgPrimVar(NIL,k,NIL);
651 Name box = repToBox(reps[i]);
655 StgRhs rhs = mkStgCon(box,singleton(v));
656 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
658 rbinds = cons(bv,rbinds);
662 /* Construct tuple of results */
665 } else { /* includes i==0 case */
666 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
667 rbinds = cons(r,rbinds);
670 /* construct result pair if needed */
671 if (nonNull(state)) {
672 /* Note that this builds a tuple directly - we know it's
675 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
676 rbinds = cons(r,rbinds);
677 rs = cons(state,rs); /* last result is a state */
680 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
683 static List mkUnboxedVars( String reps )
687 for(i=0; reps[i] != '\0'; ++i) {
688 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
694 static List mkBoxedVars( String reps )
698 for(i=0; reps[i] != '\0'; ++i) {
699 as = cons(mkStgVar(NIL,NIL),as);
704 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
706 if (nonNull(b_args)) {
707 StgVar b_arg = hd(b_args); /* boxed arg */
708 StgVar u_arg = hd(u_args); /* unboxed arg */
709 Name box = repToBox(*reps);
710 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
712 /* Use a trivial let-binding */
713 stgVarBody(u_arg) = b_arg;
714 return mkStgLet(singleton(u_arg),e);
716 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
717 return mkStgCase(b_arg,singleton(alt));
724 /* Generate wrapper for primop based on list of arg types and result types:
726 * makeStgPrim op# False "II" "II" =
727 * \ x y -> "case x of { I# x# ->
728 * case y of { I# y# ->
729 * case op#{x#,y#} of { r1# r2# ->
730 * let r1 = I# r1#; r2 = I# r2# in
734 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
740 List b_args = NIL; /* boxed args to primop */
741 List u_args = NIL; /* possibly unboxed args to primop */
743 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
744 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
747 if (strcmp(r_reps,"B") == 0) {
749 = mkStgPrimAlt(singleton(
750 mkStgPrimVar(mkInt(0),
751 mkStgRep(INT_REP),NIL)
756 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
758 alts = doubleton(altF,altT);
759 assert(nonNull(nameTrue));
762 alts = singleton(boxResults(r_reps,s1));
764 b_args = mkBoxedVars(a_reps);
765 u_args = mkUnboxedVars(a_reps);
768 = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
770 = makeStgLambda(singleton(s0),
771 unboxVars(a_reps,b_args,u_args,
772 mkStgPrimCase(mkStgPrim(op,actual_args),
774 StgVar m = mkStgVar(rhs,NIL);
775 return makeStgLambda(b_args,
776 mkStgLet(singleton(m),
777 mkStgApp(nameMkIO,singleton(m))));
779 List actual_args = appendOnto(extra_args,u_args);
780 return makeStgLambda(
782 unboxVars(a_reps,b_args,u_args,
783 mkStgPrimCase(mkStgPrim(op,actual_args),alts))
788 Void implementPrim ( n )
790 const AsmPrim* p = name(n).primop;
791 StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
792 StgVar v = mkStgVar(rhs,NIL);
794 name(n).stgSize = stgSize(stgVarBody(v));
795 name(n).inlineMe = TRUE;
796 stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
799 /* Generate wrapper code from (in,out) type lists.
803 * inTypes = [Int,Float]
804 * outTypes = [Char,Addr]
808 * case a1 of { I# a1# ->
809 * case s2 of { F# a2# ->
810 * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
818 * Addr -> (Int -> Float -> IO (Char,Addr))
820 Void implementForeignImport ( Name n )
822 Type t = name(n).type;
824 List resultTys = NIL;
825 CFunDescriptor* descriptor = 0;
826 Bool addState = TRUE;
827 while (getHead(t)==typeArrow && argCount==2) {
828 Type ta = fullExpand(arg(fun(t)));
830 argTys = cons(ta,argTys);
833 argTys = rev(argTys);
834 if (getHead(t) == typeIO) {
835 resultTys = getArgs(t);
836 assert(length(resultTys) == 1);
837 resultTys = hd(resultTys);
843 resultTys = fullExpand(resultTys);
844 if (isTuple(getHead(resultTys))) {
845 resultTys = getArgs(resultTys);
846 } else if (getHead(resultTys) == typeUnit) {
849 resultTys = singleton(resultTys);
851 mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */
852 mapOver(foreignInboundTy,resultTys); /* doesn't */
853 descriptor = mkDescriptor(charListToString(argTys),
854 charListToString(resultTys));
856 ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
860 /* ccall is the default convention, if it wasn't specified */
861 if (isNull(name(n).callconv)
862 || name(n).callconv == textCcall) {
863 name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
865 else if (name(n).callconv == textStdcall) {
866 if (!stdcallAllowed()) {
867 ERRMSG(name(n).line) "stdcall is not supported on this platform"
870 name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
873 internal ( "implementForeignImport: unknown calling convention");
876 Pair extName = name(n).defn;
877 void* funPtr = getDLLSymbol(name(n).line,
878 textToStr(textOf(fst(extName))),
879 textToStr(textOf(snd(extName))));
880 List extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
881 StgRhs rhs = makeStgPrim(n,addState,extra_args,descriptor->arg_tys,
882 descriptor->result_tys);
883 StgVar v = mkStgVar(rhs,NIL);
885 ERRMSG(name(n).line) "Could not find foreign function \"%s\" in \"%s\"",
886 textToStr(textOf(snd(extName))),
887 textToStr(textOf(fst(extName)))
893 name(n).stgSize = stgSize(stgVarBody(v));
894 name(n).inlineMe = TRUE;
895 stgGlobals=cons(pair(n,v),stgGlobals);/*so it will get codegen'd */
904 e3 = C# 'c' -- (ccall), or 's' (stdcall)
905 in primMkAdjThunk fun e1 e3 s0
907 we require, and check that,
908 fun :: prim_arg* -> IO prim_result
910 Void implementForeignExport ( Name n )
912 Type t = name(n).type;
914 List resultTys = NIL;
917 if (getHead(t)==typeArrow && argCount==2) {
920 ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
921 ERRTEXT " \"" ETHEN ERRTYPE(t);
926 while (getHead(t)==typeArrow && argCount==2) {
927 Type ta = fullExpand(arg(fun(t)));
929 argTys = cons(ta,argTys);
932 argTys = rev(argTys);
933 if (getHead(t) == typeIO) {
934 resultTys = getArgs(t);
935 assert(length(resultTys) == 1);
936 resultTys = hd(resultTys);
938 ERRMSG(name(n).line) "foreign export doesn't return an IO type" ETHEN
939 ERRTEXT " \"" ETHEN ERRTYPE(t);
943 resultTys = fullExpand(resultTys);
945 mapOver(foreignInboundTy,argTys);
947 /* ccall is the default convention, if it wasn't specified */
948 if (isNull(name(n).callconv)
949 || name(n).callconv == textCcall) {
952 else if (name(n).callconv == textStdcall) {
953 if (!stdcallAllowed()) {
954 ERRMSG(name(n).line) "stdcall is not supported on this platform"
960 internal ( "implementForeignExport: unknown calling convention");
967 StgVar e1, e2, e3, v;
970 tdList = cons(mkChar(':'),argTys);
971 if (resultTys != typeUnit)
972 tdList = cons(foreignOutboundTy(resultTys),tdList);
974 tdText = findText(charListToString ( tdList ));
977 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
981 mkStgApp(nameUnpackString,singleton(e1)),
985 mkStgCon(nameMkC,singleton(mkChar(cc_char))),
994 cons(hd(args),cons(e2,cons(e3,cons(hd(tl(args)),NIL))))
999 v = mkStgVar(fun,NIL);
1004 name(n).stgSize = stgSize(stgVarBody(v));
1005 name(n).inlineMe = FALSE;
1006 stgGlobals = cons(pair(n,v),stgGlobals);
1010 // ToDo: figure out how to set inlineMe for these (non-Name) things
1011 Void implementTuple(size)
1014 Cell t = mkTuple(size);
1015 List args = makeArgs(size);
1016 StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
1017 StgExpr e = mkStgLet(singleton(tv),tv);
1018 StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
1019 stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
1021 StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
1022 stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* ditto */
1026 /* --------------------------------------------------------------------------
1028 * ------------------------------------------------------------------------*/
1030 Void translateControl(what)
1035 /* deliberate fall through */
1046 /*-------------------------------------------------------------------------*/