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/06 14:23:55 $
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; /* arity, not incl dictionaries */
458 Int ad = numQualifiers(name(c).type); /* the number of dictionaries */
459 Type t = name(c).type;
461 /* a+ad is total arity for this fn */
463 StgVar vcurr, e1, v, vsi;
464 List args = makeArgs(a);
465 List argsd = makeArgs(ad);
466 StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
467 List binds = singleton(v0);
470 for (; nonNull(scs); scs=tl(scs)) {
471 vsi = nth(intOf(hd(scs))-1,args);
472 vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
473 binds = cons(vcurr,binds);
476 e1 = mkStgLet(binds,vcurr);
477 v = mkStgVar(mkStgLambda(dupOnto(argsd,args),e1),NIL);
480 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
483 stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
484 /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */
487 /* --------------------------------------------------------------------------
488 * Foreign function calls and primops
489 * ------------------------------------------------------------------------*/
491 /* Outbound denotes data moving from Haskell world to elsewhere.
492 Inbound denotes data moving from elsewhere to Haskell world.
494 static String charListToString ( List cs );
495 static Cell foreignTy ( Bool outBound, Type t );
496 static Cell foreignOutboundTy ( Type t );
497 static Cell foreignInboundTy ( Type t );
498 static Name repToBox ( char c );
499 static StgRhs makeStgPrim ( Name,Bool,List,String,String );
501 static String charListToString( List cs )
506 assert( length(cs) < 100 );
507 for(; nonNull(cs); ++i, cs=tl(cs)) {
508 s[i] = charOf(hd(cs));
511 return textToStr(findText(s));
514 static Cell foreignTy ( Bool outBound, Type t )
516 if (t == typeChar) return mkChar(CHAR_REP);
517 else if (t == typeInt) return mkChar(INT_REP);
519 else if (t == typeInteger)return mkChar(INTEGER_REP);
521 else if (t == typeWord) return mkChar(WORD_REP);
522 else if (t == typeAddr) return mkChar(ADDR_REP);
523 else if (t == typeFloat) return mkChar(FLOAT_REP);
524 else if (t == typeDouble) return mkChar(DOUBLE_REP);
525 else if (t == typeStable) return mkChar(STABLE_REP);
526 #ifdef PROVIDE_FOREIGN
527 else if (t == typeForeign)return mkChar(FOREIGN_REP);
528 /* ToDo: argty only! */
531 else if (t == typePrimByteArray) return mkChar(BARR_REP);
532 /* ToDo: argty only! */
533 else if (whatIs(t) == AP) {
535 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
536 /* ToDo: argty only! */
539 /* ToDo: decent line numbers! */
541 ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
542 ERRTEXT " \"" ETHEN ERRTYPE(t);
546 ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
547 ERRTEXT " \"" ETHEN ERRTYPE(t);
553 static Cell foreignOutboundTy ( Type t )
555 return foreignTy ( TRUE, t );
558 static Cell foreignInboundTy ( Type t )
560 return foreignTy ( FALSE, t );
563 static Name repToBox( char c )
566 case CHAR_REP: return nameMkC;
567 case INT_REP: return nameMkI;
568 case INTEGER_REP: return nameMkInteger;
569 case WORD_REP: return nameMkW;
570 case ADDR_REP: return nameMkA;
571 case FLOAT_REP: return nameMkF;
572 case DOUBLE_REP: return nameMkD;
573 case ARR_REP: return nameMkPrimArray;
574 case BARR_REP: return nameMkPrimByteArray;
575 case REF_REP: return nameMkRef;
576 case MUTARR_REP: return nameMkPrimMutableArray;
577 case MUTBARR_REP: return nameMkPrimMutableByteArray;
578 case STABLE_REP: return nameMkStable;
579 case THREADID_REP: return nameMkThreadId;
580 case MVAR_REP: return nameMkPrimMVar;
582 case WEAK_REP: return nameMkWeak;
584 #ifdef PROVIDE_FOREIGN
585 case FOREIGN_REP: return nameMkForeign;
591 static StgPrimAlt boxResults( String reps, StgVar state )
593 List rs = NIL; /* possibly unboxed results */
594 List bs = NIL; /* boxed results of wrapper */
595 List rbinds = NIL; /* bindings used to box results */
598 for(i=0; reps[i] != '\0'; ++i) {
599 StgRep k = mkStgRep(reps[i]);
600 Cell v = mkStgPrimVar(NIL,k,NIL);
601 Name box = repToBox(reps[i]);
605 StgRhs rhs = mkStgCon(box,singleton(v));
606 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
608 rbinds = cons(bv,rbinds);
613 /* Construct tuple of results */
620 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
621 rbinds = cons(r,rbinds);
624 /* construct result pair if needed */
625 if (nonNull(state)) {
626 /* Note that this builds a tuple directly - we know it's
629 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
630 rbinds = cons(r,rbinds);
631 rs = cons(state,rs); /* last result is a state */
634 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
637 static List mkUnboxedVars( String reps )
641 for(i=0; reps[i] != '\0'; ++i) {
642 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
648 static List mkBoxedVars( String reps )
652 for(i=0; reps[i] != '\0'; ++i) {
653 as = cons(mkStgVar(NIL,NIL),as);
658 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
660 if (nonNull(b_args)) {
661 StgVar b_arg = hd(b_args); /* boxed arg */
662 StgVar u_arg = hd(u_args); /* unboxed arg */
663 Name box = repToBox(*reps);
664 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
666 /* Use a trivial let-binding */
667 stgVarBody(u_arg) = b_arg;
668 return mkStgLet(singleton(u_arg),e);
670 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
671 return mkStgCase(b_arg,singleton(alt));
678 /* Generate wrapper for primop based on list of arg types and result types:
680 * makeStgPrim op# False "II" "II" =
681 * \ x y -> "case x of { I# x# ->
682 * case y of { I# y# ->
683 * case op#{x#,y#} of { r1# r2# ->
684 * let r1 = I# r1#; r2 = I# r2# in
688 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
694 List b_args = NIL; /* boxed args to primop */
695 List u_args = NIL; /* possibly unboxed args to primop */
697 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
698 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
701 if (strcmp(r_reps,"B") == 0) {
703 = mkStgPrimAlt(singleton(
704 mkStgPrimVar(mkInt(0),
705 mkStgRep(INT_REP),NIL)
710 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
712 alts = doubleton(altF,altT);
713 assert(nonNull(nameTrue));
716 alts = singleton(boxResults(r_reps,s1));
718 b_args = mkBoxedVars(a_reps);
719 u_args = mkUnboxedVars(a_reps);
722 = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
724 = makeStgLambda(singleton(s0),
725 unboxVars(a_reps,b_args,u_args,
726 mkStgPrimCase(mkStgPrim(op,actual_args),
728 StgVar m = mkStgVar(rhs,NIL);
729 return makeStgLambda(b_args,
730 mkStgLet(singleton(m),
731 mkStgApp(nameMkIO,singleton(m))));
733 List actual_args = appendOnto(extra_args,u_args);
734 return makeStgLambda(
736 unboxVars(a_reps,b_args,u_args,
737 mkStgPrimCase(mkStgPrim(op,actual_args),alts))
742 Void implementPrim ( n )
744 const AsmPrim* p = name(n).primop;
745 StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
746 StgVar v = mkStgVar(rhs,NIL);
748 stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
751 /* Generate wrapper code from (in,out) type lists.
755 * inTypes = [Int,Float]
756 * outTypes = [Char,Addr]
760 * case a1 of { I# a1# ->
761 * case s2 of { F# a2# ->
762 * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
770 * Addr -> (Int -> Float -> IO (Char,Addr))
772 Void implementForeignImport ( Name n )
774 Type t = name(n).type;
776 List resultTys = NIL;
777 CFunDescriptor* descriptor = 0;
778 Bool addState = TRUE;
779 Bool dynamic = isNull(name(n).defn);
780 while (getHead(t)==typeArrow && argCount==2) {
781 Type ta = fullExpand(arg(fun(t)));
783 argTys = cons(ta,argTys);
786 argTys = rev(argTys);
788 /* argTys now holds the argument tys. If this is a dynamic call,
789 the first one had better be an Addr.
792 if (isNull(argTys) || hd(argTys) != typeAddr) {
793 ERRMSG(name(n).line) "First argument in f-i-dynamic must be an Addr"
798 if (getHead(t) == typeIO) {
799 resultTys = getArgs(t);
800 assert(length(resultTys) == 1);
801 resultTys = hd(resultTys);
807 resultTys = fullExpand(resultTys);
808 if (isTuple(getHead(resultTys))) {
809 resultTys = getArgs(resultTys);
810 } else if (getHead(resultTys) == typeUnit) {
813 resultTys = singleton(resultTys);
815 mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */
816 mapOver(foreignInboundTy,resultTys); /* doesn't */
818 = mkDescriptor(charListToString(argTys),
819 charListToString(resultTys));
821 ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
825 /* ccall is the default convention, if it wasn't specified */
826 if (isNull(name(n).callconv)
827 || name(n).callconv == textCcall) {
828 name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
830 else if (name(n).callconv == textStdcall) {
831 if (!stdcallAllowed()) {
832 ERRMSG(name(n).line) "stdcall is not supported on this platform"
835 name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
838 internal ( "implementForeignImport: unknown calling convention");
849 extra_args = singleton(mkPtr(descriptor));
850 /* and we know that the first arg will be the function pointer */
852 extName = name(n).defn;
853 funPtr = getDLLSymbol(name(n).line,
854 textToStr(textOf(fst(extName))),
855 textToStr(textOf(snd(extName))));
858 "Could not find foreign function \"%s\" in \"%s\"",
859 textToStr(textOf(snd(extName))),
860 textToStr(textOf(fst(extName)))
863 extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
866 rhs = makeStgPrim(n,addState,extra_args,
868 descriptor->result_tys);
869 v = mkStgVar(rhs,NIL);
872 stgGlobals = cons(pair(n,v),stgGlobals);
875 /* At this point the descriptor contains a tags for all args,
876 because that makes makeStgPrim generate the correct unwrap
877 code. From now on, the descriptor is only used at the time
878 the actual ccall is made. So we need to zap the leading
879 addr arg IF this is a f-i-dynamic call.
882 descriptor->arg_tys++;
883 descriptor->num_args--;
892 e3 = C# 'c' -- (ccall), or 's' (stdcall)
893 in primMkAdjThunk fun e1 e3
895 we require, and check that,
896 fun :: prim_arg* -> IO prim_result
898 Void implementForeignExport ( Name n )
900 Type t = name(n).type;
902 List resultTys = NIL;
905 if (getHead(t)==typeArrow && argCount==2) {
908 ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
909 ERRTEXT " \"" ETHEN ERRTYPE(t);
914 while (getHead(t)==typeArrow && argCount==2) {
915 Type ta = fullExpand(arg(fun(t)));
917 argTys = cons(ta,argTys);
920 argTys = rev(argTys);
921 if (getHead(t) == typeIO) {
922 resultTys = getArgs(t);
923 assert(length(resultTys) == 1);
924 resultTys = hd(resultTys);
926 ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN
927 ERRTEXT " \"" ETHEN ERRTYPE(t);
931 resultTys = fullExpand(resultTys);
933 mapOver(foreignInboundTy,argTys);
935 /* ccall is the default convention, if it wasn't specified */
936 if (isNull(name(n).callconv)
937 || name(n).callconv == textCcall) {
940 else if (name(n).callconv == textStdcall) {
941 if (!stdcallAllowed()) {
942 ERRMSG(name(n).line) "stdcall is not supported on this platform"
948 internal ( "implementForeignExport: unknown calling convention");
954 StgVar e1, e2, e3, v;
957 tdList = cons(mkChar(':'),argTys);
958 if (resultTys != typeUnit)
959 tdList = cons(foreignOutboundTy(resultTys),tdList);
961 tdText = findText(charListToString ( tdList ));
964 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
968 mkStgApp(nameUnpackString,singleton(e1)),
972 mkStgCon(nameMkC,singleton(mkChar(cc_char))),
981 cons(hd(args),cons(e2,cons(e3,NIL)))
986 v = mkStgVar(fun,NIL);
990 stgGlobals = cons(pair(n,v),stgGlobals);
994 Void implementTuple(size)
997 Cell t = mkTuple(size);
998 List args = makeArgs(size);
999 StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
1000 StgExpr e = mkStgLet(singleton(tv),tv);
1001 StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
1002 stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
1004 StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
1005 stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* ditto */
1009 /* --------------------------------------------------------------------------
1011 * ------------------------------------------------------------------------*/
1013 Void translateControl(what)
1016 case POSTPREL: break;
1027 /*-------------------------------------------------------------------------*/