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/13 11:37:17 $
15 * ------------------------------------------------------------------------*/
23 #include "Assembler.h"
26 /* ---------------------------------------------------------------- */
28 static StgVar local stgOffset ( Offset,List );
29 static StgVar local stgText ( Text,List );
30 static StgRhs local stgRhs ( Cell,Int,List,StgExpr );
31 static StgCaseAlt local stgCaseAlt ( Cell,Int,List,StgExpr );
32 static StgExpr local stgExpr ( 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 ( Cell d )
42 Pair p = cellAssoc(d,stgGlobals);
43 /* Yoiks - only the Prelude sees Tuple decls! */
45 implementTuple(tupleOf(d));
46 p = cellAssoc(d,stgGlobals);
52 /* ---------------------------------------------------------------- */
54 static Cell local stgOffset(Offset o, List sc)
56 Cell r = cellAssoc(o,sc);
61 static Cell local stgText(Text t,List sc)
64 for (; nonNull(xs); xs=tl(xs)) {
67 if (!isOffset(v) && t == textOf(v)) {
74 /* ---------------------------------------------------------------- */
76 static StgRhs local stgRhs(e,co,sc,failExpr)
85 return stgOffset(e,sc);
88 return stgText(textOf(e),sc);
90 return getSTGTupleVar(e);
95 return mkStgCon(nameMkC,singleton(e));
97 return mkStgCon(nameMkI,singleton(e));
99 return mkStgCon(nameMkInteger,singleton(e));
101 return mkStgCon(nameMkD,singleton(e));
103 #if USE_ADDR_FOR_STRINGS
105 StgVar v = mkStgVar(mkStgCon(nameMkA,singleton(e)),NIL);
106 return mkStgLet(singleton(v),
107 makeStgApp(nameUnpackString,singleton(v)));
110 return mkStgApp(nameUnpackString,singleton(e));
113 return stgExpr(e,co,sc,namePMFail);
117 return stgExpr(e,co,sc,failExpr/*namePMFail*/);
121 static StgCaseAlt local stgCaseAlt(alt,co,sc,failExpr)
127 StgDiscr d = fst(alt);
128 Int da = discrArity(d);
131 for(i=1; i<=da; ++i) {
132 StgVar nv = mkStgVar(NIL,NIL);
134 sc = cons(pair(mkOffset(co+i),nv),sc);
136 return mkStgCaseAlt(d,vs,stgExpr(snd(alt),co+da,sc,failExpr));
139 static StgExpr local stgExpr(e,co,sc,failExpr)
148 return makeStgIf(stgExpr(fst3(snd(e)),co,sc,namePMFail),
149 stgExpr(snd3(snd(e)),co,sc,failExpr),
150 stgExpr(thd3(snd(e)),co,sc,failExpr));
154 List guards = reverse(snd(e));
156 for(; nonNull(guards); guards=tl(guards)) {
158 Cell c = stgExpr(fst(g),co,sc,namePMFail);
159 Cell rhs = stgExpr(snd(g),co,sc,failExpr);
160 e = makeStgIf(c,rhs,e);
166 StgExpr e2 = stgExpr(snd(snd(e)),co,sc,failExpr);
167 StgVar alt = mkStgVar(e2,NIL);
168 return mkStgLet(singleton(alt),stgExpr(fst(snd(e)),co,sc,alt));
172 List alts = snd(snd(e));
173 Cell scrut = stgExpr(fst(snd(e)),co,sc,namePMFail);
176 } else if (isChar(fst(hd(alts)))) {
178 StgDiscr d = fst(alt);
180 mkStgCon(nameMkC,singleton(d)),NIL);
181 StgExpr test = nameEqChar;
182 /* duplicates scrut but it should be atomic */
184 makeStgLet(singleton(c),
185 makeStgApp(test,doubleton(scrut,c))),
186 stgExpr(snd(alt),co,sc,failExpr),
187 stgExpr(ap(CASE,pair(fst(snd(e)),
188 tl(alts))),co,sc,failExpr));
191 for(; nonNull(alts); alts=tl(alts)) {
192 as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
198 singleton(mkStgDefault(mkStgVar(NIL,NIL),
206 Cell discr = snd3(nc);
208 Cell scrut = stgOffset(o,sc);
209 Cell h = getHead(discr);
210 Int da = discrArity(discr);
213 if (whatIs(h) == ADDPAT && argCount == 1) {
214 /* ADDPAT num dictIntegral
216 * let n = fromInteger num in
217 * if pmLe dictIntegral n scrut
218 * then let v = pmSubtract dictIntegral scrut v
222 Cell dictIntegral = arg(discr); /* Integral dictionary */
225 StgVar dIntegral = NIL;
227 /* bind dictionary */
228 dIntegral = stgRhs(dictIntegral,co,sc,namePMFail);
229 if (!isAtomic(dIntegral)) { /* wasn't atomic */
230 dIntegral = mkStgVar(dIntegral,NIL);
231 binds = cons(dIntegral,binds);
235 sprintf(str, "%d", n);
236 n = mkStgVar(mkStgCon(nameMkInteger,singleton(stringToBignum(str))),NIL);
237 binds = cons(n,binds);
239 /* coerce number to right type (using Integral dict) */
240 n = mkStgVar(mkStgApp(
241 namePmFromInteger,doubleton(dIntegral,n)),NIL);
242 binds = cons(n,binds);
245 v = mkStgVar(mkStgApp(
246 namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
251 mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
252 mkStgLet(singleton(v),
255 cons(pair(mkOffset(co),v),sc),
260 assert(isName(h) && argCount == 2);
262 /* This code is rather ugly.
263 * We ought to desugar it using one of the following:
264 * if (==) dEq (fromInt dNum pat) scrut
265 * if (==) dEq (fromInteger dNum pat) scrut
266 * if (==) dEq (fromFloat dFractional pat) scrut
267 * But it would be very hard to obtain the Eq dictionary
268 * from the Num or Fractional dictionary we have.
269 * Instead, we rely on the Prelude to supply 3 helper
270 * functions which do the test for us.
271 * primPmInt :: Num a => Int -> a -> Bool
272 * primPmInteger :: Num a => Integer -> a -> Bool
273 * primPmDouble :: Fractional a => Double -> a -> Bool
276 Cell dict = arg(fun(discr));
281 = h == nameFromInt ? nameMkI
282 : h == nameFromInteger ? nameMkInteger
285 = h == nameFromInt ? namePmInt
286 : h == nameFromInteger ? namePmInteger
292 for(i=1; i<=da; ++i) {
293 Cell nv = mkStgVar(NIL,NIL);
295 altsc = cons(pair(mkOffset(co+i),nv),altsc);
297 /* bind dictionary */
298 d = stgRhs(dict,co,sc,namePMFail);
299 if (!isAtomic(d)) { /* wasn't atomic */
301 binds = cons(d,binds);
304 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
305 binds = cons(n,binds);
310 mkStgApp(testFun,tripleton(d,n,scrut))),
311 stgExpr(r,co+da,altsc,failExpr),
322 /* allocate variables, extend scope */
323 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
324 Cell nv = mkStgVar(NIL,NIL);
325 sc = cons(pair(fst3(hd(bs)),nv),sc);
326 binds = cons(nv,binds);
329 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
330 Cell nv = mkStgVar(NIL,NIL);
331 sc = cons(pair(mkOffset(++co),nv),sc);
332 binds = cons(nv,binds);
336 /* transform functions */
337 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
342 Int arity = intOf(snd3(fun));
344 for(i=1; i<=arity; ++i) {
345 Cell v = mkStgVar(NIL,NIL);
347 funsc = cons(pair(mkOffset(co+i),v),funsc);
352 stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
354 /* transform expressions */
355 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
358 stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail);
360 return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
363 default: /* convert to an StgApp or StgVar plus some bindings */
374 args = cons(arg,args);
378 if (e == nameSel && length(args) == 3) {
380 StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
381 Int ix = intOf(hd(tl(tl(args))));
382 Int da = discrArity(con);
385 for(i=1; i<=da; ++i) {
386 Cell nv = mkStgVar(NIL,NIL);
391 doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
392 mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
395 /* Arguments must be StgAtoms */
396 for(as=args; nonNull(as); as=tl(as)) {
397 StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
398 if (whatIs(a) == LETREC) {
399 binds = appendOnto(stgLetBinds(a),binds);
404 binds = cons(a,binds);
409 /* Special case: saturated constructor application */
410 length_args = length(args);
411 if ( (isName(e) && isCfun(e)
413 && name(e).arity == length_args)
415 (isTuple(e) && tycon(e).tuple == length_args)
418 /* fprintf ( stderr, "saturated application of %s\n",
419 textToStr(isTuple(e) ? tycon(e).text : 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));
440 Void stgDefn( Name n, Int arity, Cell e )
445 for (i = 1; i <= arity; ++i) {
446 Cell nv = mkStgVar(NIL,NIL);
448 sc = cons(pair(mkOffset(i),nv),sc);
450 stgVarBody(name(n).stgVar)
451 = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
454 Void implementCfun(c,scs) /* Build implementation for constr */
455 Name c; /* fun c. scs lists integers (1..)*/
456 List scs; { /* in incr order of strict fields. */
457 Int a = name(c).arity;
460 StgVar vcurr, e1, v, vsi;
461 List args = makeArgs(a);
462 StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
463 List binds = singleton(v0);
466 for (; nonNull(scs); scs=tl(scs)) {
467 vsi = nth(intOf(hd(scs))-1,args);
468 vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
469 binds = cons(vcurr,binds);
472 e1 = mkStgLet(binds,vcurr);
473 v = mkStgVar(mkStgLambda(args,e1),NIL);
476 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
479 stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
480 /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */
483 /* --------------------------------------------------------------------------
484 * Foreign function calls and primops
485 * ------------------------------------------------------------------------*/
487 /* Outbound denotes data moving from Haskell world to elsewhere.
488 Inbound denotes data moving from elsewhere to Haskell world.
490 static String charListToString ( List cs );
491 static Cell foreignTy ( Bool outBound, Type t );
492 static Cell foreignOutboundTy ( Type t );
493 static Cell foreignInboundTy ( Type t );
494 static Name repToBox ( char c );
495 static StgRhs makeStgPrim ( Name,Bool,List,String,String );
497 static String charListToString( List cs )
502 assert( length(cs) < 100 );
503 for(; nonNull(cs); ++i, cs=tl(cs)) {
504 s[i] = charOf(hd(cs));
507 return textToStr(findText(s));
510 static Cell foreignTy ( Bool outBound, Type t )
512 if (t == typeChar) return mkChar(CHAR_REP);
513 else if (t == typeInt) return mkChar(INT_REP);
515 else if (t == typeInteger)return mkChar(INTEGER_REP);
517 else if (t == typeWord) return mkChar(WORD_REP);
518 else if (t == typeAddr) return mkChar(ADDR_REP);
519 else if (t == typeFloat) return mkChar(FLOAT_REP);
520 else if (t == typeDouble) return mkChar(DOUBLE_REP);
521 else if (t == typeStable) return mkChar(STABLE_REP);
522 #ifdef PROVIDE_FOREIGN
523 else if (t == typeForeign)return mkChar(FOREIGN_REP);
524 /* ToDo: argty only! */
527 else if (t == typePrimByteArray) return mkChar(BARR_REP);
528 /* ToDo: argty only! */
529 else if (whatIs(t) == AP) {
531 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
532 /* ToDo: argty only! */
535 /* ToDo: decent line numbers! */
537 ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
538 ERRTEXT " \"" ETHEN ERRTYPE(t);
542 ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
543 ERRTEXT " \"" ETHEN ERRTYPE(t);
549 static Cell foreignOutboundTy ( Type t )
551 return foreignTy ( TRUE, t );
554 static Cell foreignInboundTy ( Type t )
556 return foreignTy ( FALSE, t );
559 static Name repToBox( char c )
562 case CHAR_REP: return nameMkC;
563 case INT_REP: return nameMkI;
564 case INTEGER_REP: return nameMkInteger;
565 case WORD_REP: return nameMkW;
566 case ADDR_REP: return nameMkA;
567 case FLOAT_REP: return nameMkF;
568 case DOUBLE_REP: return nameMkD;
569 case ARR_REP: return nameMkPrimArray;
570 case BARR_REP: return nameMkPrimByteArray;
571 case REF_REP: return nameMkRef;
572 case MUTARR_REP: return nameMkPrimMutableArray;
573 case MUTBARR_REP: return nameMkPrimMutableByteArray;
574 case STABLE_REP: return nameMkStable;
575 case THREADID_REP: return nameMkThreadId;
576 case MVAR_REP: return nameMkPrimMVar;
578 case WEAK_REP: return nameMkWeak;
580 #ifdef PROVIDE_FOREIGN
581 case FOREIGN_REP: return nameMkForeign;
587 static StgPrimAlt boxResults( String reps, StgVar state )
589 List rs = NIL; /* possibly unboxed results */
590 List bs = NIL; /* boxed results of wrapper */
591 List rbinds = NIL; /* bindings used to box results */
594 for(i=0; reps[i] != '\0'; ++i) {
595 StgRep k = mkStgRep(reps[i]);
596 Cell v = mkStgPrimVar(NIL,k,NIL);
597 Name box = repToBox(reps[i]);
601 StgRhs rhs = mkStgCon(box,singleton(v));
602 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
604 rbinds = cons(bv,rbinds);
609 /* Construct tuple of results */
616 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
617 rbinds = cons(r,rbinds);
620 /* construct result pair if needed */
621 if (nonNull(state)) {
622 /* Note that this builds a tuple directly - we know it's
625 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
626 rbinds = cons(r,rbinds);
627 rs = cons(state,rs); /* last result is a state */
630 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
633 static List mkUnboxedVars( String reps )
637 for(i=0; reps[i] != '\0'; ++i) {
638 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
644 static List mkBoxedVars( String reps )
648 for(i=0; reps[i] != '\0'; ++i) {
649 as = cons(mkStgVar(NIL,NIL),as);
654 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
656 if (nonNull(b_args)) {
657 StgVar b_arg = hd(b_args); /* boxed arg */
658 StgVar u_arg = hd(u_args); /* unboxed arg */
659 Name box = repToBox(*reps);
660 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
662 /* Use a trivial let-binding */
663 stgVarBody(u_arg) = b_arg;
664 return mkStgLet(singleton(u_arg),e);
666 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
667 return mkStgCase(b_arg,singleton(alt));
674 /* Generate wrapper for primop based on list of arg types and result types:
676 * makeStgPrim op# False "II" "II" =
677 * \ x y -> "case x of { I# x# ->
678 * case y of { I# y# ->
679 * case op#{x#,y#} of { r1# r2# ->
680 * let r1 = I# r1#; r2 = I# r2# in
684 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
690 List b_args = NIL; /* boxed args to primop */
691 List u_args = NIL; /* possibly unboxed args to primop */
693 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
694 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
697 if (strcmp(r_reps,"B") == 0) {
699 = mkStgPrimAlt(singleton(
700 mkStgPrimVar(mkInt(0),
701 mkStgRep(INT_REP),NIL)
706 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
708 alts = doubleton(altF,altT);
709 assert(nonNull(nameTrue));
712 alts = singleton(boxResults(r_reps,s1));
714 b_args = mkBoxedVars(a_reps);
715 u_args = mkUnboxedVars(a_reps);
718 = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
720 = makeStgLambda(singleton(s0),
721 unboxVars(a_reps,b_args,u_args,
722 mkStgPrimCase(mkStgPrim(op,actual_args),
724 StgVar m = mkStgVar(rhs,NIL);
725 return makeStgLambda(b_args,
726 mkStgLet(singleton(m),
727 mkStgApp(nameMkIO,singleton(m))));
729 List actual_args = appendOnto(extra_args,u_args);
730 return makeStgLambda(
732 unboxVars(a_reps,b_args,u_args,
733 mkStgPrimCase(mkStgPrim(op,actual_args),alts))
738 Void implementPrim ( n )
740 const AsmPrim* p = name(n).primop;
741 StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
742 StgVar v = mkStgVar(rhs,NIL);
744 stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
747 /* Generate wrapper code from (in,out) type lists.
751 * inTypes = [Int,Float]
752 * outTypes = [Char,Addr]
756 * case a1 of { I# a1# ->
757 * case s2 of { F# a2# ->
758 * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
766 * Addr -> (Int -> Float -> IO (Char,Addr))
768 Void implementForeignImport ( Name n )
770 Type t = name(n).type;
772 List resultTys = NIL;
773 CFunDescriptor* descriptor = 0;
774 Bool addState = TRUE;
775 Bool dynamic = isNull(name(n).defn);
776 while (getHead(t)==typeArrow && argCount==2) {
777 Type ta = fullExpand(arg(fun(t)));
779 argTys = cons(ta,argTys);
782 argTys = rev(argTys);
784 /* argTys now holds the argument tys. If this is a dynamic call,
785 the first one had better be an Addr.
788 if (isNull(argTys) || hd(argTys) != typeAddr) {
789 ERRMSG(name(n).line) "First argument in f-i-dynamic must be an Addr"
794 if (getHead(t) == typeIO) {
795 resultTys = getArgs(t);
796 assert(length(resultTys) == 1);
797 resultTys = hd(resultTys);
803 resultTys = fullExpand(resultTys);
804 if (isTuple(getHead(resultTys))) {
805 resultTys = getArgs(resultTys);
806 } else if (getHead(resultTys) == typeUnit) {
809 resultTys = singleton(resultTys);
811 mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */
812 mapOver(foreignInboundTy,resultTys); /* doesn't */
814 = mkDescriptor(charListToString(argTys),
815 charListToString(resultTys));
817 ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
821 /* ccall is the default convention, if it wasn't specified */
822 if (isNull(name(n).callconv)
823 || name(n).callconv == textCcall) {
824 name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
826 else if (name(n).callconv == textStdcall) {
827 if (!stdcallAllowed()) {
828 ERRMSG(name(n).line) "stdcall is not supported on this platform"
831 name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
834 internal ( "implementForeignImport: unknown calling convention");
845 extra_args = singleton(mkPtr(descriptor));
846 /* and we know that the first arg will be the function pointer */
848 extName = name(n).defn;
849 funPtr = getDLLSymbol(name(n).line,
850 textToStr(textOf(fst(extName))),
851 textToStr(textOf(snd(extName))));
854 "Could not find foreign function \"%s\" in \"%s\"",
855 textToStr(textOf(snd(extName))),
856 textToStr(textOf(fst(extName)))
859 extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
862 rhs = makeStgPrim(n,addState,extra_args,
864 descriptor->result_tys);
865 v = mkStgVar(rhs,NIL);
868 stgGlobals = cons(pair(n,v),stgGlobals);
871 /* At this point the descriptor contains a tags for all args,
872 because that makes makeStgPrim generate the correct unwrap
873 code. From now on, the descriptor is only used at the time
874 the actual ccall is made. So we need to zap the leading
875 addr arg IF this is a f-i-dynamic call.
878 descriptor->arg_tys++;
879 descriptor->num_args--;
888 e3 = C# 'c' -- (ccall), or 's' (stdcall)
889 in primMkAdjThunk fun e1 e3
891 we require, and check that,
892 fun :: prim_arg* -> IO prim_result
894 Void implementForeignExport ( Name n )
896 Type t = name(n).type;
898 List resultTys = NIL;
901 if (getHead(t)==typeArrow && argCount==2) {
904 ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
905 ERRTEXT " \"" ETHEN ERRTYPE(t);
910 while (getHead(t)==typeArrow && argCount==2) {
911 Type ta = fullExpand(arg(fun(t)));
913 argTys = cons(ta,argTys);
916 argTys = rev(argTys);
917 if (getHead(t) == typeIO) {
918 resultTys = getArgs(t);
919 assert(length(resultTys) == 1);
920 resultTys = hd(resultTys);
922 ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN
923 ERRTEXT " \"" ETHEN ERRTYPE(t);
927 resultTys = fullExpand(resultTys);
929 mapOver(foreignInboundTy,argTys);
931 /* ccall is the default convention, if it wasn't specified */
932 if (isNull(name(n).callconv)
933 || name(n).callconv == textCcall) {
936 else if (name(n).callconv == textStdcall) {
937 if (!stdcallAllowed()) {
938 ERRMSG(name(n).line) "stdcall is not supported on this platform"
944 internal ( "implementForeignExport: unknown calling convention");
950 StgVar e1, e2, e3, v;
953 tdList = cons(mkChar(':'),argTys);
954 if (resultTys != typeUnit)
955 tdList = cons(foreignOutboundTy(resultTys),tdList);
957 tdText = findText(charListToString ( tdList ));
960 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
964 mkStgApp(nameUnpackString,singleton(e1)),
968 mkStgCon(nameMkC,singleton(mkChar(cc_char))),
977 cons(hd(args),cons(e2,cons(e3,NIL)))
982 v = mkStgVar(fun,NIL);
986 stgGlobals = cons(pair(n,v),stgGlobals);
990 Void implementTuple(size)
993 Cell t = mkTuple(size);
994 List args = makeArgs(size);
995 StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
996 StgExpr e = mkStgLet(singleton(tv),tv);
997 StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
998 stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
1000 StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
1001 stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* ditto */
1005 /* --------------------------------------------------------------------------
1007 * ------------------------------------------------------------------------*/
1009 Void translateControl(what)
1012 case POSTPREL: break;
1023 /*-------------------------------------------------------------------------*/