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/02/03 17:08:44 $
13 * ------------------------------------------------------------------------*/
22 #include "Assembler.h"
24 /* ---------------------------------------------------------------- */
26 static StgVar local stgOffset Args((Offset,List));
27 static StgVar local stgText Args((Text,List));
28 static StgRhs local stgRhs Args((Cell,Int,List));
29 static StgCaseAlt local stgCaseAlt Args((Cell,Int,List,StgExpr));
30 static StgExpr local stgExpr Args((Cell,Int,List,StgExpr));
32 /* ---------------------------------------------------------------- */
34 /* Association list storing globals assigned to dictionaries, tuples, etc */
35 List stgGlobals = NIL;
37 static StgVar local getSTGTupleVar Args((Cell));
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)
83 return stgOffset(e,sc);
86 return stgText(textOf(e),sc);
88 return getSTGTupleVar(e);
93 return mkStgCon(nameMkC,singleton(e));
95 return mkStgCon(nameMkI,singleton(e));
97 return mkStgCon(nameMkBignum,singleton(e));
99 return mkStgCon(nameMkD,singleton(e));
101 #if USE_ADDR_FOR_STRINGS
103 StgVar v = mkStgVar(mkStgCon(nameMkA,singleton(e)),NIL);
104 return mkStgLet(singleton(v),
105 makeStgApp(nameUnpackString,singleton(v)));
108 return mkStgApp(nameUnpackString,singleton(e));
111 return stgExpr(e,co,sc,namePMFail);
115 return stgExpr(e,co,sc,namePMFail);
119 static StgCaseAlt local stgCaseAlt(alt,co,sc,failExpr)
125 StgDiscr d = fst(alt);
126 Int da = discrArity(d);
129 for(i=1; i<=da; ++i) {
130 StgVar nv = mkStgVar(NIL,NIL);
132 sc = cons(pair(mkOffset(co+i),nv),sc);
134 return mkStgCaseAlt(d,vs,stgExpr(snd(alt),co+da,sc,failExpr));
137 static StgExpr local stgExpr(e,co,sc,failExpr)
146 return makeStgIf(stgExpr(fst3(snd(e)),co,sc,namePMFail),
147 stgExpr(snd3(snd(e)),co,sc,failExpr),
148 stgExpr(thd3(snd(e)),co,sc,failExpr));
152 List guards = rev(snd(e));
154 for(; nonNull(guards); guards=tl(guards)) {
156 Cell c = stgExpr(fst(g),co,sc,namePMFail);
157 Cell rhs = stgExpr(snd(g),co,sc,failExpr);
158 e = makeStgIf(c,rhs,e);
164 StgExpr e2 = stgExpr(snd(snd(e)),co,sc,failExpr);
165 StgVar alt = mkStgVar(e2,NIL);
166 return mkStgLet(singleton(alt),stgExpr(fst(snd(e)),co,sc,alt));
170 List alts = snd(snd(e));
171 Cell scrut = stgExpr(fst(snd(e)),co,sc,namePMFail);
174 } else if (isChar(fst(hd(alts)))) {
176 StgDiscr d = fst(alt);
177 StgVar c = mkStgVar(mkStgCon(nameMkC,singleton(d)),NIL);
178 StgExpr test = nameEqChar;
179 /* duplicates scrut but it should be atomic */
180 return makeStgIf(makeStgLet(singleton(c),makeStgApp(test,doubleton(scrut,c))),
181 stgExpr(snd(alt),co,sc,failExpr),
182 stgExpr(ap(CASE,pair(fst(snd(e)),tl(alts))),co,sc,failExpr));
185 for(; nonNull(alts); alts=tl(alts)) {
186 as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
188 return mkStgCase(scrut, revOnto(as, singleton(mkStgDefault(mkStgVar(NIL,NIL),failExpr))));
192 #if OVERLOADED_CONSTANTS
196 Cell discr = snd3(nc);
198 Cell scrut = stgOffset(o,sc);
199 Cell h = getHead(discr);
200 Int da = discrArity(discr);
203 if (whatIs(h) == ADDPAT && argCount == 1) {
204 /* ADDPAT num dictIntegral
206 * let n = fromInteger num in
207 * if pmLe dictIntegral n scrut
208 * then let v = pmSubtract dictIntegral scrut v
212 Cell dictIntegral = arg(discr); /* Integral dictionary */
215 StgVar dIntegral = NIL;
217 /* bind dictionary */
218 dIntegral = stgRhs(dictIntegral,co,sc);
219 if (!isAtomic(dIntegral)) { /* wasn't atomic */
220 dIntegral = mkStgVar(dIntegral,NIL);
221 binds = cons(dIntegral,binds);
224 n = mkStgVar(mkStgCon(nameMkBignum,singleton(n)),NIL);
225 binds = cons(n,binds);
227 /* coerce number to right type (using Integral dict) */
228 n = mkStgVar(mkStgApp(namePmFromInteger,doubleton(dIntegral,n)),NIL);
229 binds = cons(n,binds);
232 v = mkStgVar(mkStgApp(namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
233 return mkStgLet(binds,
234 makeStgIf(mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
235 mkStgLet(singleton(v),
238 cons(pair(mkOffset(co),v),sc),
244 assert(isName(h) && argCount == 2);
246 /* This code is rather ugly.
247 * We ought to desugar it using one of the following:
248 * if (==) dEq (fromInt dNum pat) scrut
249 * if (==) dEq (fromInteger dNum pat) scrut
250 * if (==) dEq (fromFloat dFractional pat) scrut
251 * But it would be very hard to obtain the Eq dictionary
252 * from the Num or Fractional dictionary we have.
253 * Instead, we rely on the Prelude to supply 3 helper
254 * functions which do the test for us.
255 * primPmInt :: Num a => Int -> a -> Bool
256 * primPmInteger :: Num a => Integer -> a -> Bool
257 * primPmDouble :: Fractional a => Double -> a -> Bool
260 Cell dict = arg(fun(discr));
265 = h == nameFromInt ? nameMkI
266 : h == nameFromInteger ? nameMkBignum
269 = h == nameFromInt ? namePmInt
270 : h == nameFromInteger ? namePmInteger
276 for(i=1; i<=da; ++i) {
277 Cell nv = mkStgVar(NIL,NIL);
279 altsc = cons(pair(mkOffset(co+i),nv),altsc);
281 /* bind dictionary */
282 d = stgRhs(dict,co,sc);
283 if (!isAtomic(d)) { /* wasn't atomic */
285 binds = cons(d,binds);
288 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
289 binds = cons(n,binds);
291 return makeStgIf(mkStgLet(binds,
292 mkStgApp(testFun,tripleton(d,n,scrut))),
293 stgExpr(r,co+da,altsc,failExpr),
297 #else /* ! OVERLOADED_CONSTANTS */
301 Cell discr = snd3(nc);
303 Cell scrut = stgOffset(o,sc);
304 Cell h = getHead(discr);
305 Int da = discrArity(discr);
309 = isInt(discr) ? nameEqInt
310 : isBignum(discr) ? nameEqInteger
313 = isInt(discr) ? nameMkI
314 : isBignum(discr) ? nameMkBignum
321 for(i=1; i<=da; ++i) {
322 Cell nv = mkStgVar(NIL,NIL);
324 altsc = cons(pair(mkOffset(co+i),nv),altsc);
328 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
329 binds = cons(n,binds);
331 test = mkStgLet(binds, mkStgApp(eq, doubleton(n,scrut)));
332 return makeStgIf(test,
333 stgExpr(r,co+da,altsc,failExpr),
336 #endif /* ! OVERLOADED_CONSTANTS */
342 /* allocate variables, extend scope */
343 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
344 Cell nv = mkStgVar(NIL,NIL);
345 sc = cons(pair(fst3(hd(bs)),nv),sc);
346 binds = cons(nv,binds);
349 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
350 Cell nv = mkStgVar(NIL,NIL);
351 sc = cons(pair(mkOffset(++co),nv),sc);
352 binds = cons(nv,binds);
356 /* transform functions */
357 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
362 Int arity = intOf(snd3(fun));
364 for(i=1; i<=arity; ++i) {
365 Cell v = mkStgVar(NIL,NIL);
367 funsc = cons(pair(mkOffset(co+i),v),funsc);
369 stgVarBody(nv) = mkStgLambda(as,stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
371 /* transform expressions */
372 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
375 stgVarBody(nv) = stgRhs(rhs,co,sc);
377 return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc));
379 default: /* convert to an StgApp or StgVar plus some bindings */
389 args = cons(arg,args);
393 if (e == nameSel && length(args) == 3) {
396 StgVar v = stgOffset(hd(tl(args)),sc);
398 StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
400 Int ix = intOf(hd(tl(tl(args))));
401 Int da = discrArity(con);
404 for(i=1; i<=da; ++i) {
405 Cell nv = mkStgVar(NIL,NIL);
409 doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
410 mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
413 /* Arguments must be StgAtoms */
414 for(as=args; nonNull(as); as=tl(as)) {
415 StgRhs a = stgRhs(hd(as),co,sc);
416 #if 1 /* optional flattening of let bindings */
417 if (whatIs(a) == LETREC) {
418 binds = appendOnto(stgLetBinds(a),binds);
425 binds = cons(a,binds);
430 /* Function must be StgVar or Name */
432 if (!isStgVar(e) && !isName(e)) {
434 binds = cons(e,binds);
437 return makeStgLet(binds,makeStgApp(e,args));
442 static Void ppExp( Name n, Int arity, Cell e );
443 static Void ppExp( Name n, Int arity, Cell e )
448 printf("%s", textToStr(name(n).text));
449 for (i = arity; i > 0; i--) {
459 Void stgDefn( Name n, Int arity, Cell e )
464 //printf("\nBEGIN --------------- stgDefn-ppExp ----------------\n" );
466 //printf("\nEND ----------------- stgDefn-ppExp ----------------\n" );
467 for (i = 1; i <= arity; ++i) {
468 Cell nv = mkStgVar(NIL,NIL);
470 sc = cons(pair(mkOffset(i),nv),sc);
472 stgVarBody(name(n).stgVar) = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
473 //printf("\nBEGIN --------------- stgDefn-ppStg ----------------\n" );
474 // ppStg(name(n).stgVar);
475 //printf("\nEND ----------------- stgDefn-ppStg ----------------\n" );
478 static StgExpr forceArgs( List is, List args, StgExpr e );
480 /* force the args numbered in is */
481 static StgExpr forceArgs( List is, List args, StgExpr e )
483 for(; nonNull(is); is=tl(is)) {
484 e = mkSeq(nth(intOf(hd(is))-1,args),e);
490 ToDo: reinstate eventually
491 /* \ v -> case v of { ...; Ci _ _ -> i; ... } */
492 Void implementConToTag(t)
494 if (isNull(tycon(t).conToTag)) {
495 List cs = tycon(t).defn;
496 Name nm = newName(inventText());
497 StgVar v = mkStgVar(NIL,NIL);
498 List alts = NIL; /* can't fail */
500 assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE));
501 for (; hasCfun(cs); cs=tl(cs)) {
503 Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
504 StgVar r = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),NIL);
505 StgExpr tag = mkStgLet(singleton(r),r);
508 for(i=0; i < name(c).arity; ++i) {
509 vs = cons(mkStgVar(NIL,NIL),vs);
511 alts = cons(mkStgCaseAlt(c,vs,tag),alts);
514 name(nm).line = tycon(t).line;
515 name(nm).type = conToTagType(t);
517 name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),NIL);
518 tycon(t).conToTag = nm;
519 /* hack to make it print out */
520 stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
524 /* \ v -> case v of { ...; i -> Ci; ... } */
525 Void implementTagToCon(t)
527 if (isNull(tycon(t).tagToCon)) {
541 assert(nameUnpackString);
543 assert(isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE));
545 tyconname = textToStr(tycon(t).text);
546 etxt = malloc(100+strlen(tyconname));
549 "out-of-range arg for `toEnum' in (derived) `instance Enum %s'",
553 nm = newName(inventText());
554 v1 = mkStgVar(NIL,NIL);
555 v2 = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
557 txt0 = mkStr(findText(etxt));
558 bind1 = mkStgVar(mkStgCon(nameMkA,singleton(txt0)),NIL);
559 bind2 = mkStgVar(mkStgApp(nameUnpackString,singleton(bind1)), NIL);
560 bind3 = mkStgVar(mkStgApp(nameError,singleton(bind2)), NIL);
565 mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)
567 makeStgLet ( tripleton(bind1,bind2,bind3), bind3 )
571 for (; hasCfun(cs); cs=tl(cs)) {
573 Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
574 StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL);
575 assert(name(c).arity==0);
576 alts = cons(mkStgPrimAlt(singleton(pat),c),alts);
579 name(nm).line = tycon(t).line;
580 name(nm).type = tagToConType(t);
582 name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v1),
583 mkStgCase(v1,singleton(mkStgCaseAlt(nameMkI,singleton(v2),
584 mkStgPrimCase(v2,alts))))),NIL);
585 tycon(t).tagToCon = nm;
586 /* hack to make it print out */
587 stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
588 if (etxt) free(etxt);
593 Void implementCfun(c,scs) /* Build implementation for constr */
594 Name c; /* fun c. scs lists integers (1..)*/
595 List scs; { /* in incr order of strict comps. */
596 Int a = name(c).arity;
597 if (name(c).arity > 0) {
598 List args = makeArgs(a);
599 StgVar tv = mkStgVar(mkStgCon(c,args),NIL);
600 StgExpr e1 = mkStgLet(singleton(tv),tv);
601 StgExpr e2 = forceArgs(scs,args,e1);
602 StgVar v = mkStgVar(mkStgLambda(args,e2),NIL);
605 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
608 /* hack to make it print out */
609 stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
612 /* --------------------------------------------------------------------------
613 * Foreign function calls and primops
614 * ------------------------------------------------------------------------*/
616 static String charListToString( List cs );
617 static Cell foreignResultTy( Type t );
618 static Cell foreignArgTy( Type t );
619 static Name repToBox Args(( char c ));
620 static StgRhs makeStgPrim Args(( Name,Bool,List,String,String ));
622 static String charListToString( List cs )
627 assert( length(cs) < 100 );
628 for(; nonNull(cs); ++i, cs=tl(cs)) {
629 s[i] = charOf(hd(cs));
632 return textToStr(findText(s));
635 static Cell foreignResultTy( Type t )
637 if (t == typeChar) return mkChar(CHAR_REP);
638 else if (t == typeInt) return mkChar(INT_REP);
640 else if (t == typeInt64) return mkChar(INT64_REP);
642 #ifdef PROVIDE_INTEGER
643 else if (t == typeInteger)return mkChar(INTEGER_REP);
646 else if (t == typeWord) return mkChar(WORD_REP);
649 else if (t == typeAddr) return mkChar(ADDR_REP);
651 else if (t == typeFloat) return mkChar(FLOAT_REP);
652 else if (t == typeDouble) return mkChar(DOUBLE_REP);
653 #ifdef PROVIDE_FOREIGN
654 else if (t == typeForeign)return mkChar(FOREIGN_REP); /* ToDo: argty only! */
657 else if (t == typePrimByteArray) return mkChar(BARR_REP); /* ToDo: argty only! */
658 else if (whatIs(t) == AP) {
660 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP); /* ToDo: argty only! */
663 /* ToDo: decent line numbers! */
664 ERRMSG(0) "Illegal foreign type" ETHEN
665 ERRTEXT " \"" ETHEN ERRTYPE(t);
670 static Cell foreignArgTy( Type t )
672 return foreignResultTy( t );
675 static Name repToBox( char c )
678 case CHAR_REP: return nameMkC;
679 case INT_REP: return nameMkI;
681 case INT64_REP: return nameMkInt64;
683 #ifdef PROVIDE_INTEGER
684 case INTEGER_REP: return nameMkInteger;
687 case WORD_REP: return nameMkW;
690 case ADDR_REP: return nameMkA;
692 case FLOAT_REP: return nameMkF;
693 case DOUBLE_REP: return nameMkD;
695 case ARR_REP: return nameMkPrimArray;
696 case BARR_REP: return nameMkPrimByteArray;
697 case REF_REP: return nameMkRef;
698 case MUTARR_REP: return nameMkPrimMutableArray;
699 case MUTBARR_REP: return nameMkPrimMutableByteArray;
701 #ifdef PROVIDE_STABLE
702 case STABLE_REP: return nameMkStable;
705 case WEAK_REP: return nameMkWeak;
707 #ifdef PROVIDE_FOREIGN
708 case FOREIGN_REP: return nameMkForeign;
710 #ifdef PROVIDE_CONCURRENT
711 case THREADID_REP: return nameMkThreadId;
712 case MVAR_REP: return nameMkMVar;
718 static StgPrimAlt boxResults( String reps, StgVar state )
720 List rs = NIL; /* possibly unboxed results */
721 List bs = NIL; /* boxed results of wrapper */
722 List rbinds = NIL; /* bindings used to box results */
725 for(i=0; reps[i] != '\0'; ++i) {
726 StgRep k = mkStgRep(reps[i]);
727 Cell v = mkStgPrimVar(NIL,k,NIL);
728 Name box = repToBox(reps[i]);
732 StgRhs rhs = mkStgCon(box,singleton(v));
733 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
735 rbinds = cons(bv,rbinds);
739 /* Construct tuple of results */
742 } else { /* includes i==0 case */
743 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
744 rbinds = cons(r,rbinds);
747 /* construct result pair if needed */
748 if (nonNull(state)) {
749 /* Note that this builds a tuple directly - we know it's
752 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
753 rbinds = cons(r,rbinds);
754 rs = cons(state,rs); /* last result is a state */
757 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
760 static List mkUnboxedVars( String reps )
764 for(i=0; reps[i] != '\0'; ++i) {
765 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
771 static List mkBoxedVars( String reps )
775 for(i=0; reps[i] != '\0'; ++i) {
776 as = cons(mkStgVar(NIL,NIL),as);
781 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
783 if (nonNull(b_args)) {
784 StgVar b_arg = hd(b_args); /* boxed arg */
785 StgVar u_arg = hd(u_args); /* unboxed arg */
786 StgRep k = mkStgRep(*reps);
787 Name box = repToBox(*reps);
788 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
790 /* Use a trivial let-binding */
791 stgVarBody(u_arg) = b_arg;
792 return mkStgLet(singleton(u_arg),e);
794 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
795 return mkStgCase(b_arg,singleton(alt));
802 /* Generate wrapper for primop based on list of arg types and result types:
804 * makeStgPrim op# False "II" "II" =
805 * \ x y -> "case x of { I# x# ->
806 * case y of { I# y# ->
807 * case op#{x#,y#} of { r1# r2# ->
808 * let r1 = I# r1#; r2 = I# r2# in
812 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
818 List b_args = NIL; /* boxed args to primop */
819 List u_args = NIL; /* possibly unboxed args to primop */
821 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
822 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
825 if (strcmp(r_reps,"B") == 0) {
826 StgPrimAlt altF = mkStgPrimAlt(singleton(
827 mkStgPrimVar(mkInt(0),
828 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,dupOnto(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 /*-------------------------------------------------------------------------*/