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/05/10 09:00:20 $
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 */
27 #include "Weak.h" /* for finalizeWeakPointersNow */
29 /* --------------------------------------------------------------------------
30 * Local function prototypes:
31 * ------------------------------------------------------------------------*/
33 static Cell local translate ( Cell );
34 static Void local transPair ( Pair );
35 static Void local transTriple ( Triple );
36 static Void local transAlt ( Cell );
37 static Void local transCase ( Cell );
38 static List local transBinds ( List );
39 static Cell local transRhs ( Cell );
40 static Cell local mkConsList ( List );
41 static Cell local expandLetrec ( Cell );
42 static Cell local transComp ( Cell,List,Cell );
43 static Cell local transDo ( Cell,Cell,List );
44 static Cell local transConFlds ( Cell,List );
45 static Cell local transUpdFlds ( Cell,List,List );
47 static Cell local refutePat ( Cell );
48 static Cell local refutePatAp ( Cell );
49 static Cell local matchPat ( Cell );
50 static List local remPat ( Cell,Cell,List );
51 static List local remPat1 ( Cell,Cell,List );
53 static Cell local pmcTerm ( Int,List,Cell );
54 static Cell local pmcPair ( Int,List,Pair );
55 static Cell local pmcTriple ( Int,List,Triple );
56 static Cell local pmcVar ( List,Text );
57 static Void local pmcLetrec ( Int,List,Pair );
58 static Cell local pmcVarDef ( Int,List,List );
59 static Void local pmcFunDef ( Int,List,Triple );
60 static List local altsMatch ( Int,Int,List,List );
61 static Cell local match ( Int,List );
62 static Cell local joinMas ( Int,List );
63 static Bool local canFail ( Cell );
64 static List local addConTable ( Cell,Cell,List );
65 static Void local advance ( Int,Int,Cell );
66 static Bool local emptyMatch ( Cell );
67 static Cell local maDiscr ( Cell );
68 static Bool local isNumDiscr ( Cell );
69 static Bool local eqNumDiscr ( Cell,Cell );
71 static Bool local isExtDiscr ( Cell );
72 static Bool local eqExtDiscr ( Cell,Cell );
75 static Void local compileGlobalFunction ( Pair );
76 static Void local compileGenFunction ( Name );
77 static Name local compileSelFunction ( Pair );
78 static List local addStgVar ( List,Pair );
80 static Name currentName; /* Top level name being processed */
81 static Int lineNumber = 0; /* previously discarded line number */
83 /* --------------------------------------------------------------------------
84 * Translation: Convert input expressions into a less complex language
85 * of terms using only LETREC, AP, constants and vars.
86 * Also remove pattern definitions on lhs of eqns.
87 * ------------------------------------------------------------------------*/
89 static Cell local translate(e) /* Translate expression: */
92 printf ( "translate: " );print(e,100);printf("\n");
95 case LETREC : snd(snd(e)) = translate(snd(snd(e)));
96 return expandLetrec(e);
98 case COND : transTriple(snd(e));
101 case AP : fst(e) = translate(fst(e));
103 /* T [id <exp>] ==> T[<exp>]
104 * T [indirect <exp> ] ==> T[<exp>]
106 if (fst(e)==nameId || fst(e)==nameInd)
107 return translate(snd(e));
108 if (isName(fst(e)) &&
111 return translate(snd(e));
113 snd(e) = translate(snd(e));
119 /* T [otherwise] ==> True
122 if (e==nameOtherwise)
124 /* T [assert] ==> T[assertError "<location info>"]
126 if (flagAssert && e==nameAssert) {
127 Cell str = errAssert(lineNumber);
128 return (ap(nameAssertError,str));
132 if (isName(name(e).defn))
134 if (isPair(name(e).defn))
135 return snd(name(e).defn);
140 case RECSEL : return nameRecSel;
152 case CHARCELL : return e;
154 case IPVAR : return nameId;
156 case FINLIST : mapOver(translate,snd(e));
157 return mkConsList(snd(e));
159 case DOCOMP : { Cell m = translate(fst(snd(e)));
160 Cell r = translate(fst(snd(snd(e))));
161 return transDo(m,r,snd(snd(snd(e))));
164 case MONADCOMP : { Cell m = translate(fst(snd(e)));
165 Cell r = translate(fst(snd(snd(e))));
166 Cell qs = snd(snd(snd(e)));
167 if (m == nameListMonad)
168 return transComp(r,qs,nameNil);
171 r = ap(ap(nameReturn,m),r);
172 return transDo(m,r,qs);
174 internal("translate: monad comps");
179 case CONFLDS : return transConFlds(fst(snd(e)),snd(snd(e)));
181 case UPDFLDS : return transUpdFlds(fst3(snd(e)),
185 case CASE : { Cell nv = inventVar();
186 mapProc(transCase,snd(snd(e)));
188 pair(singleton(pair(nv,snd(snd(e)))),
189 ap(nv,translate(fst(snd(e))))));
192 case LAMBDA : { Cell nv = inventVar();
201 default : fprintf(stderr, "stuff=%d\n",whatIs(e));
202 internal("translate");
207 static Void local transPair(pr) /* Translate each component in a */
208 Pair pr; { /* pair of expressions. */
209 fst(pr) = translate(fst(pr));
210 snd(pr) = translate(snd(pr));
213 static Void local transTriple(tr) /* Translate each component in a */
214 Triple tr; { /* triple of expressions. */
215 fst3(tr) = translate(fst3(tr));
216 snd3(tr) = translate(snd3(tr));
217 thd3(tr) = translate(thd3(tr));
220 static Void local transAlt(e) /* Translate alt: */
221 Cell e; { /* ([Pat], Rhs) ==> ([Pat], Rhs') */
223 printf ( "transAlt: " );print(snd(e),100);printf("\n");
225 snd(e) = transRhs(snd(e));
228 static Void local transCase(c) /* Translate case: */
229 Cell c; { /* (Pat, Rhs) ==> ([Pat], Rhs') */
230 fst(c) = singleton(fst(c));
231 snd(c) = transRhs(snd(c));
234 static List local transBinds(bs) /* Translate list of bindings: */
235 List bs; { /* eliminating pattern matching on */
236 List newBinds = NIL; /* lhs of bindings. */
237 for (; nonNull(bs); bs=tl(bs)) {
239 Cell v = fst(hd(bs));
240 while (isAp(v) && fst(v) == nameInd)
245 if (isVar(fst(hd(bs)))) {
247 mapProc(transAlt,snd(hd(bs)));
248 newBinds = cons(hd(bs),newBinds);
251 newBinds = remPat(fst(snd(hd(bs))),
252 snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))),
258 static Cell local transRhs(rhs) /* Translate rhs: removing line nos */
260 switch (whatIs(rhs)) {
261 case LETREC : snd(snd(rhs)) = transRhs(snd(snd(rhs)));
262 return expandLetrec(rhs);
264 case GUARDED : mapOver(snd,snd(rhs)); /* discard line number */
265 mapProc(transPair,snd(rhs));
270 Int prev = lineNumber;
271 lineNumber = intOf(fst(rhs));
272 tmp = translate(snd(rhs)); /* discard line number */
279 static Cell local mkConsList(es) /* Construct expression for list es */
280 List es; { /* using nameNil and nameCons */
284 return ap(ap(nameCons,hd(es)),mkConsList(tl(es)));
287 static Cell local expandLetrec(root) /* translate LETREC with list of */
288 Cell root; { /* groups of bindings (from depend. */
289 Cell e = snd(snd(root)); /* analysis) to use nested LETRECs */
290 List bss = fst(snd(root));
293 if (isNull(bss)) /* should never happen, but just in */
294 return e; /* case: LETREC [] IN e ==> e */
296 mapOver(transBinds,bss); /* translate each group of bindings */
298 for (temp=root; nonNull(tl(bss)); bss=tl(bss)) {
299 fst(snd(temp)) = hd(bss);
300 snd(snd(temp)) = ap(LETREC,pair(NIL,e));
301 temp = snd(snd(temp));
303 fst(snd(temp)) = hd(bss);
308 /* --------------------------------------------------------------------------
309 * Translation of list comprehensions is based on the description in
310 * `The Implementation of Functional Programming Languages':
312 * [ e | qs ] ++ l => transComp e qs l
313 * transComp e [] l => e : l
314 * transComp e ((p<-xs):qs) l => LETREC _h [] = l
315 * _h (p:_xs) = transComp e qs (_h _xs)
316 * _h (_:_xs) = _h _xs --if p !failFree
318 * transComp e (b:qs) l => if b then transComp e qs l else l
319 * transComp e (decls:qs) l => LETREC decls IN transComp e qs l
320 * ------------------------------------------------------------------------*/
322 static Cell local transComp(e,qs,l) /* Translate [e | qs] ++ l */
331 case FROMQUAL : { Cell ld = NIL;
332 Cell hVar = inventVar();
333 Cell xsVar = inventVar();
335 if (!failFree(fst(snd(q))))
336 ld = cons(pair(singleton(
343 ld = cons(pair(singleton(
351 ld = cons(pair(singleton(nameNil),
356 pair(singleton(pair(hVar,
359 translate(snd(snd(q))))));
363 expandLetrec(ap(LETREC,
365 transComp(e,qs1,l))));
367 case BOOLQUAL : return ap(COND,
368 triple(translate(snd(q)),
374 return ap(ap(nameCons,e),l);
377 /* --------------------------------------------------------------------------
378 * Translation of monad comprehensions written using do-notation:
381 * do { p <- exp; qs } => LETREC _h p = do { qs }
382 * _h _ = fail m "match fails"
384 * do { LET decls; qs } => LETREC decls IN do { qs }
385 * do { IF guard; qs } => if guard then do { qs } else fail m "guard fails"
386 * do { e; qs } => LETREC _h _ = [ e | qs ] in bind m exp _h
389 * ------------------------------------------------------------------------*/
391 static Cell local transDo(m,e,qs) /* Translate do { qs ; e } */
400 case FROMQUAL : { Cell ld = NIL;
401 Cell hVar = inventVar();
403 if (!failFree(fst(snd(q)))) {
404 Cell str = mkStr(findText("match fails"));
405 ld = cons(pair(singleton(WILDCARD),
406 ap2(nameMFail,m,str)),
410 ld = cons(pair(singleton(fst(snd(q))),
415 pair(singleton(pair(hVar,ld)),
418 translate(snd(snd(q)))),
422 case DOQUAL : { Cell hVar = inventVar();
423 Cell ld = cons(pair(singleton(WILDCARD),
427 pair(singleton(pair(hVar,ld)),
435 expandLetrec(ap(LETREC,
439 case BOOLQUAL : return
441 triple(translate(snd(q)),
444 mkStr(findText("guard fails")))));
450 /* --------------------------------------------------------------------------
451 * Translation of named field construction and update:
453 * Construction is implemented using the following transformation:
455 * C{x1=e1, ..., xn=en} = C v1 ... vm
457 * vi = e1, if the ith component of C is labelled with x1
459 * = en, if the ith component of C is labelled with xn
460 * = undefined, otherwise
462 * Update is implemented using the following transformation:
464 * e{x1=e1, ..., xn=en}
465 * = let nv (C a1 ... am) v1 ... vn = C a1' .. am'
466 * nv (D b1 ... bk) v1 ... vn = D b1' .. bk
468 * nv _ v1 ... vn = error "failed update"
471 * nv, v1, ..., vn, a1, ..., am, b1, ..., bk, ... are new variables,
472 * C,D,... = { K | K is a constr fun s.t. {x1,...,xn} subset of sels(K)}
474 * ai' = v1, if the ith component of C is labelled with x1
476 * = vn, if the ith component of C is labelled with xn
480 * The error case may be omitted if C,D,... is an enumeration of all of the
481 * constructors for the datatype concerned. Strictly speaking, error case
482 * isn't needed at all -- the only benefit of including it is that the user
483 * will get a "failed update" message rather than a cryptic {v354 ...}.
484 * So, for now, we'll go with the second option!
486 * For the time being, code for each update operation is generated
487 * independently of any other updates. However, if updates are used
488 * frequently, then we might want to consider changing the implementation
489 * at a later stage to cache definitions of functions like nv above. This
490 * would create a shared library of update functions, indexed by a set of
491 * constructors {C,D,...}.
492 * ------------------------------------------------------------------------*/
494 static Cell local transConFlds(c,flds) /* Translate C{flds} */
498 Int m = name(c).arity;
501 e = ap(e,nameUndefined);
502 for (; nonNull(flds); flds=tl(flds)) {
504 for (i=m-sfunPos(fst(hd(flds)),c); i>0; i--)
506 arg(a) = translate(snd(hd(flds)));
511 static Cell local transUpdFlds(e,cs,flds)/* Translate e{flds} */
512 Cell e; /* (cs is corresp list of constrs) */
515 Cell nv = inventVar();
516 Cell body = ap(nv,translate(e));
521 for (; nonNull(fs); fs=tl(fs)) { /* body = nv e1 ... en */
522 Cell b = hd(fs); /* args = [v1, ..., vn] */
523 body = ap(body,translate(snd(b)));
524 args = cons(inventVar(),args);
527 for (; nonNull(cs); cs=tl(cs)) { /* Loop through constructors to */
528 Cell c = hd(cs); /* build up list of alts. */
532 Int m = name(c).arity;
535 for (i=m; i>0; i--) { /* pat = C a1 ... am */
536 Cell a = inventVar(); /* rhs = C a1 ... am */
541 for (fs=flds; nonNull(fs); fs=tl(fs), as=tl(as)) {
542 Name s = fst(hd(fs)); /* Replace approp ai in rhs with */
543 Cell r = rhs; /* vars from [v1,...,vn] */
544 for (i=m-sfunPos(s,c); i>0; i--)
549 alts = cons(pair(cons(pat,args),rhs),alts);
551 return ap(LETREC,pair(singleton(pair(nv,alts)),body));
554 /* --------------------------------------------------------------------------
555 * Elimination of pattern bindings:
557 * The following code adopts the definition of failure free patterns as given
558 * in the Haskell 1.3 report; the term "irrefutable" is also used there for
559 * a subset of the failure free patterns described here, but has no useful
560 * role in this implementation. Basically speaking, the failure free patterns
561 * are: variable, wildcard, ~apat
562 * var@apat, if apat is failure free
563 * C apat1 ... apatn if C is a product constructor
564 * (i.e. an only constructor) and
565 * apat1,...,apatn are failure free
566 * Note that the last case automatically covers the case where C comes from
567 * a newtype construction.
568 * ------------------------------------------------------------------------*/
570 Bool failFree(pat) /* is pattern failure free? (do we need */
571 Cell pat; { /* a conformality check?) */
572 Cell c = getHead(pat);
575 case ASPAT : return failFree(snd(snd(pat)));
577 case NAME : if (!isCfun(c) || cfunOf(c)!=0)
579 /*intentional fall-thru*/
580 case TUPLE : for (; isAp(pat); pat=fun(pat))
581 if (!failFree(arg(pat)))
583 /*intentional fall-thru*/
588 case WILDCARD : return TRUE;
591 case EXT : return failFree(extField(pat)) &&
592 failFree(extRow(pat));
595 case CONFLDS : if (cfunOf(fst(snd(c)))==0) {
596 List fs = snd(snd(c));
597 for (; nonNull(fs); fs=tl(fs))
598 if (!failFree(snd(hd(fs))))
602 /*intentional fall-thru*/
603 default : return FALSE;
607 static Cell local refutePat(pat) /* find pattern to refute in conformality*/
608 Cell pat; { /* test with pat. */
609 /* e.g. refPat (x:y) == (_:_) */
610 /* refPat ~(x:y) == _ etc.. */
612 switch (whatIs(pat)) {
613 case ASPAT : return refutePat(snd(snd(pat)));
615 case FINLIST : { Cell ys = snd(pat);
617 for (; nonNull(ys); ys=tl(ys))
618 xs = ap(ap(nameCons,refutePat(hd(ys))),xs);
619 return revOnto(xs,nameNil);
622 case CONFLDS : { Cell ps = NIL;
623 Cell fs = snd(snd(pat));
624 for (; nonNull(fs); fs=tl(fs)) {
625 Cell p = refutePat(snd(hd(fs)));
626 ps = cons(pair(fst(hd(fs)),p),ps);
628 return pair(CONFLDS,pair(fst(snd(pat)),rev(ps)));
635 case LAZYPAT : return WILDCARD;
641 case NAME : return pat;
643 case AP : return refutePatAp(pat);
645 default : internal("refutePat");
646 return NIL; /*NOTREACHED*/
650 static Cell local refutePatAp(p) /* find pattern to refute in conformality*/
653 if (h==nameFromInt || h==nameFromInteger || h==nameFromDouble)
655 else if (whatIs(h)==ADDPAT)
656 return ap(fun(p),refutePat(arg(p)));
659 Cell pf = refutePat(extField(p));
660 Cell pr = refutePat(extRow(p));
661 return ap(ap(fun(fun(p)),pf),pr);
665 List as = getArgs(p);
666 mapOver(refutePat,as);
667 return applyToArgs(h,as);
671 static Cell local matchPat(pat) /* find pattern to match against */
672 Cell pat; { /* replaces parts of pattern that do not */
673 /* include variables with wildcards */
674 switch (whatIs(pat)) {
675 case ASPAT : { Cell p = matchPat(snd(snd(pat)));
676 return (p==WILDCARD) ? fst(snd(pat))
678 pair(fst(snd(pat)),p));
681 case FINLIST : { Cell ys = snd(pat);
683 for (; nonNull(ys); ys=tl(ys))
684 xs = cons(matchPat(hd(ys)),xs);
685 while (nonNull(xs) && hd(xs)==WILDCARD)
687 for (ys=nameNil; nonNull(xs); xs=tl(xs))
688 ys = ap(ap(nameCons,hd(xs)),ys);
692 case CONFLDS : { Cell ps = NIL;
693 Name c = fst(snd(pat));
694 Cell fs = snd(snd(pat));
696 for (; nonNull(fs); fs=tl(fs)) {
697 Cell p = matchPat(snd(hd(fs)));
698 ps = cons(pair(fst(hd(fs)),p),ps);
702 return avar ? pair(CONFLDS,pair(c,rev(ps)))
708 case DICTVAR : return pat;
710 case LAZYPAT : { Cell p = matchPat(snd(pat));
711 return (p==WILDCARD) ? WILDCARD : ap(LAZYPAT,p);
716 case CHARCELL : return WILDCARD;
720 case AP : { Cell h = getHead(pat);
721 if (h==nameFromInt ||
722 h==nameFromInteger || h==nameFromDouble)
724 else if (whatIs(h)==ADDPAT)
728 Cell pf = matchPat(extField(pat));
729 Cell pr = matchPat(extRow(pat));
730 return (pf==WILDCARD && pr==WILDCARD)
732 : ap(ap(fun(fun(pat)),pf),pr);
738 for (; isAp(pat); pat=fun(pat)) {
739 Cell p = matchPat(arg(pat));
744 return avar ? applyToArgs(pat,args)
749 default : internal("matchPat");
750 return NIL; /*NOTREACHED*/
754 #define addEqn(v,val,lds) cons(pair(v,singleton(pair(NIL,val))),lds)
756 static List local remPat(pat,expr,lds)
757 Cell pat; /* Produce list of definitions for eqn */
758 Cell expr; /* pat = expr, including a conformality */
759 List lds; { /* check if required. */
761 /* Conformality test (if required):
762 * pat = expr ==> nv = LETREC confCheck nv@pat = nv
764 * remPat1(pat,nv,.....);
767 if (!failFree(pat)) {
768 Cell confVar = inventVar();
769 Cell nv = inventVar();
770 Cell locfun = pair(confVar, /* confVar [([nv@refPat],nv)] */
771 singleton(pair(singleton(ap(ASPAT,
776 if (whatIs(expr)==GUARDED) { /* A spanner ... special case */
777 lds = addEqn(nv,expr,lds); /* for guarded pattern binding*/
782 if (whatIs(pat)==ASPAT) { /* avoid using new variable if*/
783 nv = fst(snd(pat)); /* a variable is already given*/
784 pat = snd(snd(pat)); /* by an as-pattern */
787 lds = addEqn(nv, /* nv = */
788 ap(LETREC,pair(singleton(locfun), /* LETREC [locfun] */
789 ap(confVar,expr))), /* IN confVar expr */
792 return remPat1(matchPat(pat),nv,lds);
795 return remPat1(matchPat(pat),expr,lds);
798 static List local remPat1(pat,expr,lds)
799 Cell pat; /* Add definitions for: pat = expr to */
800 Cell expr; /* list of local definitions in lds. */
802 Cell c = getHead(pat);
807 case CHARCELL : break;
809 case ASPAT : return remPat1(snd(snd(pat)), /* v@pat = expr */
811 addEqn(fst(snd(pat)),expr,lds));
813 case LAZYPAT : { Cell nv;
815 if (isVar(expr) || isName(expr))
819 lds = addEqn(nv,expr,lds);
822 return remPat(snd(pat),nv,lds);
825 case ADDPAT : return remPat1(arg(pat), /* n + k = expr */
828 mkInt(snd(fun(fun(pat))))),
832 case FINLIST : return remPat1(mkConsList(snd(pat)),expr,lds);
834 case CONFLDS : { Name h = fst(snd(pat));
835 Int m = name(h).arity;
837 List fs = snd(snd(pat));
841 for (; nonNull(fs); fs=tl(fs)) {
843 for (i=m-sfunPos(fst(hd(fs)),h); i>0; i--)
845 arg(r) = snd(hd(fs));
847 return remPat1(p,expr,lds);
850 case DICTVAR : /* shouldn't really occur */
851 //assert(0); /* so let's test for it then! ADR */
853 case VAROPCELL : return addEqn(pat,expr,lds);
855 case NAME : if (c==nameFromInt || c==nameFromInteger
856 || c==nameFromDouble) {
858 arg(fun(pat)) = translate(arg(fun(pat)));
862 if (argCount==1 && isCfun(c) /* for newtype */
863 && cfunOf(c)==0 && name(c).defn==nameId)
864 return remPat1(arg(pat),expr,lds);
866 /* intentional fall-thru */
867 case TUPLE : { List ps = getArgs(pat);
869 /* get rid of leading dictionaries in args */
870 if (isName(c) && isCfun(c)) {
871 Int i = numQualifiers(name(c).type);
872 for (; i > 0; i--) ps = tl(ps);
878 if (isVar(expr) || isName(expr))
882 lds = addEqn(nv,expr,lds);
885 sel = ap(ap(nameSel,c),nv);
886 for (i=1; nonNull(ps); ++i, ps=tl(ps))
887 lds = remPat1(hd(ps),
895 case EXT : { Cell nv = inventVar();
897 = translate(arg(fun(fun(pat))));
903 lds = remPat1(extField(pat),ap(nameFst,nv),lds);
904 lds = remPat1(extRow(pat),ap(nameSnd,nv),lds);
909 default : internal("remPat1");
915 /* --------------------------------------------------------------------------
916 * Eliminate pattern matching in function definitions -- pattern matching
919 * The original Gofer/Hugs pattern matching compiler was based on Wadler's
920 * algorithms described in `Implementation of functional programming
921 * languages'. That should still provide a good starting point for anyone
922 * wanting to understand this part of the system. However, the original
923 * algorithm has been generalized and restructured in order to implement
924 * new features added in Haskell 1.3.
926 * During the translation, in preparation for later stages of compilation,
927 * all local and bound variables are replaced by suitable offsets, and
928 * locally defined function symbols are given new names (which will
929 * eventually be their names when lifted to make top level definitions).
930 * ------------------------------------------------------------------------*/
932 static Offset freeBegin; /* only variables with offset <= freeBegin are of */
933 static List freeVars; /* interest as `free' variables */
934 static List freeFuns; /* List of `free' local functions */
936 static Cell local pmcTerm(co,sc,e) /* apply pattern matching compiler */
937 Int co; /* co = current offset */
938 List sc; /* sc = scope */
939 Cell e; { /* e = expr to transform */
941 case GUARDED : map2Over(pmcPair,co,sc,snd(e));
944 case LETREC : pmcLetrec(co,sc,snd(e));
949 case DICTVAR : return pmcVar(sc,textOf(e));
951 case COND : return ap(COND,pmcTriple(co,sc,snd(e)));
953 case AP : return pmcPair(co,sc,e);
965 case STRCELL : break;
967 default : internal("pmcTerm");
973 static Cell local pmcPair(co,sc,pr) /* apply pattern matching compiler */
974 Int co; /* to a pair of exprs */
977 return pair(pmcTerm(co,sc,fst(pr)),
978 pmcTerm(co,sc,snd(pr)));
981 static Cell local pmcTriple(co,sc,tr) /* apply pattern matching compiler */
982 Int co; /* to a triple of exprs */
985 return triple(pmcTerm(co,sc,fst3(tr)),
986 pmcTerm(co,sc,snd3(tr)),
987 pmcTerm(co,sc,thd3(tr)));
990 static Cell local pmcVar(sc,t) /* find translation of variable */
991 List sc; /* in current scope */
996 for (xs=sc; nonNull(xs); xs=tl(xs)) {
998 if (t==textOf(fst(x))) {
999 if (isOffset(snd(x))) { /* local variable ... */
1000 if (snd(x)<=freeBegin && !cellIsMember(snd(x),freeVars))
1001 freeVars = cons(snd(x),freeVars);
1004 else { /* local function ... */
1005 if (!cellIsMember(snd(x),freeFuns))
1006 freeFuns = cons(snd(x),freeFuns);
1007 return fst3(snd(x));
1012 if (isNull(n=findName(t))) /* Lookup global name - the only way*/
1013 n = newName(t,currentName); /* this (should be able to happen) */
1014 /* is with new global var introduced*/
1015 /* after type check; e.g. remPat1 */
1019 static Void local pmcLetrec(co,sc,e) /* apply pattern matching compiler */
1020 Int co; /* to LETREC, splitting decls into */
1021 List sc; /* two sections */
1023 List fs = NIL; /* local function definitions */
1024 List vs = NIL; /* local variable definitions */
1027 for (ds=fst(e); nonNull(ds); ds=tl(ds)) { /* Split decls into two */
1028 Cell v = fst(hd(ds));
1029 Int arity = length(fst(hd(snd(hd(ds)))));
1031 if (arity==0) { /* Variable declaration */
1032 vs = cons(snd(hd(ds)),vs);
1033 sc = cons(pair(v,mkOffset(++co)),sc);
1035 else { /* Function declaration */
1036 fs = cons(triple(inventVar(),mkInt(arity),snd(hd(ds))),fs);
1037 sc = cons(pair(v,hd(fs)),sc);
1040 vs = rev(vs); /* Put declaration lists back in */
1041 fs = rev(fs); /* original order */
1042 fst(e) = pair(vs,fs); /* Store declaration lists */
1043 map2Over(pmcVarDef,co,sc,vs); /* Translate variable definitions */
1044 map2Proc(pmcFunDef,co,sc,fs); /* Translate function definitions */
1045 snd(e) = pmcTerm(co,sc,snd(e)); /* Translate LETREC body */
1046 freeFuns = diffList(freeFuns,fs); /* Delete any `freeFuns' bound in fs*/
1049 static Cell local pmcVarDef(co,sc,vd) /* apply pattern matching compiler */
1050 Int co; /* to variable definition */
1052 List vd; { /* vd :: [ ([], rhs) ] */
1053 Cell d = snd(hd(vd));
1054 if (nonNull(tl(vd)) && canFail(d))
1055 return ap(FATBAR,pair(pmcTerm(co,sc,d),
1056 pmcVarDef(co,sc,tl(vd))));
1057 return pmcTerm(co,sc,d);
1060 static Void local pmcFunDef(co,sc,fd) /* apply pattern matching compiler */
1061 Int co; /* to function definition */
1063 Triple fd; { /* fd :: (Var, Arity, [Alt]) */
1064 Offset saveFreeBegin = freeBegin;
1065 List saveFreeVars = freeVars;
1066 List saveFreeFuns = freeFuns;
1067 Int arity = intOf(snd3(fd));
1068 Cell temp = altsMatch(co+1,arity,sc,thd3(fd));
1071 freeBegin = mkOffset(co);
1074 temp = match(co+arity,temp);
1075 thd3(fd) = triple(freeVars,freeFuns,temp);
1077 for (xs=freeVars; nonNull(xs); xs=tl(xs))
1078 if (hd(xs)<=saveFreeBegin && !cellIsMember(hd(xs),saveFreeVars))
1079 saveFreeVars = cons(hd(xs),saveFreeVars);
1081 for (xs=freeFuns; nonNull(xs); xs=tl(xs))
1082 if (!cellIsMember(hd(xs),saveFreeFuns))
1083 saveFreeFuns = cons(hd(xs),saveFreeFuns);
1085 freeBegin = saveFreeBegin;
1086 freeVars = saveFreeVars;
1087 freeFuns = saveFreeFuns;
1090 /* ---------------------------------------------------------------------------
1091 * Main part of pattern matching compiler: convert [Alt] to case constructs
1093 * This section of Hugs has been almost completely rewritten to be more
1094 * general, in particular, to allow pattern matching in orders other than the
1095 * strictly left-to-right approach of the previous version. This is needed
1096 * for the implementation of the so-called Haskell 1.3 `record' syntax.
1098 * At each stage, the different branches for the cases to be considered
1099 * are represented by a list of values of type:
1100 * Match ::= { maPats :: [Pat], patterns to match
1101 * maOffs :: [Offs], offsets of corresponding values
1102 * maSc :: Scope, mapping from vars to offsets
1103 * maRhs :: Rhs } right hand side
1104 * [Implementation uses nested pairs, ((pats,offs),(sc,rhs)).]
1106 * The Scope component has type:
1107 * Scope ::= [(Var,Expr)]
1108 * and provides a mapping from variable names to offsets used in the matching
1111 * Matches can be normalized by reducing them to a form in which the list
1112 * of patterns is empty (in which case the match itself is described as an
1113 * empty match), or in which the list is non-empty and the first pattern is
1114 * one that requires either a CASE or NUMCASE (or EXTCASE) to decompose.
1115 * ------------------------------------------------------------------------*/
1117 #define mkMatch(ps,os,sc,r) pair(pair(ps,os),pair(sc,r))
1118 #define maPats(ma) fst(fst(ma))
1119 #define maOffs(ma) snd(fst(ma))
1120 #define maSc(ma) fst(snd(ma))
1121 #define maRhs(ma) snd(snd(ma))
1122 #define extSc(v,o,ma) maSc(ma) = cons(pair(v,o),maSc(ma))
1124 static List local altsMatch(co,n,sc,as) /* Make a list of matches from list*/
1125 Int co; /* of Alts, with initial offsets */
1126 Int n; /* reverse (take n [co..]) */
1132 us = cons(mkOffset(co++),us);
1133 for (; nonNull(as); as=tl(as)) /* Each Alt is ([Pat], Rhs) */
1134 mas = cons(mkMatch(fst(hd(as)),us,sc,snd(hd(as))),mas);
1138 static Cell local match(co,mas) /* Generate case statement for Matches mas */
1139 Int co; /* at current offset co */
1140 List mas; { /* N.B. Assumes nonNull(mas). */
1141 Cell srhs = NIL; /* Rhs for selected matches */
1142 List smas = mas; /* List of selected matches */
1146 if (emptyMatch(hd(smas))) { /* The case for empty matches: */
1147 while (nonNull(mas) && emptyMatch(hd(mas))) {
1148 List temp = tl(mas);
1153 srhs = joinMas(co,rev(smas));
1155 else { /* Non-empty match */
1156 Int o = offsetOf(hd(maOffs(hd(smas))));
1157 Cell d = maDiscr(hd(smas));
1158 if (isNumDiscr(d)) { /* Numeric match */
1159 Int da = discrArity(d);
1160 Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
1161 while (nonNull(mas) && !emptyMatch(hd(mas))
1162 && o==offsetOf(hd(maOffs(hd(mas))))
1163 && isNumDiscr(d=maDiscr(hd(mas)))
1164 && eqNumDiscr(d,d1)) {
1165 List temp = tl(mas);
1171 map2Proc(advance,co,da,smas);
1172 srhs = ap(NUMCASE,triple(mkOffset(o),d1,match(co+da,smas)));
1175 else if (isExtDiscr(d)) { /* Record match */
1176 Int da = discrArity(d);
1177 Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
1178 while (nonNull(mas) && !emptyMatch(hd(mas))
1179 && o==offsetOf(hd(maOffs(hd(mas))))
1180 && isExtDiscr(d=maDiscr(hd(mas)))
1181 && eqExtDiscr(d,d1)) {
1182 List temp = tl(mas);
1188 map2Proc(advance,co,da,smas);
1189 srhs = ap(EXTCASE,triple(mkOffset(o),d1,match(co+da,smas)));
1192 else { /* Constructor match */
1193 List tab = addConTable(d,hd(smas),NIL);
1195 while (nonNull(mas) && !emptyMatch(hd(mas))
1196 && o==offsetOf(hd(maOffs(hd(mas))))
1197 && !isNumDiscr(d=maDiscr(hd(mas)))) {
1198 tab = addConTable(d,hd(mas),tab);
1201 for (tab=rev(tab); nonNull(tab); tab=tl(tab)) {
1203 smas = snd(hd(tab));
1205 map2Proc(advance,co,da,smas);
1206 srhs = cons(pair(d,match(co+da,smas)),srhs);
1208 srhs = ap(CASE,pair(mkOffset(o),srhs));
1211 return nonNull(mas) ? ap(FATBAR,pair(srhs,match(co,mas))) : srhs;
1214 static Cell local joinMas(co,mas) /* Combine list of matches into rhs*/
1215 Int co; /* using FATBARs as necessary */
1216 List mas; { /* Non-empty list of empty matches */
1218 Cell rhs = pmcTerm(co,maSc(ma),maRhs(ma));
1219 if (nonNull(tl(mas)) && canFail(rhs))
1220 return ap(FATBAR,pair(rhs,joinMas(co,tl(mas))));
1225 static Bool local canFail(rhs) /* Determine if expression (as rhs) */
1226 Cell rhs; { /* might ever be able to fail */
1227 switch (whatIs(rhs)) {
1228 case LETREC : return canFail(snd(snd(rhs)));
1229 case GUARDED : return TRUE; /* could get more sophisticated ..? */
1230 default : return FALSE;
1234 /* type Table a b = [(a, [b])]
1236 * addTable :: a -> b -> Table a b -> Table a b
1237 * addTable x y [] = [(x,[y])]
1238 * addTable x y (z@(n,sws):zs)
1239 * | n == x = (n,sws++[y]):zs
1240 * | otherwise = (n,sws):addTable x y zs
1243 static List local addConTable(x,y,tab) /* add element (x,y) to table */
1247 return singleton(pair(x,singleton(y)));
1248 else if (fst(hd(tab))==x)
1249 snd(hd(tab)) = appendOnto(snd(hd(tab)),singleton(y));
1251 tl(tab) = addConTable(x,y,tl(tab));
1256 static Void local advance(co,a,ma) /* Advance non-empty match by */
1257 Int co; /* processing head pattern */
1258 Int a; /* discriminator arity */
1260 Cell p = hd(maPats(ma));
1261 List ps = tl(maPats(ma));
1262 List us = tl(maOffs(ma));
1263 if (whatIs(p)==CONFLDS) { /* Special case for record syntax */
1264 Name c = fst(snd(p));
1265 List fs = snd(snd(p));
1268 for (; nonNull(fs); fs=tl(fs)) {
1269 vs = cons(mkOffset(co+a+1-sfunPos(fst(hd(fs)),c)),vs);
1270 qs = cons(snd(hd(fs)),qs);
1272 ps = revOnto(qs,ps);
1273 us = revOnto(vs,us);
1275 else /* Normally just spool off patterns*/
1276 for (; a>0; --a) { /* and corresponding offsets ... */
1277 us = cons(mkOffset(++co),us);
1278 ps = cons(arg(p),ps);
1286 /* --------------------------------------------------------------------------
1287 * Normalize and test for empty match:
1288 * ------------------------------------------------------------------------*/
1290 static Bool local emptyMatch(ma)/* Normalize and test to see if a given */
1291 Cell ma; { /* match, ma, is empty. */
1293 while (nonNull(maPats(ma))) {
1295 tidyHd: switch (whatIs(p=hd(maPats(ma)))) {
1296 case LAZYPAT : { Cell nv = inventVar();
1297 maRhs(ma) = ap(LETREC,
1298 pair(remPat(snd(p),nv,NIL),
1302 /* intentional fall-thru */
1305 case DICTVAR : extSc(p,hd(maOffs(ma)),ma);
1306 case WILDCARD : maPats(ma) = tl(maPats(ma));
1307 maOffs(ma) = tl(maOffs(ma));
1310 /* So-called "as-patterns"are really just pattern intersections:
1311 * (p1@p2:ps, o:os, sc, e) ==> (p1:p2:ps, o:o:os, sc, e)
1312 * (But the input grammar probably doesn't let us take
1313 * advantage of this, so we stick with the special case
1314 * when p1 is a variable.)
1316 case ASPAT : extSc(fst(snd(p)),hd(maOffs(ma)),ma);
1317 hd(maPats(ma)) = snd(snd(p));
1320 case FINLIST : hd(maPats(ma)) = mkConsList(snd(p));
1323 case STRCELL : { String s = textToStr(textOf(p));
1324 for (p=NIL; *s!='\0'; ++s) {
1325 if (*s!='\\' || *++s=='\\')
1326 p = ap(consChar(*s),p);
1328 p = ap(consChar('\0'),p);
1330 hd(maPats(ma)) = revOnto(p,nameNil);
1334 case AP : if (isName(fun(p)) && isCfun(fun(p))
1335 && cfunOf(fun(p))==0
1336 && name(fun(p)).defn==nameId) {
1337 hd(maPats(ma)) = arg(p);
1340 /* intentional fall-thru */
1346 default : internal("emptyMatch");
1352 /* --------------------------------------------------------------------------
1354 * ------------------------------------------------------------------------*/
1356 static Cell local maDiscr(ma) /* Get the discriminator for a non-empty */
1357 Cell ma; { /* match, ma. */
1358 Cell p = hd(maPats(ma));
1359 Cell h = getHead(p);
1360 switch (whatIs(h)) {
1361 case CONFLDS : return fst(snd(p));
1362 case ADDPAT : arg(fun(p)) = translate(arg(fun(p)));
1365 case EXT : h = fun(fun(p));
1366 arg(h) = translate(arg(h));
1369 case NAME : if (h==nameFromInt || h==nameFromInteger
1370 || h==nameFromDouble) {
1372 arg(fun(p)) = translate(arg(fun(p)));
1379 static Bool local isNumDiscr(d) /* TRUE => numeric discriminator */
1381 switch (whatIs(d)) {
1384 case CHARCELL : return FALSE;
1387 case AP : return !isExt(fun(d));
1389 case AP : return TRUE; /* must be a literal or (n+k) */
1392 internal("isNumDiscr");
1393 return 0;/*NOTREACHED*/
1396 Int discrArity(d) /* Find arity of discriminator */
1398 switch (whatIs(d)) {
1399 case NAME : return name(d).arity;
1400 case TUPLE : return tupleOf(d);
1401 case CHARCELL : return 0;
1403 case AP : switch (whatIs(fun(d))) {
1404 case ADDPAT : return 1;
1405 case EXT : return 2;
1409 case AP : return (whatIs(fun(d))==ADDPAT) ? 1 : 0;
1412 internal("discrArity");
1413 return 0;/*NOTREACHED*/
1416 static Bool local eqNumDiscr(d1,d2) /* Determine whether two numeric */
1417 Cell d1, d2; { /* descriptors have same value */
1418 if (whatIs(fun(d1))==ADDPAT)
1419 return whatIs(fun(d2))==ADDPAT && snd(fun(d1))==snd(fun(d2));
1421 return isInt(arg(d2)) && intOf(arg(d1))==intOf(arg(d2));
1422 if (isFloat(arg(d1)))
1423 return isFloat(arg(d2)) && floatOf(arg(d1))==floatOf(arg(d2));
1424 internal("eqNumDiscr");
1425 return FALSE;/*NOTREACHED*/
1429 static Bool local isExtDiscr(d) /* Test of extension discriminator */
1431 return isAp(d) && isExt(fun(d));
1434 static Bool local eqExtDiscr(d1,d2) /* Determine whether two extension */
1435 Cell d1, d2; { /* discriminators have same label */
1436 return fun(d1)==fun(d2);
1440 /*-------------------------------------------------------------------------*/
1442 /* --------------------------------------------------------------------------
1443 * Main entry points to compiler:
1444 * ------------------------------------------------------------------------*/
1446 Void evalExp ( void ) /* compile and run input expression */
1449 Name n = newName(inventText(),NIL);
1450 StgVar v = mkStgVar(NIL,NIL);
1451 name(n).closure = v;
1452 module(currentModule).codeList = singleton(n);
1454 e = pmcTerm(0,NIL,translate(inputExpr));
1457 cgModule ( name(n).mod );
1459 /* Run thread (and any other runnable threads) */
1461 /* Re-initialise the scheduler - ToDo: do I need this? */
1462 /* JRS, 991118: on SM's advice, don't call initScheduler every time.
1463 This causes an assertion failure in GC.c(revert_dead_cafs)
1464 unless doRevertCAFs below is permanently TRUE.
1466 /* initScheduler(); */
1468 /* Further comments, JRS 000411.
1469 When control returns to Hugs, you have to be pretty careful about
1470 the state of the heap. In particular, hugs.c may subsequently call
1471 nukeModule() in storage.c, which removes modules from the system.
1472 If a module defines a particular data constructor, the relevant
1473 info table is also free()d. That gives a problem if there are
1474 still closures hanging round in the heap with references to that
1477 The solution is to firstly to revert CAFs, and then force a major
1478 collection in between transitions from the mutation, ie actually
1479 running Haskell, and nukeModule. Since major GCs are potentially
1480 expensive, we don't want to do one at every call to nukeModule,
1481 so the flag nukeModule_needs_major_gc is used to signal when one
1484 This all also seems to imply that doRevertCAFs should always
1488 HaskellObj result; /* ignored */
1489 SchedulerStatus status;
1490 Bool doRevertCAFs = TRUE; /* do not change -- comment above */
1491 HugsBreakAction brkOld = setBreakAction ( HugsRtsInterrupt );
1492 nukeModule_needs_major_gc = TRUE;
1493 status = rts_eval_(cptrOf(name(n).closure),10000,&result);
1494 setBreakAction ( brkOld );
1499 printf("{Deadlock or Blackhole}"); fflush(stdout);
1502 printf("{Interrupted}");
1505 printf("{Interrupted or Killed}");
1510 internal("evalExp: Unrecognised SchedulerStatus");
1513 /* Begin heap cleanup sequence */
1515 /* fprintf ( stderr, "finalisation loop START\n" ); */
1517 finalizeWeakPointersNow();
1518 /* fprintf ( stderr, "finalisation loop END %d\n",
1519 howManyThreadsAvail() ); */
1521 while (howManyThreadsAvail() > 0);
1525 if (combined && SPT_size != 0) {
1527 "hugs: fatal: stable pointers are not yet allowed in combined mode" );
1528 internal("evalExp");
1530 /* End heap cleanup sequence */
1538 Void compileDefns() { /* compile script definitions */
1539 Target t = length(valDefns) + length(genDefns) + length(selDefns);
1545 for (vs = genDefns; nonNull(vs); vs = tl(vs)) {
1547 StgVar nv = mkStgVar(NIL,NIL);
1548 name(n).closure = nv;
1549 addToCodeList ( currentModule, n );
1551 for (vss = selDefns; nonNull(vss); vss = tl(vss)) {
1552 for (vs = hd(vss); nonNull(vs); vs = tl(vs)) {
1555 StgVar nv = mkStgVar(NIL,NIL);
1556 name(n).closure = nv;
1557 addToCodeList ( currentModule, n );
1562 setGoal("Translating",t);
1563 /* do valDefns before everything else so that all stgVar's get added. */
1564 for (; nonNull(valDefns); valDefns=tl(valDefns)) {
1566 hd(valDefns) = transBinds(hd(valDefns));
1567 for (qq = hd(valDefns); nonNull(qq); qq = tl(qq)) {
1568 Name n = findName ( textOf(fst(hd(qq))) );
1569 StgVar nv = mkStgVar(NIL,NIL);
1571 name(n).closure = nv;
1572 addToCodeList ( currentModule, n );
1573 compileGlobalFunction(hd(qq));
1577 for (; nonNull(genDefns); genDefns=tl(genDefns)) {
1578 compileGenFunction(hd(genDefns));
1581 for (; nonNull(selDefns); selDefns=tl(selDefns)) {
1582 mapOver(compileSelFunction,hd(selDefns));
1587 setGoal("Generating code",t);
1588 cgModule ( currentModule );
1593 static Void local compileGlobalFunction(bind)
1595 Name n = findName(textOf(fst(bind)));
1596 List defs = snd(bind);
1597 Int arity = length(fst(hd(defs)));
1600 stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1603 static Void local compileGenFunction(n) /* Produce code for internally */
1604 Name n; { /* generated function */
1605 List defs = name(n).defn;
1606 Int arity = length(fst(hd(defs)));
1610 mapProc(transAlt,defs);
1611 stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1615 static Name local compileSelFunction(p) /* Produce code for selector func */
1616 Pair p; { /* Should be merged with genDefns, */
1617 Name s = fst(p); /* but the name(_).defn field is */
1618 List defs = snd(p); /* already used for other purposes */
1619 Int arity = length(fst(hd(defs))); /* in selector functions. */
1622 mapProc(transAlt,defs);
1623 stgDefn(s,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1628 /* --------------------------------------------------------------------------
1630 * ------------------------------------------------------------------------*/
1636 case RESET : freeVars = NIL;
1639 freeBegin = mkOffset(0);
1642 case MARK : mark(freeVars);
1646 case POSTPREL: break;
1650 /*-------------------------------------------------------------------------*/