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: 2000/03/10 20:03:37 $
15 * ------------------------------------------------------------------------*/
23 #include "Assembler.h"
26 /* ---------------------------------------------------------------- */
28 static StgVar local stgOffset Args((Offset,List));
29 static StgVar local stgText Args((Text,List));
30 static StgRhs local stgRhs Args((Cell,Int,List,StgExpr));
31 static StgCaseAlt local stgCaseAlt Args((Cell,Int,List,StgExpr));
32 static StgExpr local stgExpr Args((Cell,Int,List,StgExpr));
34 /* ---------------------------------------------------------------- */
36 /* Association list storing globals assigned to */
37 /* dictionaries, tuples, etc */
38 List stgGlobals = NIL;
40 static StgVar local getSTGTupleVar Args((Cell));
42 static StgVar local getSTGTupleVar( Cell d )
44 Pair p = cellAssoc(d,stgGlobals);
45 /* Yoiks - only the Prelude sees Tuple decls! */
47 implementTuple(tupleOf(d));
48 p = cellAssoc(d,stgGlobals);
54 /* ---------------------------------------------------------------- */
56 static Cell local stgOffset(Offset o, List sc)
58 Cell r = cellAssoc(o,sc);
63 static Cell local stgText(Text t,List sc)
66 for (; nonNull(xs); xs=tl(xs)) {
69 if (!isOffset(v) && t == textOf(v)) {
76 /* ---------------------------------------------------------------- */
78 static StgRhs local stgRhs(e,co,sc,failExpr)
87 return stgOffset(e,sc);
90 return stgText(textOf(e),sc);
92 return getSTGTupleVar(e);
97 return mkStgCon(nameMkC,singleton(e));
99 return mkStgCon(nameMkI,singleton(e));
101 return mkStgCon(nameMkInteger,singleton(e));
103 return mkStgCon(nameMkD,singleton(e));
105 #if USE_ADDR_FOR_STRINGS
107 StgVar v = mkStgVar(mkStgCon(nameMkA,singleton(e)),NIL);
108 return mkStgLet(singleton(v),
109 makeStgApp(nameUnpackString,singleton(v)));
112 return mkStgApp(nameUnpackString,singleton(e));
115 return stgExpr(e,co,sc,namePMFail);
119 return stgExpr(e,co,sc,failExpr/*namePMFail*/);
123 static StgCaseAlt local stgCaseAlt(alt,co,sc,failExpr)
129 StgDiscr d = fst(alt);
130 Int da = discrArity(d);
133 for(i=1; i<=da; ++i) {
134 StgVar nv = mkStgVar(NIL,NIL);
136 sc = cons(pair(mkOffset(co+i),nv),sc);
138 return mkStgCaseAlt(d,vs,stgExpr(snd(alt),co+da,sc,failExpr));
141 static StgExpr local stgExpr(e,co,sc,failExpr)
150 return makeStgIf(stgExpr(fst3(snd(e)),co,sc,namePMFail),
151 stgExpr(snd3(snd(e)),co,sc,failExpr),
152 stgExpr(thd3(snd(e)),co,sc,failExpr));
156 List guards = reverse(snd(e));
158 for(; nonNull(guards); guards=tl(guards)) {
160 Cell c = stgExpr(fst(g),co,sc,namePMFail);
161 Cell rhs = stgExpr(snd(g),co,sc,failExpr);
162 e = makeStgIf(c,rhs,e);
168 StgExpr e2 = stgExpr(snd(snd(e)),co,sc,failExpr);
169 StgVar alt = mkStgVar(e2,NIL);
170 return mkStgLet(singleton(alt),stgExpr(fst(snd(e)),co,sc,alt));
174 List alts = snd(snd(e));
175 Cell scrut = stgExpr(fst(snd(e)),co,sc,namePMFail);
178 } else if (isChar(fst(hd(alts)))) {
180 StgDiscr d = fst(alt);
182 mkStgCon(nameMkC,singleton(d)),NIL);
183 StgExpr test = nameEqChar;
184 /* duplicates scrut but it should be atomic */
186 makeStgLet(singleton(c),
187 makeStgApp(test,doubleton(scrut,c))),
188 stgExpr(snd(alt),co,sc,failExpr),
189 stgExpr(ap(CASE,pair(fst(snd(e)),
190 tl(alts))),co,sc,failExpr));
193 for(; nonNull(alts); alts=tl(alts)) {
194 as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
200 singleton(mkStgDefault(mkStgVar(NIL,NIL),
208 Cell discr = snd3(nc);
210 Cell scrut = stgOffset(o,sc);
211 Cell h = getHead(discr);
212 Int da = discrArity(discr);
215 if (whatIs(h) == ADDPAT && argCount == 1) {
216 /* ADDPAT num dictIntegral
218 * let n = fromInteger num in
219 * if pmLe dictIntegral n scrut
220 * then let v = pmSubtract dictIntegral scrut v
224 Cell dictIntegral = arg(discr); /* Integral dictionary */
227 StgVar dIntegral = NIL;
229 /* bind dictionary */
230 dIntegral = stgRhs(dictIntegral,co,sc,namePMFail);
231 if (!isAtomic(dIntegral)) { /* wasn't atomic */
232 dIntegral = mkStgVar(dIntegral,NIL);
233 binds = cons(dIntegral,binds);
237 sprintf(str, "%d", n);
238 n = mkStgVar(mkStgCon(nameMkInteger,singleton(stringToBignum(str))),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),
262 assert(isName(h) && argCount == 2);
264 /* This code is rather ugly.
265 * We ought to desugar it using one of the following:
266 * if (==) dEq (fromInt dNum pat) scrut
267 * if (==) dEq (fromInteger dNum pat) scrut
268 * if (==) dEq (fromFloat dFractional pat) scrut
269 * But it would be very hard to obtain the Eq dictionary
270 * from the Num or Fractional dictionary we have.
271 * Instead, we rely on the Prelude to supply 3 helper
272 * functions which do the test for us.
273 * primPmInt :: Num a => Int -> a -> Bool
274 * primPmInteger :: Num a => Integer -> a -> Bool
275 * primPmDouble :: Fractional a => Double -> a -> Bool
278 Cell dict = arg(fun(discr));
283 = h == nameFromInt ? nameMkI
284 : h == nameFromInteger ? nameMkInteger
287 = h == nameFromInt ? namePmInt
288 : h == nameFromInteger ? namePmInteger
294 for(i=1; i<=da; ++i) {
295 Cell nv = mkStgVar(NIL,NIL);
297 altsc = cons(pair(mkOffset(co+i),nv),altsc);
299 /* bind dictionary */
300 d = stgRhs(dict,co,sc,namePMFail);
301 if (!isAtomic(d)) { /* wasn't atomic */
303 binds = cons(d,binds);
306 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
307 binds = cons(n,binds);
312 mkStgApp(testFun,tripleton(d,n,scrut))),
313 stgExpr(r,co+da,altsc,failExpr),
324 /* allocate variables, extend scope */
325 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
326 Cell nv = mkStgVar(NIL,NIL);
327 sc = cons(pair(fst3(hd(bs)),nv),sc);
328 binds = cons(nv,binds);
331 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
332 Cell nv = mkStgVar(NIL,NIL);
333 sc = cons(pair(mkOffset(++co),nv),sc);
334 binds = cons(nv,binds);
338 /* transform functions */
339 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
344 Int arity = intOf(snd3(fun));
346 for(i=1; i<=arity; ++i) {
347 Cell v = mkStgVar(NIL,NIL);
349 funsc = cons(pair(mkOffset(co+i),v),funsc);
354 stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
356 /* transform expressions */
357 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
360 stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail);
362 return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
365 default: /* convert to an StgApp or StgVar plus some bindings */
376 args = cons(arg,args);
380 if (e == nameSel && length(args) == 3) {
382 StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
383 Int ix = intOf(hd(tl(tl(args))));
384 Int da = discrArity(con);
387 for(i=1; i<=da; ++i) {
388 Cell nv = mkStgVar(NIL,NIL);
393 doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
394 mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
397 /* Arguments must be StgAtoms */
398 for(as=args; nonNull(as); as=tl(as)) {
399 StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
400 if (whatIs(a) == LETREC) {
401 binds = appendOnto(stgLetBinds(a),binds);
406 binds = cons(a,binds);
411 /* Special case: saturated constructor application */
412 length_args = length(args);
413 if ( (isName(e) && isCfun(e)
415 && name(e).arity == length_args)
417 (isTuple(e) && tycon(e).tuple == length_args)
420 /* fprintf ( stderr, "saturated application of %s\n",
421 textToStr(isTuple(e) ? tycon(e).text : name(e).text)); */
422 v = mkStgVar(mkStgCon(e,args),NIL);
423 binds = cons(v,binds);
424 return mkStgLet(binds,v);
429 /* Function must be StgVar or Name */
430 e = stgRhs(e,co,sc,namePMFail);
431 if (!isStgVar(e) && !isName(e)) {
433 binds = cons(e,binds);
436 return makeStgLet(binds,makeStgApp(e,args));
442 Void stgDefn( Name n, Int arity, Cell e )
447 for (i = 1; i <= arity; ++i) {
448 Cell nv = mkStgVar(NIL,NIL);
450 sc = cons(pair(mkOffset(i),nv),sc);
452 stgVarBody(name(n).stgVar)
453 = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
456 Void implementCfun(c,scs) /* Build implementation for constr */
457 Name c; /* fun c. scs lists integers (1..)*/
458 List scs; { /* in incr order of strict fields. */
459 Int a = name(c).arity;
462 StgVar vcurr, e1, v, vsi;
463 List args = makeArgs(a);
464 StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
465 List binds = singleton(v0);
468 for (; nonNull(scs); scs=tl(scs)) {
469 vsi = nth(intOf(hd(scs))-1,args);
470 vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
471 binds = cons(vcurr,binds);
474 e1 = mkStgLet(binds,vcurr);
475 v = mkStgVar(mkStgLambda(args,e1),NIL);
478 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
481 stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
482 /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */
485 /* --------------------------------------------------------------------------
486 * Foreign function calls and primops
487 * ------------------------------------------------------------------------*/
489 /* Outbound denotes data moving from Haskell world to elsewhere.
490 Inbound denotes data moving from elsewhere to Haskell world.
492 static String charListToString ( List cs );
493 static Cell foreignTy ( Bool outBound, Type t );
494 static Cell foreignOutboundTy ( Type t );
495 static Cell foreignInboundTy ( Type t );
496 static Name repToBox ( char c );
497 static StgRhs makeStgPrim ( Name,Bool,List,String,String );
499 static String charListToString( List cs )
504 assert( length(cs) < 100 );
505 for(; nonNull(cs); ++i, cs=tl(cs)) {
506 s[i] = charOf(hd(cs));
509 return textToStr(findText(s));
512 static Cell foreignTy ( Bool outBound, Type t )
514 if (t == typeChar) return mkChar(CHAR_REP);
515 else if (t == typeInt) return mkChar(INT_REP);
517 else if (t == typeInteger)return mkChar(INTEGER_REP);
519 else if (t == typeWord) return mkChar(WORD_REP);
520 else if (t == typeAddr) return mkChar(ADDR_REP);
521 else if (t == typeFloat) return mkChar(FLOAT_REP);
522 else if (t == typeDouble) return mkChar(DOUBLE_REP);
523 else if (t == typeStable) return mkChar(STABLE_REP);
524 #ifdef PROVIDE_FOREIGN
525 else if (t == typeForeign)return mkChar(FOREIGN_REP);
526 /* ToDo: argty only! */
529 else if (t == typePrimByteArray) return mkChar(BARR_REP);
530 /* ToDo: argty only! */
531 else if (whatIs(t) == AP) {
533 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
534 /* ToDo: argty only! */
537 /* ToDo: decent line numbers! */
539 ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
540 ERRTEXT " \"" ETHEN ERRTYPE(t);
544 ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
545 ERRTEXT " \"" ETHEN ERRTYPE(t);
551 static Cell foreignOutboundTy ( Type t )
553 return foreignTy ( TRUE, t );
556 static Cell foreignInboundTy ( Type t )
558 return foreignTy ( FALSE, t );
561 static Name repToBox( char c )
564 case CHAR_REP: return nameMkC;
565 case INT_REP: return nameMkI;
566 case INTEGER_REP: return nameMkInteger;
567 case WORD_REP: return nameMkW;
568 case ADDR_REP: return nameMkA;
569 case FLOAT_REP: return nameMkF;
570 case DOUBLE_REP: return nameMkD;
571 case ARR_REP: return nameMkPrimArray;
572 case BARR_REP: return nameMkPrimByteArray;
573 case REF_REP: return nameMkRef;
574 case MUTARR_REP: return nameMkPrimMutableArray;
575 case MUTBARR_REP: return nameMkPrimMutableByteArray;
576 case STABLE_REP: return nameMkStable;
577 case THREADID_REP: return nameMkThreadId;
578 case MVAR_REP: return nameMkPrimMVar;
580 case WEAK_REP: return nameMkWeak;
582 #ifdef PROVIDE_FOREIGN
583 case FOREIGN_REP: return nameMkForeign;
589 static StgPrimAlt boxResults( String reps, StgVar state )
591 List rs = NIL; /* possibly unboxed results */
592 List bs = NIL; /* boxed results of wrapper */
593 List rbinds = NIL; /* bindings used to box results */
596 for(i=0; reps[i] != '\0'; ++i) {
597 StgRep k = mkStgRep(reps[i]);
598 Cell v = mkStgPrimVar(NIL,k,NIL);
599 Name box = repToBox(reps[i]);
603 StgRhs rhs = mkStgCon(box,singleton(v));
604 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
606 rbinds = cons(bv,rbinds);
611 /* Construct tuple of results */
618 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
619 rbinds = cons(r,rbinds);
622 /* construct result pair if needed */
623 if (nonNull(state)) {
624 /* Note that this builds a tuple directly - we know it's
627 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
628 rbinds = cons(r,rbinds);
629 rs = cons(state,rs); /* last result is a state */
632 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
635 static List mkUnboxedVars( String reps )
639 for(i=0; reps[i] != '\0'; ++i) {
640 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
646 static List mkBoxedVars( String reps )
650 for(i=0; reps[i] != '\0'; ++i) {
651 as = cons(mkStgVar(NIL,NIL),as);
656 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
658 if (nonNull(b_args)) {
659 StgVar b_arg = hd(b_args); /* boxed arg */
660 StgVar u_arg = hd(u_args); /* unboxed arg */
661 Name box = repToBox(*reps);
662 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
664 /* Use a trivial let-binding */
665 stgVarBody(u_arg) = b_arg;
666 return mkStgLet(singleton(u_arg),e);
668 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
669 return mkStgCase(b_arg,singleton(alt));
676 /* Generate wrapper for primop based on list of arg types and result types:
678 * makeStgPrim op# False "II" "II" =
679 * \ x y -> "case x of { I# x# ->
680 * case y of { I# y# ->
681 * case op#{x#,y#} of { r1# r2# ->
682 * let r1 = I# r1#; r2 = I# r2# in
686 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
692 List b_args = NIL; /* boxed args to primop */
693 List u_args = NIL; /* possibly unboxed args to primop */
695 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
696 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
699 if (strcmp(r_reps,"B") == 0) {
701 = mkStgPrimAlt(singleton(
702 mkStgPrimVar(mkInt(0),
703 mkStgRep(INT_REP),NIL)
708 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
710 alts = doubleton(altF,altT);
711 assert(nonNull(nameTrue));
714 alts = singleton(boxResults(r_reps,s1));
716 b_args = mkBoxedVars(a_reps);
717 u_args = mkUnboxedVars(a_reps);
720 = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
722 = makeStgLambda(singleton(s0),
723 unboxVars(a_reps,b_args,u_args,
724 mkStgPrimCase(mkStgPrim(op,actual_args),
726 StgVar m = mkStgVar(rhs,NIL);
727 return makeStgLambda(b_args,
728 mkStgLet(singleton(m),
729 mkStgApp(nameMkIO,singleton(m))));
731 List actual_args = appendOnto(extra_args,u_args);
732 return makeStgLambda(
734 unboxVars(a_reps,b_args,u_args,
735 mkStgPrimCase(mkStgPrim(op,actual_args),alts))
740 Void implementPrim ( n )
742 const AsmPrim* p = name(n).primop;
743 StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
744 StgVar v = mkStgVar(rhs,NIL);
746 stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
749 /* Generate wrapper code from (in,out) type lists.
753 * inTypes = [Int,Float]
754 * outTypes = [Char,Addr]
758 * case a1 of { I# a1# ->
759 * case s2 of { F# a2# ->
760 * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
768 * Addr -> (Int -> Float -> IO (Char,Addr))
770 Void implementForeignImport ( Name n )
772 Type t = name(n).type;
774 List resultTys = NIL;
775 CFunDescriptor* descriptor = 0;
776 Bool addState = TRUE;
777 Bool dynamic = isNull(name(n).defn);
778 while (getHead(t)==typeArrow && argCount==2) {
779 Type ta = fullExpand(arg(fun(t)));
781 argTys = cons(ta,argTys);
784 argTys = rev(argTys);
786 /* argTys now holds the argument tys. If this is a dynamic call,
787 the first one had better be an Addr.
790 if (isNull(argTys) || hd(argTys) != typeAddr) {
791 ERRMSG(name(n).line) "First argument in f-i-dynamic must be an Addr"
796 if (getHead(t) == typeIO) {
797 resultTys = getArgs(t);
798 assert(length(resultTys) == 1);
799 resultTys = hd(resultTys);
805 resultTys = fullExpand(resultTys);
806 if (isTuple(getHead(resultTys))) {
807 resultTys = getArgs(resultTys);
808 } else if (getHead(resultTys) == typeUnit) {
811 resultTys = singleton(resultTys);
813 mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */
814 mapOver(foreignInboundTy,resultTys); /* doesn't */
816 = mkDescriptor(charListToString(argTys),
817 charListToString(resultTys));
819 ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
823 /* ccall is the default convention, if it wasn't specified */
824 if (isNull(name(n).callconv)
825 || name(n).callconv == textCcall) {
826 name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
828 else if (name(n).callconv == textStdcall) {
829 if (!stdcallAllowed()) {
830 ERRMSG(name(n).line) "stdcall is not supported on this platform"
833 name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
836 internal ( "implementForeignImport: unknown calling convention");
847 extra_args = singleton(mkPtr(descriptor));
848 /* and we know that the first arg will be the function pointer */
850 extName = name(n).defn;
851 funPtr = getDLLSymbol(name(n).line,
852 textToStr(textOf(fst(extName))),
853 textToStr(textOf(snd(extName))));
856 "Could not find foreign function \"%s\" in \"%s\"",
857 textToStr(textOf(snd(extName))),
858 textToStr(textOf(fst(extName)))
861 extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
864 rhs = makeStgPrim(n,addState,extra_args,
866 descriptor->result_tys);
867 v = mkStgVar(rhs,NIL);
870 stgGlobals = cons(pair(n,v),stgGlobals);
873 /* At this point the descriptor contains a tags for all args,
874 because that makes makeStgPrim generate the correct unwrap
875 code. From now on, the descriptor is only used at the time
876 the actual ccall is made. So we need to zap the leading
877 addr arg IF this is a f-i-dynamic call.
880 descriptor->arg_tys++;
881 descriptor->num_args--;
890 e3 = C# 'c' -- (ccall), or 's' (stdcall)
891 in primMkAdjThunk fun e1 e3
893 we require, and check that,
894 fun :: prim_arg* -> IO prim_result
896 Void implementForeignExport ( Name n )
898 Type t = name(n).type;
900 List resultTys = NIL;
903 if (getHead(t)==typeArrow && argCount==2) {
906 ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
907 ERRTEXT " \"" ETHEN ERRTYPE(t);
912 while (getHead(t)==typeArrow && argCount==2) {
913 Type ta = fullExpand(arg(fun(t)));
915 argTys = cons(ta,argTys);
918 argTys = rev(argTys);
919 if (getHead(t) == typeIO) {
920 resultTys = getArgs(t);
921 assert(length(resultTys) == 1);
922 resultTys = hd(resultTys);
924 ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN
925 ERRTEXT " \"" ETHEN ERRTYPE(t);
929 resultTys = fullExpand(resultTys);
931 mapOver(foreignInboundTy,argTys);
933 /* ccall is the default convention, if it wasn't specified */
934 if (isNull(name(n).callconv)
935 || name(n).callconv == textCcall) {
938 else if (name(n).callconv == textStdcall) {
939 if (!stdcallAllowed()) {
940 ERRMSG(name(n).line) "stdcall is not supported on this platform"
946 internal ( "implementForeignExport: unknown calling convention");
952 StgVar e1, e2, e3, v;
955 tdList = cons(mkChar(':'),argTys);
956 if (resultTys != typeUnit)
957 tdList = cons(foreignOutboundTy(resultTys),tdList);
959 tdText = findText(charListToString ( tdList ));
962 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
966 mkStgApp(nameUnpackString,singleton(e1)),
970 mkStgCon(nameMkC,singleton(mkChar(cc_char))),
979 cons(hd(args),cons(e2,cons(e3,NIL)))
984 v = mkStgVar(fun,NIL);
988 stgGlobals = cons(pair(n,v),stgGlobals);
992 Void implementTuple(size)
995 Cell t = mkTuple(size);
996 List args = makeArgs(size);
997 StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
998 StgExpr e = mkStgLet(singleton(tv),tv);
999 StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
1000 stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
1002 StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
1003 stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* ditto */
1007 /* --------------------------------------------------------------------------
1009 * ------------------------------------------------------------------------*/
1011 Void translateControl(what)
1014 case POSTPREL: break;
1025 /*-------------------------------------------------------------------------*/