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/04/05 10:25:09 $
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
413 && !name(e).hasStrict)
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 /*-------------------------------------------------------------------------*/