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/27 16:35:29 $
15 * ------------------------------------------------------------------------*/
17 #include "hugsbasictypes.h"
22 #include "Rts.h" /* to make StgPtr visible in Assembler.h */
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 /* ---------------------------------------------------------------- */
37 static StgVar local getSTGTupleVar ( Cell d )
39 Pair p = cellAssoc(d,stgGlobals);
40 /* Yoiks - only the Prelude sees Tuple decls! */
42 implementTuple(tupleOf(d));
43 p = cellAssoc(d,stgGlobals);
50 /* ---------------------------------------------------------------- */
52 static Cell local stgOffset(Offset o, List sc)
54 Cell r = cellAssoc(o,sc);
59 static Cell local stgText(Text t,List sc)
62 for (; nonNull(xs); xs=tl(xs)) {
65 if (!isOffset(v) && t == textOf(v)) {
72 /* ---------------------------------------------------------------- */
74 static StgRhs local stgRhs(e,co,sc,failExpr)
83 return stgOffset(e,sc);
86 return stgText(textOf(e),sc);
88 /* 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
414 && numQualifiers(name(e).type) == 0)
416 (isTuple(e) && tycon(e).tuple == length_args)
419 /* fprintf ( stderr, "saturated application of %s\n",
420 textToStr(isTuple(e) ? tycon(e).text : name(e).text)); */
421 v = mkStgVar(mkStgCon(e,args),NIL);
422 binds = cons(v,binds);
423 return mkStgLet(binds,v);
428 /* Function must be StgVar or Name */
429 e = stgRhs(e,co,sc,namePMFail);
430 if (!isStgVar(e) && !isName(e)) {
432 binds = cons(e,binds);
435 return makeStgLet(binds,makeStgApp(e,args));
441 Void stgDefn( Name n, Int arity, Cell e )
446 for (i = 1; i <= arity; ++i) {
447 Cell nv = mkStgVar(NIL,NIL);
449 sc = cons(pair(mkOffset(i),nv),sc);
451 stgVarBody(name(n).closure)
452 = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
455 Void implementCfun(c,scs) /* Build implementation for constr */
456 Name c; /* fun c. scs lists integers (1..)*/
457 List scs; { /* in incr order of strict fields. */
458 Int a = name(c).arity; /* arity, not incl dictionaries */
459 Int ad = numQualifiers(name(c).type); /* the number of dictionaries */
460 Type t = name(c).type;
462 /* a+ad is total arity for this fn */
464 StgVar vcurr, e1, v, vsi;
465 List args = makeArgs(a);
466 List argsd = makeArgs(ad);
467 StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
468 List binds = singleton(v0);
471 for (; nonNull(scs); scs=tl(scs)) {
472 vsi = nth(intOf(hd(scs))-1,args);
473 vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
474 binds = cons(vcurr,binds);
477 e1 = mkStgLet(binds,vcurr);
478 v = mkStgVar(mkStgLambda(dupOnto(argsd,args),e1),NIL);
481 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
484 addToCodeList ( currentModule, c );
485 /* printStg(stderr, name(c).closure); fprintf(stderr,"\n\n"); */
488 /* --------------------------------------------------------------------------
489 * Foreign function calls and primops
490 * ------------------------------------------------------------------------*/
492 /* Outbound denotes data moving from Haskell world to elsewhere.
493 Inbound denotes data moving from elsewhere to Haskell world.
495 static String charListToString ( List cs );
496 static Cell foreignTy ( Bool outBound, Type t );
497 static Cell foreignOutboundTy ( Type t );
498 static Cell foreignInboundTy ( Type t );
499 static Name repToBox ( char c );
500 static StgRhs makeStgPrim ( Name,Bool,List,String,String );
502 static String charListToString( List cs )
507 assert( length(cs) < 100 );
508 for(; nonNull(cs); ++i, cs=tl(cs)) {
509 s[i] = charOf(hd(cs));
512 return textToStr(findText(s));
515 static Cell foreignTy ( Bool outBound, Type t )
517 if (t == typeChar) return mkChar(CHAR_REP);
518 else if (t == typeInt) return mkChar(INT_REP);
520 else if (t == typeInteger)return mkChar(INTEGER_REP);
522 else if (t == typeWord) return mkChar(WORD_REP);
523 else if (t == typeAddr) return mkChar(ADDR_REP);
524 else if (t == typeFloat) return mkChar(FLOAT_REP);
525 else if (t == typeDouble) return mkChar(DOUBLE_REP);
526 else if (t == typeStable) return mkChar(STABLE_REP);
527 #ifdef PROVIDE_FOREIGN
528 else if (t == typeForeign)return mkChar(FOREIGN_REP);
529 /* ToDo: argty only! */
532 else if (t == typePrimByteArray) return mkChar(BARR_REP);
533 /* ToDo: argty only! */
534 else if (whatIs(t) == AP) {
536 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
537 /* ToDo: argty only! */
540 /* ToDo: decent line numbers! */
542 ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
543 ERRTEXT " \"" ETHEN ERRTYPE(t);
547 ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
548 ERRTEXT " \"" ETHEN ERRTYPE(t);
554 static Cell foreignOutboundTy ( Type t )
556 return foreignTy ( TRUE, t );
559 static Cell foreignInboundTy ( Type t )
561 return foreignTy ( FALSE, t );
564 static Name repToBox( char c )
567 case CHAR_REP: return nameMkC;
568 case INT_REP: return nameMkI;
569 case INTEGER_REP: return nameMkInteger;
570 case WORD_REP: return nameMkW;
571 case ADDR_REP: return nameMkA;
572 case FLOAT_REP: return nameMkF;
573 case DOUBLE_REP: return nameMkD;
574 case ARR_REP: return nameMkPrimArray;
575 case BARR_REP: return nameMkPrimByteArray;
576 case REF_REP: return nameMkRef;
577 case MUTARR_REP: return nameMkPrimMutableArray;
578 case MUTBARR_REP: return nameMkPrimMutableByteArray;
579 case STABLE_REP: return nameMkStable;
580 case THREADID_REP: return nameMkThreadId;
581 case MVAR_REP: return nameMkPrimMVar;
583 case WEAK_REP: return nameMkWeak;
585 #ifdef PROVIDE_FOREIGN
586 case FOREIGN_REP: return nameMkForeign;
592 static StgPrimAlt boxResults( String reps, StgVar state )
594 List rs = NIL; /* possibly unboxed results */
595 List bs = NIL; /* boxed results of wrapper */
596 List rbinds = NIL; /* bindings used to box results */
599 for(i=0; reps[i] != '\0'; ++i) {
600 StgRep k = mkStgRep(reps[i]);
601 Cell v = mkStgPrimVar(NIL,k,NIL);
602 Name box = repToBox(reps[i]);
606 StgRhs rhs = mkStgCon(box,singleton(v));
607 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
609 rbinds = cons(bv,rbinds);
614 /* Construct tuple of results */
621 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
622 rbinds = cons(r,rbinds);
625 /* construct result pair if needed */
626 if (nonNull(state)) {
627 /* Note that this builds a tuple directly - we know it's
630 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
631 rbinds = cons(r,rbinds);
632 rs = cons(state,rs); /* last result is a state */
635 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
638 static List mkUnboxedVars( String reps )
642 for(i=0; reps[i] != '\0'; ++i) {
643 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
649 static List mkBoxedVars( String reps )
653 for(i=0; reps[i] != '\0'; ++i) {
654 as = cons(mkStgVar(NIL,NIL),as);
659 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
661 if (nonNull(b_args)) {
662 StgVar b_arg = hd(b_args); /* boxed arg */
663 StgVar u_arg = hd(u_args); /* unboxed arg */
664 Name box = repToBox(*reps);
665 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
667 /* Use a trivial let-binding */
668 stgVarBody(u_arg) = b_arg;
669 return mkStgLet(singleton(u_arg),e);
671 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
672 return mkStgCase(b_arg,singleton(alt));
679 /* Generate wrapper for primop based on list of arg types and result types:
681 * makeStgPrim op# False "II" "II" =
682 * \ x y -> "case x of { I# x# ->
683 * case y of { I# y# ->
684 * case op#{x#,y#} of { r1# r2# ->
685 * let r1 = I# r1#; r2 = I# r2# in
689 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
695 List b_args = NIL; /* boxed args to primop */
696 List u_args = NIL; /* possibly unboxed args to primop */
698 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
699 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
702 if (strcmp(r_reps,"B") == 0) {
704 = mkStgPrimAlt(singleton(
705 mkStgPrimVar(mkInt(0),
706 mkStgRep(INT_REP),NIL)
711 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
713 alts = doubleton(altF,altT);
714 assert(nonNull(nameTrue));
717 alts = singleton(boxResults(r_reps,s1));
719 b_args = mkBoxedVars(a_reps);
720 u_args = mkUnboxedVars(a_reps);
723 = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
725 = makeStgLambda(singleton(s0),
726 unboxVars(a_reps,b_args,u_args,
727 mkStgPrimCase(mkStgPrim(op,actual_args),
729 StgVar m = mkStgVar(rhs,NIL);
730 return makeStgLambda(b_args,
731 mkStgLet(singleton(m),
732 mkStgApp(nameMkIO,singleton(m))));
734 List actual_args = appendOnto(extra_args,u_args);
735 return makeStgLambda(
737 unboxVars(a_reps,b_args,u_args,
738 mkStgPrimCase(mkStgPrim(op,actual_args),alts))
743 Void implementPrim ( n )
745 const AsmPrim* p = name(n).primop;
746 StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
747 StgVar v = mkStgVar(rhs,NIL);
749 addToCodeList ( currentModule, n );
752 /* Generate wrapper code from (in,out) type lists.
756 * inTypes = [Int,Float]
757 * outTypes = [Char,Addr]
761 * case a1 of { I# a1# ->
762 * case s2 of { F# a2# ->
763 * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
771 * Addr -> (Int -> Float -> IO (Char,Addr))
773 Void implementForeignImport ( Name n )
775 Type t = name(n).type;
777 List resultTys = NIL;
778 CFunDescriptor* descriptor = 0;
779 Bool addState = TRUE;
780 Bool dynamic = isNull(name(n).defn);
781 while (getHead(t)==typeArrow && argCount==2) {
782 Type ta = fullExpand(arg(fun(t)));
784 argTys = cons(ta,argTys);
787 argTys = rev(argTys);
789 /* argTys now holds the argument tys. If this is a dynamic call,
790 the first one had better be an Addr.
793 if (isNull(argTys) || hd(argTys) != typeAddr) {
794 ERRMSG(name(n).line) "First argument in f-i-dynamic must be an Addr"
799 if (getHead(t) == typeIO) {
800 resultTys = getArgs(t);
801 assert(length(resultTys) == 1);
802 resultTys = hd(resultTys);
808 resultTys = fullExpand(resultTys);
809 if (isTuple(getHead(resultTys))) {
810 resultTys = getArgs(resultTys);
811 } else if (getHead(resultTys) == typeUnit) {
814 resultTys = singleton(resultTys);
816 mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */
817 mapOver(foreignInboundTy,resultTys); /* doesn't */
819 = mkDescriptor(charListToString(argTys),
820 charListToString(resultTys));
822 ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
826 /* ccall is the default convention, if it wasn't specified */
827 if (isNull(name(n).callconv)
828 || name(n).callconv == textCcall) {
829 name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
831 else if (name(n).callconv == textStdcall) {
832 if (!stdcallAllowed()) {
833 ERRMSG(name(n).line) "stdcall is not supported on this platform"
836 name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
839 internal ( "implementForeignImport: unknown calling convention");
850 extra_args = singleton(mkAddr(descriptor));
851 /* and we know that the first arg will be the function pointer */
853 extName = name(n).defn;
854 funPtr = getDLLSymbol(name(n).line,
855 textToStr(textOf(fst(extName))),
856 textToStr(textOf(snd(extName))));
859 "Could not find foreign function \"%s\" in \"%s\"",
860 textToStr(textOf(snd(extName))),
861 textToStr(textOf(fst(extName)))
864 extra_args = doubleton(mkAddr(descriptor),mkAddr(funPtr));
867 rhs = makeStgPrim(n,addState,extra_args,
869 descriptor->result_tys);
870 v = mkStgVar(rhs,NIL);
873 addToCodeList ( currentModule, n );
876 /* At this point the descriptor contains a tag for each arg,
877 because that makes makeStgPrim generate the correct unwrap
878 code. From now on, the descriptor is only used at the time
879 the actual ccall is made. So we need to zap the leading
880 addr arg IF this is a f-i-dynamic call.
883 descriptor->arg_tys++;
884 descriptor->num_args--;
893 e3 = C# 'c' -- (ccall), or 's' (stdcall)
894 in primMkAdjThunk fun e1 e3
896 we require, and check that,
897 fun :: prim_arg* -> IO prim_result
899 Void implementForeignExport ( Name n )
901 Type t = name(n).type;
903 List resultTys = NIL;
906 if (getHead(t)==typeArrow && argCount==2) {
909 ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
910 ERRTEXT " \"" ETHEN ERRTYPE(t);
915 while (getHead(t)==typeArrow && argCount==2) {
916 Type ta = fullExpand(arg(fun(t)));
918 argTys = cons(ta,argTys);
921 argTys = rev(argTys);
922 if (getHead(t) == typeIO) {
923 resultTys = getArgs(t);
924 assert(length(resultTys) == 1);
925 resultTys = hd(resultTys);
927 ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN
928 ERRTEXT " \"" ETHEN ERRTYPE(t);
932 resultTys = fullExpand(resultTys);
934 mapOver(foreignInboundTy,argTys);
936 /* ccall is the default convention, if it wasn't specified */
937 if (isNull(name(n).callconv)
938 || name(n).callconv == textCcall) {
941 else if (name(n).callconv == textStdcall) {
942 if (!stdcallAllowed()) {
943 ERRMSG(name(n).line) "stdcall is not supported on this platform"
949 internal ( "implementForeignExport: unknown calling convention");
955 StgVar e1, e2, e3, v;
958 tdList = cons(mkChar(':'),argTys);
959 if (resultTys != typeUnit)
960 tdList = cons(foreignOutboundTy(resultTys),tdList);
962 tdText = findText(charListToString ( tdList ));
965 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
969 mkStgApp(nameUnpackString,singleton(e1)),
973 mkStgCon(nameMkC,singleton(mkChar(cc_char))),
982 cons(hd(args),cons(e2,cons(e3,NIL)))
987 v = mkStgVar(fun,NIL);
991 addToCodeList ( currentModule, n );
995 Void implementTuple(size)
998 Tycon t = mkTuple(size);
999 List args = makeArgs(size);
1000 StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
1001 StgExpr e = mkStgLet(singleton(tv),tv);
1002 StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
1003 tycon(t).closure = v;
1004 addToCodeList ( currentModule, t );
1006 addToCodeList ( currentModule, nameUnit );
1010 /* --------------------------------------------------------------------------
1012 * ------------------------------------------------------------------------*/
1014 Void translateControl(what)
1017 case POSTPREL: break;
1026 /*-------------------------------------------------------------------------*/