2 /* --------------------------------------------------------------------------
3 * Translator: generates stg code from output of pattern matching
6 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
7 * All rights reserved. See NOTICE for details and conditions of use etc...
8 * Hugs version 1.4, December 1997
10 * $RCSfile: translate.c,v $
12 * $Date: 1999/01/13 16:47:26 $
13 * ------------------------------------------------------------------------*/
21 #include "pmc.h" /* for discrArity */
22 #include "hugs.h" /* for debugCode */
23 #include "type.h" /* for conToTagType, tagToConType */
27 #include "Assembler.h"
28 #include "translate.h"
30 /* ---------------------------------------------------------------- */
32 static StgVar local stgOffset Args((Offset,List));
33 static StgVar local stgText Args((Text,List));
34 static StgRhs local stgRhs Args((Cell,Int,List));
35 static StgCaseAlt local stgCaseAlt Args((Cell,Int,List,StgExpr));
36 static StgExpr local stgExpr Args((Cell,Int,List,StgExpr));
38 /* ---------------------------------------------------------------- */
40 /* Association list storing globals assigned to dictionaries, tuples, etc */
41 List stgGlobals = NIL;
43 static StgVar local getSTGTupleVar Args((Cell));
45 static StgVar local getSTGTupleVar( Cell d )
47 Pair p = cellAssoc(d,stgGlobals);
48 /* Yoiks - only the Prelude sees Tuple decls! */
50 implementTuple(tupleOf(d));
51 p = cellAssoc(d,stgGlobals);
57 /* ---------------------------------------------------------------- */
59 static Cell local stgOffset(Offset o, List sc)
61 Cell r = cellAssoc(o,sc);
66 static Cell local stgText(Text t,List sc)
69 for (; nonNull(xs); xs=tl(xs)) {
72 if (!isOffset(v) && t == textOf(v)) {
79 /* ---------------------------------------------------------------- */
81 static StgRhs local stgRhs(e,co,sc)
89 return stgOffset(e,sc);
92 return stgText(textOf(e),sc);
94 return getSTGTupleVar(e);
99 return mkStgCon(nameMkC,singleton(e));
101 return mkStgCon(nameMkI,singleton(e));
103 return mkStgCon(nameMkBignum,singleton(e));
105 return mkStgCon(nameMkD,singleton(e));
107 #if USE_ADDR_FOR_STRINGS
109 StgVar v = mkStgVar(mkStgCon(nameMkA,singleton(e)),NIL);
110 return mkStgLet(singleton(v),
111 makeStgApp(nameUnpackString,singleton(v)));
114 return mkStgApp(nameUnpackString,singleton(e));
117 return stgExpr(e,co,sc,namePMFail);
121 return stgExpr(e,co,sc,namePMFail);
125 static StgCaseAlt local stgCaseAlt(alt,co,sc,failExpr)
131 StgDiscr d = fst(alt);
132 Int da = discrArity(d);
135 for(i=1; i<=da; ++i) {
136 StgVar nv = mkStgVar(NIL,NIL);
138 sc = cons(pair(mkOffset(co+i),nv),sc);
140 return mkStgCaseAlt(d,vs,stgExpr(snd(alt),co+da,sc,failExpr));
143 static StgExpr local stgExpr(e,co,sc,failExpr)
152 return makeStgIf(stgExpr(fst3(snd(e)),co,sc,namePMFail),
153 stgExpr(snd3(snd(e)),co,sc,failExpr),
154 stgExpr(thd3(snd(e)),co,sc,failExpr));
158 List guards = reverse(snd(e));
160 for(; nonNull(guards); guards=tl(guards)) {
162 Cell c = stgExpr(fst(g),co,sc,namePMFail);
163 Cell rhs = stgExpr(snd(g),co,sc,failExpr);
164 e = makeStgIf(c,rhs,e);
170 StgExpr e2 = stgExpr(snd(snd(e)),co,sc,failExpr);
171 StgVar alt = mkStgVar(e2,NIL);
172 return mkStgLet(singleton(alt),stgExpr(fst(snd(e)),co,sc,alt));
176 List alts = snd(snd(e));
177 Cell scrut = stgExpr(fst(snd(e)),co,sc,namePMFail);
180 } else if (isChar(fst(hd(alts)))) {
182 StgDiscr d = fst(alt);
183 StgVar c = mkStgVar(mkStgCon(nameMkC,singleton(d)),NIL);
184 StgExpr test = nameEqChar;
185 /* duplicates scrut but it should be atomic */
186 return makeStgIf(makeStgLet(singleton(c),makeStgApp(test,doubleton(scrut,c))),
187 stgExpr(snd(alt),co,sc,failExpr),
188 stgExpr(ap(CASE,pair(fst(snd(e)),tl(alts))),co,sc,failExpr));
191 for(; nonNull(alts); alts=tl(alts)) {
192 as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
194 return mkStgCase(scrut, revOnto(as, singleton(mkStgDefault(mkStgVar(NIL,NIL),failExpr))));
198 #if OVERLOADED_CONSTANTS
202 Cell discr = snd3(nc);
204 Cell scrut = stgOffset(o,sc);
205 Cell h = getHead(discr);
206 Int da = discrArity(discr);
209 if (whatIs(h) == ADDPAT && argCount == 1) {
210 /* ADDPAT num dictIntegral
212 * let n = fromInteger num in
213 * if pmLe dictIntegral n scrut
214 * then let v = pmSubtract dictIntegral scrut v
218 Cell dictIntegral = arg(discr); /* Integral dictionary */
221 StgVar dIntegral = NIL;
223 /* bind dictionary */
224 dIntegral = stgRhs(dictIntegral,co,sc);
225 if (!isAtomic(dIntegral)) { /* wasn't atomic */
226 dIntegral = mkStgVar(dIntegral,NIL);
227 binds = cons(dIntegral,binds);
230 n = mkStgVar(mkStgCon(nameMkBignum,singleton(n)),NIL);
231 binds = cons(n,binds);
233 /* coerce number to right type (using Integral dict) */
234 n = mkStgVar(mkStgApp(namePmFromInteger,doubleton(dIntegral,n)),NIL);
235 binds = cons(n,binds);
238 v = mkStgVar(mkStgApp(namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
239 return mkStgLet(binds,
240 makeStgIf(mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
241 mkStgLet(singleton(v),
244 cons(pair(mkOffset(co),v),sc),
250 assert(isName(h) && argCount == 2);
252 /* This code is rather ugly.
253 * We ought to desugar it using one of the following:
254 * if (==) dEq (fromInt dNum pat) scrut
255 * if (==) dEq (fromInteger dNum pat) scrut
256 * if (==) dEq (fromFloat dFractional pat) scrut
257 * But it would be very hard to obtain the Eq dictionary
258 * from the Num or Fractional dictionary we have.
259 * Instead, we rely on the Prelude to supply 3 helper
260 * functions which do the test for us.
261 * primPmInt :: Num a => Int -> a -> Bool
262 * primPmInteger :: Num a => Integer -> a -> Bool
263 * primPmDouble :: Fractional a => Double -> a -> Bool
266 Cell dict = arg(fun(discr));
271 = h == nameFromInt ? nameMkI
272 : h == nameFromInteger ? nameMkBignum
275 = h == nameFromInt ? namePmInt
276 : h == nameFromInteger ? namePmInteger
282 for(i=1; i<=da; ++i) {
283 Cell nv = mkStgVar(NIL,NIL);
285 altsc = cons(pair(mkOffset(co+i),nv),altsc);
287 /* bind dictionary */
288 d = stgRhs(dict,co,sc);
289 if (!isAtomic(d)) { /* wasn't atomic */
291 binds = cons(d,binds);
294 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
295 binds = cons(n,binds);
297 return makeStgIf(mkStgLet(binds,
298 mkStgApp(testFun,tripleton(d,n,scrut))),
299 stgExpr(r,co+da,altsc,failExpr),
303 #else /* ! OVERLOADED_CONSTANTS */
307 Cell discr = snd3(nc);
309 Cell scrut = stgOffset(o,sc);
310 Cell h = getHead(discr);
311 Int da = discrArity(discr);
315 = isInt(discr) ? nameEqInt
316 : isBignum(discr) ? nameEqInteger
319 = isInt(discr) ? nameMkI
320 : isBignum(discr) ? nameMkBignum
327 for(i=1; i<=da; ++i) {
328 Cell nv = mkStgVar(NIL,NIL);
330 altsc = cons(pair(mkOffset(co+i),nv),altsc);
334 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
335 binds = cons(n,binds);
337 test = mkStgLet(binds, mkStgApp(eq, doubleton(n,scrut)));
338 return makeStgIf(test,
339 stgExpr(r,co+da,altsc,failExpr),
342 #endif /* ! OVERLOADED_CONSTANTS */
348 /* allocate variables, extend scope */
349 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
350 Cell nv = mkStgVar(NIL,NIL);
351 sc = cons(pair(fst3(hd(bs)),nv),sc);
352 binds = cons(nv,binds);
355 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
356 Cell nv = mkStgVar(NIL,NIL);
357 sc = cons(pair(mkOffset(++co),nv),sc);
358 binds = cons(nv,binds);
362 /* transform functions */
363 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
368 Int arity = intOf(snd3(fun));
370 for(i=1; i<=arity; ++i) {
371 Cell v = mkStgVar(NIL,NIL);
373 funsc = cons(pair(mkOffset(co+i),v),funsc);
375 stgVarBody(nv) = mkStgLambda(as,stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
377 /* transform expressions */
378 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
381 stgVarBody(nv) = stgRhs(rhs,co,sc);
383 return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc));
385 default: /* convert to an StgApp or StgVar plus some bindings */
395 args = cons(arg,args);
399 if (e == nameSel && length(args) == 3) {
402 StgVar v = stgOffset(hd(tl(args)),sc);
404 StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
406 Int ix = intOf(hd(tl(tl(args))));
407 Int da = discrArity(con);
410 for(i=1; i<=da; ++i) {
411 Cell nv = mkStgVar(NIL,NIL);
415 doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
416 mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
419 /* Arguments must be StgAtoms */
420 for(as=args; nonNull(as); as=tl(as)) {
421 StgRhs a = stgRhs(hd(as),co,sc);
422 #if 1 /* optional flattening of let bindings */
423 if (whatIs(a) == LETREC) {
424 binds = appendOnto(stgLetBinds(a),binds);
431 binds = cons(a,binds);
436 /* Function must be StgVar or Name */
438 if (!isStgVar(e) && !isName(e)) {
440 binds = cons(e,binds);
443 return makeStgLet(binds,makeStgApp(e,args));
448 static Void ppExp( Name n, Int arity, Cell e );
449 static Void ppExp( Name n, Int arity, Cell e )
454 printf("%s", textToStr(name(n).text));
455 for (i = arity; i > 0; i--) {
465 Void stgDefn( Name n, Int arity, Cell e )
470 //printf("\nBEGIN --------------- stgDefn-ppExp ----------------\n" );
472 //printf("\nEND ----------------- stgDefn-ppExp ----------------\n" );
473 for (i = 1; i <= arity; ++i) {
474 Cell nv = mkStgVar(NIL,NIL);
476 sc = cons(pair(mkOffset(i),nv),sc);
478 stgVarBody(name(n).stgVar) = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
479 //printf("\nBEGIN --------------- stgDefn-ppStg ----------------\n" );
480 // ppStg(name(n).stgVar);
481 //printf("\nEND ----------------- stgDefn-ppStg ----------------\n" );
484 static StgExpr forceArgs( List is, List args, StgExpr e );
486 /* force the args numbered in is */
487 static StgExpr forceArgs( List is, List args, StgExpr e )
489 for(; nonNull(is); is=tl(is)) {
490 e = mkSeq(nth(intOf(hd(is))-1,args),e);
495 /* \ v -> case v of { ...; Ci _ _ -> i; ... } */
496 Void implementConToTag(t)
498 if (isNull(tycon(t).conToTag)) {
499 List cs = tycon(t).defn;
500 Name nm = newName(inventText());
501 StgVar v = mkStgVar(NIL,NIL);
502 List alts = NIL; /* can't fail */
504 assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE));
505 for (; hasCfun(cs); cs=tl(cs)) {
507 Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
508 StgVar r = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),NIL);
509 StgExpr tag = mkStgLet(singleton(r),r);
512 for(i=0; i < name(c).arity; ++i) {
513 vs = cons(mkStgVar(NIL,NIL),vs);
515 alts = cons(mkStgCaseAlt(c,vs,tag),alts);
518 name(nm).line = tycon(t).line;
519 name(nm).type = conToTagType(t);
521 name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),NIL);
522 tycon(t).conToTag = nm;
523 /* hack to make it print out */
524 stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
528 /* \ v -> case v of { ...; i -> Ci; ... } */
529 Void implementTagToCon(t)
531 if (isNull(tycon(t).tagToCon)) {
545 assert(nameUnpackString);
547 assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE));
549 tyconname = textToStr(tycon(t).text);
550 etxt = malloc(100+strlen(tyconname));
553 "out-of-range arg for `toEnum' in (derived) `instance Enum %s'",
557 nm = newName(inventText());
558 v1 = mkStgVar(NIL,NIL);
559 v2 = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
561 txt0 = mkStr(findText(etxt));
562 bind1 = mkStgVar(mkStgCon(nameMkA,singleton(txt0)),NIL);
563 bind2 = mkStgVar(mkStgApp(nameUnpackString,singleton(bind1)), NIL);
564 bind3 = mkStgVar(mkStgApp(nameError,singleton(bind2)), NIL);
569 mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)
571 makeStgLet ( tripleton(bind1,bind2,bind3), bind3 )
575 for (; hasCfun(cs); cs=tl(cs)) {
577 Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
578 StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL);
579 assert(name(c).arity==0);
580 alts = cons(mkStgPrimAlt(singleton(pat),c),alts);
583 name(nm).line = tycon(t).line;
584 name(nm).type = tagToConType(t);
586 name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v1),
587 mkStgCase(v1,singleton(mkStgCaseAlt(nameMkI,singleton(v2),
588 mkStgPrimCase(v2,alts))))),NIL);
589 tycon(t).tagToCon = nm;
590 /* hack to make it print out */
591 stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
592 if (etxt) free(etxt);
596 Void implementCfun(c,scs) /* Build implementation for constr */
597 Name c; /* fun c. scs lists integers (1..)*/
598 List scs; { /* in incr order of strict comps. */
599 Int a = name(c).arity;
600 if (name(c).arity > 0) {
601 List args = makeArgs(a);
602 StgVar tv = mkStgVar(mkStgCon(c,args),NIL);
603 StgExpr e1 = mkStgLet(singleton(tv),tv);
604 StgExpr e2 = forceArgs(scs,args,e1);
605 StgVar v = mkStgVar(mkStgLambda(args,e2),NIL);
608 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
611 /* hack to make it print out */
612 stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
615 /* --------------------------------------------------------------------------
616 * Foreign function calls and primops
617 * ------------------------------------------------------------------------*/
619 static String charListToString( List cs );
620 static Cell foreignResultTy( Type t );
621 static Cell foreignArgTy( Type t );
622 static Name repToBox Args(( char c ));
623 static StgRhs makeStgPrim Args(( Name,Bool,List,String,String ));
625 static String charListToString( List cs )
630 assert( length(cs) < 100 );
631 for(; nonNull(cs); ++i, cs=tl(cs)) {
632 s[i] = charOf(hd(cs));
635 return textToStr(findText(s));
638 static Cell foreignResultTy( Type t )
640 if (t == typeChar) return mkChar(CHAR_REP);
641 else if (t == typeInt) return mkChar(INT_REP);
643 else if (t == typeInt64) return mkChar(INT64_REP);
645 #ifdef PROVIDE_INTEGER
646 else if (t == typeInteger)return mkChar(INTEGER_REP);
649 else if (t == typeWord) return mkChar(WORD_REP);
652 else if (t == typeAddr) return mkChar(ADDR_REP);
654 else if (t == typeFloat) return mkChar(FLOAT_REP);
655 else if (t == typeDouble) return mkChar(DOUBLE_REP);
656 #ifdef PROVIDE_FOREIGN
657 else if (t == typeForeign)return mkChar(FOREIGN_REP); /* ToDo: argty only! */
660 else if (t == typePrimByteArray) return mkChar(BARR_REP); /* ToDo: argty only! */
661 else if (whatIs(t) == AP) {
663 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP); /* ToDo: argty only! */
666 /* ToDo: decent line numbers! */
667 ERRMSG(0) "Illegal foreign type" ETHEN
668 ERRTEXT " \"" ETHEN ERRTYPE(t);
673 static Cell foreignArgTy( Type t )
675 return foreignResultTy( t );
678 static Name repToBox( char c )
681 case CHAR_REP: return nameMkC;
682 case INT_REP: return nameMkI;
684 case INT64_REP: return nameMkInt64;
686 #ifdef PROVIDE_INTEGER
687 case INTEGER_REP: return nameMkInteger;
690 case WORD_REP: return nameMkW;
693 case ADDR_REP: return nameMkA;
695 case FLOAT_REP: return nameMkF;
696 case DOUBLE_REP: return nameMkD;
698 case ARR_REP: return nameMkPrimArray;
699 case BARR_REP: return nameMkPrimByteArray;
700 case REF_REP: return nameMkRef;
701 case MUTARR_REP: return nameMkPrimMutableArray;
702 case MUTBARR_REP: return nameMkPrimMutableByteArray;
704 #ifdef PROVIDE_STABLE
705 case STABLE_REP: return nameMkStable;
708 case WEAK_REP: return nameMkWeak;
710 #ifdef PROVIDE_FOREIGN
711 case FOREIGN_REP: return nameMkForeign;
713 #ifdef PROVIDE_CONCURRENT
714 case THREADID_REP: return nameMkThreadId;
715 case MVAR_REP: return nameMkMVar;
721 static StgPrimAlt boxResults( String reps, StgVar state )
723 List rs = NIL; /* possibly unboxed results */
724 List bs = NIL; /* boxed results of wrapper */
725 List rbinds = NIL; /* bindings used to box results */
728 for(i=0; reps[i] != '\0'; ++i) {
729 StgRep k = mkStgRep(reps[i]);
730 Cell v = mkStgPrimVar(NIL,k,NIL);
731 Name box = repToBox(reps[i]);
735 StgRhs rhs = mkStgCon(box,singleton(v));
736 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
738 rbinds = cons(bv,rbinds);
742 /* Construct tuple of results */
745 } else { /* includes i==0 case */
746 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
747 rbinds = cons(r,rbinds);
750 /* construct result pair if needed */
751 if (nonNull(state)) {
752 /* Note that this builds a tuple directly - we know it's
755 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
756 rbinds = cons(r,rbinds);
757 rs = cons(state,rs); /* last result is a state */
760 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
763 static List mkUnboxedVars( String reps )
767 for(i=0; reps[i] != '\0'; ++i) {
768 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
774 static List mkBoxedVars( String reps )
778 for(i=0; reps[i] != '\0'; ++i) {
779 as = cons(mkStgVar(NIL,NIL),as);
784 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
786 if (nonNull(b_args)) {
787 StgVar b_arg = hd(b_args); /* boxed arg */
788 StgVar u_arg = hd(u_args); /* unboxed arg */
789 StgRep k = mkStgRep(*reps);
790 Name box = repToBox(*reps);
791 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
793 /* Use a trivial let-binding */
794 stgVarBody(u_arg) = b_arg;
795 return mkStgLet(singleton(u_arg),e);
797 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
798 return mkStgCase(b_arg,singleton(alt));
805 /* Generate wrapper for primop based on list of arg types and result types:
807 * makeStgPrim op# False "II" "II" =
808 * \ x y -> "case x of { I# x# ->
809 * case y of { I# y# ->
810 * case op#{x#,y#} of { r1# r2# ->
811 * let r1 = I# r1#; r2 = I# r2# in
815 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
821 List b_args = NIL; /* boxed args to primop */
822 List u_args = NIL; /* possibly unboxed args to primop */
824 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
825 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
828 if (strcmp(r_reps,"B") == 0) {
829 StgPrimAlt altF = mkStgPrimAlt(singleton(mkStgPrimVar(mkInt(0),mkStgRep(INT_REP),NIL)),
831 StgPrimAlt altT = mkStgPrimAlt(singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
833 alts = doubleton(altF,altT);
834 assert(nonNull(nameTrue));
837 alts = singleton(boxResults(r_reps,s1));
839 b_args = mkBoxedVars(a_reps);
840 u_args = mkUnboxedVars(a_reps);
842 List actual_args = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
843 StgRhs rhs = makeStgLambda(singleton(s0),
844 unboxVars(a_reps,b_args,u_args,
845 mkStgPrimCase(mkStgPrim(op,actual_args),
847 StgVar m = mkStgVar(rhs,NIL);
848 return makeStgLambda(b_args,
849 mkStgLet(singleton(m),
850 mkStgApp(nameMkIO,singleton(m))));
852 List actual_args = appendOnto(extra_args,u_args);
853 return makeStgLambda(b_args,
854 unboxVars(a_reps,b_args,u_args,mkStgPrimCase(mkStgPrim(op,actual_args),alts)));
858 Void implementPrim( n )
860 const AsmPrim* p = name(n).primop;
861 StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
862 StgVar v = mkStgVar(rhs,NIL);
864 stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
867 /* Generate wrapper code from (in,out) type lists.
871 * inTypes = [Int,Float]
872 * outTypes = [Char,Addr]
876 * case a1 of { I# a1# ->
877 * case s2 of { F# a2# ->
878 * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
886 * Addr -> (Int -> Float -> IO (Char,Addr)
888 Void implementForeignImport( Name n )
890 Type t = name(n).type;
892 List resultTys = NIL;
893 CFunDescriptor* descriptor = 0;
894 Bool addState = TRUE;
895 while (getHead(t)==typeArrow && argCount==2) {
896 Type ta = fullExpand(arg(fun(t)));
898 argTys = cons(ta,argTys);
901 argTys = rev(argTys);
902 if (getHead(t) == typeIO) {
903 resultTys = getArgs(t);
904 assert(length(resultTys) == 1);
905 resultTys = hd(resultTys);
911 resultTys = fullExpand(resultTys);
912 if (isTuple(getHead(resultTys))) {
913 resultTys = getArgs(resultTys);
914 } else if (getHead(resultTys) == typeUnit) {
917 resultTys = singleton(resultTys);
919 mapOver(foreignArgTy,argTys); /* allows foreignObj, byteArrays, etc */
920 mapOver(foreignResultTy,resultTys);/* doesn't */
921 descriptor = mkDescriptor(charListToString(argTys),
922 charListToString(resultTys));
923 name(n).primop = addState ? &ccall_IO : &ccall_Id;
925 Pair extName = name(n).defn;
926 void* funPtr = getDLLSymbol(textToStr(textOf(fst(extName))),
927 textToStr(textOf(snd(extName))));
928 List extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
929 StgRhs rhs = makeStgPrim(n,addState,extra_args,descriptor->arg_tys,descriptor->result_tys);
930 StgVar v = mkStgVar(rhs,NIL);
932 ERRMSG(0) "Could not find foreign function \"%s\" in \"%s\"",
933 textToStr(textOf(snd(extName))),
934 textToStr(textOf(fst(extName)))
940 stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
944 Void implementForeignExport( Name n )
946 internal("implementForeignExport: not implemented");
949 Void implementTuple(size)
952 Cell t = mkTuple(size);
953 List args = makeArgs(size);
954 StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
955 StgExpr e = mkStgLet(singleton(tv),tv);
956 StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
957 stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
959 StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
960 stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* so we can see it */
964 /* --------------------------------------------------------------------------
966 * ------------------------------------------------------------------------*/
968 Void translateControl(what)
973 /* deliberate fall through */
984 /*-------------------------------------------------------------------------*/