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 14:53:00 $
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);
216 if (whatIs(h) == ADDPAT && argCount == 1) {
217 /* ADDPAT num dictIntegral
219 * let n = fromInteger num in
220 * if pmLe dictIntegral n scrut
221 * then let v = pmSubtract dictIntegral scrut v
225 Cell dictIntegral = arg(discr); /* Integral dictionary */
228 StgVar dIntegral = NIL;
230 /* bind dictionary */
231 dIntegral = stgRhs(dictIntegral,co,sc,namePMFail);
232 if (!isAtomic(dIntegral)) { /* wasn't atomic */
233 dIntegral = mkStgVar(dIntegral,NIL);
234 binds = cons(dIntegral,binds);
238 sprintf(str, "%d", n);
239 n = mkStgVar(mkStgCon(nameMkInteger,singleton(stringToBignum(str))),NIL);
240 binds = cons(n,binds);
242 /* coerce number to right type (using Integral dict) */
243 n = mkStgVar(mkStgApp(
244 namePmFromInteger,doubleton(dIntegral,n)),NIL);
245 binds = cons(n,binds);
248 v = mkStgVar(mkStgApp(
249 namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
254 mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
255 mkStgLet(singleton(v),
258 cons(pair(mkOffset(co),v),sc),
263 assert(isName(h) && argCount == 2);
265 /* This code is rather ugly.
266 * We ought to desugar it using one of the following:
267 * if (==) dEq (fromInt dNum pat) scrut
268 * if (==) dEq (fromInteger dNum pat) scrut
269 * if (==) dEq (fromFloat dFractional pat) scrut
270 * But it would be very hard to obtain the Eq dictionary
271 * from the Num or Fractional dictionary we have.
272 * Instead, we rely on the Prelude to supply 3 helper
273 * functions which do the test for us.
274 * primPmInt :: Num a => Int -> a -> Bool
275 * primPmInteger :: Num a => Integer -> a -> Bool
276 * primPmDouble :: Fractional a => Double -> a -> Bool
279 Cell dict = arg(fun(discr));
284 = h == nameFromInt ? nameMkI
285 : h == nameFromInteger ? nameMkInteger
288 = h == nameFromInt ? namePmInt
289 : h == nameFromInteger ? namePmInteger
295 for(i=1; i<=da; ++i) {
296 Cell nv = mkStgVar(NIL,NIL);
298 altsc = cons(pair(mkOffset(co+i),nv),altsc);
300 /* bind dictionary */
301 d = stgRhs(dict,co,sc,namePMFail);
302 if (!isAtomic(d)) { /* wasn't atomic */
304 binds = cons(d,binds);
307 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
308 binds = cons(n,binds);
313 mkStgApp(testFun,tripleton(d,n,scrut))),
314 stgExpr(r,co+da,altsc,failExpr),
325 /* allocate variables, extend scope */
326 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
327 Cell nv = mkStgVar(NIL,NIL);
328 sc = cons(pair(fst3(hd(bs)),nv),sc);
329 binds = cons(nv,binds);
332 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
333 Cell nv = mkStgVar(NIL,NIL);
334 sc = cons(pair(mkOffset(++co),nv),sc);
335 binds = cons(nv,binds);
339 /* transform functions */
340 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
345 Int arity = intOf(snd3(fun));
347 for(i=1; i<=arity; ++i) {
348 Cell v = mkStgVar(NIL,NIL);
350 funsc = cons(pair(mkOffset(co+i),v),funsc);
355 stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
357 /* transform expressions */
358 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
361 stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail);
363 return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
366 default: /* convert to an StgApp or StgVar plus some bindings */
377 args = cons(arg,args);
381 if (e == nameSel && length(args) == 3) {
383 StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
384 Int ix = intOf(hd(tl(tl(args))));
385 Int da = discrArity(con);
388 for(i=1; i<=da; ++i) {
389 Cell nv = mkStgVar(NIL,NIL);
394 doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
395 mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
398 /* Arguments must be StgAtoms */
399 for(as=args; nonNull(as); as=tl(as)) {
400 StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
401 if (whatIs(a) == LETREC) {
402 binds = appendOnto(stgLetBinds(a),binds);
407 binds = cons(a,binds);
412 /* Special case: saturated constructor application */
413 length_args = length(args);
414 if ( (isName(e) && isCfun(e)
416 && name(e).arity == length_args)
418 (isTuple(e) && tycon(e).tuple == length_args)
421 /* fprintf ( stderr, "saturated application of %s\n",
422 textToStr(isTuple(e) ? tycon(e).text : name(e).text)); */
423 v = mkStgVar(mkStgCon(e,args),NIL);
424 binds = cons(v,binds);
425 return mkStgLet(binds,v);
430 /* Function must be StgVar or Name */
431 e = stgRhs(e,co,sc,namePMFail);
432 if (!isStgVar(e) && !isName(e)) {
434 binds = cons(e,binds);
437 return makeStgLet(binds,makeStgApp(e,args));
442 #if 0 /* apparently not used */
443 static Void ppExp( Name n, Int arity, Cell e )
445 if (1 || debugCode) {
447 printf("%s", textToStr(name(n).text));
448 for (i = arity; i > 0; i--) {
459 Void stgDefn( Name n, Int arity, Cell e )
464 for (i = 1; i <= arity; ++i) {
465 Cell nv = mkStgVar(NIL,NIL);
467 sc = cons(pair(mkOffset(i),nv),sc);
469 stgVarBody(name(n).stgVar)
470 = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
473 Void implementCfun(c,scs) /* Build implementation for constr */
474 Name c; /* fun c. scs lists integers (1..)*/
475 List scs; { /* in incr order of strict fields. */
476 Int a = name(c).arity;
479 StgVar vcurr, e1, v, vsi;
480 List args = makeArgs(a);
481 StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
482 List binds = singleton(v0);
485 for (; nonNull(scs); scs=tl(scs)) {
486 vsi = nth(intOf(hd(scs))-1,args);
487 vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
488 binds = cons(vcurr,binds);
491 e1 = mkStgLet(binds,vcurr);
492 v = mkStgVar(mkStgLambda(args,e1),NIL);
495 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
498 stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
499 /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */
502 /* --------------------------------------------------------------------------
503 * Foreign function calls and primops
504 * ------------------------------------------------------------------------*/
506 /* Outbound denotes data moving from Haskell world to elsewhere.
507 Inbound denotes data moving from elsewhere to Haskell world.
509 static String charListToString ( List cs );
510 static Cell foreignTy ( Bool outBound, Type t );
511 static Cell foreignOutboundTy ( Type t );
512 static Cell foreignInboundTy ( Type t );
513 static Name repToBox ( char c );
514 static StgRhs makeStgPrim ( Name,Bool,List,String,String );
516 static String charListToString( List cs )
521 assert( length(cs) < 100 );
522 for(; nonNull(cs); ++i, cs=tl(cs)) {
523 s[i] = charOf(hd(cs));
526 return textToStr(findText(s));
529 static Cell foreignTy ( Bool outBound, Type t )
531 if (t == typeChar) return mkChar(CHAR_REP);
532 else if (t == typeInt) return mkChar(INT_REP);
534 else if (t == typeInteger)return mkChar(INTEGER_REP);
536 else if (t == typeWord) return mkChar(WORD_REP);
537 else if (t == typeAddr) return mkChar(ADDR_REP);
538 else if (t == typeFloat) return mkChar(FLOAT_REP);
539 else if (t == typeDouble) return mkChar(DOUBLE_REP);
540 else if (t == typeStable) return mkChar(STABLE_REP);
541 #ifdef PROVIDE_FOREIGN
542 else if (t == typeForeign)return mkChar(FOREIGN_REP);
543 /* ToDo: argty only! */
546 else if (t == typePrimByteArray) return mkChar(BARR_REP);
547 /* ToDo: argty only! */
548 else if (whatIs(t) == AP) {
550 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
551 /* ToDo: argty only! */
554 /* ToDo: decent line numbers! */
556 ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
557 ERRTEXT " \"" ETHEN ERRTYPE(t);
561 ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
562 ERRTEXT " \"" ETHEN ERRTYPE(t);
568 static Cell foreignOutboundTy ( Type t )
570 return foreignTy ( TRUE, t );
573 static Cell foreignInboundTy ( Type t )
575 return foreignTy ( FALSE, t );
578 static Name repToBox( char c )
581 case CHAR_REP: return nameMkC;
582 case INT_REP: return nameMkI;
583 case INTEGER_REP: return nameMkInteger;
584 case WORD_REP: return nameMkW;
585 case ADDR_REP: return nameMkA;
586 case FLOAT_REP: return nameMkF;
587 case DOUBLE_REP: return nameMkD;
588 case ARR_REP: return nameMkPrimArray;
589 case BARR_REP: return nameMkPrimByteArray;
590 case REF_REP: return nameMkRef;
591 case MUTARR_REP: return nameMkPrimMutableArray;
592 case MUTBARR_REP: return nameMkPrimMutableByteArray;
593 case STABLE_REP: return nameMkStable;
594 case THREADID_REP: return nameMkThreadId;
595 case MVAR_REP: return nameMkPrimMVar;
597 case WEAK_REP: return nameMkWeak;
599 #ifdef PROVIDE_FOREIGN
600 case FOREIGN_REP: return nameMkForeign;
606 static StgPrimAlt boxResults( String reps, StgVar state )
608 List rs = NIL; /* possibly unboxed results */
609 List bs = NIL; /* boxed results of wrapper */
610 List rbinds = NIL; /* bindings used to box results */
613 for(i=0; reps[i] != '\0'; ++i) {
614 StgRep k = mkStgRep(reps[i]);
615 Cell v = mkStgPrimVar(NIL,k,NIL);
616 Name box = repToBox(reps[i]);
620 StgRhs rhs = mkStgCon(box,singleton(v));
621 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
623 rbinds = cons(bv,rbinds);
628 /* Construct tuple of results */
635 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
636 rbinds = cons(r,rbinds);
639 /* construct result pair if needed */
640 if (nonNull(state)) {
641 /* Note that this builds a tuple directly - we know it's
644 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
645 rbinds = cons(r,rbinds);
646 rs = cons(state,rs); /* last result is a state */
649 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
652 static List mkUnboxedVars( String reps )
656 for(i=0; reps[i] != '\0'; ++i) {
657 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
663 static List mkBoxedVars( String reps )
667 for(i=0; reps[i] != '\0'; ++i) {
668 as = cons(mkStgVar(NIL,NIL),as);
673 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
675 if (nonNull(b_args)) {
676 StgVar b_arg = hd(b_args); /* boxed arg */
677 StgVar u_arg = hd(u_args); /* unboxed arg */
678 Name box = repToBox(*reps);
679 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
681 /* Use a trivial let-binding */
682 stgVarBody(u_arg) = b_arg;
683 return mkStgLet(singleton(u_arg),e);
685 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
686 return mkStgCase(b_arg,singleton(alt));
693 /* Generate wrapper for primop based on list of arg types and result types:
695 * makeStgPrim op# False "II" "II" =
696 * \ x y -> "case x of { I# x# ->
697 * case y of { I# y# ->
698 * case op#{x#,y#} of { r1# r2# ->
699 * let r1 = I# r1#; r2 = I# r2# in
703 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
709 List b_args = NIL; /* boxed args to primop */
710 List u_args = NIL; /* possibly unboxed args to primop */
712 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
713 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
716 if (strcmp(r_reps,"B") == 0) {
718 = mkStgPrimAlt(singleton(
719 mkStgPrimVar(mkInt(0),
720 mkStgRep(INT_REP),NIL)
725 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
727 alts = doubleton(altF,altT);
728 assert(nonNull(nameTrue));
731 alts = singleton(boxResults(r_reps,s1));
733 b_args = mkBoxedVars(a_reps);
734 u_args = mkUnboxedVars(a_reps);
737 = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
739 = makeStgLambda(singleton(s0),
740 unboxVars(a_reps,b_args,u_args,
741 mkStgPrimCase(mkStgPrim(op,actual_args),
743 StgVar m = mkStgVar(rhs,NIL);
744 return makeStgLambda(b_args,
745 mkStgLet(singleton(m),
746 mkStgApp(nameMkIO,singleton(m))));
748 List actual_args = appendOnto(extra_args,u_args);
749 return makeStgLambda(
751 unboxVars(a_reps,b_args,u_args,
752 mkStgPrimCase(mkStgPrim(op,actual_args),alts))
757 Void implementPrim ( n )
759 const AsmPrim* p = name(n).primop;
760 StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
761 StgVar v = mkStgVar(rhs,NIL);
763 stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
766 /* Generate wrapper code from (in,out) type lists.
770 * inTypes = [Int,Float]
771 * outTypes = [Char,Addr]
775 * case a1 of { I# a1# ->
776 * case s2 of { F# a2# ->
777 * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
785 * Addr -> (Int -> Float -> IO (Char,Addr))
787 Void implementForeignImport ( Name n )
789 Type t = name(n).type;
791 List resultTys = NIL;
792 CFunDescriptor* descriptor = 0;
793 Bool addState = TRUE;
794 Bool dynamic = isNull(name(n).defn);
795 while (getHead(t)==typeArrow && argCount==2) {
796 Type ta = fullExpand(arg(fun(t)));
798 argTys = cons(ta,argTys);
801 argTys = rev(argTys);
803 /* argTys now holds the argument tys. If this is a dynamic call,
804 the first one had better be an Addr.
807 if (isNull(argTys) || hd(argTys) != typeAddr) {
808 ERRMSG(name(n).line) "First argument in f-i-dynamic must be an Addr"
813 if (getHead(t) == typeIO) {
814 resultTys = getArgs(t);
815 assert(length(resultTys) == 1);
816 resultTys = hd(resultTys);
822 resultTys = fullExpand(resultTys);
823 if (isTuple(getHead(resultTys))) {
824 resultTys = getArgs(resultTys);
825 } else if (getHead(resultTys) == typeUnit) {
828 resultTys = singleton(resultTys);
830 mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */
831 mapOver(foreignInboundTy,resultTys); /* doesn't */
833 = mkDescriptor(charListToString(argTys),
834 charListToString(resultTys));
836 ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
840 /* ccall is the default convention, if it wasn't specified */
841 if (isNull(name(n).callconv)
842 || name(n).callconv == textCcall) {
843 name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
845 else if (name(n).callconv == textStdcall) {
846 if (!stdcallAllowed()) {
847 ERRMSG(name(n).line) "stdcall is not supported on this platform"
850 name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
853 internal ( "implementForeignImport: unknown calling convention");
864 extra_args = singleton(mkPtr(descriptor));
865 /* and we know that the first arg will be the function pointer */
867 extName = name(n).defn;
868 funPtr = getDLLSymbol(name(n).line,
869 textToStr(textOf(fst(extName))),
870 textToStr(textOf(snd(extName))));
873 "Could not find foreign function \"%s\" in \"%s\"",
874 textToStr(textOf(snd(extName))),
875 textToStr(textOf(fst(extName)))
878 extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
881 rhs = makeStgPrim(n,addState,extra_args,
883 descriptor->result_tys);
884 v = mkStgVar(rhs,NIL);
887 stgGlobals = cons(pair(n,v),stgGlobals);
890 /* At this point the descriptor contains a tags for all args,
891 because that makes makeStgPrim generate the correct unwrap
892 code. From now on, the descriptor is only used at the time
893 the actual ccall is made. So we need to zap the leading
894 addr arg IF this is a f-i-dynamic call.
897 descriptor->arg_tys++;
898 descriptor->num_args--;
907 e3 = C# 'c' -- (ccall), or 's' (stdcall)
908 in primMkAdjThunk fun e1 e3
910 we require, and check that,
911 fun :: prim_arg* -> IO prim_result
913 Void implementForeignExport ( Name n )
915 Type t = name(n).type;
917 List resultTys = NIL;
920 if (getHead(t)==typeArrow && argCount==2) {
923 ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
924 ERRTEXT " \"" ETHEN ERRTYPE(t);
929 while (getHead(t)==typeArrow && argCount==2) {
930 Type ta = fullExpand(arg(fun(t)));
932 argTys = cons(ta,argTys);
935 argTys = rev(argTys);
936 if (getHead(t) == typeIO) {
937 resultTys = getArgs(t);
938 assert(length(resultTys) == 1);
939 resultTys = hd(resultTys);
941 ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN
942 ERRTEXT " \"" ETHEN ERRTYPE(t);
946 resultTys = fullExpand(resultTys);
948 mapOver(foreignInboundTy,argTys);
950 /* ccall is the default convention, if it wasn't specified */
951 if (isNull(name(n).callconv)
952 || name(n).callconv == textCcall) {
955 else if (name(n).callconv == textStdcall) {
956 if (!stdcallAllowed()) {
957 ERRMSG(name(n).line) "stdcall is not supported on this platform"
963 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,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)
1031 case POSTPREL: break;
1042 /*-------------------------------------------------------------------------*/