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/03/01 14:46:57 $
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 */
35 /* dictionaries, tuples, etc */
36 List stgGlobals = NIL;
38 static StgVar local getSTGTupleVar Args((Cell));
40 static StgVar local getSTGTupleVar( Cell d )
42 Pair p = cellAssoc(d,stgGlobals);
43 /* Yoiks - only the Prelude sees Tuple decls! */
45 implementTuple(tupleOf(d));
46 p = cellAssoc(d,stgGlobals);
52 /* ---------------------------------------------------------------- */
54 static Cell local stgOffset(Offset o, List sc)
56 Cell r = cellAssoc(o,sc);
61 static Cell local stgText(Text t,List sc)
64 for (; nonNull(xs); xs=tl(xs)) {
67 if (!isOffset(v) && t == textOf(v)) {
74 /* ---------------------------------------------------------------- */
76 static StgRhs local stgRhs(e,co,sc)
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(nameMkBignum,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,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),
202 #if OVERLOADED_CONSTANTS
206 Cell discr = snd3(nc);
208 Cell scrut = stgOffset(o,sc);
209 Cell h = getHead(discr);
210 Int da = discrArity(discr);
213 if (whatIs(h) == ADDPAT && argCount == 1) {
214 /* ADDPAT num dictIntegral
216 * let n = fromInteger num in
217 * if pmLe dictIntegral n scrut
218 * then let v = pmSubtract dictIntegral scrut v
222 Cell dictIntegral = arg(discr); /* Integral dictionary */
225 StgVar dIntegral = NIL;
227 /* bind dictionary */
228 dIntegral = stgRhs(dictIntegral,co,sc);
229 if (!isAtomic(dIntegral)) { /* wasn't atomic */
230 dIntegral = mkStgVar(dIntegral,NIL);
231 binds = cons(dIntegral,binds);
234 n = mkStgVar(mkStgCon(nameMkBignum,singleton(n)),NIL);
235 binds = cons(n,binds);
237 /* coerce number to right type (using Integral dict) */
238 n = mkStgVar(mkStgApp(
239 namePmFromInteger,doubleton(dIntegral,n)),NIL);
240 binds = cons(n,binds);
243 v = mkStgVar(mkStgApp(
244 namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
249 mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
250 mkStgLet(singleton(v),
253 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 ? nameMkBignum
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);
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),
315 #else /* ! OVERLOADED_CONSTANTS */
319 Cell discr = snd3(nc);
321 Cell scrut = stgOffset(o,sc);
322 Cell h = getHead(discr);
323 Int da = discrArity(discr);
327 = isInt(discr) ? nameEqInt
328 : isBignum(discr) ? nameEqInteger
331 = isInt(discr) ? nameMkI
332 : isBignum(discr) ? nameMkBignum
339 for(i=1; i<=da; ++i) {
340 Cell nv = mkStgVar(NIL,NIL);
342 altsc = cons(pair(mkOffset(co+i),nv),altsc);
346 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
347 binds = cons(n,binds);
349 test = mkStgLet(binds, mkStgApp(eq, doubleton(n,scrut)));
350 return makeStgIf(test,
351 stgExpr(r,co+da,altsc,failExpr),
354 #endif /* ! OVERLOADED_CONSTANTS */
360 /* allocate variables, extend scope */
361 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
362 Cell nv = mkStgVar(NIL,NIL);
363 sc = cons(pair(fst3(hd(bs)),nv),sc);
364 binds = cons(nv,binds);
367 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
368 Cell nv = mkStgVar(NIL,NIL);
369 sc = cons(pair(mkOffset(++co),nv),sc);
370 binds = cons(nv,binds);
374 /* transform functions */
375 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
380 Int arity = intOf(snd3(fun));
382 for(i=1; i<=arity; ++i) {
383 Cell v = mkStgVar(NIL,NIL);
385 funsc = cons(pair(mkOffset(co+i),v),funsc);
390 stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
392 /* transform expressions */
393 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
396 stgVarBody(nv) = stgRhs(rhs,co,sc);
398 return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc));
400 default: /* convert to an StgApp or StgVar plus some bindings */
410 args = cons(arg,args);
414 if (e == nameSel && length(args) == 3) {
417 StgVar v = stgOffset(hd(tl(args)),sc);
419 StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
421 Int ix = intOf(hd(tl(tl(args))));
422 Int da = discrArity(con);
425 for(i=1; i<=da; ++i) {
426 Cell nv = mkStgVar(NIL,NIL);
431 doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
432 mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
435 /* Arguments must be StgAtoms */
436 for(as=args; nonNull(as); as=tl(as)) {
437 StgRhs a = stgRhs(hd(as),co,sc);
438 #if 1 /* optional flattening of let bindings */
439 if (whatIs(a) == LETREC) {
440 binds = appendOnto(stgLetBinds(a),binds);
447 binds = cons(a,binds);
452 /* Function must be StgVar or Name */
454 if (!isStgVar(e) && !isName(e)) {
456 binds = cons(e,binds);
459 return makeStgLet(binds,makeStgApp(e,args));
464 #if 0 /* apparently not used */
465 static Void ppExp( Name n, Int arity, Cell e )
470 printf("%s", textToStr(name(n).text));
471 for (i = arity; i > 0; i--) {
483 Void stgDefn( Name n, Int arity, Cell e )
489 for (i = 1; i <= arity; ++i) {
490 Cell nv = mkStgVar(NIL,NIL);
492 sc = cons(pair(mkOffset(i),nv),sc);
494 stgVarBody(name(n).stgVar)
495 = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
496 //ppStg(name(n).stgVar);
497 //printStg(stdout, name(n).stgVar);
500 static StgExpr forceArgs( List is, List args, StgExpr e );
502 /* force the args numbered in is */
503 static StgExpr forceArgs( List is, List args, StgExpr e )
505 for(; nonNull(is); is=tl(is)) {
506 e = mkSeq(nth(intOf(hd(is))-1,args),e);
512 Void implementCfun(c,scs) /* Build implementation for constr */
513 Name c; /* fun c. scs lists integers (1..)*/
514 List scs; { /* in incr order of strict comps. */
515 Int a = name(c).arity;
516 //printf ( "implementCfun %s\n", textToStr(name(c).text) );
517 if (name(c).arity > 0) {
518 List args = makeArgs(a);
519 StgVar tv = mkStgVar(mkStgCon(c,args),NIL);
520 StgExpr e1 = mkStgLet(singleton(tv),tv);
521 StgExpr e2 = forceArgs(scs,args,e1);
522 StgVar v = mkStgVar(mkStgLambda(args,e2),NIL);
525 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
528 /* hack to make it print out */
529 stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
532 /* --------------------------------------------------------------------------
533 * Foreign function calls and primops
534 * ------------------------------------------------------------------------*/
536 static String charListToString( List cs );
537 static Cell foreignResultTy( Type t );
538 static Cell foreignArgTy( Type t );
539 static Name repToBox Args(( char c ));
540 static StgRhs makeStgPrim Args(( Name,Bool,List,String,String ));
542 static String charListToString( List cs )
547 assert( length(cs) < 100 );
548 for(; nonNull(cs); ++i, cs=tl(cs)) {
549 s[i] = charOf(hd(cs));
552 return textToStr(findText(s));
555 static Cell foreignResultTy( Type t )
557 if (t == typeChar) return mkChar(CHAR_REP);
558 else if (t == typeInt) return mkChar(INT_REP);
560 else if (t == typeInt64) return mkChar(INT64_REP);
562 #ifdef PROVIDE_INTEGER
563 else if (t == typeInteger)return mkChar(INTEGER_REP);
566 else if (t == typeWord) return mkChar(WORD_REP);
569 else if (t == typeAddr) return mkChar(ADDR_REP);
571 else if (t == typeFloat) return mkChar(FLOAT_REP);
572 else if (t == typeDouble) return mkChar(DOUBLE_REP);
573 #ifdef PROVIDE_FOREIGN
574 else if (t == typeForeign)return mkChar(FOREIGN_REP);
575 /* ToDo: argty only! */
578 else if (t == typePrimByteArray) return mkChar(BARR_REP);
579 /* ToDo: argty only! */
580 else if (whatIs(t) == AP) {
582 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
583 /* ToDo: argty only! */
586 /* ToDo: decent line numbers! */
587 ERRMSG(0) "Illegal foreign type" ETHEN
588 ERRTEXT " \"" ETHEN ERRTYPE(t);
593 static Cell foreignArgTy( Type t )
595 return foreignResultTy( t );
598 static Name repToBox( char c )
601 case CHAR_REP: return nameMkC;
602 case INT_REP: return nameMkI;
604 case INT64_REP: return nameMkInt64;
606 #ifdef PROVIDE_INTEGER
607 case INTEGER_REP: return nameMkInteger;
610 case WORD_REP: return nameMkW;
613 case ADDR_REP: return nameMkA;
615 case FLOAT_REP: return nameMkF;
616 case DOUBLE_REP: return nameMkD;
618 case ARR_REP: return nameMkPrimArray;
619 case BARR_REP: return nameMkPrimByteArray;
620 case REF_REP: return nameMkRef;
621 case MUTARR_REP: return nameMkPrimMutableArray;
622 case MUTBARR_REP: return nameMkPrimMutableByteArray;
624 #ifdef PROVIDE_STABLE
625 case STABLE_REP: return nameMkStable;
628 case WEAK_REP: return nameMkWeak;
630 #ifdef PROVIDE_FOREIGN
631 case FOREIGN_REP: return nameMkForeign;
633 #ifdef PROVIDE_CONCURRENT
634 case THREADID_REP: return nameMkThreadId;
635 case MVAR_REP: return nameMkMVar;
641 static StgPrimAlt boxResults( String reps, StgVar state )
643 List rs = NIL; /* possibly unboxed results */
644 List bs = NIL; /* boxed results of wrapper */
645 List rbinds = NIL; /* bindings used to box results */
648 for(i=0; reps[i] != '\0'; ++i) {
649 StgRep k = mkStgRep(reps[i]);
650 Cell v = mkStgPrimVar(NIL,k,NIL);
651 Name box = repToBox(reps[i]);
655 StgRhs rhs = mkStgCon(box,singleton(v));
656 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
658 rbinds = cons(bv,rbinds);
662 /* Construct tuple of results */
665 } else { /* includes i==0 case */
666 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
667 rbinds = cons(r,rbinds);
670 /* construct result pair if needed */
671 if (nonNull(state)) {
672 /* Note that this builds a tuple directly - we know it's
675 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
676 rbinds = cons(r,rbinds);
677 rs = cons(state,rs); /* last result is a state */
680 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
683 static List mkUnboxedVars( String reps )
687 for(i=0; reps[i] != '\0'; ++i) {
688 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
694 static List mkBoxedVars( String reps )
698 for(i=0; reps[i] != '\0'; ++i) {
699 as = cons(mkStgVar(NIL,NIL),as);
704 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
706 if (nonNull(b_args)) {
707 StgVar b_arg = hd(b_args); /* boxed arg */
708 StgVar u_arg = hd(u_args); /* unboxed arg */
709 //StgRep k = mkStgRep(*reps);
710 Name box = repToBox(*reps);
711 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
713 /* Use a trivial let-binding */
714 stgVarBody(u_arg) = b_arg;
715 return mkStgLet(singleton(u_arg),e);
717 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
718 return mkStgCase(b_arg,singleton(alt));
725 /* Generate wrapper for primop based on list of arg types and result types:
727 * makeStgPrim op# False "II" "II" =
728 * \ x y -> "case x of { I# x# ->
729 * case y of { I# y# ->
730 * case op#{x#,y#} of { r1# r2# ->
731 * let r1 = I# r1#; r2 = I# r2# in
735 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
741 List b_args = NIL; /* boxed args to primop */
742 List u_args = NIL; /* possibly unboxed args to primop */
744 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
745 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
748 if (strcmp(r_reps,"B") == 0) {
750 = mkStgPrimAlt(singleton(
751 mkStgPrimVar(mkInt(0),
752 mkStgRep(INT_REP),NIL)
757 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
759 alts = doubleton(altF,altT);
760 assert(nonNull(nameTrue));
763 alts = singleton(boxResults(r_reps,s1));
765 b_args = mkBoxedVars(a_reps);
766 u_args = mkUnboxedVars(a_reps);
769 = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
771 = makeStgLambda(singleton(s0),
772 unboxVars(a_reps,b_args,u_args,
773 mkStgPrimCase(mkStgPrim(op,actual_args),
775 StgVar m = mkStgVar(rhs,NIL);
776 return makeStgLambda(b_args,
777 mkStgLet(singleton(m),
778 mkStgApp(nameMkIO,singleton(m))));
780 List actual_args = appendOnto(extra_args,u_args);
781 return makeStgLambda(
783 unboxVars(a_reps,b_args,u_args,
784 mkStgPrimCase(mkStgPrim(op,actual_args),alts))
789 Void implementPrim( n )
791 const AsmPrim* p = name(n).primop;
792 StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
793 StgVar v = mkStgVar(rhs,NIL);
795 stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
798 /* Generate wrapper code from (in,out) type lists.
802 * inTypes = [Int,Float]
803 * outTypes = [Char,Addr]
807 * case a1 of { I# a1# ->
808 * case s2 of { F# a2# ->
809 * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
817 * Addr -> (Int -> Float -> IO (Char,Addr))
819 Void implementForeignImport( Name n )
821 Type t = name(n).type;
823 List resultTys = NIL;
824 CFunDescriptor* descriptor = 0;
825 Bool addState = TRUE;
826 while (getHead(t)==typeArrow && argCount==2) {
827 Type ta = fullExpand(arg(fun(t)));
829 argTys = cons(ta,argTys);
832 argTys = rev(argTys);
833 if (getHead(t) == typeIO) {
834 resultTys = getArgs(t);
835 assert(length(resultTys) == 1);
836 resultTys = hd(resultTys);
842 resultTys = fullExpand(resultTys);
843 if (isTuple(getHead(resultTys))) {
844 resultTys = getArgs(resultTys);
845 } else if (getHead(resultTys) == typeUnit) {
848 resultTys = singleton(resultTys);
850 mapOver(foreignArgTy,argTys); /* allows foreignObj, byteArrays, etc */
851 mapOver(foreignResultTy,resultTys); /* doesn't */
852 descriptor = mkDescriptor(charListToString(argTys),
853 charListToString(resultTys));
854 name(n).primop = addState ? &ccall_IO : &ccall_Id;
856 Pair extName = name(n).defn;
857 void* funPtr = getDLLSymbol(textToStr(textOf(fst(extName))),
858 textToStr(textOf(snd(extName))));
859 List extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
860 StgRhs rhs = makeStgPrim(n,addState,extra_args,descriptor->arg_tys,
861 descriptor->result_tys);
862 StgVar v = mkStgVar(rhs,NIL);
864 ERRMSG(0) "Could not find foreign function \"%s\" in \"%s\"",
865 textToStr(textOf(snd(extName))),
866 textToStr(textOf(fst(extName)))
872 stgGlobals=cons(pair(n,v),stgGlobals);/*so it will get codegen'd */
876 Void implementForeignExport( Name n )
878 internal("implementForeignExport: not implemented");
881 Void implementTuple(size)
884 Cell t = mkTuple(size);
885 List args = makeArgs(size);
886 StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
887 StgExpr e = mkStgLet(singleton(tv),tv);
888 StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
889 stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
891 StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
892 stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* ditto */
896 /* --------------------------------------------------------------------------
898 * ------------------------------------------------------------------------*/
900 Void translateControl(what)
905 /* deliberate fall through */
916 /*-------------------------------------------------------------------------*/