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/23 14:54:21 $
15 * ------------------------------------------------------------------------*/
17 #include "hugsbasictypes.h"
22 #include "Assembler.h"
25 /* ---------------------------------------------------------------- */
27 static StgVar local stgOffset ( Offset,List );
28 static StgVar local stgText ( Text,List );
29 static StgRhs local stgRhs ( Cell,Int,List,StgExpr );
30 static StgCaseAlt local stgCaseAlt ( Cell,Int,List,StgExpr );
31 static StgExpr local stgExpr ( Cell,Int,List,StgExpr );
33 /* ---------------------------------------------------------------- */
35 /* Association list storing globals assigned to */
36 /* dictionaries, tuples, etc */
37 List stgGlobals = NIL;
39 static StgVar local getSTGTupleVar ( Cell d )
41 Pair p = cellAssoc(d,stgGlobals);
42 /* Yoiks - only the Prelude sees Tuple decls! */
44 implementTuple(tupleOf(d));
45 p = cellAssoc(d,stgGlobals);
51 /* ---------------------------------------------------------------- */
53 static Cell local stgOffset(Offset o, List sc)
55 Cell r = cellAssoc(o,sc);
60 static Cell local stgText(Text t,List sc)
63 for (; nonNull(xs); xs=tl(xs)) {
66 if (!isOffset(v) && t == textOf(v)) {
73 /* ---------------------------------------------------------------- */
75 static StgRhs local stgRhs(e,co,sc,failExpr)
84 return stgOffset(e,sc);
87 return stgText(textOf(e),sc);
89 return getSTGTupleVar(e);
94 return mkStgCon(nameMkC,singleton(e));
96 return mkStgCon(nameMkI,singleton(e));
98 return mkStgCon(nameMkInteger,singleton(e));
100 return mkStgCon(nameMkD,singleton(e));
102 #if USE_ADDR_FOR_STRINGS
104 StgVar v = mkStgVar(mkStgCon(nameMkA,singleton(e)),NIL);
105 return mkStgLet(singleton(v),
106 makeStgApp(nameUnpackString,singleton(v)));
109 return mkStgApp(nameUnpackString,singleton(e));
112 return stgExpr(e,co,sc,namePMFail);
116 return stgExpr(e,co,sc,failExpr/*namePMFail*/);
120 static StgCaseAlt local stgCaseAlt(alt,co,sc,failExpr)
126 StgDiscr d = fst(alt);
127 Int da = discrArity(d);
130 for(i=1; i<=da; ++i) {
131 StgVar nv = mkStgVar(NIL,NIL);
133 sc = cons(pair(mkOffset(co+i),nv),sc);
135 return mkStgCaseAlt(d,vs,stgExpr(snd(alt),co+da,sc,failExpr));
138 static StgExpr local stgExpr(e,co,sc,failExpr)
147 return makeStgIf(stgExpr(fst3(snd(e)),co,sc,namePMFail),
148 stgExpr(snd3(snd(e)),co,sc,failExpr),
149 stgExpr(thd3(snd(e)),co,sc,failExpr));
153 List guards = reverse(snd(e));
155 for(; nonNull(guards); guards=tl(guards)) {
157 Cell c = stgExpr(fst(g),co,sc,namePMFail);
158 Cell rhs = stgExpr(snd(g),co,sc,failExpr);
159 e = makeStgIf(c,rhs,e);
165 StgExpr e2 = stgExpr(snd(snd(e)),co,sc,failExpr);
166 StgVar alt = mkStgVar(e2,NIL);
167 return mkStgLet(singleton(alt),stgExpr(fst(snd(e)),co,sc,alt));
171 List alts = snd(snd(e));
172 Cell scrut = stgExpr(fst(snd(e)),co,sc,namePMFail);
175 } else if (isChar(fst(hd(alts)))) {
177 StgDiscr d = fst(alt);
179 mkStgCon(nameMkC,singleton(d)),NIL);
180 StgExpr test = nameEqChar;
181 /* duplicates scrut but it should be atomic */
183 makeStgLet(singleton(c),
184 makeStgApp(test,doubleton(scrut,c))),
185 stgExpr(snd(alt),co,sc,failExpr),
186 stgExpr(ap(CASE,pair(fst(snd(e)),
187 tl(alts))),co,sc,failExpr));
190 for(; nonNull(alts); alts=tl(alts)) {
191 as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
197 singleton(mkStgDefault(mkStgVar(NIL,NIL),
205 Cell discr = snd3(nc);
207 Cell scrut = stgOffset(o,sc);
208 Cell h = getHead(discr);
209 Int da = discrArity(discr);
212 if (whatIs(h) == ADDPAT && argCount == 1) {
213 /* ADDPAT num dictIntegral
215 * let n = fromInteger num in
216 * if pmLe dictIntegral n scrut
217 * then let v = pmSubtract dictIntegral scrut v
221 Cell dictIntegral = arg(discr); /* Integral dictionary */
224 StgVar dIntegral = NIL;
226 /* bind dictionary */
227 dIntegral = stgRhs(dictIntegral,co,sc,namePMFail);
228 if (!isAtomic(dIntegral)) { /* wasn't atomic */
229 dIntegral = mkStgVar(dIntegral,NIL);
230 binds = cons(dIntegral,binds);
234 sprintf(str, "%d", n);
235 n = mkStgVar(mkStgCon(nameMkInteger,singleton(stringToBignum(str))),NIL);
236 binds = cons(n,binds);
238 /* coerce number to right type (using Integral dict) */
239 n = mkStgVar(mkStgApp(
240 namePmFromInteger,doubleton(dIntegral,n)),NIL);
241 binds = cons(n,binds);
244 v = mkStgVar(mkStgApp(
245 namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
250 mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
251 mkStgLet(singleton(v),
254 cons(pair(mkOffset(co),v),sc),
259 assert(isName(h) && argCount == 2);
261 /* This code is rather ugly.
262 * We ought to desugar it using one of the following:
263 * if (==) dEq (fromInt dNum pat) scrut
264 * if (==) dEq (fromInteger dNum pat) scrut
265 * if (==) dEq (fromFloat dFractional pat) scrut
266 * But it would be very hard to obtain the Eq dictionary
267 * from the Num or Fractional dictionary we have.
268 * Instead, we rely on the Prelude to supply 3 helper
269 * functions which do the test for us.
270 * primPmInt :: Num a => Int -> a -> Bool
271 * primPmInteger :: Num a => Integer -> a -> Bool
272 * primPmDouble :: Fractional a => Double -> a -> Bool
275 Cell dict = arg(fun(discr));
280 = h == nameFromInt ? nameMkI
281 : h == nameFromInteger ? nameMkInteger
284 = h == nameFromInt ? namePmInt
285 : h == nameFromInteger ? namePmInteger
291 for(i=1; i<=da; ++i) {
292 Cell nv = mkStgVar(NIL,NIL);
294 altsc = cons(pair(mkOffset(co+i),nv),altsc);
296 /* bind dictionary */
297 d = stgRhs(dict,co,sc,namePMFail);
298 if (!isAtomic(d)) { /* wasn't atomic */
300 binds = cons(d,binds);
303 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
304 binds = cons(n,binds);
309 mkStgApp(testFun,tripleton(d,n,scrut))),
310 stgExpr(r,co+da,altsc,failExpr),
321 /* allocate variables, extend scope */
322 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
323 Cell nv = mkStgVar(NIL,NIL);
324 sc = cons(pair(fst3(hd(bs)),nv),sc);
325 binds = cons(nv,binds);
328 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
329 Cell nv = mkStgVar(NIL,NIL);
330 sc = cons(pair(mkOffset(++co),nv),sc);
331 binds = cons(nv,binds);
335 /* transform functions */
336 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
341 Int arity = intOf(snd3(fun));
343 for(i=1; i<=arity; ++i) {
344 Cell v = mkStgVar(NIL,NIL);
346 funsc = cons(pair(mkOffset(co+i),v),funsc);
351 stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
353 /* transform expressions */
354 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
357 stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail);
359 return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
362 default: /* convert to an StgApp or StgVar plus some bindings */
373 args = cons(arg,args);
377 if (e == nameSel && length(args) == 3) {
379 StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
380 Int ix = intOf(hd(tl(tl(args))));
381 Int da = discrArity(con);
384 for(i=1; i<=da; ++i) {
385 Cell nv = mkStgVar(NIL,NIL);
390 doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
391 mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
394 /* Arguments must be StgAtoms */
395 for(as=args; nonNull(as); as=tl(as)) {
396 StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
397 if (whatIs(a) == LETREC) {
398 binds = appendOnto(stgLetBinds(a),binds);
403 binds = cons(a,binds);
408 /* Special case: saturated constructor application */
409 length_args = length(args);
410 if ( (isName(e) && isCfun(e)
412 && name(e).arity == length_args)
414 (isTuple(e) && tycon(e).tuple == length_args)
417 /* fprintf ( stderr, "saturated application of %s\n",
418 textToStr(isTuple(e) ? tycon(e).text : name(e).text)); */
419 v = mkStgVar(mkStgCon(e,args),NIL);
420 binds = cons(v,binds);
421 return mkStgLet(binds,v);
426 /* Function must be StgVar or Name */
427 e = stgRhs(e,co,sc,namePMFail);
428 if (!isStgVar(e) && !isName(e)) {
430 binds = cons(e,binds);
433 return makeStgLet(binds,makeStgApp(e,args));
439 Void stgDefn( Name n, Int arity, Cell e )
444 for (i = 1; i <= arity; ++i) {
445 Cell nv = mkStgVar(NIL,NIL);
447 sc = cons(pair(mkOffset(i),nv),sc);
449 stgVarBody(name(n).stgVar)
450 = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
453 Void implementCfun(c,scs) /* Build implementation for constr */
454 Name c; /* fun c. scs lists integers (1..)*/
455 List scs; { /* in incr order of strict fields. */
456 Int a = name(c).arity;
459 StgVar vcurr, e1, v, vsi;
460 List args = makeArgs(a);
461 StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
462 List binds = singleton(v0);
465 for (; nonNull(scs); scs=tl(scs)) {
466 vsi = nth(intOf(hd(scs))-1,args);
467 vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
468 binds = cons(vcurr,binds);
471 e1 = mkStgLet(binds,vcurr);
472 v = mkStgVar(mkStgLambda(args,e1),NIL);
475 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
478 stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
479 /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */
482 /* --------------------------------------------------------------------------
483 * Foreign function calls and primops
484 * ------------------------------------------------------------------------*/
486 /* Outbound denotes data moving from Haskell world to elsewhere.
487 Inbound denotes data moving from elsewhere to Haskell world.
489 static String charListToString ( List cs );
490 static Cell foreignTy ( Bool outBound, Type t );
491 static Cell foreignOutboundTy ( Type t );
492 static Cell foreignInboundTy ( Type t );
493 static Name repToBox ( char c );
494 static StgRhs makeStgPrim ( Name,Bool,List,String,String );
496 static String charListToString( List cs )
501 assert( length(cs) < 100 );
502 for(; nonNull(cs); ++i, cs=tl(cs)) {
503 s[i] = charOf(hd(cs));
506 return textToStr(findText(s));
509 static Cell foreignTy ( Bool outBound, Type t )
511 if (t == typeChar) return mkChar(CHAR_REP);
512 else if (t == typeInt) return mkChar(INT_REP);
514 else if (t == typeInteger)return mkChar(INTEGER_REP);
516 else if (t == typeWord) return mkChar(WORD_REP);
517 else if (t == typeAddr) return mkChar(ADDR_REP);
518 else if (t == typeFloat) return mkChar(FLOAT_REP);
519 else if (t == typeDouble) return mkChar(DOUBLE_REP);
520 else if (t == typeStable) return mkChar(STABLE_REP);
521 #ifdef PROVIDE_FOREIGN
522 else if (t == typeForeign)return mkChar(FOREIGN_REP);
523 /* ToDo: argty only! */
526 else if (t == typePrimByteArray) return mkChar(BARR_REP);
527 /* ToDo: argty only! */
528 else if (whatIs(t) == AP) {
530 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
531 /* ToDo: argty only! */
534 /* ToDo: decent line numbers! */
536 ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
537 ERRTEXT " \"" ETHEN ERRTYPE(t);
541 ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
542 ERRTEXT " \"" ETHEN ERRTYPE(t);
548 static Cell foreignOutboundTy ( Type t )
550 return foreignTy ( TRUE, t );
553 static Cell foreignInboundTy ( Type t )
555 return foreignTy ( FALSE, t );
558 static Name repToBox( char c )
561 case CHAR_REP: return nameMkC;
562 case INT_REP: return nameMkI;
563 case INTEGER_REP: return nameMkInteger;
564 case WORD_REP: return nameMkW;
565 case ADDR_REP: return nameMkA;
566 case FLOAT_REP: return nameMkF;
567 case DOUBLE_REP: return nameMkD;
568 case ARR_REP: return nameMkPrimArray;
569 case BARR_REP: return nameMkPrimByteArray;
570 case REF_REP: return nameMkRef;
571 case MUTARR_REP: return nameMkPrimMutableArray;
572 case MUTBARR_REP: return nameMkPrimMutableByteArray;
573 case STABLE_REP: return nameMkStable;
574 case THREADID_REP: return nameMkThreadId;
575 case MVAR_REP: return nameMkPrimMVar;
577 case WEAK_REP: return nameMkWeak;
579 #ifdef PROVIDE_FOREIGN
580 case FOREIGN_REP: return nameMkForeign;
586 static StgPrimAlt boxResults( String reps, StgVar state )
588 List rs = NIL; /* possibly unboxed results */
589 List bs = NIL; /* boxed results of wrapper */
590 List rbinds = NIL; /* bindings used to box results */
593 for(i=0; reps[i] != '\0'; ++i) {
594 StgRep k = mkStgRep(reps[i]);
595 Cell v = mkStgPrimVar(NIL,k,NIL);
596 Name box = repToBox(reps[i]);
600 StgRhs rhs = mkStgCon(box,singleton(v));
601 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
603 rbinds = cons(bv,rbinds);
608 /* Construct tuple of results */
615 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
616 rbinds = cons(r,rbinds);
619 /* construct result pair if needed */
620 if (nonNull(state)) {
621 /* Note that this builds a tuple directly - we know it's
624 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
625 rbinds = cons(r,rbinds);
626 rs = cons(state,rs); /* last result is a state */
629 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
632 static List mkUnboxedVars( String reps )
636 for(i=0; reps[i] != '\0'; ++i) {
637 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
643 static List mkBoxedVars( String reps )
647 for(i=0; reps[i] != '\0'; ++i) {
648 as = cons(mkStgVar(NIL,NIL),as);
653 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
655 if (nonNull(b_args)) {
656 StgVar b_arg = hd(b_args); /* boxed arg */
657 StgVar u_arg = hd(u_args); /* unboxed arg */
658 Name box = repToBox(*reps);
659 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
661 /* Use a trivial let-binding */
662 stgVarBody(u_arg) = b_arg;
663 return mkStgLet(singleton(u_arg),e);
665 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
666 return mkStgCase(b_arg,singleton(alt));
673 /* Generate wrapper for primop based on list of arg types and result types:
675 * makeStgPrim op# False "II" "II" =
676 * \ x y -> "case x of { I# x# ->
677 * case y of { I# y# ->
678 * case op#{x#,y#} of { r1# r2# ->
679 * let r1 = I# r1#; r2 = I# r2# in
683 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
689 List b_args = NIL; /* boxed args to primop */
690 List u_args = NIL; /* possibly unboxed args to primop */
692 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
693 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
696 if (strcmp(r_reps,"B") == 0) {
698 = mkStgPrimAlt(singleton(
699 mkStgPrimVar(mkInt(0),
700 mkStgRep(INT_REP),NIL)
705 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
707 alts = doubleton(altF,altT);
708 assert(nonNull(nameTrue));
711 alts = singleton(boxResults(r_reps,s1));
713 b_args = mkBoxedVars(a_reps);
714 u_args = mkUnboxedVars(a_reps);
717 = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
719 = makeStgLambda(singleton(s0),
720 unboxVars(a_reps,b_args,u_args,
721 mkStgPrimCase(mkStgPrim(op,actual_args),
723 StgVar m = mkStgVar(rhs,NIL);
724 return makeStgLambda(b_args,
725 mkStgLet(singleton(m),
726 mkStgApp(nameMkIO,singleton(m))));
728 List actual_args = appendOnto(extra_args,u_args);
729 return makeStgLambda(
731 unboxVars(a_reps,b_args,u_args,
732 mkStgPrimCase(mkStgPrim(op,actual_args),alts))
737 Void implementPrim ( n )
739 const AsmPrim* p = name(n).primop;
740 StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
741 StgVar v = mkStgVar(rhs,NIL);
743 stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
746 /* Generate wrapper code from (in,out) type lists.
750 * inTypes = [Int,Float]
751 * outTypes = [Char,Addr]
755 * case a1 of { I# a1# ->
756 * case s2 of { F# a2# ->
757 * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
765 * Addr -> (Int -> Float -> IO (Char,Addr))
767 Void implementForeignImport ( Name n )
769 Type t = name(n).type;
771 List resultTys = NIL;
772 CFunDescriptor* descriptor = 0;
773 Bool addState = TRUE;
774 Bool dynamic = isNull(name(n).defn);
775 while (getHead(t)==typeArrow && argCount==2) {
776 Type ta = fullExpand(arg(fun(t)));
778 argTys = cons(ta,argTys);
781 argTys = rev(argTys);
783 /* argTys now holds the argument tys. If this is a dynamic call,
784 the first one had better be an Addr.
787 if (isNull(argTys) || hd(argTys) != typeAddr) {
788 ERRMSG(name(n).line) "First argument in f-i-dynamic must be an Addr"
793 if (getHead(t) == typeIO) {
794 resultTys = getArgs(t);
795 assert(length(resultTys) == 1);
796 resultTys = hd(resultTys);
802 resultTys = fullExpand(resultTys);
803 if (isTuple(getHead(resultTys))) {
804 resultTys = getArgs(resultTys);
805 } else if (getHead(resultTys) == typeUnit) {
808 resultTys = singleton(resultTys);
810 mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */
811 mapOver(foreignInboundTy,resultTys); /* doesn't */
813 = mkDescriptor(charListToString(argTys),
814 charListToString(resultTys));
816 ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
820 /* ccall is the default convention, if it wasn't specified */
821 if (isNull(name(n).callconv)
822 || name(n).callconv == textCcall) {
823 name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
825 else if (name(n).callconv == textStdcall) {
826 if (!stdcallAllowed()) {
827 ERRMSG(name(n).line) "stdcall is not supported on this platform"
830 name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
833 internal ( "implementForeignImport: unknown calling convention");
844 extra_args = singleton(mkPtr(descriptor));
845 /* and we know that the first arg will be the function pointer */
847 extName = name(n).defn;
848 funPtr = getDLLSymbol(name(n).line,
849 textToStr(textOf(fst(extName))),
850 textToStr(textOf(snd(extName))));
853 "Could not find foreign function \"%s\" in \"%s\"",
854 textToStr(textOf(snd(extName))),
855 textToStr(textOf(fst(extName)))
858 extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
861 rhs = makeStgPrim(n,addState,extra_args,
863 descriptor->result_tys);
864 v = mkStgVar(rhs,NIL);
867 stgGlobals = cons(pair(n,v),stgGlobals);
870 /* At this point the descriptor contains a tags for all args,
871 because that makes makeStgPrim generate the correct unwrap
872 code. From now on, the descriptor is only used at the time
873 the actual ccall is made. So we need to zap the leading
874 addr arg IF this is a f-i-dynamic call.
877 descriptor->arg_tys++;
878 descriptor->num_args--;
887 e3 = C# 'c' -- (ccall), or 's' (stdcall)
888 in primMkAdjThunk fun e1 e3
890 we require, and check that,
891 fun :: prim_arg* -> IO prim_result
893 Void implementForeignExport ( Name n )
895 Type t = name(n).type;
897 List resultTys = NIL;
900 if (getHead(t)==typeArrow && argCount==2) {
903 ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
904 ERRTEXT " \"" ETHEN ERRTYPE(t);
909 while (getHead(t)==typeArrow && argCount==2) {
910 Type ta = fullExpand(arg(fun(t)));
912 argTys = cons(ta,argTys);
915 argTys = rev(argTys);
916 if (getHead(t) == typeIO) {
917 resultTys = getArgs(t);
918 assert(length(resultTys) == 1);
919 resultTys = hd(resultTys);
921 ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN
922 ERRTEXT " \"" ETHEN ERRTYPE(t);
926 resultTys = fullExpand(resultTys);
928 mapOver(foreignInboundTy,argTys);
930 /* ccall is the default convention, if it wasn't specified */
931 if (isNull(name(n).callconv)
932 || name(n).callconv == textCcall) {
935 else if (name(n).callconv == textStdcall) {
936 if (!stdcallAllowed()) {
937 ERRMSG(name(n).line) "stdcall is not supported on this platform"
943 internal ( "implementForeignExport: unknown calling convention");
949 StgVar e1, e2, e3, v;
952 tdList = cons(mkChar(':'),argTys);
953 if (resultTys != typeUnit)
954 tdList = cons(foreignOutboundTy(resultTys),tdList);
956 tdText = findText(charListToString ( tdList ));
959 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
963 mkStgApp(nameUnpackString,singleton(e1)),
967 mkStgCon(nameMkC,singleton(mkChar(cc_char))),
976 cons(hd(args),cons(e2,cons(e3,NIL)))
981 v = mkStgVar(fun,NIL);
985 stgGlobals = cons(pair(n,v),stgGlobals);
989 Void implementTuple(size)
992 Cell t = mkTuple(size);
993 List args = makeArgs(size);
994 StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
995 StgExpr e = mkStgLet(singleton(tv),tv);
996 StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
997 stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
999 StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
1000 stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* ditto */
1004 /* --------------------------------------------------------------------------
1006 * ------------------------------------------------------------------------*/
1008 Void translateControl(what)
1011 case POSTPREL: break;
1022 /*-------------------------------------------------------------------------*/