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/05/12 11:59:39 $
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 /* ---------------------------------------------------------------- */
36 static Cell local stgOffset(Offset o, List sc)
38 Cell r = cellAssoc(o,sc);
43 static Cell local stgText(Text t,List sc)
46 for (; nonNull(xs); xs=tl(xs)) {
49 if (!isOffset(v) && t == textOf(v)) {
56 /* ---------------------------------------------------------------- */
58 static StgRhs local stgRhs(e,co,sc,failExpr)
67 return stgOffset(e,sc);
70 return stgText(textOf(e),sc);
77 return mkStgCon(nameMkC,singleton(e));
79 return mkStgCon(nameMkI,singleton(e));
81 return mkStgCon(nameMkInteger,singleton(e));
83 return mkStgCon(nameMkD,singleton(e));
85 #if USE_ADDR_FOR_STRINGS
87 StgVar v = mkStgVar(mkStgCon(nameMkA,singleton(e)),NIL);
88 return mkStgLet(singleton(v),
89 makeStgApp(nameUnpackString,singleton(v)));
92 return mkStgApp(nameUnpackString,singleton(e));
95 return stgExpr(e,co,sc,namePMFail);
99 return stgExpr(e,co,sc,failExpr/*namePMFail*/);
103 static StgCaseAlt local stgCaseAlt(alt,co,sc,failExpr)
109 StgDiscr d = fst(alt);
110 Int da = discrArity(d);
113 for(i=1; i<=da; ++i) {
114 StgVar nv = mkStgVar(NIL,NIL);
116 sc = cons(pair(mkOffset(co+i),nv),sc);
118 return mkStgCaseAlt(d,vs,stgExpr(snd(alt),co+da,sc,failExpr));
121 static StgExpr local stgExpr(e,co,sc,failExpr)
130 return makeStgIf(stgExpr(fst3(snd(e)),co,sc,namePMFail),
131 stgExpr(snd3(snd(e)),co,sc,failExpr),
132 stgExpr(thd3(snd(e)),co,sc,failExpr));
136 List guards = reverse(snd(e));
138 for(; nonNull(guards); guards=tl(guards)) {
140 Cell c = stgExpr(fst(g),co,sc,namePMFail);
141 Cell rhs = stgExpr(snd(g),co,sc,failExpr);
142 e = makeStgIf(c,rhs,e);
148 StgExpr e2 = stgExpr(snd(snd(e)),co,sc,failExpr);
149 StgVar alt = mkStgVar(e2,NIL);
150 return mkStgLet(singleton(alt),stgExpr(fst(snd(e)),co,sc,alt));
154 List alts = snd(snd(e));
155 Cell scrut = stgExpr(fst(snd(e)),co,sc,namePMFail);
158 } else if (isChar(fst(hd(alts)))) {
160 StgDiscr d = fst(alt);
162 mkStgCon(nameMkC,singleton(d)),NIL);
163 StgExpr test = nameEqChar;
164 /* duplicates scrut but it should be atomic */
166 makeStgLet(singleton(c),
167 makeStgApp(test,doubleton(scrut,c))),
168 stgExpr(snd(alt),co,sc,failExpr),
169 stgExpr(ap(CASE,pair(fst(snd(e)),
170 tl(alts))),co,sc,failExpr));
173 for(; nonNull(alts); alts=tl(alts)) {
174 as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
180 singleton(mkStgDefault(mkStgVar(NIL,NIL),
188 Cell discr = snd3(nc);
190 Cell scrut = stgOffset(o,sc);
191 Cell h = getHead(discr);
192 Int da = discrArity(discr);
195 if (whatIs(h) == ADDPAT && argCount == 1) {
196 /* ADDPAT num dictIntegral
198 * let n = fromInteger num in
199 * if pmLe dictIntegral n scrut
200 * then let v = pmSubtract dictIntegral scrut v
204 Cell dictIntegral = arg(discr); /* Integral dictionary */
207 StgVar dIntegral = NIL;
209 /* bind dictionary */
210 dIntegral = stgRhs(dictIntegral,co,sc,namePMFail);
211 if (!isAtomic(dIntegral)) { /* wasn't atomic */
212 dIntegral = mkStgVar(dIntegral,NIL);
213 binds = cons(dIntegral,binds);
217 sprintf(str, "%d", n);
218 n = mkStgVar(mkStgCon(nameMkInteger,singleton(stringToBignum(str))),NIL);
219 binds = cons(n,binds);
221 /* coerce number to right type (using Integral dict) */
222 n = mkStgVar(mkStgApp(
223 namePmFromInteger,doubleton(dIntegral,n)),NIL);
224 binds = cons(n,binds);
227 v = mkStgVar(mkStgApp(
228 namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
233 mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
234 mkStgLet(singleton(v),
237 cons(pair(mkOffset(co),v),sc),
242 assert(isName(h) && argCount == 2);
244 /* This code is rather ugly.
245 * We ought to desugar it using one of the following:
246 * if (==) dEq (fromInt dNum pat) scrut
247 * if (==) dEq (fromInteger dNum pat) scrut
248 * if (==) dEq (fromFloat dFractional pat) scrut
249 * But it would be very hard to obtain the Eq dictionary
250 * from the Num or Fractional dictionary we have.
251 * Instead, we rely on the Prelude to supply 3 helper
252 * functions which do the test for us.
253 * primPmInt :: Num a => Int -> a -> Bool
254 * primPmInteger :: Num a => Integer -> a -> Bool
255 * primPmDouble :: Fractional a => Double -> a -> Bool
258 Cell dict = arg(fun(discr));
263 = h == nameFromInt ? nameMkI
264 : h == nameFromInteger ? nameMkInteger
267 = h == nameFromInt ? namePmInt
268 : h == nameFromInteger ? namePmInteger
274 for(i=1; i<=da; ++i) {
275 Cell nv = mkStgVar(NIL,NIL);
277 altsc = cons(pair(mkOffset(co+i),nv),altsc);
279 /* bind dictionary */
280 d = stgRhs(dict,co,sc,namePMFail);
281 if (!isAtomic(d)) { /* wasn't atomic */
283 binds = cons(d,binds);
286 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
287 binds = cons(n,binds);
292 mkStgApp(testFun,tripleton(d,n,scrut))),
293 stgExpr(r,co+da,altsc,failExpr),
304 /* allocate variables, extend scope */
305 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
306 Cell nv = mkStgVar(NIL,NIL);
307 sc = cons(pair(fst3(hd(bs)),nv),sc);
308 binds = cons(nv,binds);
311 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
312 Cell nv = mkStgVar(NIL,NIL);
313 sc = cons(pair(mkOffset(++co),nv),sc);
314 binds = cons(nv,binds);
318 /* transform functions */
319 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
324 Int arity = intOf(snd3(fun));
326 for(i=1; i<=arity; ++i) {
327 Cell v = mkStgVar(NIL,NIL);
329 funsc = cons(pair(mkOffset(co+i),v),funsc);
334 stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
336 /* transform expressions */
337 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
340 stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail);
342 return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
345 default: /* convert to an StgApp or StgVar plus some bindings */
356 args = cons(arg,args);
360 if (e == nameSel && length(args) == 3) {
362 StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
363 Int ix = intOf(hd(tl(tl(args))));
364 Int da = discrArity(con);
367 for(i=1; i<=da; ++i) {
368 Cell nv = mkStgVar(NIL,NIL);
373 doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
374 mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
377 /* Arguments must be StgAtoms */
378 for(as=args; nonNull(as); as=tl(as)) {
379 StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
380 if (whatIs(a) == LETREC) {
381 binds = appendOnto(stgLetBinds(a),binds);
386 binds = cons(a,binds);
391 /* Special case: saturated constructor application */
392 length_args = length(args);
393 if ( (isName(e) && isCfun(e)
395 && name(e).arity == length_args
396 && !name(e).hasStrict
397 && numQualifiers(name(e).type) == 0)
399 (isTuple(e) && tycon(e).tuple == length_args)
402 /* fprintf ( stderr, "saturated application of %s\n",
403 textToStr(isTuple(e) ? tycon(e).text : name(e).text)); */
404 v = mkStgVar(mkStgCon(e,args),NIL);
405 binds = cons(v,binds);
406 return mkStgLet(binds,v);
411 /* Function must be StgVar or Name */
412 e = stgRhs(e,co,sc,namePMFail);
413 if (!isStgVar(e) && !isName(e)) {
415 binds = cons(e,binds);
418 return makeStgLet(binds,makeStgApp(e,args));
424 Void stgDefn( Name n, Int arity, Cell e )
429 for (i = 1; i <= arity; ++i) {
430 Cell nv = mkStgVar(NIL,NIL);
432 sc = cons(pair(mkOffset(i),nv),sc);
434 stgVarBody(name(n).closure)
435 = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
438 Void implementCfun(c,scs) /* Build implementation for constr */
439 Name c; /* fun c. scs lists integers (1..)*/
440 List scs; { /* in incr order of strict fields. */
441 Int a = name(c).arity; /* arity, not incl dictionaries */
442 Int ad = numQualifiers(name(c).type); /* the number of dictionaries */
443 Type t = name(c).type;
445 /* a+ad is total arity for this fn */
447 StgVar vcurr, e1, v, vsi;
448 List args = makeArgs(a);
449 List argsd = makeArgs(ad);
450 StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
451 List binds = singleton(v0);
454 for (; nonNull(scs); scs=tl(scs)) {
455 vsi = nth(intOf(hd(scs))-1,args);
456 vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
457 binds = cons(vcurr,binds);
460 e1 = mkStgLet(binds,vcurr);
461 v = mkStgVar(mkStgLambda(dupOnto(argsd,args),e1),NIL);
464 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
467 addToCodeList ( currentModule, c );
468 /* printStg(stderr, name(c).closure); fprintf(stderr,"\n\n"); */
471 /* --------------------------------------------------------------------------
472 * Foreign function calls and primops
473 * ------------------------------------------------------------------------*/
475 /* Outbound denotes data moving from Haskell world to elsewhere.
476 Inbound denotes data moving from elsewhere to Haskell world.
478 static String charListToString ( List cs );
479 static Cell foreignTy ( Bool outBound, Type t );
480 static Cell foreignOutboundTy ( Type t );
481 static Cell foreignInboundTy ( Type t );
482 static Name repToBox ( char c );
483 static StgRhs makeStgPrim ( Name,Bool,List,String,String );
485 static String charListToString( List cs )
490 assert( length(cs) < 100 );
491 for(; nonNull(cs); ++i, cs=tl(cs)) {
492 s[i] = charOf(hd(cs));
495 return textToStr(findText(s));
498 static Cell foreignTy ( Bool outBound, Type t )
500 if (t == typeChar) return mkChar(CHAR_REP);
501 else if (t == typeInt) return mkChar(INT_REP);
503 else if (t == typeInteger)return mkChar(INTEGER_REP);
505 else if (t == typeWord) return mkChar(WORD_REP);
506 else if (t == typeAddr) return mkChar(ADDR_REP);
507 else if (t == typeFloat) return mkChar(FLOAT_REP);
508 else if (t == typeDouble) return mkChar(DOUBLE_REP);
509 else if (t == typeStable) return mkChar(STABLE_REP);
510 #ifdef PROVIDE_FOREIGN
511 else if (t == typeForeign)return mkChar(FOREIGN_REP);
512 /* ToDo: argty only! */
515 else if (t == typePrimByteArray) return mkChar(BARR_REP);
516 /* ToDo: argty only! */
517 else if (whatIs(t) == AP) {
519 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
520 /* ToDo: argty only! */
523 /* ToDo: decent line numbers! */
525 ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
526 ERRTEXT " \"" ETHEN ERRTYPE(t);
530 ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
531 ERRTEXT " \"" ETHEN ERRTYPE(t);
537 static Cell foreignOutboundTy ( Type t )
539 return foreignTy ( TRUE, t );
542 static Cell foreignInboundTy ( Type t )
544 return foreignTy ( FALSE, t );
547 static Name repToBox( char c )
550 case CHAR_REP: return nameMkC;
551 case INT_REP: return nameMkI;
552 case INTEGER_REP: return nameMkInteger;
553 case WORD_REP: return nameMkW;
554 case ADDR_REP: return nameMkA;
555 case FLOAT_REP: return nameMkF;
556 case DOUBLE_REP: return nameMkD;
557 case ARR_REP: return nameMkPrimArray;
558 case BARR_REP: return nameMkPrimByteArray;
559 case REF_REP: return nameMkRef;
560 case MUTARR_REP: return nameMkPrimMutableArray;
561 case MUTBARR_REP: return nameMkPrimMutableByteArray;
562 case STABLE_REP: return nameMkStable;
563 case THREADID_REP: return nameMkThreadId;
564 case MVAR_REP: return nameMkPrimMVar;
566 case WEAK_REP: return nameMkWeak;
568 #ifdef PROVIDE_FOREIGN
569 case FOREIGN_REP: return nameMkForeign;
575 static StgPrimAlt boxResults( String reps, StgVar state )
577 List rs = NIL; /* possibly unboxed results */
578 List bs = NIL; /* boxed results of wrapper */
579 List rbinds = NIL; /* bindings used to box results */
582 for(i=0; reps[i] != '\0'; ++i) {
583 StgRep k = mkStgRep(reps[i]);
584 Cell v = mkStgPrimVar(NIL,k,NIL);
585 Name box = repToBox(reps[i]);
589 StgRhs rhs = mkStgCon(box,singleton(v));
590 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
592 rbinds = cons(bv,rbinds);
597 /* Construct tuple of results */
604 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
605 rbinds = cons(r,rbinds);
608 /* construct result pair if needed */
609 if (nonNull(state)) {
610 /* Note that this builds a tuple directly - we know it's
613 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
614 rbinds = cons(r,rbinds);
615 rs = cons(state,rs); /* last result is a state */
618 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
621 static List mkUnboxedVars( String reps )
625 for(i=0; reps[i] != '\0'; ++i) {
626 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
632 static List mkBoxedVars( String reps )
636 for(i=0; reps[i] != '\0'; ++i) {
637 as = cons(mkStgVar(NIL,NIL),as);
642 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
644 if (nonNull(b_args)) {
645 StgVar b_arg = hd(b_args); /* boxed arg */
646 StgVar u_arg = hd(u_args); /* unboxed arg */
647 Name box = repToBox(*reps);
648 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
650 /* Use a trivial let-binding */
651 stgVarBody(u_arg) = b_arg;
652 return mkStgLet(singleton(u_arg),e);
654 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
655 return mkStgCase(b_arg,singleton(alt));
662 /* Generate wrapper for primop based on list of arg types and result types:
664 * makeStgPrim op# False "II" "II" =
665 * \ x y -> "case x of { I# x# ->
666 * case y of { I# y# ->
667 * case op#{x#,y#} of { r1# r2# ->
668 * let r1 = I# r1#; r2 = I# r2# in
672 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
678 List b_args = NIL; /* boxed args to primop */
679 List u_args = NIL; /* possibly unboxed args to primop */
681 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
682 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
685 if (strcmp(r_reps,"B") == 0) {
687 = mkStgPrimAlt(singleton(
688 mkStgPrimVar(mkInt(0),
689 mkStgRep(INT_REP),NIL)
694 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
696 alts = doubleton(altF,altT);
697 assert(nonNull(nameTrue));
700 alts = singleton(boxResults(r_reps,s1));
702 b_args = mkBoxedVars(a_reps);
703 u_args = mkUnboxedVars(a_reps);
706 = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
708 = makeStgLambda(singleton(s0),
709 unboxVars(a_reps,b_args,u_args,
710 mkStgPrimCase(mkStgPrim(op,actual_args),
712 StgVar m = mkStgVar(rhs,NIL);
713 return makeStgLambda(b_args,
714 mkStgLet(singleton(m),
715 mkStgApp(nameMkIO,singleton(m))));
717 List actual_args = appendOnto(extra_args,u_args);
718 return makeStgLambda(
720 unboxVars(a_reps,b_args,u_args,
721 mkStgPrimCase(mkStgPrim(op,actual_args),alts))
726 Void implementPrim ( n )
728 const AsmPrim* p = name(n).primop;
729 StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
730 StgVar v = mkStgVar(rhs,NIL);
732 addToCodeList ( currentModule, n );
735 /* Generate wrapper code from (in,out) type lists.
739 * inTypes = [Int,Float]
740 * outTypes = [Char,Addr]
744 * case a1 of { I# a1# ->
745 * case s2 of { F# a2# ->
746 * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
754 * Addr -> (Int -> Float -> IO (Char,Addr))
756 Void implementForeignImport ( Name n )
758 Type t = name(n).type;
760 List resultTys = NIL;
761 CFunDescriptor* descriptor = 0;
762 Bool addState = TRUE;
763 Bool dynamic = isNull(name(n).defn);
764 while (getHead(t)==typeArrow && argCount==2) {
765 Type ta = fullExpand(arg(fun(t)));
767 argTys = cons(ta,argTys);
770 argTys = rev(argTys);
772 /* argTys now holds the argument tys. If this is a dynamic call,
773 the first one had better be an Addr.
776 if (isNull(argTys) || hd(argTys) != typeAddr) {
777 ERRMSG(name(n).line) "First argument in f-i-dynamic must be an Addr"
782 if (getHead(t) == typeIO) {
783 resultTys = getArgs(t);
784 assert(length(resultTys) == 1);
785 resultTys = hd(resultTys);
791 resultTys = fullExpand(resultTys);
792 if (isTuple(getHead(resultTys))) {
793 resultTys = getArgs(resultTys);
794 } else if (getHead(resultTys) == typeUnit) {
797 resultTys = singleton(resultTys);
799 mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */
800 mapOver(foreignInboundTy,resultTys); /* doesn't */
802 = mkDescriptor(charListToString(argTys),
803 charListToString(resultTys));
805 ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
809 /* ccall is the default convention, if it wasn't specified */
810 if (isNull(name(n).callconv)
811 || name(n).callconv == textCcall) {
812 name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
814 else if (name(n).callconv == textStdcall) {
815 if (!stdcallAllowed()) {
816 ERRMSG(name(n).line) "stdcall is not supported on this platform"
819 name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
822 internal ( "implementForeignImport: unknown calling convention");
833 extra_args = singleton(mkAddr(descriptor));
834 /* and we know that the first arg will be the function pointer */
836 extName = name(n).defn;
837 funPtr = getDLLSymbol(name(n).line,
838 textToStr(textOf(fst(extName))),
839 textToStr(textOf(snd(extName))));
842 "Could not find foreign function \"%s\" in \"%s\"",
843 textToStr(textOf(snd(extName))),
844 textToStr(textOf(fst(extName)))
847 extra_args = doubleton(mkAddr(descriptor),mkAddr(funPtr));
850 rhs = makeStgPrim(n,addState,extra_args,
852 descriptor->result_tys);
853 v = mkStgVar(rhs,NIL);
856 addToCodeList ( currentModule, n );
859 /* At this point the descriptor contains a tag for each arg,
860 because that makes makeStgPrim generate the correct unwrap
861 code. From now on, the descriptor is only used at the time
862 the actual ccall is made. So we need to zap the leading
863 addr arg IF this is a f-i-dynamic call.
866 descriptor->arg_tys++;
867 descriptor->num_args--;
877 e3 = C# 'c' -- (ccall), or 's' (stdcall)
878 in primMkAdjThunk fun e1 e3
880 we require, and check that,
881 fun :: prim_arg* -> IO prim_result
883 Text makeTypeDescrText ( Type t )
886 List resultTys = NIL;
890 // I don't understand what this achieves.
891 if (getHead(t)==typeArrow && argCount==2) {
897 while (getHead(t)==typeArrow && argCount==2) {
898 Type ta = fullExpand(arg(fun(t)));
900 argTys = cons(ta,argTys);
903 argTys = rev(argTys);
904 if (getHead(t) == typeIO) {
905 resultTys = getArgs(t);
906 assert(length(resultTys) == 1);
907 resultTys = hd(resultTys);
911 resultTys = fullExpand(resultTys);
913 mapOver(foreignInboundTy,argTys);
915 tdList = cons(mkChar(':'),argTys);
916 if (resultTys != typeUnit)
917 tdList = cons(foreignOutboundTy(resultTys),tdList);
919 return findText(charListToString ( tdList ));
923 Void implementForeignExport ( Name n )
927 StgVar e1, e2, e3, v;
931 tdText = makeTypeDescrText ( name(n).type );
932 if (isNull(tdText)) {
933 ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
934 ERRTEXT " \"" ETHEN ERRTYPE(name(n).type);
939 /* ccall is the default convention, if it wasn't specified */
940 if (isNull(name(n).callconv)
941 || name(n).callconv == textCcall) {
944 else if (name(n).callconv == textStdcall) {
945 if (!stdcallAllowed()) {
946 ERRMSG(name(n).line) "stdcall is not supported on this platform"
952 internal ( "implementForeignExport: unknown calling convention");
956 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
960 mkStgApp(nameUnpackString,singleton(e1)),
964 mkStgCon(nameMkC,singleton(mkChar(cc_char))),
973 cons(hd(args),cons(e2,cons(e3,NIL)))
978 v = mkStgVar(fun,NIL);
982 addToCodeList ( currentModule, n );
985 Void implementTuple(size)
988 Tycon t = mkTuple(size);
989 List args = makeArgs(size);
990 StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
991 StgExpr e = mkStgLet(singleton(tv),tv);
992 StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
993 tycon(t).closure = v;
994 addToCodeList ( currentModule, t );
996 addToCodeList ( currentModule, nameUnit );
1000 /* --------------------------------------------------------------------------
1002 * ------------------------------------------------------------------------*/
1004 Void translateControl(what)
1007 case POSTPREL: break;
1016 /*-------------------------------------------------------------------------*/