2 /* --------------------------------------------------------------------------
3 * This is the Hugs compiler, handling translation of typechecked code to
4 * `kernel' language, elimination of pattern matching and translation to
5 * super combinators (lambda lifting).
7 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
8 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
9 * Technology, 1994-1999, All rights reserved. It is distributed as
10 * free software under the license in the file "License", which is
11 * included in the distribution.
13 * $RCSfile: compiler.c,v $
15 * $Date: 2000/04/14 15:18:06 $
16 * ------------------------------------------------------------------------*/
18 #include "hugsbasictypes.h"
23 #include "Rts.h" /* for rts_eval and related stuff */
24 #include "RtsAPI.h" /* for rts_eval and related stuff */
25 #include "SchedAPI.h" /* for RevertCAFs */
28 /* --------------------------------------------------------------------------
29 * Local function prototypes:
30 * ------------------------------------------------------------------------*/
32 static Cell local translate ( Cell );
33 static Void local transPair ( Pair );
34 static Void local transTriple ( Triple );
35 static Void local transAlt ( Cell );
36 static Void local transCase ( Cell );
37 static List local transBinds ( List );
38 static Cell local transRhs ( Cell );
39 static Cell local mkConsList ( List );
40 static Cell local expandLetrec ( Cell );
41 static Cell local transComp ( Cell,List,Cell );
42 static Cell local transDo ( Cell,Cell,List );
43 static Cell local transConFlds ( Cell,List );
44 static Cell local transUpdFlds ( Cell,List,List );
46 static Cell local refutePat ( Cell );
47 static Cell local refutePatAp ( Cell );
48 static Cell local matchPat ( Cell );
49 static List local remPat ( Cell,Cell,List );
50 static List local remPat1 ( Cell,Cell,List );
52 static Cell local pmcTerm ( Int,List,Cell );
53 static Cell local pmcPair ( Int,List,Pair );
54 static Cell local pmcTriple ( Int,List,Triple );
55 static Cell local pmcVar ( List,Text );
56 static Void local pmcLetrec ( Int,List,Pair );
57 static Cell local pmcVarDef ( Int,List,List );
58 static Void local pmcFunDef ( Int,List,Triple );
59 static List local altsMatch ( Int,Int,List,List );
60 static Cell local match ( Int,List );
61 static Cell local joinMas ( Int,List );
62 static Bool local canFail ( Cell );
63 static List local addConTable ( Cell,Cell,List );
64 static Void local advance ( Int,Int,Cell );
65 static Bool local emptyMatch ( Cell );
66 static Cell local maDiscr ( Cell );
67 static Bool local isNumDiscr ( Cell );
68 static Bool local eqNumDiscr ( Cell,Cell );
70 static Bool local isExtDiscr ( Cell );
71 static Bool local eqExtDiscr ( Cell,Cell );
74 static Void local compileGlobalFunction ( Pair );
75 static Void local compileGenFunction ( Name );
76 static Name local compileSelFunction ( Pair );
77 static List local addStgVar ( List,Pair );
79 static Name currentName; /* Top level name being processed */
80 static Int lineNumber = 0; /* previously discarded line number */
82 /* --------------------------------------------------------------------------
83 * Translation: Convert input expressions into a less complex language
84 * of terms using only LETREC, AP, constants and vars.
85 * Also remove pattern definitions on lhs of eqns.
86 * ------------------------------------------------------------------------*/
88 static Cell local translate(e) /* Translate expression: */
91 printf ( "translate: " );print(e,100);printf("\n");
94 case LETREC : snd(snd(e)) = translate(snd(snd(e)));
95 return expandLetrec(e);
97 case COND : transTriple(snd(e));
100 case AP : fst(e) = translate(fst(e));
102 /* T [id <exp>] ==> T[<exp>]
103 * T [indirect <exp> ] ==> T[<exp>]
105 if (fst(e)==nameId || fst(e)==nameInd)
106 return translate(snd(e));
107 if (isName(fst(e)) &&
110 return translate(snd(e));
112 snd(e) = translate(snd(e));
118 /* T [otherwise] ==> True
121 if (e==nameOtherwise)
123 /* T [assert] ==> T[assertError "<location info>"]
125 if (flagAssert && e==nameAssert) {
126 Cell str = errAssert(lineNumber);
127 return (ap(nameAssertError,str));
131 if (isName(name(e).defn))
133 if (isPair(name(e).defn))
134 return snd(name(e).defn);
139 case RECSEL : return nameRecSel;
151 case CHARCELL : return e;
153 case IPVAR : return nameId;
155 case FINLIST : mapOver(translate,snd(e));
156 return mkConsList(snd(e));
158 case DOCOMP : { Cell m = translate(fst(snd(e)));
159 Cell r = translate(fst(snd(snd(e))));
160 return transDo(m,r,snd(snd(snd(e))));
163 case MONADCOMP : { Cell m = translate(fst(snd(e)));
164 Cell r = translate(fst(snd(snd(e))));
165 Cell qs = snd(snd(snd(e)));
166 if (m == nameListMonad)
167 return transComp(r,qs,nameNil);
170 r = ap(ap(nameReturn,m),r);
171 return transDo(m,r,qs);
173 internal("translate: monad comps");
178 case CONFLDS : return transConFlds(fst(snd(e)),snd(snd(e)));
180 case UPDFLDS : return transUpdFlds(fst3(snd(e)),
184 case CASE : { Cell nv = inventVar();
185 mapProc(transCase,snd(snd(e)));
187 pair(singleton(pair(nv,snd(snd(e)))),
188 ap(nv,translate(fst(snd(e))))));
191 case LAMBDA : { Cell nv = inventVar();
200 default : fprintf(stderr, "stuff=%d\n",whatIs(e));
201 internal("translate");
206 static Void local transPair(pr) /* Translate each component in a */
207 Pair pr; { /* pair of expressions. */
208 fst(pr) = translate(fst(pr));
209 snd(pr) = translate(snd(pr));
212 static Void local transTriple(tr) /* Translate each component in a */
213 Triple tr; { /* triple of expressions. */
214 fst3(tr) = translate(fst3(tr));
215 snd3(tr) = translate(snd3(tr));
216 thd3(tr) = translate(thd3(tr));
219 static Void local transAlt(e) /* Translate alt: */
220 Cell e; { /* ([Pat], Rhs) ==> ([Pat], Rhs') */
222 printf ( "transAlt: " );print(snd(e),100);printf("\n");
224 snd(e) = transRhs(snd(e));
227 static Void local transCase(c) /* Translate case: */
228 Cell c; { /* (Pat, Rhs) ==> ([Pat], Rhs') */
229 fst(c) = singleton(fst(c));
230 snd(c) = transRhs(snd(c));
233 static List local transBinds(bs) /* Translate list of bindings: */
234 List bs; { /* eliminating pattern matching on */
235 List newBinds = NIL; /* lhs of bindings. */
236 for (; nonNull(bs); bs=tl(bs)) {
238 Cell v = fst(hd(bs));
239 while (isAp(v) && fst(v) == nameInd)
244 if (isVar(fst(hd(bs)))) {
246 mapProc(transAlt,snd(hd(bs)));
247 newBinds = cons(hd(bs),newBinds);
250 newBinds = remPat(fst(snd(hd(bs))),
251 snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))),
257 static Cell local transRhs(rhs) /* Translate rhs: removing line nos */
259 switch (whatIs(rhs)) {
260 case LETREC : snd(snd(rhs)) = transRhs(snd(snd(rhs)));
261 return expandLetrec(rhs);
263 case GUARDED : mapOver(snd,snd(rhs)); /* discard line number */
264 mapProc(transPair,snd(rhs));
269 Int prev = lineNumber;
270 lineNumber = intOf(fst(rhs));
271 tmp = translate(snd(rhs)); /* discard line number */
278 static Cell local mkConsList(es) /* Construct expression for list es */
279 List es; { /* using nameNil and nameCons */
283 return ap(ap(nameCons,hd(es)),mkConsList(tl(es)));
286 static Cell local expandLetrec(root) /* translate LETREC with list of */
287 Cell root; { /* groups of bindings (from depend. */
288 Cell e = snd(snd(root)); /* analysis) to use nested LETRECs */
289 List bss = fst(snd(root));
292 if (isNull(bss)) /* should never happen, but just in */
293 return e; /* case: LETREC [] IN e ==> e */
295 mapOver(transBinds,bss); /* translate each group of bindings */
297 for (temp=root; nonNull(tl(bss)); bss=tl(bss)) {
298 fst(snd(temp)) = hd(bss);
299 snd(snd(temp)) = ap(LETREC,pair(NIL,e));
300 temp = snd(snd(temp));
302 fst(snd(temp)) = hd(bss);
307 /* --------------------------------------------------------------------------
308 * Translation of list comprehensions is based on the description in
309 * `The Implementation of Functional Programming Languages':
311 * [ e | qs ] ++ l => transComp e qs l
312 * transComp e [] l => e : l
313 * transComp e ((p<-xs):qs) l => LETREC _h [] = l
314 * _h (p:_xs) = transComp e qs (_h _xs)
315 * _h (_:_xs) = _h _xs --if p !failFree
317 * transComp e (b:qs) l => if b then transComp e qs l else l
318 * transComp e (decls:qs) l => LETREC decls IN transComp e qs l
319 * ------------------------------------------------------------------------*/
321 static Cell local transComp(e,qs,l) /* Translate [e | qs] ++ l */
330 case FROMQUAL : { Cell ld = NIL;
331 Cell hVar = inventVar();
332 Cell xsVar = inventVar();
334 if (!failFree(fst(snd(q))))
335 ld = cons(pair(singleton(
342 ld = cons(pair(singleton(
350 ld = cons(pair(singleton(nameNil),
355 pair(singleton(pair(hVar,
358 translate(snd(snd(q))))));
362 expandLetrec(ap(LETREC,
364 transComp(e,qs1,l))));
366 case BOOLQUAL : return ap(COND,
367 triple(translate(snd(q)),
373 return ap(ap(nameCons,e),l);
376 /* --------------------------------------------------------------------------
377 * Translation of monad comprehensions written using do-notation:
380 * do { p <- exp; qs } => LETREC _h p = do { qs }
381 * _h _ = fail m "match fails"
383 * do { LET decls; qs } => LETREC decls IN do { qs }
384 * do { IF guard; qs } => if guard then do { qs } else fail m "guard fails"
385 * do { e; qs } => LETREC _h _ = [ e | qs ] in bind m exp _h
388 * ------------------------------------------------------------------------*/
390 static Cell local transDo(m,e,qs) /* Translate do { qs ; e } */
399 case FROMQUAL : { Cell ld = NIL;
400 Cell hVar = inventVar();
402 if (!failFree(fst(snd(q)))) {
403 Cell str = mkStr(findText("match fails"));
404 ld = cons(pair(singleton(WILDCARD),
405 ap2(nameMFail,m,str)),
409 ld = cons(pair(singleton(fst(snd(q))),
414 pair(singleton(pair(hVar,ld)),
417 translate(snd(snd(q)))),
421 case DOQUAL : { Cell hVar = inventVar();
422 Cell ld = cons(pair(singleton(WILDCARD),
426 pair(singleton(pair(hVar,ld)),
434 expandLetrec(ap(LETREC,
438 case BOOLQUAL : return
440 triple(translate(snd(q)),
443 mkStr(findText("guard fails")))));
449 /* --------------------------------------------------------------------------
450 * Translation of named field construction and update:
452 * Construction is implemented using the following transformation:
454 * C{x1=e1, ..., xn=en} = C v1 ... vm
456 * vi = e1, if the ith component of C is labelled with x1
458 * = en, if the ith component of C is labelled with xn
459 * = undefined, otherwise
461 * Update is implemented using the following transformation:
463 * e{x1=e1, ..., xn=en}
464 * = let nv (C a1 ... am) v1 ... vn = C a1' .. am'
465 * nv (D b1 ... bk) v1 ... vn = D b1' .. bk
467 * nv _ v1 ... vn = error "failed update"
470 * nv, v1, ..., vn, a1, ..., am, b1, ..., bk, ... are new variables,
471 * C,D,... = { K | K is a constr fun s.t. {x1,...,xn} subset of sels(K)}
473 * ai' = v1, if the ith component of C is labelled with x1
475 * = vn, if the ith component of C is labelled with xn
479 * The error case may be omitted if C,D,... is an enumeration of all of the
480 * constructors for the datatype concerned. Strictly speaking, error case
481 * isn't needed at all -- the only benefit of including it is that the user
482 * will get a "failed update" message rather than a cryptic {v354 ...}.
483 * So, for now, we'll go with the second option!
485 * For the time being, code for each update operation is generated
486 * independently of any other updates. However, if updates are used
487 * frequently, then we might want to consider changing the implementation
488 * at a later stage to cache definitions of functions like nv above. This
489 * would create a shared library of update functions, indexed by a set of
490 * constructors {C,D,...}.
491 * ------------------------------------------------------------------------*/
493 static Cell local transConFlds(c,flds) /* Translate C{flds} */
497 Int m = name(c).arity;
500 e = ap(e,nameUndefined);
501 for (; nonNull(flds); flds=tl(flds)) {
503 for (i=m-sfunPos(fst(hd(flds)),c); i>0; i--)
505 arg(a) = translate(snd(hd(flds)));
510 static Cell local transUpdFlds(e,cs,flds)/* Translate e{flds} */
511 Cell e; /* (cs is corresp list of constrs) */
514 Cell nv = inventVar();
515 Cell body = ap(nv,translate(e));
520 for (; nonNull(fs); fs=tl(fs)) { /* body = nv e1 ... en */
521 Cell b = hd(fs); /* args = [v1, ..., vn] */
522 body = ap(body,translate(snd(b)));
523 args = cons(inventVar(),args);
526 for (; nonNull(cs); cs=tl(cs)) { /* Loop through constructors to */
527 Cell c = hd(cs); /* build up list of alts. */
531 Int m = name(c).arity;
534 for (i=m; i>0; i--) { /* pat = C a1 ... am */
535 Cell a = inventVar(); /* rhs = C a1 ... am */
540 for (fs=flds; nonNull(fs); fs=tl(fs), as=tl(as)) {
541 Name s = fst(hd(fs)); /* Replace approp ai in rhs with */
542 Cell r = rhs; /* vars from [v1,...,vn] */
543 for (i=m-sfunPos(s,c); i>0; i--)
548 alts = cons(pair(cons(pat,args),rhs),alts);
550 return ap(LETREC,pair(singleton(pair(nv,alts)),body));
553 /* --------------------------------------------------------------------------
554 * Elimination of pattern bindings:
556 * The following code adopts the definition of failure free patterns as given
557 * in the Haskell 1.3 report; the term "irrefutable" is also used there for
558 * a subset of the failure free patterns described here, but has no useful
559 * role in this implementation. Basically speaking, the failure free patterns
560 * are: variable, wildcard, ~apat
561 * var@apat, if apat is failure free
562 * C apat1 ... apatn if C is a product constructor
563 * (i.e. an only constructor) and
564 * apat1,...,apatn are failure free
565 * Note that the last case automatically covers the case where C comes from
566 * a newtype construction.
567 * ------------------------------------------------------------------------*/
569 Bool failFree(pat) /* is pattern failure free? (do we need */
570 Cell pat; { /* a conformality check?) */
571 Cell c = getHead(pat);
574 case ASPAT : return failFree(snd(snd(pat)));
576 case NAME : if (!isCfun(c) || cfunOf(c)!=0)
578 /*intentional fall-thru*/
579 case TUPLE : for (; isAp(pat); pat=fun(pat))
580 if (!failFree(arg(pat)))
582 /*intentional fall-thru*/
587 case WILDCARD : return TRUE;
590 case EXT : return failFree(extField(pat)) &&
591 failFree(extRow(pat));
594 case CONFLDS : if (cfunOf(fst(snd(c)))==0) {
595 List fs = snd(snd(c));
596 for (; nonNull(fs); fs=tl(fs))
597 if (!failFree(snd(hd(fs))))
601 /*intentional fall-thru*/
602 default : return FALSE;
606 static Cell local refutePat(pat) /* find pattern to refute in conformality*/
607 Cell pat; { /* test with pat. */
608 /* e.g. refPat (x:y) == (_:_) */
609 /* refPat ~(x:y) == _ etc.. */
611 switch (whatIs(pat)) {
612 case ASPAT : return refutePat(snd(snd(pat)));
614 case FINLIST : { Cell ys = snd(pat);
616 for (; nonNull(ys); ys=tl(ys))
617 xs = ap(ap(nameCons,refutePat(hd(ys))),xs);
618 return revOnto(xs,nameNil);
621 case CONFLDS : { Cell ps = NIL;
622 Cell fs = snd(snd(pat));
623 for (; nonNull(fs); fs=tl(fs)) {
624 Cell p = refutePat(snd(hd(fs)));
625 ps = cons(pair(fst(hd(fs)),p),ps);
627 return pair(CONFLDS,pair(fst(snd(pat)),rev(ps)));
634 case LAZYPAT : return WILDCARD;
640 case NAME : return pat;
642 case AP : return refutePatAp(pat);
644 default : internal("refutePat");
645 return NIL; /*NOTREACHED*/
649 static Cell local refutePatAp(p) /* find pattern to refute in conformality*/
652 if (h==nameFromInt || h==nameFromInteger || h==nameFromDouble)
654 else if (whatIs(h)==ADDPAT)
655 return ap(fun(p),refutePat(arg(p)));
658 Cell pf = refutePat(extField(p));
659 Cell pr = refutePat(extRow(p));
660 return ap(ap(fun(fun(p)),pf),pr);
664 List as = getArgs(p);
665 mapOver(refutePat,as);
666 return applyToArgs(h,as);
670 static Cell local matchPat(pat) /* find pattern to match against */
671 Cell pat; { /* replaces parts of pattern that do not */
672 /* include variables with wildcards */
673 switch (whatIs(pat)) {
674 case ASPAT : { Cell p = matchPat(snd(snd(pat)));
675 return (p==WILDCARD) ? fst(snd(pat))
677 pair(fst(snd(pat)),p));
680 case FINLIST : { Cell ys = snd(pat);
682 for (; nonNull(ys); ys=tl(ys))
683 xs = cons(matchPat(hd(ys)),xs);
684 while (nonNull(xs) && hd(xs)==WILDCARD)
686 for (ys=nameNil; nonNull(xs); xs=tl(xs))
687 ys = ap(ap(nameCons,hd(xs)),ys);
691 case CONFLDS : { Cell ps = NIL;
692 Name c = fst(snd(pat));
693 Cell fs = snd(snd(pat));
695 for (; nonNull(fs); fs=tl(fs)) {
696 Cell p = matchPat(snd(hd(fs)));
697 ps = cons(pair(fst(hd(fs)),p),ps);
701 return avar ? pair(CONFLDS,pair(c,rev(ps)))
707 case DICTVAR : return pat;
709 case LAZYPAT : { Cell p = matchPat(snd(pat));
710 return (p==WILDCARD) ? WILDCARD : ap(LAZYPAT,p);
715 case CHARCELL : return WILDCARD;
719 case AP : { Cell h = getHead(pat);
720 if (h==nameFromInt ||
721 h==nameFromInteger || h==nameFromDouble)
723 else if (whatIs(h)==ADDPAT)
727 Cell pf = matchPat(extField(pat));
728 Cell pr = matchPat(extRow(pat));
729 return (pf==WILDCARD && pr==WILDCARD)
731 : ap(ap(fun(fun(pat)),pf),pr);
737 for (; isAp(pat); pat=fun(pat)) {
738 Cell p = matchPat(arg(pat));
743 return avar ? applyToArgs(pat,args)
748 default : internal("matchPat");
749 return NIL; /*NOTREACHED*/
753 #define addEqn(v,val,lds) cons(pair(v,singleton(pair(NIL,val))),lds)
755 static List local remPat(pat,expr,lds)
756 Cell pat; /* Produce list of definitions for eqn */
757 Cell expr; /* pat = expr, including a conformality */
758 List lds; { /* check if required. */
760 /* Conformality test (if required):
761 * pat = expr ==> nv = LETREC confCheck nv@pat = nv
763 * remPat1(pat,nv,.....);
766 if (!failFree(pat)) {
767 Cell confVar = inventVar();
768 Cell nv = inventVar();
769 Cell locfun = pair(confVar, /* confVar [([nv@refPat],nv)] */
770 singleton(pair(singleton(ap(ASPAT,
775 if (whatIs(expr)==GUARDED) { /* A spanner ... special case */
776 lds = addEqn(nv,expr,lds); /* for guarded pattern binding*/
781 if (whatIs(pat)==ASPAT) { /* avoid using new variable if*/
782 nv = fst(snd(pat)); /* a variable is already given*/
783 pat = snd(snd(pat)); /* by an as-pattern */
786 lds = addEqn(nv, /* nv = */
787 ap(LETREC,pair(singleton(locfun), /* LETREC [locfun] */
788 ap(confVar,expr))), /* IN confVar expr */
791 return remPat1(matchPat(pat),nv,lds);
794 return remPat1(matchPat(pat),expr,lds);
797 static List local remPat1(pat,expr,lds)
798 Cell pat; /* Add definitions for: pat = expr to */
799 Cell expr; /* list of local definitions in lds. */
801 Cell c = getHead(pat);
806 case CHARCELL : break;
808 case ASPAT : return remPat1(snd(snd(pat)), /* v@pat = expr */
810 addEqn(fst(snd(pat)),expr,lds));
812 case LAZYPAT : { Cell nv;
814 if (isVar(expr) || isName(expr))
818 lds = addEqn(nv,expr,lds);
821 return remPat(snd(pat),nv,lds);
824 case ADDPAT : return remPat1(arg(pat), /* n + k = expr */
827 mkInt(snd(fun(fun(pat))))),
831 case FINLIST : return remPat1(mkConsList(snd(pat)),expr,lds);
833 case CONFLDS : { Name h = fst(snd(pat));
834 Int m = name(h).arity;
836 List fs = snd(snd(pat));
840 for (; nonNull(fs); fs=tl(fs)) {
842 for (i=m-sfunPos(fst(hd(fs)),h); i>0; i--)
844 arg(r) = snd(hd(fs));
846 return remPat1(p,expr,lds);
849 case DICTVAR : /* shouldn't really occur */
850 //assert(0); /* so let's test for it then! ADR */
852 case VAROPCELL : return addEqn(pat,expr,lds);
854 case NAME : if (c==nameFromInt || c==nameFromInteger
855 || c==nameFromDouble) {
857 arg(fun(pat)) = translate(arg(fun(pat)));
861 if (argCount==1 && isCfun(c) /* for newtype */
862 && cfunOf(c)==0 && name(c).defn==nameId)
863 return remPat1(arg(pat),expr,lds);
865 /* intentional fall-thru */
866 case TUPLE : { List ps = getArgs(pat);
868 /* get rid of leading dictionaries in args */
869 if (isName(c) && isCfun(c)) {
870 Int i = numQualifiers(name(c).type);
871 for (; i > 0; i--) ps = tl(ps);
877 if (isVar(expr) || isName(expr))
881 lds = addEqn(nv,expr,lds);
884 sel = ap(ap(nameSel,c),nv);
885 for (i=1; nonNull(ps); ++i, ps=tl(ps))
886 lds = remPat1(hd(ps),
894 case EXT : { Cell nv = inventVar();
896 = translate(arg(fun(fun(pat))));
902 lds = remPat1(extField(pat),ap(nameFst,nv),lds);
903 lds = remPat1(extRow(pat),ap(nameSnd,nv),lds);
908 default : internal("remPat1");
914 /* --------------------------------------------------------------------------
915 * Eliminate pattern matching in function definitions -- pattern matching
918 * The original Gofer/Hugs pattern matching compiler was based on Wadler's
919 * algorithms described in `Implementation of functional programming
920 * languages'. That should still provide a good starting point for anyone
921 * wanting to understand this part of the system. However, the original
922 * algorithm has been generalized and restructured in order to implement
923 * new features added in Haskell 1.3.
925 * During the translation, in preparation for later stages of compilation,
926 * all local and bound variables are replaced by suitable offsets, and
927 * locally defined function symbols are given new names (which will
928 * eventually be their names when lifted to make top level definitions).
929 * ------------------------------------------------------------------------*/
931 static Offset freeBegin; /* only variables with offset <= freeBegin are of */
932 static List freeVars; /* interest as `free' variables */
933 static List freeFuns; /* List of `free' local functions */
935 static Cell local pmcTerm(co,sc,e) /* apply pattern matching compiler */
936 Int co; /* co = current offset */
937 List sc; /* sc = scope */
938 Cell e; { /* e = expr to transform */
940 case GUARDED : map2Over(pmcPair,co,sc,snd(e));
943 case LETREC : pmcLetrec(co,sc,snd(e));
948 case DICTVAR : return pmcVar(sc,textOf(e));
950 case COND : return ap(COND,pmcTriple(co,sc,snd(e)));
952 case AP : return pmcPair(co,sc,e);
964 case STRCELL : break;
966 default : internal("pmcTerm");
972 static Cell local pmcPair(co,sc,pr) /* apply pattern matching compiler */
973 Int co; /* to a pair of exprs */
976 return pair(pmcTerm(co,sc,fst(pr)),
977 pmcTerm(co,sc,snd(pr)));
980 static Cell local pmcTriple(co,sc,tr) /* apply pattern matching compiler */
981 Int co; /* to a triple of exprs */
984 return triple(pmcTerm(co,sc,fst3(tr)),
985 pmcTerm(co,sc,snd3(tr)),
986 pmcTerm(co,sc,thd3(tr)));
989 static Cell local pmcVar(sc,t) /* find translation of variable */
990 List sc; /* in current scope */
995 for (xs=sc; nonNull(xs); xs=tl(xs)) {
997 if (t==textOf(fst(x))) {
998 if (isOffset(snd(x))) { /* local variable ... */
999 if (snd(x)<=freeBegin && !cellIsMember(snd(x),freeVars))
1000 freeVars = cons(snd(x),freeVars);
1003 else { /* local function ... */
1004 if (!cellIsMember(snd(x),freeFuns))
1005 freeFuns = cons(snd(x),freeFuns);
1006 return fst3(snd(x));
1011 if (isNull(n=findName(t))) /* Lookup global name - the only way*/
1012 n = newName(t,currentName); /* this (should be able to happen) */
1013 /* is with new global var introduced*/
1014 /* after type check; e.g. remPat1 */
1018 static Void local pmcLetrec(co,sc,e) /* apply pattern matching compiler */
1019 Int co; /* to LETREC, splitting decls into */
1020 List sc; /* two sections */
1022 List fs = NIL; /* local function definitions */
1023 List vs = NIL; /* local variable definitions */
1026 for (ds=fst(e); nonNull(ds); ds=tl(ds)) { /* Split decls into two */
1027 Cell v = fst(hd(ds));
1028 Int arity = length(fst(hd(snd(hd(ds)))));
1030 if (arity==0) { /* Variable declaration */
1031 vs = cons(snd(hd(ds)),vs);
1032 sc = cons(pair(v,mkOffset(++co)),sc);
1034 else { /* Function declaration */
1035 fs = cons(triple(inventVar(),mkInt(arity),snd(hd(ds))),fs);
1036 sc = cons(pair(v,hd(fs)),sc);
1039 vs = rev(vs); /* Put declaration lists back in */
1040 fs = rev(fs); /* original order */
1041 fst(e) = pair(vs,fs); /* Store declaration lists */
1042 map2Over(pmcVarDef,co,sc,vs); /* Translate variable definitions */
1043 map2Proc(pmcFunDef,co,sc,fs); /* Translate function definitions */
1044 snd(e) = pmcTerm(co,sc,snd(e)); /* Translate LETREC body */
1045 freeFuns = diffList(freeFuns,fs); /* Delete any `freeFuns' bound in fs*/
1048 static Cell local pmcVarDef(co,sc,vd) /* apply pattern matching compiler */
1049 Int co; /* to variable definition */
1051 List vd; { /* vd :: [ ([], rhs) ] */
1052 Cell d = snd(hd(vd));
1053 if (nonNull(tl(vd)) && canFail(d))
1054 return ap(FATBAR,pair(pmcTerm(co,sc,d),
1055 pmcVarDef(co,sc,tl(vd))));
1056 return pmcTerm(co,sc,d);
1059 static Void local pmcFunDef(co,sc,fd) /* apply pattern matching compiler */
1060 Int co; /* to function definition */
1062 Triple fd; { /* fd :: (Var, Arity, [Alt]) */
1063 Offset saveFreeBegin = freeBegin;
1064 List saveFreeVars = freeVars;
1065 List saveFreeFuns = freeFuns;
1066 Int arity = intOf(snd3(fd));
1067 Cell temp = altsMatch(co+1,arity,sc,thd3(fd));
1070 freeBegin = mkOffset(co);
1073 temp = match(co+arity,temp);
1074 thd3(fd) = triple(freeVars,freeFuns,temp);
1076 for (xs=freeVars; nonNull(xs); xs=tl(xs))
1077 if (hd(xs)<=saveFreeBegin && !cellIsMember(hd(xs),saveFreeVars))
1078 saveFreeVars = cons(hd(xs),saveFreeVars);
1080 for (xs=freeFuns; nonNull(xs); xs=tl(xs))
1081 if (!cellIsMember(hd(xs),saveFreeFuns))
1082 saveFreeFuns = cons(hd(xs),saveFreeFuns);
1084 freeBegin = saveFreeBegin;
1085 freeVars = saveFreeVars;
1086 freeFuns = saveFreeFuns;
1089 /* ---------------------------------------------------------------------------
1090 * Main part of pattern matching compiler: convert [Alt] to case constructs
1092 * This section of Hugs has been almost completely rewritten to be more
1093 * general, in particular, to allow pattern matching in orders other than the
1094 * strictly left-to-right approach of the previous version. This is needed
1095 * for the implementation of the so-called Haskell 1.3 `record' syntax.
1097 * At each stage, the different branches for the cases to be considered
1098 * are represented by a list of values of type:
1099 * Match ::= { maPats :: [Pat], patterns to match
1100 * maOffs :: [Offs], offsets of corresponding values
1101 * maSc :: Scope, mapping from vars to offsets
1102 * maRhs :: Rhs } right hand side
1103 * [Implementation uses nested pairs, ((pats,offs),(sc,rhs)).]
1105 * The Scope component has type:
1106 * Scope ::= [(Var,Expr)]
1107 * and provides a mapping from variable names to offsets used in the matching
1110 * Matches can be normalized by reducing them to a form in which the list
1111 * of patterns is empty (in which case the match itself is described as an
1112 * empty match), or in which the list is non-empty and the first pattern is
1113 * one that requires either a CASE or NUMCASE (or EXTCASE) to decompose.
1114 * ------------------------------------------------------------------------*/
1116 #define mkMatch(ps,os,sc,r) pair(pair(ps,os),pair(sc,r))
1117 #define maPats(ma) fst(fst(ma))
1118 #define maOffs(ma) snd(fst(ma))
1119 #define maSc(ma) fst(snd(ma))
1120 #define maRhs(ma) snd(snd(ma))
1121 #define extSc(v,o,ma) maSc(ma) = cons(pair(v,o),maSc(ma))
1123 static List local altsMatch(co,n,sc,as) /* Make a list of matches from list*/
1124 Int co; /* of Alts, with initial offsets */
1125 Int n; /* reverse (take n [co..]) */
1131 us = cons(mkOffset(co++),us);
1132 for (; nonNull(as); as=tl(as)) /* Each Alt is ([Pat], Rhs) */
1133 mas = cons(mkMatch(fst(hd(as)),us,sc,snd(hd(as))),mas);
1137 static Cell local match(co,mas) /* Generate case statement for Matches mas */
1138 Int co; /* at current offset co */
1139 List mas; { /* N.B. Assumes nonNull(mas). */
1140 Cell srhs = NIL; /* Rhs for selected matches */
1141 List smas = mas; /* List of selected matches */
1145 if (emptyMatch(hd(smas))) { /* The case for empty matches: */
1146 while (nonNull(mas) && emptyMatch(hd(mas))) {
1147 List temp = tl(mas);
1152 srhs = joinMas(co,rev(smas));
1154 else { /* Non-empty match */
1155 Int o = offsetOf(hd(maOffs(hd(smas))));
1156 Cell d = maDiscr(hd(smas));
1157 if (isNumDiscr(d)) { /* Numeric match */
1158 Int da = discrArity(d);
1159 Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
1160 while (nonNull(mas) && !emptyMatch(hd(mas))
1161 && o==offsetOf(hd(maOffs(hd(mas))))
1162 && isNumDiscr(d=maDiscr(hd(mas)))
1163 && eqNumDiscr(d,d1)) {
1164 List temp = tl(mas);
1170 map2Proc(advance,co,da,smas);
1171 srhs = ap(NUMCASE,triple(mkOffset(o),d1,match(co+da,smas)));
1174 else if (isExtDiscr(d)) { /* Record match */
1175 Int da = discrArity(d);
1176 Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
1177 while (nonNull(mas) && !emptyMatch(hd(mas))
1178 && o==offsetOf(hd(maOffs(hd(mas))))
1179 && isExtDiscr(d=maDiscr(hd(mas)))
1180 && eqExtDiscr(d,d1)) {
1181 List temp = tl(mas);
1187 map2Proc(advance,co,da,smas);
1188 srhs = ap(EXTCASE,triple(mkOffset(o),d1,match(co+da,smas)));
1191 else { /* Constructor match */
1192 List tab = addConTable(d,hd(smas),NIL);
1194 while (nonNull(mas) && !emptyMatch(hd(mas))
1195 && o==offsetOf(hd(maOffs(hd(mas))))
1196 && !isNumDiscr(d=maDiscr(hd(mas)))) {
1197 tab = addConTable(d,hd(mas),tab);
1200 for (tab=rev(tab); nonNull(tab); tab=tl(tab)) {
1202 smas = snd(hd(tab));
1204 map2Proc(advance,co,da,smas);
1205 srhs = cons(pair(d,match(co+da,smas)),srhs);
1207 srhs = ap(CASE,pair(mkOffset(o),srhs));
1210 return nonNull(mas) ? ap(FATBAR,pair(srhs,match(co,mas))) : srhs;
1213 static Cell local joinMas(co,mas) /* Combine list of matches into rhs*/
1214 Int co; /* using FATBARs as necessary */
1215 List mas; { /* Non-empty list of empty matches */
1217 Cell rhs = pmcTerm(co,maSc(ma),maRhs(ma));
1218 if (nonNull(tl(mas)) && canFail(rhs))
1219 return ap(FATBAR,pair(rhs,joinMas(co,tl(mas))));
1224 static Bool local canFail(rhs) /* Determine if expression (as rhs) */
1225 Cell rhs; { /* might ever be able to fail */
1226 switch (whatIs(rhs)) {
1227 case LETREC : return canFail(snd(snd(rhs)));
1228 case GUARDED : return TRUE; /* could get more sophisticated ..? */
1229 default : return FALSE;
1233 /* type Table a b = [(a, [b])]
1235 * addTable :: a -> b -> Table a b -> Table a b
1236 * addTable x y [] = [(x,[y])]
1237 * addTable x y (z@(n,sws):zs)
1238 * | n == x = (n,sws++[y]):zs
1239 * | otherwise = (n,sws):addTable x y zs
1242 static List local addConTable(x,y,tab) /* add element (x,y) to table */
1246 return singleton(pair(x,singleton(y)));
1247 else if (fst(hd(tab))==x)
1248 snd(hd(tab)) = appendOnto(snd(hd(tab)),singleton(y));
1250 tl(tab) = addConTable(x,y,tl(tab));
1255 static Void local advance(co,a,ma) /* Advance non-empty match by */
1256 Int co; /* processing head pattern */
1257 Int a; /* discriminator arity */
1259 Cell p = hd(maPats(ma));
1260 List ps = tl(maPats(ma));
1261 List us = tl(maOffs(ma));
1262 if (whatIs(p)==CONFLDS) { /* Special case for record syntax */
1263 Name c = fst(snd(p));
1264 List fs = snd(snd(p));
1267 for (; nonNull(fs); fs=tl(fs)) {
1268 vs = cons(mkOffset(co+a+1-sfunPos(fst(hd(fs)),c)),vs);
1269 qs = cons(snd(hd(fs)),qs);
1271 ps = revOnto(qs,ps);
1272 us = revOnto(vs,us);
1274 else /* Normally just spool off patterns*/
1275 for (; a>0; --a) { /* and corresponding offsets ... */
1276 us = cons(mkOffset(++co),us);
1277 ps = cons(arg(p),ps);
1285 /* --------------------------------------------------------------------------
1286 * Normalize and test for empty match:
1287 * ------------------------------------------------------------------------*/
1289 static Bool local emptyMatch(ma)/* Normalize and test to see if a given */
1290 Cell ma; { /* match, ma, is empty. */
1292 while (nonNull(maPats(ma))) {
1294 tidyHd: switch (whatIs(p=hd(maPats(ma)))) {
1295 case LAZYPAT : { Cell nv = inventVar();
1296 maRhs(ma) = ap(LETREC,
1297 pair(remPat(snd(p),nv,NIL),
1301 /* intentional fall-thru */
1304 case DICTVAR : extSc(p,hd(maOffs(ma)),ma);
1305 case WILDCARD : maPats(ma) = tl(maPats(ma));
1306 maOffs(ma) = tl(maOffs(ma));
1309 /* So-called "as-patterns"are really just pattern intersections:
1310 * (p1@p2:ps, o:os, sc, e) ==> (p1:p2:ps, o:o:os, sc, e)
1311 * (But the input grammar probably doesn't let us take
1312 * advantage of this, so we stick with the special case
1313 * when p1 is a variable.)
1315 case ASPAT : extSc(fst(snd(p)),hd(maOffs(ma)),ma);
1316 hd(maPats(ma)) = snd(snd(p));
1319 case FINLIST : hd(maPats(ma)) = mkConsList(snd(p));
1322 case STRCELL : { String s = textToStr(textOf(p));
1323 for (p=NIL; *s!='\0'; ++s) {
1324 if (*s!='\\' || *++s=='\\')
1325 p = ap(consChar(*s),p);
1327 p = ap(consChar('\0'),p);
1329 hd(maPats(ma)) = revOnto(p,nameNil);
1333 case AP : if (isName(fun(p)) && isCfun(fun(p))
1334 && cfunOf(fun(p))==0
1335 && name(fun(p)).defn==nameId) {
1336 hd(maPats(ma)) = arg(p);
1339 /* intentional fall-thru */
1345 default : internal("emptyMatch");
1351 /* --------------------------------------------------------------------------
1353 * ------------------------------------------------------------------------*/
1355 static Cell local maDiscr(ma) /* Get the discriminator for a non-empty */
1356 Cell ma; { /* match, ma. */
1357 Cell p = hd(maPats(ma));
1358 Cell h = getHead(p);
1359 switch (whatIs(h)) {
1360 case CONFLDS : return fst(snd(p));
1361 case ADDPAT : arg(fun(p)) = translate(arg(fun(p)));
1364 case EXT : h = fun(fun(p));
1365 arg(h) = translate(arg(h));
1368 case NAME : if (h==nameFromInt || h==nameFromInteger
1369 || h==nameFromDouble) {
1371 arg(fun(p)) = translate(arg(fun(p)));
1378 static Bool local isNumDiscr(d) /* TRUE => numeric discriminator */
1380 switch (whatIs(d)) {
1383 case CHARCELL : return FALSE;
1386 case AP : return !isExt(fun(d));
1388 case AP : return TRUE; /* must be a literal or (n+k) */
1391 internal("isNumDiscr");
1392 return 0;/*NOTREACHED*/
1395 Int discrArity(d) /* Find arity of discriminator */
1397 switch (whatIs(d)) {
1398 case NAME : return name(d).arity;
1399 case TUPLE : return tupleOf(d);
1400 case CHARCELL : return 0;
1402 case AP : switch (whatIs(fun(d))) {
1403 case ADDPAT : return 1;
1404 case EXT : return 2;
1408 case AP : return (whatIs(fun(d))==ADDPAT) ? 1 : 0;
1411 internal("discrArity");
1412 return 0;/*NOTREACHED*/
1415 static Bool local eqNumDiscr(d1,d2) /* Determine whether two numeric */
1416 Cell d1, d2; { /* descriptors have same value */
1417 if (whatIs(fun(d1))==ADDPAT)
1418 return whatIs(fun(d2))==ADDPAT && snd(fun(d1))==snd(fun(d2));
1420 return isInt(arg(d2)) && intOf(arg(d1))==intOf(arg(d2));
1421 if (isFloat(arg(d1)))
1422 return isFloat(arg(d2)) && floatOf(arg(d1))==floatOf(arg(d2));
1423 internal("eqNumDiscr");
1424 return FALSE;/*NOTREACHED*/
1428 static Bool local isExtDiscr(d) /* Test of extension discriminator */
1430 return isAp(d) && isExt(fun(d));
1433 static Bool local eqExtDiscr(d1,d2) /* Determine whether two extension */
1434 Cell d1, d2; { /* discriminators have same label */
1435 return fun(d1)==fun(d2);
1439 /*-------------------------------------------------------------------------*/
1443 /* --------------------------------------------------------------------------
1445 * ------------------------------------------------------------------------*/
1447 static Void local stgCGBinds( List );
1449 static Void local stgCGBinds(binds)
1454 /* --------------------------------------------------------------------------
1455 * Main entry points to compiler:
1456 * ------------------------------------------------------------------------*/
1458 static List addGlobals( List binds )
1460 /* stgGlobals = list of top-level STG binds */
1461 for(;nonNull(stgGlobals);stgGlobals=tl(stgGlobals)) {
1462 StgVar bind = snd(hd(stgGlobals));
1463 if (nonNull(stgVarBody(bind))) {
1464 binds = cons(bind,binds);
1471 Void evalExp ( void ) { /* compile and run input expression */
1472 /* ToDo: this name (and other names generated during pattern match?)
1473 * get inserted in the symbol table but never get removed.
1475 Name n = newName(inventText(),NIL);
1477 StgVar v = mkStgVar(NIL,NIL);
1480 e = pmcTerm(0,NIL,translate(inputExpr));
1483 stgCGBinds(addGlobals(singleton(v)));
1485 /* Run thread (and any other runnable threads) */
1487 /* Re-initialise the scheduler - ToDo: do I need this? */
1488 /* JRS, 991118: on SM's advice, don't call initScheduler every time.
1489 This causes an assertion failure in GC.c(revert_dead_cafs)
1490 unless doRevertCAFs below is permanently TRUE.
1492 /* initScheduler(); */
1494 /* Further comments, JRS 000411.
1495 When control returns to Hugs, you have to be pretty careful about
1496 the state of the heap. In particular, hugs.c may subsequently call
1497 nukeModule() in storage.c, which removes modules from the system.
1498 If a module defines a particular data constructor, the relevant
1499 info table is also free()d. That gives a problem if there are
1500 still closures hanging round in the heap with references to that
1503 The solution is to firstly to revert CAFs, and then force a major
1504 collection in between transitions from the mutation, ie actually
1505 running Haskell, and nukeModule. Since major GCs are potentially
1506 expensive, we don't want to do one at every call to nukeModule,
1507 so the flag nukeModule_needs_major_gc is used to signal when one
1510 This all also seems to imply that doRevertCAFs should always
1514 # ifdef CRUDE_PROFILING
1519 HaskellObj result; /* ignored */
1520 SchedulerStatus status;
1521 Bool doRevertCAFs = TRUE; /* do not change -- comment above */
1522 HugsBreakAction brkOld = setBreakAction ( HugsRtsInterrupt );
1523 nukeModule_needs_major_gc = TRUE;
1524 status = rts_eval_(closureOfVar(v),10000,&result);
1525 setBreakAction ( brkOld );
1530 printf("{Deadlock or Blackhole}");
1533 printf("{Interrupted}");
1536 printf("{Interrupted or Killed}");
1541 internal("evalExp: Unrecognised SchedulerStatus");
1544 /* Begin heap cleanup sequence */
1546 /* fprintf ( stderr, "finalisation loop START\n" ); */
1548 finalizeWeakPointersNow();
1549 /* fprintf ( stderr, "finalisation loop END %d\n",
1550 howManyThreadsAvail() ); */
1552 while (howManyThreadsAvail() > 0);
1556 if (combined && SPT_size != 0) {
1558 "hugs: fatal: stable pointers are not yet allowed in combined mode" );
1559 internal("evalExp");
1561 /* End heap cleanup sequence */
1566 # ifdef CRUDE_PROFILING
1573 static List local addStgVar( List binds, Pair bind )
1575 StgVar nv = mkStgVar(NIL,NIL);
1576 Text t = textOf(fst(bind));
1577 Name n = findName(t);
1579 if (isNull(n)) { /* Lookup global name - the only way*/
1580 n = newName(t,NIL); /* this (should be able to happen) */
1581 } /* is with new global var introduced*/
1582 /* after type check; e.g. remPat1 */
1583 name(n).stgVar = nv;
1584 return cons(nv,binds);
1588 Void compileDefns() { /* compile script definitions */
1589 Target t = length(valDefns) + length(genDefns) + length(selDefns);
1596 for(vs=genDefns; nonNull(vs); vs=tl(vs)) {
1598 StgVar nv = mkStgVar(NIL,NIL);
1600 name(n).stgVar = nv;
1601 binds = cons(nv,binds);
1603 for(vss=selDefns; nonNull(vss); vss=tl(vss)) {
1604 for(vs=hd(vss); nonNull(vs); vs=tl(vs)) {
1607 StgVar nv = mkStgVar(NIL,NIL);
1609 name(n).stgVar = nv;
1610 binds = cons(nv,binds);
1615 setGoal("Translating",t);
1616 /* do valDefns before everything else so that all stgVar's get added. */
1617 for (; nonNull(valDefns); valDefns=tl(valDefns)) {
1618 hd(valDefns) = transBinds(hd(valDefns));
1619 mapAccum(addStgVar,binds,hd(valDefns));
1620 mapProc(compileGlobalFunction,hd(valDefns));
1623 for (; nonNull(genDefns); genDefns=tl(genDefns)) {
1624 compileGenFunction(hd(genDefns));
1627 for (; nonNull(selDefns); selDefns=tl(selDefns)) {
1628 mapOver(compileSelFunction,hd(selDefns));
1632 binds = addGlobals(binds);
1634 setGoal("Generating code",t);
1640 static Void local compileGlobalFunction(bind)
1642 Name n = findName(textOf(fst(bind)));
1643 List defs = snd(bind);
1644 Int arity = length(fst(hd(defs)));
1647 stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1650 static Void local compileGenFunction(n) /* Produce code for internally */
1651 Name n; { /* generated function */
1652 List defs = name(n).defn;
1653 Int arity = length(fst(hd(defs)));
1655 printf ( "compGenFn: " );print(defs,100);printf("\n");
1659 mapProc(transAlt,defs);
1660 stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1664 static Name local compileSelFunction(p) /* Produce code for selector func */
1665 Pair p; { /* Should be merged with genDefns, */
1666 Name s = fst(p); /* but the name(_).defn field is */
1667 List defs = snd(p); /* already used for other purposes */
1668 Int arity = length(fst(hd(defs))); /* in selector functions. */
1671 mapProc(transAlt,defs);
1672 stgDefn(s,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1677 /* --------------------------------------------------------------------------
1679 * ------------------------------------------------------------------------*/
1685 case RESET : freeVars = NIL;
1688 freeBegin = mkOffset(0);
1691 case MARK : mark(freeVars);
1695 case POSTPREL: break;
1699 /*-------------------------------------------------------------------------*/