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/09 14:51:15 $
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,StgExpr));
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,failExpr)
85 return stgOffset(e,sc);
88 return stgText(textOf(e),sc);
90 return getSTGTupleVar(e);
95 return mkStgCon(nameMkC,singleton(e));
97 return mkStgCon(nameMkI,singleton(e));
99 return mkStgCon(nameMkBignum,singleton(e));
101 return mkStgCon(nameMkD,singleton(e));
103 #if USE_ADDR_FOR_STRINGS
105 StgVar v = mkStgVar(mkStgCon(nameMkA,singleton(e)),NIL);
106 return mkStgLet(singleton(v),
107 makeStgApp(nameUnpackString,singleton(v)));
110 return mkStgApp(nameUnpackString,singleton(e));
113 return stgExpr(e,co,sc,namePMFailBUG);
117 return stgExpr(e,co,sc,failExpr/*namePMFail*/);
121 static StgCaseAlt local stgCaseAlt(alt,co,sc,failExpr)
127 StgDiscr d = fst(alt);
128 Int da = discrArity(d);
131 for(i=1; i<=da; ++i) {
132 StgVar nv = mkStgVar(NIL,NIL);
134 sc = cons(pair(mkOffset(co+i),nv),sc);
136 return mkStgCaseAlt(d,vs,stgExpr(snd(alt),co+da,sc,failExpr));
139 static StgExpr local stgExpr(e,co,sc,failExpr)
148 return makeStgIf(stgExpr(fst3(snd(e)),co,sc,namePMFail),
149 stgExpr(snd3(snd(e)),co,sc,failExpr),
150 stgExpr(thd3(snd(e)),co,sc,failExpr));
154 List guards = reverse(snd(e));
156 for(; nonNull(guards); guards=tl(guards)) {
158 Cell c = stgExpr(fst(g),co,sc,namePMFail);
159 Cell rhs = stgExpr(snd(g),co,sc,failExpr);
160 e = makeStgIf(c,rhs,e);
166 StgExpr e2 = stgExpr(snd(snd(e)),co,sc,failExpr);
167 StgVar alt = mkStgVar(e2,NIL);
168 return mkStgLet(singleton(alt),stgExpr(fst(snd(e)),co,sc,alt));
172 List alts = snd(snd(e));
173 Cell scrut = stgExpr(fst(snd(e)),co,sc,namePMFail);
176 } else if (isChar(fst(hd(alts)))) {
178 StgDiscr d = fst(alt);
180 mkStgCon(nameMkC,singleton(d)),NIL);
181 StgExpr test = nameEqChar;
182 /* duplicates scrut but it should be atomic */
184 makeStgLet(singleton(c),
185 makeStgApp(test,doubleton(scrut,c))),
186 stgExpr(snd(alt),co,sc,failExpr),
187 stgExpr(ap(CASE,pair(fst(snd(e)),
188 tl(alts))),co,sc,failExpr));
191 for(; nonNull(alts); alts=tl(alts)) {
192 as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
198 singleton(mkStgDefault(mkStgVar(NIL,NIL),
203 #if OVERLOADED_CONSTANTS
207 Cell discr = snd3(nc);
209 Cell scrut = stgOffset(o,sc);
210 Cell h = getHead(discr);
211 Int da = discrArity(discr);
214 if (whatIs(h) == ADDPAT && argCount == 1) {
215 /* ADDPAT num dictIntegral
217 * let n = fromInteger num in
218 * if pmLe dictIntegral n scrut
219 * then let v = pmSubtract dictIntegral scrut v
223 Cell dictIntegral = arg(discr); /* Integral dictionary */
226 StgVar dIntegral = NIL;
228 /* bind dictionary */
229 dIntegral = stgRhs(dictIntegral,co,sc,namePMFailBUG);
230 if (!isAtomic(dIntegral)) { /* wasn't atomic */
231 dIntegral = mkStgVar(dIntegral,NIL);
232 binds = cons(dIntegral,binds);
235 n = mkStgVar(mkStgCon(nameMkBignum,singleton(n)),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),
260 assert(isName(h) && argCount == 2);
262 /* This code is rather ugly.
263 * We ought to desugar it using one of the following:
264 * if (==) dEq (fromInt dNum pat) scrut
265 * if (==) dEq (fromInteger dNum pat) scrut
266 * if (==) dEq (fromFloat dFractional pat) scrut
267 * But it would be very hard to obtain the Eq dictionary
268 * from the Num or Fractional dictionary we have.
269 * Instead, we rely on the Prelude to supply 3 helper
270 * functions which do the test for us.
271 * primPmInt :: Num a => Int -> a -> Bool
272 * primPmInteger :: Num a => Integer -> a -> Bool
273 * primPmDouble :: Fractional a => Double -> a -> Bool
276 Cell dict = arg(fun(discr));
281 = h == nameFromInt ? nameMkI
282 : h == nameFromInteger ? nameMkBignum
285 = h == nameFromInt ? namePmInt
286 : h == nameFromInteger ? namePmInteger
292 for(i=1; i<=da; ++i) {
293 Cell nv = mkStgVar(NIL,NIL);
295 altsc = cons(pair(mkOffset(co+i),nv),altsc);
297 /* bind dictionary */
298 d = stgRhs(dict,co,sc,namePMFailBUG);
299 if (!isAtomic(d)) { /* wasn't atomic */
301 binds = cons(d,binds);
304 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
305 binds = cons(n,binds);
310 mkStgApp(testFun,tripleton(d,n,scrut))),
311 stgExpr(r,co+da,altsc,failExpr),
316 #else /* ! OVERLOADED_CONSTANTS */
320 Cell discr = snd3(nc);
322 Cell scrut = stgOffset(o,sc);
323 Cell h = getHead(discr);
324 Int da = discrArity(discr);
328 = isInt(discr) ? nameEqInt
329 : isBignum(discr) ? nameEqInteger
332 = isInt(discr) ? nameMkI
333 : isBignum(discr) ? nameMkBignum
340 for(i=1; i<=da; ++i) {
341 Cell nv = mkStgVar(NIL,NIL);
343 altsc = cons(pair(mkOffset(co+i),nv),altsc);
347 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
348 binds = cons(n,binds);
350 test = mkStgLet(binds, mkStgApp(eq, doubleton(n,scrut)));
351 return makeStgIf(test,
352 stgExpr(r,co+da,altsc,failExpr),
355 #endif /* ! OVERLOADED_CONSTANTS */
361 /* allocate variables, extend scope */
362 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
363 Cell nv = mkStgVar(NIL,NIL);
364 sc = cons(pair(fst3(hd(bs)),nv),sc);
365 binds = cons(nv,binds);
368 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
369 Cell nv = mkStgVar(NIL,NIL);
370 sc = cons(pair(mkOffset(++co),nv),sc);
371 binds = cons(nv,binds);
375 /* transform functions */
376 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
381 Int arity = intOf(snd3(fun));
383 for(i=1; i<=arity; ++i) {
384 Cell v = mkStgVar(NIL,NIL);
386 funsc = cons(pair(mkOffset(co+i),v),funsc);
391 stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
393 /* transform expressions */
394 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
397 stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFailBUG);
399 return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFailBUG*/));
401 default: /* convert to an StgApp or StgVar plus some bindings */
411 args = cons(arg,args);
415 if (e == nameSel && length(args) == 3) {
418 StgVar v = stgOffset(hd(tl(args)),sc);
420 StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
422 Int ix = intOf(hd(tl(tl(args))));
423 Int da = discrArity(con);
426 for(i=1; i<=da; ++i) {
427 Cell nv = mkStgVar(NIL,NIL);
432 doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
433 mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
436 /* Arguments must be StgAtoms */
437 for(as=args; nonNull(as); as=tl(as)) {
438 StgRhs a = stgRhs(hd(as),co,sc,namePMFailBUG);
439 #if 1 /* optional flattening of let bindings */
440 if (whatIs(a) == LETREC) {
441 binds = appendOnto(stgLetBinds(a),binds);
448 binds = cons(a,binds);
453 /* Function must be StgVar or Name */
454 e = stgRhs(e,co,sc,namePMFailBUG);
455 if (!isStgVar(e) && !isName(e)) {
457 binds = cons(e,binds);
460 return makeStgLet(binds,makeStgApp(e,args));
465 #if 0 /* apparently not used */
466 static Void ppExp( Name n, Int arity, Cell e )
468 if (1 || debugCode) {
470 printf("%s", textToStr(name(n).text));
471 for (i = arity; i > 0; i--) {
482 Void stgDefn( Name n, Int arity, Cell e )
488 if (lastModule() != modulePrelude) {
489 fprintf(stderr, "\n===========================================\n" );
491 printf("\n\n"); fflush(stdout);
494 for (i = 1; i <= arity; ++i) {
495 Cell nv = mkStgVar(NIL,NIL);
497 sc = cons(pair(mkOffset(i),nv),sc);
499 stgVarBody(name(n).stgVar)
500 = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
502 if (lastModule() != modulePrelude) {
503 ppStg(name(n).stgVar);
504 fprintf(stderr, "\n\n");
506 //printStg(stdout, name(n).stgVar);
510 Void implementCfun(c,scs) /* Build implementation for constr */
511 Name c; /* fun c. scs lists integers (1..)*/
512 List scs; { /* in incr order of strict comps. */
513 Int a = name(c).arity;
514 //fprintf ( stderr,"implementCfun %s\n", textToStr(name(c).text) );
516 StgVar vcurr, e1, v, vsi;
517 List args = makeArgs(a);
518 StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
519 List binds = singleton(v0);
522 for (; nonNull(scs); scs=tl(scs)) {
523 vsi = nth(intOf(hd(scs))-1,args);
524 vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
525 binds = cons(vcurr,binds);
528 e1 = mkStgLet(binds,vcurr);
529 v = mkStgVar(mkStgLambda(args,e1),NIL);
532 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
535 stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
536 //printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n");
539 /* --------------------------------------------------------------------------
540 * Foreign function calls and primops
541 * ------------------------------------------------------------------------*/
543 static String charListToString( List cs );
544 static Cell foreignResultTy( Type t );
545 static Cell foreignArgTy( Type t );
546 static Name repToBox Args(( char c ));
547 static StgRhs makeStgPrim Args(( Name,Bool,List,String,String ));
549 static String charListToString( List cs )
554 assert( length(cs) < 100 );
555 for(; nonNull(cs); ++i, cs=tl(cs)) {
556 s[i] = charOf(hd(cs));
559 return textToStr(findText(s));
562 static Cell foreignResultTy( Type t )
564 if (t == typeChar) return mkChar(CHAR_REP);
565 else if (t == typeInt) return mkChar(INT_REP);
567 else if (t == typeInt64) return mkChar(INT64_REP);
569 #ifdef PROVIDE_INTEGER
570 else if (t == typeInteger)return mkChar(INTEGER_REP);
573 else if (t == typeWord) return mkChar(WORD_REP);
576 else if (t == typeAddr) return mkChar(ADDR_REP);
578 else if (t == typeFloat) return mkChar(FLOAT_REP);
579 else if (t == typeDouble) return mkChar(DOUBLE_REP);
580 #ifdef PROVIDE_FOREIGN
581 else if (t == typeForeign)return mkChar(FOREIGN_REP);
582 /* ToDo: argty only! */
585 else if (t == typePrimByteArray) return mkChar(BARR_REP);
586 /* ToDo: argty only! */
587 else if (whatIs(t) == AP) {
589 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
590 /* ToDo: argty only! */
593 /* ToDo: decent line numbers! */
594 ERRMSG(0) "Illegal foreign type" ETHEN
595 ERRTEXT " \"" ETHEN ERRTYPE(t);
600 static Cell foreignArgTy( Type t )
602 return foreignResultTy( t );
605 static Name repToBox( char c )
608 case CHAR_REP: return nameMkC;
609 case INT_REP: return nameMkI;
611 case INT64_REP: return nameMkInt64;
613 #ifdef PROVIDE_INTEGER
614 case INTEGER_REP: return nameMkInteger;
617 case WORD_REP: return nameMkW;
620 case ADDR_REP: return nameMkA;
622 case FLOAT_REP: return nameMkF;
623 case DOUBLE_REP: return nameMkD;
625 case ARR_REP: return nameMkPrimArray;
626 case BARR_REP: return nameMkPrimByteArray;
627 case REF_REP: return nameMkRef;
628 case MUTARR_REP: return nameMkPrimMutableArray;
629 case MUTBARR_REP: return nameMkPrimMutableByteArray;
631 #ifdef PROVIDE_STABLE
632 case STABLE_REP: return nameMkStable;
635 case WEAK_REP: return nameMkWeak;
637 #ifdef PROVIDE_FOREIGN
638 case FOREIGN_REP: return nameMkForeign;
640 #ifdef PROVIDE_CONCURRENT
641 case THREADID_REP: return nameMkThreadId;
642 case MVAR_REP: return nameMkMVar;
648 static StgPrimAlt boxResults( String reps, StgVar state )
650 List rs = NIL; /* possibly unboxed results */
651 List bs = NIL; /* boxed results of wrapper */
652 List rbinds = NIL; /* bindings used to box results */
655 for(i=0; reps[i] != '\0'; ++i) {
656 StgRep k = mkStgRep(reps[i]);
657 Cell v = mkStgPrimVar(NIL,k,NIL);
658 Name box = repToBox(reps[i]);
662 StgRhs rhs = mkStgCon(box,singleton(v));
663 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
665 rbinds = cons(bv,rbinds);
669 /* Construct tuple of results */
672 } else { /* includes i==0 case */
673 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
674 rbinds = cons(r,rbinds);
677 /* construct result pair if needed */
678 if (nonNull(state)) {
679 /* Note that this builds a tuple directly - we know it's
682 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
683 rbinds = cons(r,rbinds);
684 rs = cons(state,rs); /* last result is a state */
687 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
690 static List mkUnboxedVars( String reps )
694 for(i=0; reps[i] != '\0'; ++i) {
695 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
701 static List mkBoxedVars( String reps )
705 for(i=0; reps[i] != '\0'; ++i) {
706 as = cons(mkStgVar(NIL,NIL),as);
711 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
713 if (nonNull(b_args)) {
714 StgVar b_arg = hd(b_args); /* boxed arg */
715 StgVar u_arg = hd(u_args); /* unboxed arg */
716 //StgRep k = mkStgRep(*reps);
717 Name box = repToBox(*reps);
718 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
720 /* Use a trivial let-binding */
721 stgVarBody(u_arg) = b_arg;
722 return mkStgLet(singleton(u_arg),e);
724 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
725 return mkStgCase(b_arg,singleton(alt));
732 /* Generate wrapper for primop based on list of arg types and result types:
734 * makeStgPrim op# False "II" "II" =
735 * \ x y -> "case x of { I# x# ->
736 * case y of { I# y# ->
737 * case op#{x#,y#} of { r1# r2# ->
738 * let r1 = I# r1#; r2 = I# r2# in
742 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
748 List b_args = NIL; /* boxed args to primop */
749 List u_args = NIL; /* possibly unboxed args to primop */
751 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
752 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
755 if (strcmp(r_reps,"B") == 0) {
757 = mkStgPrimAlt(singleton(
758 mkStgPrimVar(mkInt(0),
759 mkStgRep(INT_REP),NIL)
764 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
766 alts = doubleton(altF,altT);
767 assert(nonNull(nameTrue));
770 alts = singleton(boxResults(r_reps,s1));
772 b_args = mkBoxedVars(a_reps);
773 u_args = mkUnboxedVars(a_reps);
776 = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
778 = makeStgLambda(singleton(s0),
779 unboxVars(a_reps,b_args,u_args,
780 mkStgPrimCase(mkStgPrim(op,actual_args),
782 StgVar m = mkStgVar(rhs,NIL);
783 return makeStgLambda(b_args,
784 mkStgLet(singleton(m),
785 mkStgApp(nameMkIO,singleton(m))));
787 List actual_args = appendOnto(extra_args,u_args);
788 return makeStgLambda(
790 unboxVars(a_reps,b_args,u_args,
791 mkStgPrimCase(mkStgPrim(op,actual_args),alts))
796 Void implementPrim( n )
798 const AsmPrim* p = name(n).primop;
799 StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
800 StgVar v = mkStgVar(rhs,NIL);
802 stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
805 /* Generate wrapper code from (in,out) type lists.
809 * inTypes = [Int,Float]
810 * outTypes = [Char,Addr]
814 * case a1 of { I# a1# ->
815 * case s2 of { F# a2# ->
816 * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
824 * Addr -> (Int -> Float -> IO (Char,Addr))
826 Void implementForeignImport( Name n )
828 Type t = name(n).type;
830 List resultTys = NIL;
831 CFunDescriptor* descriptor = 0;
832 Bool addState = TRUE;
833 while (getHead(t)==typeArrow && argCount==2) {
834 Type ta = fullExpand(arg(fun(t)));
836 argTys = cons(ta,argTys);
839 argTys = rev(argTys);
840 if (getHead(t) == typeIO) {
841 resultTys = getArgs(t);
842 assert(length(resultTys) == 1);
843 resultTys = hd(resultTys);
849 resultTys = fullExpand(resultTys);
850 if (isTuple(getHead(resultTys))) {
851 resultTys = getArgs(resultTys);
852 } else if (getHead(resultTys) == typeUnit) {
855 resultTys = singleton(resultTys);
857 mapOver(foreignArgTy,argTys); /* allows foreignObj, byteArrays, etc */
858 mapOver(foreignResultTy,resultTys); /* doesn't */
859 descriptor = mkDescriptor(charListToString(argTys),
860 charListToString(resultTys));
861 name(n).primop = addState ? &ccall_IO : &ccall_Id;
863 Pair extName = name(n).defn;
864 void* funPtr = getDLLSymbol(textToStr(textOf(fst(extName))),
865 textToStr(textOf(snd(extName))));
866 List extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
867 StgRhs rhs = makeStgPrim(n,addState,extra_args,descriptor->arg_tys,
868 descriptor->result_tys);
869 StgVar v = mkStgVar(rhs,NIL);
871 ERRMSG(0) "Could not find foreign function \"%s\" in \"%s\"",
872 textToStr(textOf(snd(extName))),
873 textToStr(textOf(fst(extName)))
879 stgGlobals=cons(pair(n,v),stgGlobals);/*so it will get codegen'd */
883 Void implementForeignExport( Name n )
885 internal("implementForeignExport: not implemented");
888 Void implementTuple(size)
891 Cell t = mkTuple(size);
892 List args = makeArgs(size);
893 StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
894 StgExpr e = mkStgLet(singleton(tv),tv);
895 StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
896 stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
898 StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
899 stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* ditto */
903 /* --------------------------------------------------------------------------
905 * ------------------------------------------------------------------------*/
907 Void translateControl(what)
912 /* deliberate fall through */
923 /*-------------------------------------------------------------------------*/