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/04/27 10:07:08 $
13 * ------------------------------------------------------------------------*/
22 #include "Assembler.h"
25 /* ---------------------------------------------------------------- */
27 static StgVar local stgOffset Args((Offset,List));
28 static StgVar local stgText Args((Text,List));
29 static StgRhs local stgRhs Args((Cell,Int,List,StgExpr));
30 static StgCaseAlt local stgCaseAlt Args((Cell,Int,List,StgExpr));
31 static StgExpr local stgExpr Args((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 Args((Cell));
41 static StgVar local getSTGTupleVar( Cell d )
43 Pair p = cellAssoc(d,stgGlobals);
44 /* Yoiks - only the Prelude sees Tuple decls! */
46 implementTuple(tupleOf(d));
47 p = cellAssoc(d,stgGlobals);
53 /* ---------------------------------------------------------------- */
55 static Cell local stgOffset(Offset o, List sc)
57 Cell r = cellAssoc(o,sc);
62 static Cell local stgText(Text t,List sc)
65 for (; nonNull(xs); xs=tl(xs)) {
68 if (!isOffset(v) && t == textOf(v)) {
75 /* ---------------------------------------------------------------- */
77 static StgRhs local stgRhs(e,co,sc,failExpr)
86 return stgOffset(e,sc);
89 return stgText(textOf(e),sc);
91 return getSTGTupleVar(e);
96 return mkStgCon(nameMkC,singleton(e));
98 return mkStgCon(nameMkI,singleton(e));
100 return mkStgCon(nameMkInteger,singleton(e));
102 return mkStgCon(nameMkD,singleton(e));
104 #if USE_ADDR_FOR_STRINGS
106 StgVar v = mkStgVar(mkStgCon(nameMkA,singleton(e)),NIL);
107 return mkStgLet(singleton(v),
108 makeStgApp(nameUnpackString,singleton(v)));
111 return mkStgApp(nameUnpackString,singleton(e));
114 return stgExpr(e,co,sc,namePMFail);
118 return stgExpr(e,co,sc,failExpr/*namePMFail*/);
122 static StgCaseAlt local stgCaseAlt(alt,co,sc,failExpr)
128 StgDiscr d = fst(alt);
129 Int da = discrArity(d);
132 for(i=1; i<=da; ++i) {
133 StgVar nv = mkStgVar(NIL,NIL);
135 sc = cons(pair(mkOffset(co+i),nv),sc);
137 return mkStgCaseAlt(d,vs,stgExpr(snd(alt),co+da,sc,failExpr));
140 static StgExpr local stgExpr(e,co,sc,failExpr)
149 return makeStgIf(stgExpr(fst3(snd(e)),co,sc,namePMFail),
150 stgExpr(snd3(snd(e)),co,sc,failExpr),
151 stgExpr(thd3(snd(e)),co,sc,failExpr));
155 List guards = reverse(snd(e));
157 for(; nonNull(guards); guards=tl(guards)) {
159 Cell c = stgExpr(fst(g),co,sc,namePMFail);
160 Cell rhs = stgExpr(snd(g),co,sc,failExpr);
161 e = makeStgIf(c,rhs,e);
167 StgExpr e2 = stgExpr(snd(snd(e)),co,sc,failExpr);
168 StgVar alt = mkStgVar(e2,NIL);
169 return mkStgLet(singleton(alt),stgExpr(fst(snd(e)),co,sc,alt));
173 List alts = snd(snd(e));
174 Cell scrut = stgExpr(fst(snd(e)),co,sc,namePMFail);
177 } else if (isChar(fst(hd(alts)))) {
179 StgDiscr d = fst(alt);
181 mkStgCon(nameMkC,singleton(d)),NIL);
182 StgExpr test = nameEqChar;
183 /* duplicates scrut but it should be atomic */
185 makeStgLet(singleton(c),
186 makeStgApp(test,doubleton(scrut,c))),
187 stgExpr(snd(alt),co,sc,failExpr),
188 stgExpr(ap(CASE,pair(fst(snd(e)),
189 tl(alts))),co,sc,failExpr));
192 for(; nonNull(alts); alts=tl(alts)) {
193 as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
199 singleton(mkStgDefault(mkStgVar(NIL,NIL),
204 #if OVERLOADED_CONSTANTS
208 Cell discr = snd3(nc);
210 Cell scrut = stgOffset(o,sc);
211 Cell h = getHead(discr);
212 Int da = discrArity(discr);
215 if (whatIs(h) == ADDPAT && argCount == 1) {
216 /* ADDPAT num dictIntegral
218 * let n = fromInteger num in
219 * if pmLe dictIntegral n scrut
220 * then let v = pmSubtract dictIntegral scrut v
224 Cell dictIntegral = arg(discr); /* Integral dictionary */
227 StgVar dIntegral = NIL;
229 /* bind dictionary */
230 dIntegral = stgRhs(dictIntegral,co,sc,namePMFail);
231 if (!isAtomic(dIntegral)) { /* wasn't atomic */
232 dIntegral = mkStgVar(dIntegral,NIL);
233 binds = cons(dIntegral,binds);
236 n = mkStgVar(mkStgCon(nameMkInteger,singleton(n)),NIL);
237 binds = cons(n,binds);
239 /* coerce number to right type (using Integral dict) */
240 n = mkStgVar(mkStgApp(
241 namePmFromInteger,doubleton(dIntegral,n)),NIL);
242 binds = cons(n,binds);
245 v = mkStgVar(mkStgApp(
246 namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
251 mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
252 mkStgLet(singleton(v),
255 cons(pair(mkOffset(co),v),sc),
261 assert(isName(h) && argCount == 2);
263 /* This code is rather ugly.
264 * We ought to desugar it using one of the following:
265 * if (==) dEq (fromInt dNum pat) scrut
266 * if (==) dEq (fromInteger dNum pat) scrut
267 * if (==) dEq (fromFloat dFractional pat) scrut
268 * But it would be very hard to obtain the Eq dictionary
269 * from the Num or Fractional dictionary we have.
270 * Instead, we rely on the Prelude to supply 3 helper
271 * functions which do the test for us.
272 * primPmInt :: Num a => Int -> a -> Bool
273 * primPmInteger :: Num a => Integer -> a -> Bool
274 * primPmDouble :: Fractional a => Double -> a -> Bool
277 Cell dict = arg(fun(discr));
282 = h == nameFromInt ? nameMkI
283 : h == nameFromInteger ? nameMkInteger
286 = h == nameFromInt ? namePmInt
287 : h == nameFromInteger ? namePmInteger
293 for(i=1; i<=da; ++i) {
294 Cell nv = mkStgVar(NIL,NIL);
296 altsc = cons(pair(mkOffset(co+i),nv),altsc);
298 /* bind dictionary */
299 d = stgRhs(dict,co,sc,namePMFail);
300 if (!isAtomic(d)) { /* wasn't atomic */
302 binds = cons(d,binds);
305 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
306 binds = cons(n,binds);
311 mkStgApp(testFun,tripleton(d,n,scrut))),
312 stgExpr(r,co+da,altsc,failExpr),
317 #else /* ! OVERLOADED_CONSTANTS */
321 Cell discr = snd3(nc);
323 Cell scrut = stgOffset(o,sc);
324 Cell h = getHead(discr);
325 Int da = discrArity(discr);
329 = isInt(discr) ? nameEqInt
330 : isBignum(discr) ? nameEqInteger
333 = isInt(discr) ? nameMkI
334 : isBignum(discr) ? nameMkBignum
341 for(i=1; i<=da; ++i) {
342 Cell nv = mkStgVar(NIL,NIL);
344 altsc = cons(pair(mkOffset(co+i),nv),altsc);
348 n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
349 binds = cons(n,binds);
351 test = mkStgLet(binds, mkStgApp(eq, doubleton(n,scrut)));
352 return makeStgIf(test,
353 stgExpr(r,co+da,altsc,failExpr),
356 #endif /* ! OVERLOADED_CONSTANTS */
362 /* allocate variables, extend scope */
363 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
364 Cell nv = mkStgVar(NIL,NIL);
365 sc = cons(pair(fst3(hd(bs)),nv),sc);
366 binds = cons(nv,binds);
369 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
370 Cell nv = mkStgVar(NIL,NIL);
371 sc = cons(pair(mkOffset(++co),nv),sc);
372 binds = cons(nv,binds);
376 /* transform functions */
377 for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
382 Int arity = intOf(snd3(fun));
384 for(i=1; i<=arity; ++i) {
385 Cell v = mkStgVar(NIL,NIL);
387 funsc = cons(pair(mkOffset(co+i),v),funsc);
392 stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
394 /* transform expressions */
395 for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
398 stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFail);
400 return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
402 default: /* convert to an StgApp or StgVar plus some bindings */
412 args = cons(arg,args);
416 if (e == nameSel && length(args) == 3) {
419 StgVar v = stgOffset(hd(tl(args)),sc);
421 StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
423 Int ix = intOf(hd(tl(tl(args))));
424 Int da = discrArity(con);
427 for(i=1; i<=da; ++i) {
428 Cell nv = mkStgVar(NIL,NIL);
433 doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
434 mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
437 /* Arguments must be StgAtoms */
438 for(as=args; nonNull(as); as=tl(as)) {
439 StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
440 #if 1 /* optional flattening of let bindings */
441 if (whatIs(a) == LETREC) {
442 binds = appendOnto(stgLetBinds(a),binds);
449 binds = cons(a,binds);
454 /* Function must be StgVar or Name */
455 e = stgRhs(e,co,sc,namePMFail);
456 if (!isStgVar(e) && !isName(e)) {
458 binds = cons(e,binds);
461 return makeStgLet(binds,makeStgApp(e,args));
466 #if 0 /* apparently not used */
467 static Void ppExp( Name n, Int arity, Cell e )
469 if (1 || debugCode) {
471 printf("%s", textToStr(name(n).text));
472 for (i = arity; i > 0; i--) {
483 Void stgDefn( Name n, Int arity, Cell e )
488 for (i = 1; i <= arity; ++i) {
489 Cell nv = mkStgVar(NIL,NIL);
491 sc = cons(pair(mkOffset(i),nv),sc);
493 stgVarBody(name(n).stgVar)
494 = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
495 s = stgSize(stgVarBody(name(n).stgVar));
497 if (s <= SMALL_INLINE_SIZE && !name(n).inlineMe) {
498 name(n).inlineMe = TRUE;
502 Void implementCfun(c,scs) /* Build implementation for constr */
503 Name c; /* fun c. scs lists integers (1..)*/
504 List scs; { /* in incr order of strict comps. */
505 Int a = name(c).arity;
508 StgVar vcurr, e1, v, vsi;
509 List args = makeArgs(a);
510 StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
511 List binds = singleton(v0);
514 for (; nonNull(scs); scs=tl(scs)) {
515 vsi = nth(intOf(hd(scs))-1,args);
516 vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
517 binds = cons(vcurr,binds);
520 e1 = mkStgLet(binds,vcurr);
521 v = mkStgVar(mkStgLambda(args,e1),NIL);
524 StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
527 name(c).inlineMe = TRUE;
528 name(c).stgSize = stgSize(stgVarBody(name(c).stgVar));
529 stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
530 //printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n");
533 /* --------------------------------------------------------------------------
534 * Foreign function calls and primops
535 * ------------------------------------------------------------------------*/
537 static String charListToString( List cs );
538 static Cell foreignResultTy( Type t );
539 static Cell foreignArgTy( Type t );
540 static Name repToBox Args(( char c ));
541 static StgRhs makeStgPrim Args(( Name,Bool,List,String,String ));
543 static String charListToString( List cs )
548 assert( length(cs) < 100 );
549 for(; nonNull(cs); ++i, cs=tl(cs)) {
550 s[i] = charOf(hd(cs));
553 return textToStr(findText(s));
556 static Cell foreignResultTy( Type t )
558 if (t == typeChar) return mkChar(CHAR_REP);
559 else if (t == typeInt) return mkChar(INT_REP);
560 else if (t == typeInteger)return mkChar(INTEGER_REP);
561 else if (t == typeWord) return mkChar(WORD_REP);
562 else if (t == typeAddr) return mkChar(ADDR_REP);
563 else if (t == typeFloat) return mkChar(FLOAT_REP);
564 else if (t == typeDouble) return mkChar(DOUBLE_REP);
565 #ifdef PROVIDE_FOREIGN
566 else if (t == typeForeign)return mkChar(FOREIGN_REP);
567 /* ToDo: argty only! */
569 else if (t == typePrimByteArray) return mkChar(BARR_REP);
570 /* ToDo: argty only! */
571 else if (whatIs(t) == AP) {
573 if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
574 /* ToDo: argty only! */
576 /* ToDo: decent line numbers! */
577 ERRMSG(0) "Illegal foreign type" ETHEN
578 ERRTEXT " \"" ETHEN ERRTYPE(t);
583 static Cell foreignArgTy( Type t )
585 return foreignResultTy( t );
588 static Name repToBox( char c )
591 case CHAR_REP: return nameMkC;
592 case INT_REP: return nameMkI;
593 case INTEGER_REP: return nameMkInteger;
594 case WORD_REP: return nameMkW;
595 case ADDR_REP: return nameMkA;
596 case FLOAT_REP: return nameMkF;
597 case DOUBLE_REP: return nameMkD;
598 case ARR_REP: return nameMkPrimArray;
599 case BARR_REP: return nameMkPrimByteArray;
600 case REF_REP: return nameMkRef;
601 case MUTARR_REP: return nameMkPrimMutableArray;
602 case MUTBARR_REP: return nameMkPrimMutableByteArray;
603 #ifdef PROVIDE_STABLE
604 case STABLE_REP: return nameMkStable;
607 case WEAK_REP: return nameMkWeak;
609 #ifdef PROVIDE_FOREIGN
610 case FOREIGN_REP: return nameMkForeign;
612 #ifdef PROVIDE_CONCURRENT
613 case THREADID_REP: return nameMkThreadId;
614 case MVAR_REP: return nameMkMVar;
620 static StgPrimAlt boxResults( String reps, StgVar state )
622 List rs = NIL; /* possibly unboxed results */
623 List bs = NIL; /* boxed results of wrapper */
624 List rbinds = NIL; /* bindings used to box results */
627 for(i=0; reps[i] != '\0'; ++i) {
628 StgRep k = mkStgRep(reps[i]);
629 Cell v = mkStgPrimVar(NIL,k,NIL);
630 Name box = repToBox(reps[i]);
634 StgRhs rhs = mkStgCon(box,singleton(v));
635 StgVar bv = mkStgVar(rhs,NIL); /* boxed */
637 rbinds = cons(bv,rbinds);
641 /* Construct tuple of results */
644 } else { /* includes i==0 case */
645 StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
646 rbinds = cons(r,rbinds);
649 /* construct result pair if needed */
650 if (nonNull(state)) {
651 /* Note that this builds a tuple directly - we know it's
654 StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
655 rbinds = cons(r,rbinds);
656 rs = cons(state,rs); /* last result is a state */
659 return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
662 static List mkUnboxedVars( String reps )
666 for(i=0; reps[i] != '\0'; ++i) {
667 Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
673 static List mkBoxedVars( String reps )
677 for(i=0; reps[i] != '\0'; ++i) {
678 as = cons(mkStgVar(NIL,NIL),as);
683 static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
685 if (nonNull(b_args)) {
686 StgVar b_arg = hd(b_args); /* boxed arg */
687 StgVar u_arg = hd(u_args); /* unboxed arg */
688 //StgRep k = mkStgRep(*reps);
689 Name box = repToBox(*reps);
690 e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
692 /* Use a trivial let-binding */
693 stgVarBody(u_arg) = b_arg;
694 return mkStgLet(singleton(u_arg),e);
696 StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
697 return mkStgCase(b_arg,singleton(alt));
704 /* Generate wrapper for primop based on list of arg types and result types:
706 * makeStgPrim op# False "II" "II" =
707 * \ x y -> "case x of { I# x# ->
708 * case y of { I# y# ->
709 * case op#{x#,y#} of { r1# r2# ->
710 * let r1 = I# r1#; r2 = I# r2# in
714 static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
720 List b_args = NIL; /* boxed args to primop */
721 List u_args = NIL; /* possibly unboxed args to primop */
723 StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
724 StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
727 if (strcmp(r_reps,"B") == 0) {
729 = mkStgPrimAlt(singleton(
730 mkStgPrimVar(mkInt(0),
731 mkStgRep(INT_REP),NIL)
736 singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
738 alts = doubleton(altF,altT);
739 assert(nonNull(nameTrue));
742 alts = singleton(boxResults(r_reps,s1));
744 b_args = mkBoxedVars(a_reps);
745 u_args = mkUnboxedVars(a_reps);
748 = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
750 = makeStgLambda(singleton(s0),
751 unboxVars(a_reps,b_args,u_args,
752 mkStgPrimCase(mkStgPrim(op,actual_args),
754 StgVar m = mkStgVar(rhs,NIL);
755 return makeStgLambda(b_args,
756 mkStgLet(singleton(m),
757 mkStgApp(nameMkIO,singleton(m))));
759 List actual_args = appendOnto(extra_args,u_args);
760 return makeStgLambda(
762 unboxVars(a_reps,b_args,u_args,
763 mkStgPrimCase(mkStgPrim(op,actual_args),alts))
768 Void implementPrim( n )
770 const AsmPrim* p = name(n).primop;
771 StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
772 StgVar v = mkStgVar(rhs,NIL);
774 name(n).stgSize = stgSize(stgVarBody(v));
775 name(n).inlineMe = TRUE;
776 stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */
779 /* Generate wrapper code from (in,out) type lists.
783 * inTypes = [Int,Float]
784 * outTypes = [Char,Addr]
788 * case a1 of { I# a1# ->
789 * case s2 of { F# a2# ->
790 * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
798 * Addr -> (Int -> Float -> IO (Char,Addr))
800 Void implementForeignImport( Name n )
802 Type t = name(n).type;
804 List resultTys = NIL;
805 CFunDescriptor* descriptor = 0;
806 Bool addState = TRUE;
807 while (getHead(t)==typeArrow && argCount==2) {
808 Type ta = fullExpand(arg(fun(t)));
810 argTys = cons(ta,argTys);
813 argTys = rev(argTys);
814 if (getHead(t) == typeIO) {
815 resultTys = getArgs(t);
816 assert(length(resultTys) == 1);
817 resultTys = hd(resultTys);
823 resultTys = fullExpand(resultTys);
824 if (isTuple(getHead(resultTys))) {
825 resultTys = getArgs(resultTys);
826 } else if (getHead(resultTys) == typeUnit) {
829 resultTys = singleton(resultTys);
831 mapOver(foreignArgTy,argTys); /* allows foreignObj, byteArrays, etc */
832 mapOver(foreignResultTy,resultTys); /* doesn't */
833 descriptor = mkDescriptor(charListToString(argTys),
834 charListToString(resultTys));
835 name(n).primop = addState ? &ccall_IO : &ccall_Id;
837 Pair extName = name(n).defn;
838 void* funPtr = getDLLSymbol(textToStr(textOf(fst(extName))),
839 textToStr(textOf(snd(extName))));
840 List extra_args = doubleton(mkPtr(descriptor),mkPtr(funPtr));
841 StgRhs rhs = makeStgPrim(n,addState,extra_args,descriptor->arg_tys,
842 descriptor->result_tys);
843 StgVar v = mkStgVar(rhs,NIL);
845 ERRMSG(0) "Could not find foreign function \"%s\" in \"%s\"",
846 textToStr(textOf(snd(extName))),
847 textToStr(textOf(fst(extName)))
853 name(n).stgSize = stgSize(stgVarBody(v));
854 name(n).inlineMe = TRUE;
855 stgGlobals=cons(pair(n,v),stgGlobals);/*so it will get codegen'd */
859 Void implementForeignExport( Name n )
861 internal("implementForeignExport: not implemented");
864 // ToDo: figure out how to set inlineMe for these (non-Name) things
865 Void implementTuple(size)
868 Cell t = mkTuple(size);
869 List args = makeArgs(size);
870 StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
871 StgExpr e = mkStgLet(singleton(tv),tv);
872 StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
873 stgGlobals = cons(pair(t,v),stgGlobals); /* so we can see it */
875 StgVar tv = mkStgVar(mkStgCon(nameUnit,NIL),NIL);
876 stgGlobals = cons(pair(nameUnit,tv),stgGlobals); /* ditto */
880 /* --------------------------------------------------------------------------
882 * ------------------------------------------------------------------------*/
884 Void translateControl(what)
889 /* deliberate fall through */
900 /*-------------------------------------------------------------------------*/