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/12/06 16:25:27 $
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),
209 Cell discr = snd3(nc);
211 Cell scrut = stgOffset(o,sc);
212 Cell h = getHead(discr);
213 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);
239 sprintf(str, "%d", n);
240 n = mkStgVar(mkStgCon(nameMkInteger,singleton(stringToBignum(str))),NIL);
241 binds = cons(n,binds);
243 /* coerce number to right type (using Integral dict) */
244 n = mkStgVar(mkStgApp(
245 namePmFromInteger,doubleton(dIntegral,n)),NIL);
246 binds = cons(n,binds);
249 v = mkStgVar(mkStgApp(
250 namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
255 mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
256 mkStgLet(singleton(v),
259 cons(pair(mkOffset(co),v),sc),
265 assert(isName(h) && argCount == 2);
267 /* This code is rather ugly.
268 * We ought to desugar it using one of the following:
269 * if (==) dEq (fromInt dNum pat) scrut
270 * if (==) dEq (fromInteger dNum pat) scrut
271 * if (==) dEq (fromFloat dFractional pat) scrut
272 * But it would be very hard to obtain the Eq dictionary
273 * from the Num or Fractional dictionary we have.
274 * Instead, we rely on the Prelude to supply 3 helper
275 * functions which do the test for us.
276 * primPmInt :: Num a => Int -> a -> Bool
277 * primPmInteger :: Num a => Integer -> a -> Bool
278 * primPmDouble :: Fractional a => Double -> a -> Bool
281 Cell dict = arg(fun(discr));
286 = h == nameFromInt ? nameMkI
287 : h == nameFromInteger ? nameMkInteger
290 = h == nameFromInt ? namePmInt
291 : h == nameFromInteger ? namePmInteger
297 for(i=1; i<=da; ++i) {
298 Cell nv = mkStgVar(NIL,NIL);
300 altsc = cons(pair(mkOffset(co+i),nv),altsc);
302 /* bind dictionary */
303 d = stgRhs(dict,co,sc,namePMFail);
304 if (!isAtomic(d)) { /* wasn't atomic */
306 binds = cons(d,binds);
309 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
310 binds = cons(n,binds);
315 mkStgApp(testFun,tripleton(d,n,scrut))),
316 stgExpr(r,co+da,altsc,failExpr),
327 /* allocate variables, extend scope */
328 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
329 Cell nv = mkStgVar(NIL,NIL);
330 sc = cons(pair(fst3(hd(bs)),nv),sc);
331 binds = cons(nv,binds);
334 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
335 Cell nv = mkStgVar(NIL,NIL);
336 sc = cons(pair(mkOffset(++co),nv),sc);
337 binds = cons(nv,binds);
341 /* transform functions */
342 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
347 Int arity = intOf(snd3(fun));
349 for(i=1; i<=arity; ++i) {
350 Cell v = mkStgVar(NIL,NIL);
352 funsc = cons(pair(mkOffset(co+i),v),funsc);
357 stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
359 /* transform expressions */
360 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
363 stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail);
365 return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
368 default: /* convert to an StgApp or StgVar plus some bindings */
378 args = cons(arg,args);
382 if (e == nameSel && length(args) == 3) {
384 StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
385 Int ix = intOf(hd(tl(tl(args))));
386 Int da = discrArity(con);
389 for(i=1; i<=da; ++i) {
390 Cell nv = mkStgVar(NIL,NIL);
395 doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
396 mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
399 /* Arguments must be StgAtoms */
400 for(as=args; nonNull(as); as=tl(as)) {
401 StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
402 if (whatIs(a) == LETREC) {
403 binds = appendOnto(stgLetBinds(a),binds);
408 binds = cons(a,binds);
413 /* Special case: saturated constructor application */
414 if (isName(e) && isCfun(e)
416 && name(e).arity == length(args)) {
418 /* fprintf ( stderr, "saturated application of %s\n",
419 textToStr(name(e).text)); */
420 v = mkStgVar(mkStgCon(e,args),NIL);
421 binds = cons(v,binds);
422 return mkStgLet(binds,v);
427 /* Function must be StgVar or Name */
428 e = stgRhs(e,co,sc,namePMFail);
429 if (!isStgVar(e) && !isName(e)) {
431 binds = cons(e,binds);
434 return makeStgLet(binds,makeStgApp(e,args));
439 #if 0 /* apparently not used */
440 static Void ppExp( Name n, Int arity, Cell e )
442 if (1 || debugCode) {
444 printf("%s", textToStr(name(n).text));
445 for (i = arity; i > 0; i--) {
456 Void stgDefn( Name n, Int arity, Cell e )
461 for (i = 1; i <= arity; ++i) {
462 Cell nv = mkStgVar(NIL,NIL);
464 sc = cons(pair(mkOffset(i),nv),sc);
466 stgVarBody(name(n).stgVar)
467 = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
470 Void implementCfun(c,scs) /* Build implementation for constr */
471 Name c; /* fun c. scs lists integers (1..)*/
472 List scs; { /* in incr order of strict fields. */
473 Int a = name(c).arity;
476 StgVar vcurr, e1, v, vsi;
477 List args = makeArgs(a);
478 StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
479 List binds = singleton(v0);
482 for (; nonNull(scs); scs=tl(scs)) {
483 vsi = nth(intOf(hd(scs))-1,args);
484 vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
485 binds = cons(vcurr,binds);
488 e1 = mkStgLet(binds,vcurr);
489 v = mkStgVar(mkStgLambda(args,e1),NIL);
492 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
495 stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
496 /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */
499 /* --------------------------------------------------------------------------
500 * Foreign function calls and primops
501 * ------------------------------------------------------------------------*/
503 /* Outbound denotes data moving from Haskell world to elsewhere.
504 Inbound denotes data moving from elsewhere to Haskell world.
506 static String charListToString ( List cs );
507 static Cell foreignTy ( Bool outBound, Type t );
508 static Cell foreignOutboundTy ( Type t );
509 static Cell foreignInboundTy ( Type t );
510 static Name repToBox ( char c );
511 static StgRhs makeStgPrim ( Name,Bool,List,String,String );
513 static String charListToString( List cs )
518 assert( length(cs) < 100 );
519 for(; nonNull(cs); ++i, cs=tl(cs)) {
520 s[i] = charOf(hd(cs));
523 return textToStr(findText(s));
526 static Cell foreignTy ( Bool outBound, Type t )
528 if (t == typeChar) return mkChar(CHAR_REP);
529 else if (t == typeInt) return mkChar(INT_REP);
531 else if (t == typeInteger)return mkChar(INTEGER_REP);
533 else if (t == typeWord) return mkChar(WORD_REP);
534 else if (t == typeAddr) return mkChar(ADDR_REP);
535 else if (t == typeFloat) return mkChar(FLOAT_REP);
536 else if (t == typeDouble) return mkChar(DOUBLE_REP);
537 else if (t == typeStable) return mkChar(STABLE_REP);
538 #ifdef PROVIDE_FOREIGN
539 else if (t == typeForeign)return mkChar(FOREIGN_REP);
540 /* ToDo: argty only! */
543 else if (t == typePrimByteArray) return mkChar(BARR_REP);
544 /* ToDo: argty only! */
545 else if (whatIs(t) == AP) {
547 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
548 /* ToDo: argty only! */
551 /* ToDo: decent line numbers! */
553 ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
554 ERRTEXT " \"" ETHEN ERRTYPE(t);
558 ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
559 ERRTEXT " \"" ETHEN ERRTYPE(t);
565 static Cell foreignOutboundTy ( Type t )
567 return foreignTy ( TRUE, t );
570 static Cell foreignInboundTy ( Type t )
572 return foreignTy ( FALSE, t );
575 static Name repToBox( char c )
578 case CHAR_REP: return nameMkC;
579 case INT_REP: return nameMkI;
580 case INTEGER_REP: return nameMkInteger;
581 case WORD_REP: return nameMkW;
582 case ADDR_REP: return nameMkA;
583 case FLOAT_REP: return nameMkF;
584 case DOUBLE_REP: return nameMkD;
585 case ARR_REP: return nameMkPrimArray;
586 case BARR_REP: return nameMkPrimByteArray;
587 case REF_REP: return nameMkRef;
588 case MUTARR_REP: return nameMkPrimMutableArray;
589 case MUTBARR_REP: return nameMkPrimMutableByteArray;
590 case STABLE_REP: return nameMkStable;
591 case THREADID_REP: return nameMkThreadId;
592 case MVAR_REP: return nameMkPrimMVar;
594 case WEAK_REP: return nameMkWeak;
596 #ifdef PROVIDE_FOREIGN
597 case FOREIGN_REP: return nameMkForeign;
603 static StgPrimAlt boxResults( String reps, StgVar state )
605 List rs = NIL; /* possibly unboxed results */
606 List bs = NIL; /* boxed results of wrapper */
607 List rbinds = NIL; /* bindings used to box results */
610 for(i=0; reps[i] != '\0'; ++i) {
611 StgRep k = mkStgRep(reps[i]);
612 Cell v = mkStgPrimVar(NIL,k,NIL);
613 Name box = repToBox(reps[i]);
617 StgRhs rhs = mkStgCon(box,singleton(v));
618 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
620 rbinds = cons(bv,rbinds);
625 /* Construct tuple of results */
632 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
633 rbinds = cons(r,rbinds);
636 /* construct result pair if needed */
637 if (nonNull(state)) {
638 /* Note that this builds a tuple directly - we know it's
641 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
642 rbinds = cons(r,rbinds);
643 rs = cons(state,rs); /* last result is a state */
646 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
649 static List mkUnboxedVars( String reps )
653 for(i=0; reps[i] != '\0'; ++i) {
654 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
660 static List mkBoxedVars( String reps )
664 for(i=0; reps[i] != '\0'; ++i) {
665 as = cons(mkStgVar(NIL,NIL),as);
670 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
672 if (nonNull(b_args)) {
673 StgVar b_arg = hd(b_args); /* boxed arg */
674 StgVar u_arg = hd(u_args); /* unboxed arg */
675 Name box = repToBox(*reps);
676 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
678 /* Use a trivial let-binding */
679 stgVarBody(u_arg) = b_arg;
680 return mkStgLet(singleton(u_arg),e);
682 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
683 return mkStgCase(b_arg,singleton(alt));
690 /* Generate wrapper for primop based on list of arg types and result types:
692 * makeStgPrim op# False "II" "II" =
693 * \ x y -> "case x of { I# x# ->
694 * case y of { I# y# ->
695 * case op#{x#,y#} of { r1# r2# ->
696 * let r1 = I# r1#; r2 = I# r2# in
700 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
706 List b_args = NIL; /* boxed args to primop */
707 List u_args = NIL; /* possibly unboxed args to primop */
709 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
710 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
713 if (strcmp(r_reps,"B") == 0) {
715 = mkStgPrimAlt(singleton(
716 mkStgPrimVar(mkInt(0),
717 mkStgRep(INT_REP),NIL)
722 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
724 alts = doubleton(altF,altT);
725 assert(nonNull(nameTrue));
728 alts = singleton(boxResults(r_reps,s1));
730 b_args = mkBoxedVars(a_reps);
731 u_args = mkUnboxedVars(a_reps);
734 = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
736 = makeStgLambda(singleton(s0),
737 unboxVars(a_reps,b_args,u_args,
738 mkStgPrimCase(mkStgPrim(op,actual_args),
740 StgVar m = mkStgVar(rhs,NIL);
741 return makeStgLambda(b_args,
742 mkStgLet(singleton(m),
743 mkStgApp(nameMkIO,singleton(m))));
745 List actual_args = appendOnto(extra_args,u_args);
746 return makeStgLambda(
748 unboxVars(a_reps,b_args,u_args,
749 mkStgPrimCase(mkStgPrim(op,actual_args),alts))
754 Void implementPrim ( n )
756 const AsmPrim* p = name(n).primop;
757 StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
758 StgVar v = mkStgVar(rhs,NIL);
760 stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
763 /* Generate wrapper code from (in,out) type lists.
767 * inTypes = [Int,Float]
768 * outTypes = [Char,Addr]
772 * case a1 of { I# a1# ->
773 * case s2 of { F# a2# ->
774 * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
782 * Addr -> (Int -> Float -> IO (Char,Addr))
784 Void implementForeignImport ( Name n )
786 Type t = name(n).type;
788 List resultTys = NIL;
789 CFunDescriptor* descriptor = 0;
790 Bool addState = TRUE;
791 Bool dynamic = isNull(name(n).defn);
792 while (getHead(t)==typeArrow && argCount==2) {
793 Type ta = fullExpand(arg(fun(t)));
795 argTys = cons(ta,argTys);
798 argTys = rev(argTys);
800 /* argTys now holds the argument tys. If this is a dynamic call,
801 the first one had better be an Addr.
804 if (isNull(argTys) || hd(argTys) != typeAddr) {
805 ERRMSG(name(n).line) "First argument in f-i-dynamic must be an Addr"
810 if (getHead(t) == typeIO) {
811 resultTys = getArgs(t);
812 assert(length(resultTys) == 1);
813 resultTys = hd(resultTys);
819 resultTys = fullExpand(resultTys);
820 if (isTuple(getHead(resultTys))) {
821 resultTys = getArgs(resultTys);
822 } else if (getHead(resultTys) == typeUnit) {
825 resultTys = singleton(resultTys);
827 mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */
828 mapOver(foreignInboundTy,resultTys); /* doesn't */
830 = mkDescriptor(charListToString(argTys),
831 charListToString(resultTys));
833 ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
837 /* ccall is the default convention, if it wasn't specified */
838 if (isNull(name(n).callconv)
839 || name(n).callconv == textCcall) {
840 name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
842 else if (name(n).callconv == textStdcall) {
843 if (!stdcallAllowed()) {
844 ERRMSG(name(n).line) "stdcall is not supported on this platform"
847 name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
850 internal ( "implementForeignImport: unknown calling convention");
861 extra_args = singleton(mkPtr(descriptor));
862 /* and we know that the first arg will be the function pointer */
864 extName = name(n).defn;
865 funPtr = getDLLSymbol(name(n).line,
866 textToStr(textOf(fst(extName))),
867 textToStr(textOf(snd(extName))));
870 "Could not find foreign function \"%s\" in \"%s\"",
871 textToStr(textOf(snd(extName))),
872 textToStr(textOf(fst(extName)))
875 extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
878 rhs = makeStgPrim(n,addState,extra_args,
880 descriptor->result_tys);
881 v = mkStgVar(rhs,NIL);
884 stgGlobals = cons(pair(n,v),stgGlobals);
887 /* At this point the descriptor contains a tags for all args,
888 because that makes makeStgPrim generate the correct unwrap
889 code. From now on, the descriptor is only used at the time
890 the actual ccall is made. So we need to zap the leading
891 addr arg IF this is a f-i-dynamic call.
894 descriptor->arg_tys++;
895 descriptor->num_args--;
906 e3 = C# 'c' -- (ccall), or 's' (stdcall)
907 in primMkAdjThunk fun e1 e3 s0
909 we require, and check that,
910 fun :: prim_arg* -> IO prim_result
912 Void implementForeignExport ( Name n )
914 Type t = name(n).type;
916 List resultTys = NIL;
919 if (getHead(t)==typeArrow && argCount==2) {
922 ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
923 ERRTEXT " \"" ETHEN ERRTYPE(t);
928 while (getHead(t)==typeArrow && argCount==2) {
929 Type ta = fullExpand(arg(fun(t)));
931 argTys = cons(ta,argTys);
934 argTys = rev(argTys);
935 if (getHead(t) == typeIO) {
936 resultTys = getArgs(t);
937 assert(length(resultTys) == 1);
938 resultTys = hd(resultTys);
940 ERRMSG(name(n).line) "foreign export doesn't return an IO type" ETHEN
941 ERRTEXT " \"" ETHEN ERRTYPE(t);
945 resultTys = fullExpand(resultTys);
947 mapOver(foreignInboundTy,argTys);
949 /* ccall is the default convention, if it wasn't specified */
950 if (isNull(name(n).callconv)
951 || name(n).callconv == textCcall) {
954 else if (name(n).callconv == textStdcall) {
955 if (!stdcallAllowed()) {
956 ERRMSG(name(n).line) "stdcall is not supported on this platform"
962 internal ( "implementForeignExport: unknown calling convention");
969 StgVar e1, e2, e3, v;
972 tdList = cons(mkChar(':'),argTys);
973 if (resultTys != typeUnit)
974 tdList = cons(foreignOutboundTy(resultTys),tdList);
976 tdText = findText(charListToString ( tdList ));
979 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
983 mkStgApp(nameUnpackString,singleton(e1)),
987 mkStgCon(nameMkC,singleton(mkChar(cc_char))),
996 cons(hd(args),cons(e2,cons(e3,cons(hd(tl(args)),NIL))))
1001 v = mkStgVar(fun,NIL);
1005 stgGlobals = cons(pair(n,v),stgGlobals);
1009 Void implementTuple(size)
1012 Cell t = mkTuple(size);
1013 List args = makeArgs(size);
1014 StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
1015 StgExpr e = mkStgLet(singleton(tv),tv);
1016 StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
1017 stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
1019 StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
1020 stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* ditto */
1024 /* --------------------------------------------------------------------------
1026 * ------------------------------------------------------------------------*/
1028 Void translateControl(what)
1033 /* deliberate fall through */
1044 /*-------------------------------------------------------------------------*/