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/02 10:10:33 $
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);
217 if (whatIs(h) == ADDPAT && argCount == 1) {
218 /* ADDPAT num dictIntegral
220 * let n = fromInteger num in
221 * if pmLe dictIntegral n scrut
222 * then let v = pmSubtract dictIntegral scrut v
226 Cell dictIntegral = arg(discr); /* Integral dictionary */
229 StgVar dIntegral = NIL;
231 /* bind dictionary */
232 dIntegral = stgRhs(dictIntegral,co,sc,namePMFail);
233 if (!isAtomic(dIntegral)) { /* wasn't atomic */
234 dIntegral = mkStgVar(dIntegral,NIL);
235 binds = cons(dIntegral,binds);
239 sprintf(str, "%d", n);
240 n = mkStgVar(mkStgCon(nameMkInteger,singleton(stringToBignum(str))),NIL);
241 binds = cons(n,binds);
243 /* coerce number to right type (using Integral dict) */
244 n = mkStgVar(mkStgApp(
245 namePmFromInteger,doubleton(dIntegral,n)),NIL);
246 binds = cons(n,binds);
249 v = mkStgVar(mkStgApp(
250 namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
255 mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
256 mkStgLet(singleton(v),
259 cons(pair(mkOffset(co),v),sc),
265 assert(isName(h) && argCount == 2);
267 /* This code is rather ugly.
268 * We ought to desugar it using one of the following:
269 * if (==) dEq (fromInt dNum pat) scrut
270 * if (==) dEq (fromInteger dNum pat) scrut
271 * if (==) dEq (fromFloat dFractional pat) scrut
272 * But it would be very hard to obtain the Eq dictionary
273 * from the Num or Fractional dictionary we have.
274 * Instead, we rely on the Prelude to supply 3 helper
275 * functions which do the test for us.
276 * primPmInt :: Num a => Int -> a -> Bool
277 * primPmInteger :: Num a => Integer -> a -> Bool
278 * primPmDouble :: Fractional a => Double -> a -> Bool
281 Cell dict = arg(fun(discr));
286 = h == nameFromInt ? nameMkI
287 : h == nameFromInteger ? nameMkInteger
290 = h == nameFromInt ? namePmInt
291 : h == nameFromInteger ? namePmInteger
297 for(i=1; i<=da; ++i) {
298 Cell nv = mkStgVar(NIL,NIL);
300 altsc = cons(pair(mkOffset(co+i),nv),altsc);
302 /* bind dictionary */
303 d = stgRhs(dict,co,sc,namePMFail);
304 if (!isAtomic(d)) { /* wasn't atomic */
306 binds = cons(d,binds);
309 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
310 binds = cons(n,binds);
315 mkStgApp(testFun,tripleton(d,n,scrut))),
316 stgExpr(r,co+da,altsc,failExpr),
327 /* allocate variables, extend scope */
328 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
329 Cell nv = mkStgVar(NIL,NIL);
330 sc = cons(pair(fst3(hd(bs)),nv),sc);
331 binds = cons(nv,binds);
334 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
335 Cell nv = mkStgVar(NIL,NIL);
336 sc = cons(pair(mkOffset(++co),nv),sc);
337 binds = cons(nv,binds);
341 /* transform functions */
342 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
347 Int arity = intOf(snd3(fun));
349 for(i=1; i<=arity; ++i) {
350 Cell v = mkStgVar(NIL,NIL);
352 funsc = cons(pair(mkOffset(co+i),v),funsc);
357 stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
359 /* transform expressions */
360 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
363 stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail);
365 return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
368 default: /* convert to an StgApp or StgVar plus some bindings */
379 args = cons(arg,args);
383 if (e == nameSel && length(args) == 3) {
385 StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
386 Int ix = intOf(hd(tl(tl(args))));
387 Int da = discrArity(con);
390 for(i=1; i<=da; ++i) {
391 Cell nv = mkStgVar(NIL,NIL);
396 doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
397 mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
400 /* Arguments must be StgAtoms */
401 for(as=args; nonNull(as); as=tl(as)) {
402 StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
403 if (whatIs(a) == LETREC) {
404 binds = appendOnto(stgLetBinds(a),binds);
409 binds = cons(a,binds);
414 /* Special case: saturated constructor application */
415 length_args = length(args);
416 if ( (isName(e) && isCfun(e)
418 && name(e).arity == length_args)
420 (isTuple(e) && tycon(e).tuple == length_args)
423 /* fprintf ( stderr, "saturated application of %s\n",
424 textToStr(isTuple(e) ? tycon(e).text : name(e).text)); */
425 v = mkStgVar(mkStgCon(e,args),NIL);
426 binds = cons(v,binds);
427 return mkStgLet(binds,v);
432 /* Function must be StgVar or Name */
433 e = stgRhs(e,co,sc,namePMFail);
434 if (!isStgVar(e) && !isName(e)) {
436 binds = cons(e,binds);
439 return makeStgLet(binds,makeStgApp(e,args));
444 #if 0 /* apparently not used */
445 static Void ppExp( Name n, Int arity, Cell e )
447 if (1 || debugCode) {
449 printf("%s", textToStr(name(n).text));
450 for (i = arity; i > 0; i--) {
461 Void stgDefn( Name n, Int arity, Cell e )
466 for (i = 1; i <= arity; ++i) {
467 Cell nv = mkStgVar(NIL,NIL);
469 sc = cons(pair(mkOffset(i),nv),sc);
471 stgVarBody(name(n).stgVar)
472 = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
475 Void implementCfun(c,scs) /* Build implementation for constr */
476 Name c; /* fun c. scs lists integers (1..)*/
477 List scs; { /* in incr order of strict fields. */
478 Int a = name(c).arity;
481 StgVar vcurr, e1, v, vsi;
482 List args = makeArgs(a);
483 StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
484 List binds = singleton(v0);
487 for (; nonNull(scs); scs=tl(scs)) {
488 vsi = nth(intOf(hd(scs))-1,args);
489 vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
490 binds = cons(vcurr,binds);
493 e1 = mkStgLet(binds,vcurr);
494 v = mkStgVar(mkStgLambda(args,e1),NIL);
497 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
500 stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
501 /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */
504 /* --------------------------------------------------------------------------
505 * Foreign function calls and primops
506 * ------------------------------------------------------------------------*/
508 /* Outbound denotes data moving from Haskell world to elsewhere.
509 Inbound denotes data moving from elsewhere to Haskell world.
511 static String charListToString ( List cs );
512 static Cell foreignTy ( Bool outBound, Type t );
513 static Cell foreignOutboundTy ( Type t );
514 static Cell foreignInboundTy ( Type t );
515 static Name repToBox ( char c );
516 static StgRhs makeStgPrim ( Name,Bool,List,String,String );
518 static String charListToString( List cs )
523 assert( length(cs) < 100 );
524 for(; nonNull(cs); ++i, cs=tl(cs)) {
525 s[i] = charOf(hd(cs));
528 return textToStr(findText(s));
531 static Cell foreignTy ( Bool outBound, Type t )
533 if (t == typeChar) return mkChar(CHAR_REP);
534 else if (t == typeInt) return mkChar(INT_REP);
536 else if (t == typeInteger)return mkChar(INTEGER_REP);
538 else if (t == typeWord) return mkChar(WORD_REP);
539 else if (t == typeAddr) return mkChar(ADDR_REP);
540 else if (t == typeFloat) return mkChar(FLOAT_REP);
541 else if (t == typeDouble) return mkChar(DOUBLE_REP);
542 else if (t == typeStable) return mkChar(STABLE_REP);
543 #ifdef PROVIDE_FOREIGN
544 else if (t == typeForeign)return mkChar(FOREIGN_REP);
545 /* ToDo: argty only! */
548 else if (t == typePrimByteArray) return mkChar(BARR_REP);
549 /* ToDo: argty only! */
550 else if (whatIs(t) == AP) {
552 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
553 /* ToDo: argty only! */
556 /* ToDo: decent line numbers! */
558 ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
559 ERRTEXT " \"" ETHEN ERRTYPE(t);
563 ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
564 ERRTEXT " \"" ETHEN ERRTYPE(t);
570 static Cell foreignOutboundTy ( Type t )
572 return foreignTy ( TRUE, t );
575 static Cell foreignInboundTy ( Type t )
577 return foreignTy ( FALSE, t );
580 static Name repToBox( char c )
583 case CHAR_REP: return nameMkC;
584 case INT_REP: return nameMkI;
585 case INTEGER_REP: return nameMkInteger;
586 case WORD_REP: return nameMkW;
587 case ADDR_REP: return nameMkA;
588 case FLOAT_REP: return nameMkF;
589 case DOUBLE_REP: return nameMkD;
590 case ARR_REP: return nameMkPrimArray;
591 case BARR_REP: return nameMkPrimByteArray;
592 case REF_REP: return nameMkRef;
593 case MUTARR_REP: return nameMkPrimMutableArray;
594 case MUTBARR_REP: return nameMkPrimMutableByteArray;
595 case STABLE_REP: return nameMkStable;
596 case THREADID_REP: return nameMkThreadId;
597 case MVAR_REP: return nameMkPrimMVar;
599 case WEAK_REP: return nameMkWeak;
601 #ifdef PROVIDE_FOREIGN
602 case FOREIGN_REP: return nameMkForeign;
608 static StgPrimAlt boxResults( String reps, StgVar state )
610 List rs = NIL; /* possibly unboxed results */
611 List bs = NIL; /* boxed results of wrapper */
612 List rbinds = NIL; /* bindings used to box results */
615 for(i=0; reps[i] != '\0'; ++i) {
616 StgRep k = mkStgRep(reps[i]);
617 Cell v = mkStgPrimVar(NIL,k,NIL);
618 Name box = repToBox(reps[i]);
622 StgRhs rhs = mkStgCon(box,singleton(v));
623 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
625 rbinds = cons(bv,rbinds);
630 /* Construct tuple of results */
637 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
638 rbinds = cons(r,rbinds);
641 /* construct result pair if needed */
642 if (nonNull(state)) {
643 /* Note that this builds a tuple directly - we know it's
646 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
647 rbinds = cons(r,rbinds);
648 rs = cons(state,rs); /* last result is a state */
651 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
654 static List mkUnboxedVars( String reps )
658 for(i=0; reps[i] != '\0'; ++i) {
659 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
665 static List mkBoxedVars( String reps )
669 for(i=0; reps[i] != '\0'; ++i) {
670 as = cons(mkStgVar(NIL,NIL),as);
675 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
677 if (nonNull(b_args)) {
678 StgVar b_arg = hd(b_args); /* boxed arg */
679 StgVar u_arg = hd(u_args); /* unboxed arg */
680 Name box = repToBox(*reps);
681 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
683 /* Use a trivial let-binding */
684 stgVarBody(u_arg) = b_arg;
685 return mkStgLet(singleton(u_arg),e);
687 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
688 return mkStgCase(b_arg,singleton(alt));
695 /* Generate wrapper for primop based on list of arg types and result types:
697 * makeStgPrim op# False "II" "II" =
698 * \ x y -> "case x of { I# x# ->
699 * case y of { I# y# ->
700 * case op#{x#,y#} of { r1# r2# ->
701 * let r1 = I# r1#; r2 = I# r2# in
705 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
711 List b_args = NIL; /* boxed args to primop */
712 List u_args = NIL; /* possibly unboxed args to primop */
714 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
715 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
718 if (strcmp(r_reps,"B") == 0) {
720 = mkStgPrimAlt(singleton(
721 mkStgPrimVar(mkInt(0),
722 mkStgRep(INT_REP),NIL)
727 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
729 alts = doubleton(altF,altT);
730 assert(nonNull(nameTrue));
733 alts = singleton(boxResults(r_reps,s1));
735 b_args = mkBoxedVars(a_reps);
736 u_args = mkUnboxedVars(a_reps);
739 = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
741 = makeStgLambda(singleton(s0),
742 unboxVars(a_reps,b_args,u_args,
743 mkStgPrimCase(mkStgPrim(op,actual_args),
745 StgVar m = mkStgVar(rhs,NIL);
746 return makeStgLambda(b_args,
747 mkStgLet(singleton(m),
748 mkStgApp(nameMkIO,singleton(m))));
750 List actual_args = appendOnto(extra_args,u_args);
751 return makeStgLambda(
753 unboxVars(a_reps,b_args,u_args,
754 mkStgPrimCase(mkStgPrim(op,actual_args),alts))
759 Void implementPrim ( n )
761 const AsmPrim* p = name(n).primop;
762 StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
763 StgVar v = mkStgVar(rhs,NIL);
765 stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
768 /* Generate wrapper code from (in,out) type lists.
772 * inTypes = [Int,Float]
773 * outTypes = [Char,Addr]
777 * case a1 of { I# a1# ->
778 * case s2 of { F# a2# ->
779 * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
787 * Addr -> (Int -> Float -> IO (Char,Addr))
789 Void implementForeignImport ( Name n )
791 Type t = name(n).type;
793 List resultTys = NIL;
794 CFunDescriptor* descriptor = 0;
795 Bool addState = TRUE;
796 Bool dynamic = isNull(name(n).defn);
797 while (getHead(t)==typeArrow && argCount==2) {
798 Type ta = fullExpand(arg(fun(t)));
800 argTys = cons(ta,argTys);
803 argTys = rev(argTys);
805 /* argTys now holds the argument tys. If this is a dynamic call,
806 the first one had better be an Addr.
809 if (isNull(argTys) || hd(argTys) != typeAddr) {
810 ERRMSG(name(n).line) "First argument in f-i-dynamic must be an Addr"
815 if (getHead(t) == typeIO) {
816 resultTys = getArgs(t);
817 assert(length(resultTys) == 1);
818 resultTys = hd(resultTys);
824 resultTys = fullExpand(resultTys);
825 if (isTuple(getHead(resultTys))) {
826 resultTys = getArgs(resultTys);
827 } else if (getHead(resultTys) == typeUnit) {
830 resultTys = singleton(resultTys);
832 mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */
833 mapOver(foreignInboundTy,resultTys); /* doesn't */
835 = mkDescriptor(charListToString(argTys),
836 charListToString(resultTys));
838 ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
842 /* ccall is the default convention, if it wasn't specified */
843 if (isNull(name(n).callconv)
844 || name(n).callconv == textCcall) {
845 name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
847 else if (name(n).callconv == textStdcall) {
848 if (!stdcallAllowed()) {
849 ERRMSG(name(n).line) "stdcall is not supported on this platform"
852 name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
855 internal ( "implementForeignImport: unknown calling convention");
866 extra_args = singleton(mkPtr(descriptor));
867 /* and we know that the first arg will be the function pointer */
869 extName = name(n).defn;
870 funPtr = getDLLSymbol(name(n).line,
871 textToStr(textOf(fst(extName))),
872 textToStr(textOf(snd(extName))));
875 "Could not find foreign function \"%s\" in \"%s\"",
876 textToStr(textOf(snd(extName))),
877 textToStr(textOf(fst(extName)))
880 extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
883 rhs = makeStgPrim(n,addState,extra_args,
885 descriptor->result_tys);
886 v = mkStgVar(rhs,NIL);
889 stgGlobals = cons(pair(n,v),stgGlobals);
892 /* At this point the descriptor contains a tags for all args,
893 because that makes makeStgPrim generate the correct unwrap
894 code. From now on, the descriptor is only used at the time
895 the actual ccall is made. So we need to zap the leading
896 addr arg IF this is a f-i-dynamic call.
899 descriptor->arg_tys++;
900 descriptor->num_args--;
909 e3 = C# 'c' -- (ccall), or 's' (stdcall)
910 in primMkAdjThunk fun e1 e3
912 we require, and check that,
913 fun :: prim_arg* -> IO prim_result
915 Void implementForeignExport ( Name n )
917 Type t = name(n).type;
919 List resultTys = NIL;
922 if (getHead(t)==typeArrow && argCount==2) {
925 ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
926 ERRTEXT " \"" ETHEN ERRTYPE(t);
931 while (getHead(t)==typeArrow && argCount==2) {
932 Type ta = fullExpand(arg(fun(t)));
934 argTys = cons(ta,argTys);
937 argTys = rev(argTys);
938 if (getHead(t) == typeIO) {
939 resultTys = getArgs(t);
940 assert(length(resultTys) == 1);
941 resultTys = hd(resultTys);
943 ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN
944 ERRTEXT " \"" ETHEN ERRTYPE(t);
948 resultTys = fullExpand(resultTys);
950 mapOver(foreignInboundTy,argTys);
952 /* ccall is the default convention, if it wasn't specified */
953 if (isNull(name(n).callconv)
954 || name(n).callconv == textCcall) {
957 else if (name(n).callconv == textStdcall) {
958 if (!stdcallAllowed()) {
959 ERRMSG(name(n).line) "stdcall is not supported on this platform"
965 internal ( "implementForeignExport: unknown calling convention");
971 StgVar e1, e2, e3, v;
974 tdList = cons(mkChar(':'),argTys);
975 if (resultTys != typeUnit)
976 tdList = cons(foreignOutboundTy(resultTys),tdList);
978 tdText = findText(charListToString ( tdList ));
981 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
985 mkStgApp(nameUnpackString,singleton(e1)),
989 mkStgCon(nameMkC,singleton(mkChar(cc_char))),
998 cons(hd(args),cons(e2,cons(e3,NIL)))
1003 v = mkStgVar(fun,NIL);
1007 stgGlobals = cons(pair(n,v),stgGlobals);
1011 Void implementTuple(size)
1014 Cell t = mkTuple(size);
1015 List args = makeArgs(size);
1016 StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
1017 StgExpr e = mkStgLet(singleton(tv),tv);
1018 StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
1019 stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
1021 StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
1022 stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* ditto */
1026 /* --------------------------------------------------------------------------
1028 * ------------------------------------------------------------------------*/
1030 Void translateControl(what)
1033 case POSTPREL: break;
1044 /*-------------------------------------------------------------------------*/