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 * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
8 * Haskell Group 1994-99, and is distributed as Open Source software
9 * under the Artistic License; see the file "Artistic" that is included
10 * in the distribution for details.
12 * $RCSfile: compiler.c,v $
14 * $Date: 1999/03/09 14:51:05 $
15 * ------------------------------------------------------------------------*/
22 #include "Rts.h" /* for rts_eval and related stuff */
23 #include "RtsAPI.h" /* for rts_eval and related stuff */
27 Addr inputCode; /* Addr of compiled code for expr */
28 static Name currentName; /* Top level name being processed */
30 Bool debugCode = FALSE; /* TRUE => print G-code to screen */
35 /* --------------------------------------------------------------------------
36 * Local function prototypes:
37 * ------------------------------------------------------------------------*/
39 static Cell local translate Args((Cell));
40 static Void local transPair Args((Pair));
41 static Void local transTriple Args((Triple));
42 static Void local transAlt Args((Cell));
43 static Void local transCase Args((Cell));
44 static List local transBinds Args((List));
45 static Cell local transRhs Args((Cell));
46 static Cell local mkConsList Args((List));
47 static Cell local expandLetrec Args((Cell));
48 static Cell local transComp Args((Cell,List,Cell));
49 static Cell local transDo Args((Cell,Cell,List));
50 static Cell local transConFlds Args((Cell,List));
51 static Cell local transUpdFlds Args((Cell,List,List));
53 static Cell local refutePat Args((Cell));
54 static Cell local refutePatAp Args((Cell));
55 static Cell local matchPat Args((Cell));
56 static List local remPat Args((Cell,Cell,List));
57 static List local remPat1 Args((Cell,Cell,List));
59 static Cell local pmcTerm Args((Int,List,Cell));
60 static Cell local pmcPair Args((Int,List,Pair));
61 static Cell local pmcTriple Args((Int,List,Triple));
62 static Cell local pmcVar Args((List,Text));
63 static Void local pmcLetrec Args((Int,List,Pair));
64 static Cell local pmcVarDef Args((Int,List,List));
65 static Void local pmcFunDef Args((Int,List,Triple));
66 static List local altsMatch Args((Int,Int,List,List));
67 static Cell local match Args((Int,List));
68 static Cell local joinMas Args((Int,List));
69 static Bool local canFail Args((Cell));
70 static List local addConTable Args((Cell,Cell,List));
71 static Void local advance Args((Int,Int,Cell));
72 static Bool local emptyMatch Args((Cell));
73 static Cell local maDiscr Args((Cell));
74 static Bool local isNumDiscr Args((Cell));
75 static Bool local eqNumDiscr Args((Cell,Cell));
77 static Bool local isExtDiscr Args((Cell));
78 static Bool local eqExtDiscr Args((Cell,Cell));
81 static Void local compileGlobalFunction Args((Pair));
82 static Void local compileGenFunction Args((Name));
83 static Name local compileSelFunction Args((Pair));
85 /* --------------------------------------------------------------------------
86 * Translation: Convert input expressions into a less complex language
87 * of terms using only LETREC, AP, constants and vars.
88 * Also remove pattern definitions on lhs of eqns.
89 * ------------------------------------------------------------------------*/
91 static Cell local translate(e) /* Translate expression: */
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 if (fst(e)==nameId || fst(e)==nameInd)
103 return translate(snd(e));
105 if (fst(e)==nameStrict)
110 if (isName(fst(e)) &&
113 return translate(snd(e));
115 snd(e) = translate(snd(e));
121 case NEGNUM : return e;
123 case NAME : if (e==nameOtherwise)
126 if (isName(name(e).defn))
128 if (isPair(name(e).defn))
129 return snd(name(e).defn);
134 case RECSEL : return nameRecSel;
145 case CHARCELL : return e;
147 case FINLIST : mapOver(translate,snd(e));
148 return mkConsList(snd(e));
150 case DOCOMP : { Cell m = translate(fst(snd(e)));
151 Cell r = translate(fst(snd(snd(e))));
152 return transDo(m,r,snd(snd(snd(e))));
155 case MONADCOMP : { Cell m = translate(fst(snd(e)));
156 Cell r = translate(fst(snd(snd(e))));
157 Cell qs = snd(snd(snd(e)));
158 if (m == nameListMonad)
159 return transComp(r,qs,nameNil);
162 r = ap(ap(nameReturn,m),r);
163 return transDo(m,r,qs);
165 internal("translate: monad comps");
170 case CONFLDS : return transConFlds(fst(snd(e)),snd(snd(e)));
172 case UPDFLDS : return transUpdFlds(fst3(snd(e)),
176 case CASE : { Cell nv = inventVar();
177 mapProc(transCase,snd(snd(e)));
179 pair(singleton(pair(nv,snd(snd(e)))),
180 ap(nv,translate(fst(snd(e))))));
183 case LAMBDA : { Cell nv = inventVar();
192 default : internal("translate");
197 static Void local transPair(pr) /* Translate each component in a */
198 Pair pr; { /* pair of expressions. */
199 fst(pr) = translate(fst(pr));
200 snd(pr) = translate(snd(pr));
203 static Void local transTriple(tr) /* Translate each component in a */
204 Triple tr; { /* triple of expressions. */
205 fst3(tr) = translate(fst3(tr));
206 snd3(tr) = translate(snd3(tr));
207 thd3(tr) = translate(thd3(tr));
210 static Void local transAlt(e) /* Translate alt: */
211 Cell e; { /* ([Pat], Rhs) ==> ([Pat], Rhs') */
212 snd(e) = transRhs(snd(e));
215 static Void local transCase(c) /* Translate case: */
216 Cell c; { /* (Pat, Rhs) ==> ([Pat], Rhs') */
217 fst(c) = singleton(fst(c));
218 snd(c) = transRhs(snd(c));
221 static List local transBinds(bs) /* Translate list of bindings: */
222 List bs; { /* eliminating pattern matching on */
223 List newBinds = NIL; /* lhs of bindings. */
224 for (; nonNull(bs); bs=tl(bs)) {
225 if (isVar(fst(hd(bs)))) {
226 mapProc(transAlt,snd(hd(bs)));
227 newBinds = cons(hd(bs),newBinds);
230 newBinds = remPat(fst(snd(hd(bs))),
231 snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))),
237 static Cell local transRhs(rhs) /* Translate rhs: removing line nos */
239 switch (whatIs(rhs)) {
240 case LETREC : snd(snd(rhs)) = transRhs(snd(snd(rhs)));
241 return expandLetrec(rhs);
243 case GUARDED : mapOver(snd,snd(rhs)); /* discard line number */
244 mapProc(transPair,snd(rhs));
247 default : return translate(snd(rhs)); /* discard line number */
251 static Cell local mkConsList(es) /* Construct expression for list es */
252 List es; { /* using nameNil and nameCons */
256 return ap(ap(nameCons,hd(es)),mkConsList(tl(es)));
259 static Cell local expandLetrec(root) /* translate LETREC with list of */
260 Cell root; { /* groups of bindings (from depend. */
261 Cell e = snd(snd(root)); /* analysis) to use nested LETRECs */
262 List bss = fst(snd(root));
265 if (isNull(bss)) /* should never happen, but just in */
266 return e; /* case: LETREC [] IN e ==> e */
268 mapOver(transBinds,bss); /* translate each group of bindings */
270 for (temp=root; nonNull(tl(bss)); bss=tl(bss)) {
271 fst(snd(temp)) = hd(bss);
272 snd(snd(temp)) = ap(LETREC,pair(NIL,e));
273 temp = snd(snd(temp));
275 fst(snd(temp)) = hd(bss);
280 /* --------------------------------------------------------------------------
281 * Translation of list comprehensions is based on the description in
282 * `The Implementation of Functional Programming Languages':
284 * [ e | qs ] ++ l => transComp e qs l
285 * transComp e [] l => e : l
286 * transComp e ((p<-xs):qs) l => LETREC _h [] = l
287 * _h (p:_xs) = transComp e qs (_h _xs)
288 * _h (_:_xs) = _h _xs --if p !failFree
290 * transComp e (b:qs) l => if b then transComp e qs l else l
291 * transComp e (decls:qs) l => LETREC decls IN transComp e qs l
292 * ------------------------------------------------------------------------*/
294 static Cell local transComp(e,qs,l) /* Translate [e | qs] ++ l */
303 case FROMQUAL : { Cell ld = NIL;
304 Cell hVar = inventVar();
305 Cell xsVar = inventVar();
307 if (!failFree(fst(snd(q))))
308 ld = cons(pair(singleton(
315 ld = cons(pair(singleton(
323 ld = cons(pair(singleton(nameNil),
328 pair(singleton(pair(hVar,
331 translate(snd(snd(q))))));
335 expandLetrec(ap(LETREC,
337 transComp(e,qs1,l))));
339 case BOOLQUAL : return ap(COND,
340 triple(translate(snd(q)),
346 return ap(ap(nameCons,e),l);
349 /* --------------------------------------------------------------------------
350 * Translation of monad comprehensions written using do-notation:
353 * do { p <- exp; qs } => LETREC _h p = do { qs }
354 * _h _ = fail m "match fails"
356 * do { LET decls; qs } => LETREC decls IN do { qs }
357 * do { IF guard; qs } => if guard then do { qs } else fail m "guard fails"
358 * do { e; qs } => LETREC _h _ = [ e | qs ] in bind m exp _h
361 * ------------------------------------------------------------------------*/
363 static Cell local transDo(m,e,qs) /* Translate do { qs ; e } */
372 case FROMQUAL : { Cell ld = NIL;
373 Cell hVar = inventVar();
375 if (!failFree(fst(snd(q)))) {
376 Cell str = mkStr(findText("match fails"));
377 ld = cons(pair(singleton(WILDCARD),
378 ap2(nameMFail,m,str)),
382 ld = cons(pair(singleton(fst(snd(q))),
387 pair(singleton(pair(hVar,ld)),
390 translate(snd(snd(q)))),
394 case DOQUAL : { Cell hVar = inventVar();
395 Cell ld = cons(pair(singleton(WILDCARD),
399 pair(singleton(pair(hVar,ld)),
407 expandLetrec(ap(LETREC,
411 case BOOLQUAL : return
413 triple(translate(snd(q)),
416 mkStr(findText("guard fails")))));
422 /* --------------------------------------------------------------------------
423 * Translation of named field construction and update:
425 * Construction is implemented using the following transformation:
427 * C{x1=e1, ..., xn=en} = C v1 ... vm
429 * vi = e1, if the ith component of C is labelled with x1
431 * = en, if the ith component of C is labelled with xn
432 * = undefined, otherwise
434 * Update is implemented using the following transformation:
436 * e{x1=e1, ..., xn=en}
437 * = let nv (C a1 ... am) v1 ... vn = C a1' .. am'
438 * nv (D b1 ... bk) v1 ... vn = D b1' .. bk
440 * nv _ v1 ... vn = error "failed update"
443 * nv, v1, ..., vn, a1, ..., am, b1, ..., bk, ... are new variables,
444 * C,D,... = { K | K is a constr fun s.t. {x1,...,xn} subset of sels(K)}
446 * ai' = v1, if the ith component of C is labelled with x1
448 * = vn, if the ith component of C is labelled with xn
452 * The error case may be omitted if C,D,... is an enumeration of all of the
453 * constructors for the datatype concerned. Strictly speaking, error case
454 * isn't needed at all -- the only benefit of including it is that the user
455 * will get a "failed update" message rather than a cryptic {v354 ...}.
456 * So, for now, we'll go with the second option!
458 * For the time being, code for each update operation is generated
459 * independently of any other updates. However, if updates are used
460 * frequently, then we might want to consider changing the implementation
461 * at a later stage to cache definitions of functions like nv above. This
462 * would create a shared library of update functions, indexed by a set of
463 * constructors {C,D,...}.
464 * ------------------------------------------------------------------------*/
466 static Cell local transConFlds(c,flds) /* Translate C{flds} */
470 Int m = name(c).arity;
473 e = ap(e,nameUndefined);
474 for (; nonNull(flds); flds=tl(flds)) {
476 for (i=m-sfunPos(fst(hd(flds)),c); i>0; i--)
478 arg(a) = translate(snd(hd(flds)));
483 static Cell local transUpdFlds(e,cs,flds)/* Translate e{flds} */
484 Cell e; /* (cs is corresp list of constrs) */
487 Cell nv = inventVar();
488 Cell body = ap(nv,translate(e));
493 for (; nonNull(fs); fs=tl(fs)) { /* body = nv e1 ... en */
494 Cell b = hd(fs); /* args = [v1, ..., vn] */
495 body = ap(body,translate(snd(b)));
496 args = cons(inventVar(),args);
499 for (; nonNull(cs); cs=tl(cs)) { /* Loop through constructors to */
500 Cell c = hd(cs); /* build up list of alts. */
504 Int m = name(c).arity;
507 for (i=m; i>0; i--) { /* pat = C a1 ... am */
508 Cell a = inventVar(); /* rhs = C a1 ... am */
513 for (fs=flds; nonNull(fs); fs=tl(fs), as=tl(as)) {
514 Name s = fst(hd(fs)); /* Replace approp ai in rhs with */
515 Cell r = rhs; /* vars from [v1,...,vn] */
516 for (i=m-sfunPos(s,c); i>0; i--)
521 alts = cons(pair(cons(pat,args),rhs),alts);
523 return ap(LETREC,pair(singleton(pair(nv,alts)),body));
526 /* --------------------------------------------------------------------------
527 * Elimination of pattern bindings:
529 * The following code adopts the definition of failure free patterns as given
530 * in the Haskell 1.3 report; the term "irrefutable" is also used there for
531 * a subset of the failure free patterns described here, but has no useful
532 * role in this implementation. Basically speaking, the failure free patterns
533 * are: variable, wildcard, ~apat
534 * var@apat, if apat is failure free
535 * C apat1 ... apatn if C is a product constructor
536 * (i.e. an only constructor) and
537 * apat1,...,apatn are failure free
538 * Note that the last case automatically covers the case where C comes from
539 * a newtype construction.
540 * ------------------------------------------------------------------------*/
542 Bool failFree(pat) /* is pattern failure free? (do we need */
543 Cell pat; { /* a conformality check?) */
544 Cell c = getHead(pat);
547 case ASPAT : return failFree(snd(snd(pat)));
549 case NAME : if (!isCfun(c) || cfunOf(c)!=0)
551 /*intentional fall-thru*/
552 case TUPLE : for (; isAp(pat); pat=fun(pat))
553 if (!failFree(arg(pat)))
555 /*intentional fall-thru*/
560 case WILDCARD : return TRUE;
563 case EXT : return failFree(extField(pat)) &&
564 failFree(extRow(pat));
567 case CONFLDS : if (cfunOf(fst(snd(c)))==0) {
568 List fs = snd(snd(c));
569 for (; nonNull(fs); fs=tl(fs))
570 if (!failFree(snd(hd(fs))))
574 /*intentional fall-thru*/
575 default : return FALSE;
579 static Cell local refutePat(pat) /* find pattern to refute in conformality*/
580 Cell pat; { /* test with pat. */
581 /* e.g. refPat (x:y) == (_:_) */
582 /* refPat ~(x:y) == _ etc.. */
584 switch (whatIs(pat)) {
585 case ASPAT : return refutePat(snd(snd(pat)));
587 case FINLIST : { Cell ys = snd(pat);
589 for (; nonNull(ys); ys=tl(ys))
590 xs = ap(ap(nameCons,refutePat(hd(ys))),xs);
591 return revOnto(xs,nameNil);
594 case CONFLDS : { Cell ps = NIL;
595 Cell fs = snd(snd(pat));
596 for (; nonNull(fs); fs=tl(fs)) {
597 Cell p = refutePat(snd(hd(fs)));
598 ps = cons(pair(fst(hd(fs)),p),ps);
600 return pair(CONFLDS,pair(fst(snd(pat)),rev(ps)));
607 case LAZYPAT : return WILDCARD;
615 case NAME : return pat;
617 case AP : return refutePatAp(pat);
619 default : internal("refutePat");
620 return NIL; /*NOTREACHED*/
624 static Cell local refutePatAp(p) /* find pattern to refute in conformality*/
627 if (h==nameFromInt || h==nameFromInteger || h==nameFromDouble)
630 else if (whatIs(h)==ADDPAT)
631 return ap(fun(p),refutePat(arg(p)));
635 Cell pf = refutePat(extField(p));
636 Cell pr = refutePat(extRow(p));
637 return ap(ap(fun(fun(p)),pf),pr);
641 List as = getArgs(p);
642 mapOver(refutePat,as);
643 return applyToArgs(h,as);
647 static Cell local matchPat(pat) /* find pattern to match against */
648 Cell pat; { /* replaces parts of pattern that do not */
649 /* include variables with wildcards */
650 switch (whatIs(pat)) {
651 case ASPAT : { Cell p = matchPat(snd(snd(pat)));
652 return (p==WILDCARD) ? fst(snd(pat))
654 pair(fst(snd(pat)),p));
657 case FINLIST : { Cell ys = snd(pat);
659 for (; nonNull(ys); ys=tl(ys))
660 xs = cons(matchPat(hd(ys)),xs);
661 while (nonNull(xs) && hd(xs)==WILDCARD)
663 for (ys=nameNil; nonNull(xs); xs=tl(xs))
664 ys = ap(ap(nameCons,hd(xs)),ys);
668 case CONFLDS : { Cell ps = NIL;
669 Name c = fst(snd(pat));
670 Cell fs = snd(snd(pat));
672 for (; nonNull(fs); fs=tl(fs)) {
673 Cell p = matchPat(snd(hd(fs)));
674 ps = cons(pair(fst(hd(fs)),p),ps);
678 return avar ? pair(CONFLDS,pair(c,rev(ps)))
684 case DICTVAR : return pat;
686 case LAZYPAT : { Cell p = matchPat(snd(pat));
687 return (p==WILDCARD) ? WILDCARD : ap(LAZYPAT,p);
692 case CHARCELL : return WILDCARD;
696 case AP : { Cell h = getHead(pat);
697 if (h==nameFromInt ||
698 h==nameFromInteger || h==nameFromDouble)
701 else if (whatIs(h)==ADDPAT)
706 Cell pf = matchPat(extField(pat));
707 Cell pr = matchPat(extRow(pat));
708 return (pf==WILDCARD && pr==WILDCARD)
710 : ap(ap(fun(fun(pat)),pf),pr);
716 for (; isAp(pat); pat=fun(pat)) {
717 Cell p = matchPat(arg(pat));
722 return avar ? applyToArgs(pat,args)
727 default : internal("matchPat");
728 return NIL; /*NOTREACHED*/
732 #define addEqn(v,val,lds) cons(pair(v,singleton(pair(NIL,val))),lds)
734 static List local remPat(pat,expr,lds)
735 Cell pat; /* Produce list of definitions for eqn */
736 Cell expr; /* pat = expr, including a conformality */
737 List lds; { /* check if required. */
739 /* Conformality test (if required):
740 * pat = expr ==> nv = LETREC confCheck nv@pat = nv
742 * remPat1(pat,nv,.....);
745 if (!failFree(pat)) {
746 Cell confVar = inventVar();
747 Cell nv = inventVar();
748 Cell locfun = pair(confVar, /* confVar [([nv@refPat],nv)] */
749 singleton(pair(singleton(ap(ASPAT,
754 if (whatIs(expr)==GUARDED) { /* A spanner ... special case */
755 lds = addEqn(nv,expr,lds); /* for guarded pattern binding*/
760 if (whatIs(pat)==ASPAT) { /* avoid using new variable if*/
761 nv = fst(snd(pat)); /* a variable is already given*/
762 pat = snd(snd(pat)); /* by an as-pattern */
765 lds = addEqn(nv, /* nv = */
766 ap(LETREC,pair(singleton(locfun), /* LETREC [locfun] */
767 ap(confVar,expr))), /* IN confVar expr */
770 return remPat1(matchPat(pat),nv,lds);
773 return remPat1(matchPat(pat),expr,lds);
776 static List local remPat1(pat,expr,lds)
777 Cell pat; /* Add definitions for: pat = expr to */
778 Cell expr; /* list of local definitions in lds. */
780 Cell c = getHead(pat);
785 case CHARCELL : break;
787 case ASPAT : return remPat1(snd(snd(pat)), /* v@pat = expr */
789 addEqn(fst(snd(pat)),expr,lds));
791 case LAZYPAT : { Cell nv;
793 if (isVar(expr) || isName(expr))
797 lds = addEqn(nv,expr,lds);
800 return remPat(snd(pat),nv,lds);
804 case ADDPAT : return remPat1(arg(pat), /* n + k = expr */
807 mkInt(snd(fun(fun(pat))))),
812 case FINLIST : return remPat1(mkConsList(snd(pat)),expr,lds);
814 case CONFLDS : { Name h = fst(snd(pat));
815 Int m = name(h).arity;
817 List fs = snd(snd(pat));
821 for (; nonNull(fs); fs=tl(fs)) {
823 for (i=m-sfunPos(fst(hd(fs)),h); i>0; i--)
825 arg(r) = snd(hd(fs));
827 return remPat1(p,expr,lds);
830 case DICTVAR : /* shouldn't really occur */
831 assert(0); /* so let's test for it then! ADR */
833 case VAROPCELL : return addEqn(pat,expr,lds);
835 case NAME : if (c==nameFromInt || c==nameFromInteger
836 || c==nameFromDouble) {
838 arg(fun(pat)) = translate(arg(fun(pat)));
842 if (argCount==1 && isCfun(c) /* for newtype */
843 && cfunOf(c)==0 && name(c).defn==nameId)
844 return remPat1(arg(pat),expr,lds);
846 /* intentional fall-thru */
847 case TUPLE : { List ps = getArgs(pat);
853 if (isVar(expr) || isName(expr))
857 lds = addEqn(nv,expr,lds);
860 sel = ap(ap(nameSel,c),nv);
861 for (i=1; nonNull(ps); ++i, ps=tl(ps))
862 lds = remPat1(hd(ps),
870 case EXT : { Cell nv = inventVar();
872 = translate(arg(fun(fun(pat))));
878 lds = remPat1(extField(pat),ap(nameFst,nv),lds);
879 lds = remPat1(extRow(pat),ap(nameSnd,nv),lds);
884 default : internal("remPat1");
890 /* --------------------------------------------------------------------------
891 * Eliminate pattern matching in function definitions -- pattern matching
894 * The original Gofer/Hugs pattern matching compiler was based on Wadler's
895 * algorithms described in `Implementation of functional programming
896 * languages'. That should still provide a good starting point for anyone
897 * wanting to understand this part of the system. However, the original
898 * algorithm has been generalized and restructured in order to implement
899 * new features added in Haskell 1.3.
901 * During the translation, in preparation for later stages of compilation,
902 * all local and bound variables are replaced by suitable offsets, and
903 * locally defined function symbols are given new names (which will
904 * eventually be their names when lifted to make top level definitions).
905 * ------------------------------------------------------------------------*/
907 static Offset freeBegin; /* only variables with offset <= freeBegin are of */
908 static List freeVars; /* interest as `free' variables */
909 static List freeFuns; /* List of `free' local functions */
911 static Cell local pmcTerm(co,sc,e) /* apply pattern matching compiler */
912 Int co; /* co = current offset */
913 List sc; /* sc = scope */
914 Cell e; { /* e = expr to transform */
916 case GUARDED : map2Over(pmcPair,co,sc,snd(e));
919 case LETREC : pmcLetrec(co,sc,snd(e));
924 case DICTVAR : return pmcVar(sc,textOf(e));
926 case COND : return ap(COND,pmcTriple(co,sc,snd(e)));
928 case AP : return pmcPair(co,sc,e);
946 case STRCELL : break;
948 default : internal("pmcTerm");
954 static Cell local pmcPair(co,sc,pr) /* apply pattern matching compiler */
955 Int co; /* to a pair of exprs */
958 return pair(pmcTerm(co,sc,fst(pr)),
959 pmcTerm(co,sc,snd(pr)));
962 static Cell local pmcTriple(co,sc,tr) /* apply pattern matching compiler */
963 Int co; /* to a triple of exprs */
966 return triple(pmcTerm(co,sc,fst3(tr)),
967 pmcTerm(co,sc,snd3(tr)),
968 pmcTerm(co,sc,thd3(tr)));
971 static Cell local pmcVar(sc,t) /* find translation of variable */
972 List sc; /* in current scope */
977 for (xs=sc; nonNull(xs); xs=tl(xs)) {
979 if (t==textOf(fst(x))) {
980 if (isOffset(snd(x))) { /* local variable ... */
981 if (snd(x)<=freeBegin && !cellIsMember(snd(x),freeVars))
982 freeVars = cons(snd(x),freeVars);
985 else { /* local function ... */
986 if (!cellIsMember(snd(x),freeFuns))
987 freeFuns = cons(snd(x),freeFuns);
993 if (isNull(n=findName(t))) /* Lookup global name - the only way*/
994 n = newName(t,currentName); /* this (should be able to happen) */
995 /* is with new global var introduced*/
996 /* after type check; e.g. remPat1 */
1000 static Void local pmcLetrec(co,sc,e) /* apply pattern matching compiler */
1001 Int co; /* to LETREC, splitting decls into */
1002 List sc; /* two sections */
1004 List fs = NIL; /* local function definitions */
1005 List vs = NIL; /* local variable definitions */
1008 for (ds=fst(e); nonNull(ds); ds=tl(ds)) { /* Split decls into two */
1009 Cell v = fst(hd(ds));
1010 Int arity = length(fst(hd(snd(hd(ds)))));
1012 if (arity==0) { /* Variable declaration */
1013 vs = cons(snd(hd(ds)),vs);
1014 sc = cons(pair(v,mkOffset(++co)),sc);
1016 else { /* Function declaration */
1017 fs = cons(triple(inventVar(),mkInt(arity),snd(hd(ds))),fs);
1018 sc = cons(pair(v,hd(fs)),sc);
1021 vs = rev(vs); /* Put declaration lists back in */
1022 fs = rev(fs); /* original order */
1023 fst(e) = pair(vs,fs); /* Store declaration lists */
1024 map2Over(pmcVarDef,co,sc,vs); /* Translate variable definitions */
1025 map2Proc(pmcFunDef,co,sc,fs); /* Translate function definitions */
1026 snd(e) = pmcTerm(co,sc,snd(e)); /* Translate LETREC body */
1027 freeFuns = diffList(freeFuns,fs); /* Delete any `freeFuns' bound in fs*/
1030 static Cell local pmcVarDef(co,sc,vd) /* apply pattern matching compiler */
1031 Int co; /* to variable definition */
1033 List vd; { /* vd :: [ ([], rhs) ] */
1034 Cell d = snd(hd(vd));
1035 if (nonNull(tl(vd)) && canFail(d))
1036 return ap(FATBAR,pair(pmcTerm(co,sc,d),
1037 pmcVarDef(co,sc,tl(vd))));
1038 return pmcTerm(co,sc,d);
1041 static Void local pmcFunDef(co,sc,fd) /* apply pattern matching compiler */
1042 Int co; /* to function definition */
1044 Triple fd; { /* fd :: (Var, Arity, [Alt]) */
1045 Offset saveFreeBegin = freeBegin;
1046 List saveFreeVars = freeVars;
1047 List saveFreeFuns = freeFuns;
1048 Int arity = intOf(snd3(fd));
1049 Cell temp = altsMatch(co+1,arity,sc,thd3(fd));
1052 freeBegin = mkOffset(co);
1055 temp = match(co+arity,temp);
1056 thd3(fd) = triple(freeVars,freeFuns,temp);
1058 for (xs=freeVars; nonNull(xs); xs=tl(xs))
1059 if (hd(xs)<=saveFreeBegin && !cellIsMember(hd(xs),saveFreeVars))
1060 saveFreeVars = cons(hd(xs),saveFreeVars);
1062 for (xs=freeFuns; nonNull(xs); xs=tl(xs))
1063 if (!cellIsMember(hd(xs),saveFreeFuns))
1064 saveFreeFuns = cons(hd(xs),saveFreeFuns);
1066 freeBegin = saveFreeBegin;
1067 freeVars = saveFreeVars;
1068 freeFuns = saveFreeFuns;
1071 /* ---------------------------------------------------------------------------
1072 * Main part of pattern matching compiler: convert [Alt] to case constructs
1074 * This section of Hugs has been almost completely rewritten to be more
1075 * general, in particular, to allow pattern matching in orders other than the
1076 * strictly left-to-right approach of the previous version. This is needed
1077 * for the implementation of the so-called Haskell 1.3 `record' syntax.
1079 * At each stage, the different branches for the cases to be considered
1080 * are represented by a list of values of type:
1081 * Match ::= { maPats :: [Pat], patterns to match
1082 * maOffs :: [Offs], offsets of corresponding values
1083 * maSc :: Scope, mapping from vars to offsets
1084 * maRhs :: Rhs } right hand side
1085 * [Implementation uses nested pairs, ((pats,offs),(sc,rhs)).]
1087 * The Scope component has type:
1088 * Scope ::= [(Var,Expr)]
1089 * and provides a mapping from variable names to offsets used in the matching
1092 * Matches can be normalized by reducing them to a form in which the list
1093 * of patterns is empty (in which case the match itself is described as an
1094 * empty match), or in which the list is non-empty and the first pattern is
1095 * one that requires either a CASE or NUMCASE (or EXTCASE) to decompose.
1096 * ------------------------------------------------------------------------*/
1098 #define mkMatch(ps,os,sc,r) pair(pair(ps,os),pair(sc,r))
1099 #define maPats(ma) fst(fst(ma))
1100 #define maOffs(ma) snd(fst(ma))
1101 #define maSc(ma) fst(snd(ma))
1102 #define maRhs(ma) snd(snd(ma))
1103 #define extSc(v,o,ma) maSc(ma) = cons(pair(v,o),maSc(ma))
1105 static List local altsMatch(co,n,sc,as) /* Make a list of matches from list*/
1106 Int co; /* of Alts, with initial offsets */
1107 Int n; /* reverse (take n [co..]) */
1113 us = cons(mkOffset(co++),us);
1114 for (; nonNull(as); as=tl(as)) /* Each Alt is ([Pat], Rhs) */
1115 mas = cons(mkMatch(fst(hd(as)),us,sc,snd(hd(as))),mas);
1119 static Cell local match(co,mas) /* Generate case statement for Matches mas */
1120 Int co; /* at current offset co */
1121 List mas; { /* N.B. Assumes nonNull(mas). */
1122 Cell srhs = NIL; /* Rhs for selected matches */
1123 List smas = mas; /* List of selected matches */
1127 if (emptyMatch(hd(smas))) { /* The case for empty matches: */
1128 while (nonNull(mas) && emptyMatch(hd(mas))) {
1129 List temp = tl(mas);
1134 srhs = joinMas(co,rev(smas));
1136 else { /* Non-empty match */
1137 Int o = offsetOf(hd(maOffs(hd(smas))));
1138 Cell d = maDiscr(hd(smas));
1139 if (isNumDiscr(d)) { /* Numeric match */
1140 Int da = discrArity(d);
1141 Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
1142 while (nonNull(mas) && !emptyMatch(hd(mas))
1143 && o==offsetOf(hd(maOffs(hd(mas))))
1144 && isNumDiscr(d=maDiscr(hd(mas)))
1145 && eqNumDiscr(d,d1)) {
1146 List temp = tl(mas);
1152 map2Proc(advance,co,da,smas);
1153 srhs = ap(NUMCASE,triple(mkOffset(o),d1,match(co+da,smas)));
1156 else if (isExtDiscr(d)) { /* Record match */
1157 Int da = discrArity(d);
1158 Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
1159 while (nonNull(mas) && !emptyMatch(hd(mas))
1160 && o==offsetOf(hd(maOffs(hd(mas))))
1161 && isExtDiscr(d=maDiscr(hd(mas)))
1162 && eqExtDiscr(d,d1)) {
1163 List temp = tl(mas);
1169 map2Proc(advance,co,da,smas);
1170 srhs = ap(EXTCASE,triple(mkOffset(o),d1,match(co+da,smas)));
1173 else { /* Constructor match */
1174 List tab = addConTable(d,hd(smas),NIL);
1176 while (nonNull(mas) && !emptyMatch(hd(mas))
1177 && o==offsetOf(hd(maOffs(hd(mas))))
1178 && !isNumDiscr(d=maDiscr(hd(mas)))) {
1179 tab = addConTable(d,hd(mas),tab);
1182 for (tab=rev(tab); nonNull(tab); tab=tl(tab)) {
1184 smas = snd(hd(tab));
1186 map2Proc(advance,co,da,smas);
1187 srhs = cons(pair(d,match(co+da,smas)),srhs);
1189 srhs = ap(CASE,pair(mkOffset(o),srhs));
1192 return nonNull(mas) ? ap(FATBAR,pair(srhs,match(co,mas))) : srhs;
1195 static Cell local joinMas(co,mas) /* Combine list of matches into rhs*/
1196 Int co; /* using FATBARs as necessary */
1197 List mas; { /* Non-empty list of empty matches */
1199 Cell rhs = pmcTerm(co,maSc(ma),maRhs(ma));
1200 if (nonNull(tl(mas)) && canFail(rhs))
1201 return ap(FATBAR,pair(rhs,joinMas(co,tl(mas))));
1206 static Bool local canFail(rhs) /* Determine if expression (as rhs) */
1207 Cell rhs; { /* might ever be able to fail */
1208 switch (whatIs(rhs)) {
1209 case LETREC : return canFail(snd(snd(rhs)));
1210 case GUARDED : return TRUE; /* could get more sophisticated ..? */
1211 default : return FALSE;
1215 /* type Table a b = [(a, [b])]
1217 * addTable :: a -> b -> Table a b -> Table a b
1218 * addTable x y [] = [(x,[y])]
1219 * addTable x y (z@(n,sws):zs)
1220 * | n == x = (n,sws++[y]):zs
1221 * | otherwise = (n,sws):addTable x y zs
1224 static List local addConTable(x,y,tab) /* add element (x,y) to table */
1228 return singleton(pair(x,singleton(y)));
1229 else if (fst(hd(tab))==x)
1230 snd(hd(tab)) = appendOnto(snd(hd(tab)),singleton(y));
1232 tl(tab) = addConTable(x,y,tl(tab));
1237 static Void local advance(co,a,ma) /* Advance non-empty match by */
1238 Int co; /* processing head pattern */
1239 Int a; /* discriminator arity */
1241 Cell p = hd(maPats(ma));
1242 List ps = tl(maPats(ma));
1243 List us = tl(maOffs(ma));
1244 if (whatIs(p)==CONFLDS) { /* Special case for record syntax */
1245 Name c = fst(snd(p));
1246 List fs = snd(snd(p));
1249 for (; nonNull(fs); fs=tl(fs)) {
1250 vs = cons(mkOffset(co+a+1-sfunPos(fst(hd(fs)),c)),vs);
1251 qs = cons(snd(hd(fs)),qs);
1253 ps = revOnto(qs,ps);
1254 us = revOnto(vs,us);
1256 else /* Normally just spool off patterns*/
1257 for (; a>0; --a) { /* and corresponding offsets ... */
1258 us = cons(mkOffset(++co),us);
1259 ps = cons(arg(p),ps);
1267 /* --------------------------------------------------------------------------
1268 * Normalize and test for empty match:
1269 * ------------------------------------------------------------------------*/
1271 static Bool local emptyMatch(ma)/* Normalize and test to see if a given */
1272 Cell ma; { /* match, ma, is empty. */
1274 while (nonNull(maPats(ma))) {
1276 tidyHd: switch (whatIs(p=hd(maPats(ma)))) {
1277 case LAZYPAT : { Cell nv = inventVar();
1278 maRhs(ma) = ap(LETREC,
1279 pair(remPat(snd(p),nv,NIL),
1283 /* intentional fall-thru */
1286 case DICTVAR : extSc(p,hd(maOffs(ma)),ma);
1287 case WILDCARD : maPats(ma) = tl(maPats(ma));
1288 maOffs(ma) = tl(maOffs(ma));
1291 /* So-called "as-patterns"are really just pattern intersections:
1292 * (p1@p2:ps, o:os, sc, e) ==> (p1:p2:ps, o:o:os, sc, e)
1293 * (But the input grammar probably doesn't let us take
1294 * advantage of this, so we stick with the special case
1295 * when p1 is a variable.)
1297 case ASPAT : extSc(fst(snd(p)),hd(maOffs(ma)),ma);
1298 hd(maPats(ma)) = snd(snd(p));
1301 case FINLIST : hd(maPats(ma)) = mkConsList(snd(p));
1304 case STRCELL : { String s = textToStr(textOf(p));
1305 for (p=NIL; *s!='\0'; ++s)
1306 if (*s!='\\' || *++s=='\\')
1307 p = ap(consChar(*s),p);
1309 p = ap(consChar('\0'),p);
1310 hd(maPats(ma)) = revOnto(p,nameNil);
1314 case AP : if (isName(fun(p)) && isCfun(fun(p))
1315 && cfunOf(fun(p))==0
1316 && name(fun(p)).defn==nameId) {
1317 hd(maPats(ma)) = arg(p);
1320 /* intentional fall-thru */
1326 default : internal("emptyMatch");
1332 /* --------------------------------------------------------------------------
1334 * ------------------------------------------------------------------------*/
1336 static Cell local maDiscr(ma) /* Get the discriminator for a non-empty */
1337 Cell ma; { /* match, ma. */
1338 Cell p = hd(maPats(ma));
1339 Cell h = getHead(p);
1340 switch (whatIs(h)) {
1341 case CONFLDS : return fst(snd(p));
1343 case ADDPAT : arg(fun(p)) = translate(arg(fun(p)));
1347 case EXT : h = fun(fun(p));
1348 arg(h) = translate(arg(h));
1351 case NAME : if (h==nameFromInt || h==nameFromInteger
1352 || h==nameFromDouble) {
1354 arg(fun(p)) = translate(arg(fun(p)));
1361 static Bool local isNumDiscr(d) /* TRUE => numeric discriminator */
1363 switch (whatIs(d)) {
1366 case CHARCELL : return FALSE;
1369 case AP : return !isExt(fun(d));
1371 case AP : return TRUE; /* must be a literal or (n+k) */
1374 internal("isNumDiscr");
1375 return 0;/*NOTREACHED*/
1378 Int discrArity(d) /* Find arity of discriminator */
1380 switch (whatIs(d)) {
1381 case NAME : return name(d).arity;
1382 case TUPLE : return tupleOf(d);
1383 case CHARCELL : return 0;
1385 case AP : switch (whatIs(fun(d))) {
1387 case ADDPAT : return 1;
1389 case EXT : return 2;
1394 case AP : return (whatIs(fun(d))==ADDPAT) ? 1 : 0;
1396 case AP : return 0; /* must be an Int or Float lit */
1400 internal("discrArity");
1401 return 0;/*NOTREACHED*/
1404 static Bool local eqNumDiscr(d1,d2) /* Determine whether two numeric */
1405 Cell d1, d2; { /* descriptors have same value */
1407 if (whatIs(fun(d1))==ADDPAT)
1408 return whatIs(fun(d2))==ADDPAT && snd(fun(d1))==snd(fun(d2));
1411 return isInt(arg(d2)) && intOf(arg(d1))==intOf(arg(d2));
1412 if (isFloat(arg(d1)))
1413 return isFloat(arg(d2)) && floatOf(arg(d1))==floatOf(arg(d2));
1415 if (isBignum(arg(d1)))
1416 return isBignum(arg(d2)) && bigCmp(arg(d1),arg(d2))==0;
1418 internal("eqNumDiscr");
1419 return FALSE;/*NOTREACHED*/
1423 static Bool local isExtDiscr(d) /* Test of extension discriminator */
1425 return isAp(d) && isExt(fun(d));
1428 static Bool local eqExtDiscr(d1,d2) /* Determine whether two extension */
1429 Cell d1, d2; { /* discriminators have same label */
1430 return fun(d1)==fun(d2);
1434 /*-------------------------------------------------------------------------*/
1438 /* --------------------------------------------------------------------------
1440 * ------------------------------------------------------------------------*/
1442 static Void local stgCGBinds( List );
1444 static Void local stgCGBinds(binds)
1449 /* --------------------------------------------------------------------------
1450 * Main entry points to compiler:
1451 * ------------------------------------------------------------------------*/
1453 static List addGlobals( List binds )
1455 /* stgGlobals = pieces of code generated for selectors, tuples, etc */
1456 for(;nonNull(stgGlobals);stgGlobals=tl(stgGlobals)) {
1457 StgVar bind = snd(hd(stgGlobals));
1458 if (nonNull(stgVarBody(bind))) {
1459 binds = cons(bind,binds);
1466 Void evalExp() { /* compile and run input expression */
1467 /* ToDo: this name (and other names generated during pattern match?)
1468 * get inserted in the symbol table but never get removed.
1470 Name n = newName(inventText(),NIL);
1472 StgVar v = mkStgVar(NIL,NIL);
1475 e = pmcTerm(0,NIL,translate(inputExpr));
1476 stgDefn(n,0,e); //ppStg(name(n).stgVar);
1478 stgCGBinds(addGlobals(singleton(v)));
1480 /* Run thread (and any other runnable threads) */
1482 /* Re-initialise the scheduler - ToDo: do I need this? */
1484 /* ToDo: don't really initScheduler every time. fix */
1486 HaskellObj result; /* ignored */
1487 SchedulerStatus status = rts_eval_(closureOfVar(v),10000,&result);
1490 case AllBlocked: /* I don't understand the distinction - ADR */
1491 printf("{Deadlock}");
1495 printf("{Interrupted}");
1505 internal("evalExp: Unrecognised SchedulerStatus");
1512 static List local addStgVar( List binds, Pair bind ); /* todo */
1514 static List local addStgVar( List binds, Pair bind )
1516 StgVar nv = mkStgVar(NIL,NIL);
1517 Text t = textOf(fst(bind));
1518 Name n = findName(t);
1519 //printf ( "addStgVar %s\n", textToStr(t));
1520 if (isNull(n)) { /* Lookup global name - the only way*/
1521 n = newName(t,NIL); /* this (should be able to happen) */
1522 } /* is with new global var introduced*/
1523 /* after type check; e.g. remPat1 */
1524 name(n).stgVar = nv;
1525 return cons(nv,binds);
1529 Void compileDefns() { /* compile script definitions */
1530 Target t = length(valDefns) + length(genDefns) + length(selDefns);
1534 /* a nasty hack. But I don't know an easier way to make */
1535 /* these things appear. */
1536 if (lastModule() == modulePrelude) {
1537 implementCfun ( nameCons, NIL );
1538 implementCfun ( nameNil, NIL );
1539 implementCfun ( nameUnit, NIL );
1545 for(vs=genDefns; nonNull(vs); vs=tl(vs)) {
1547 StgVar nv = mkStgVar(NIL,NIL);
1549 name(n).stgVar = nv;
1550 binds = cons(nv,binds);
1552 for(vss=selDefns; nonNull(vss); vss=tl(vss)) {
1553 for(vs=hd(vss); nonNull(vs); vs=tl(vs)) {
1556 StgVar nv = mkStgVar(NIL,NIL);
1558 name(n).stgVar = nv;
1559 binds = cons(nv,binds);
1564 setGoal("Compiling",t);
1565 /* do valDefns before everything else so that all stgVar's get added. */
1566 for (; nonNull(valDefns); valDefns=tl(valDefns)) {
1567 hd(valDefns) = transBinds(hd(valDefns));
1568 mapAccum(addStgVar,binds,hd(valDefns));
1569 mapProc(compileGlobalFunction,hd(valDefns));
1572 for (; nonNull(genDefns); genDefns=tl(genDefns)) {
1573 compileGenFunction(hd(genDefns));
1576 for (; nonNull(selDefns); selDefns=tl(selDefns)) {
1577 mapOver(compileSelFunction,hd(selDefns));
1581 /* binds=revOnto(binds,NIL); *//* ToDo: maintain compilation order?? */
1582 binds = addGlobals(binds);
1583 #if USE_HUGS_OPTIMIZER
1585 if (lastModule() != modulePrelude)
1586 mapProc(optimiseTopBind,binds);
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)));
1601 // printf ( "compileGlobalFunction %s\n", textToStr(name(n).text));
1603 // while (nonNull(cc)) {
1604 // printExp(stdout, fst(hd(cc)));
1605 // printf ( "\n = " );
1606 // printExp(stdout, snd(hd(cc)));
1610 // printf ( "\n\n\n" );
1614 stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1617 static Void local compileGenFunction(n) /* Produce code for internally */
1618 Name n; { /* generated function */
1619 List defs = name(n).defn;
1620 Int arity = length(fst(hd(defs)));
1623 // printf ( "compileGenFunction %s\n", textToStr(name(n).text));
1625 // while (nonNull(cc)) {
1626 // printExp(stdout, fst(hd(cc)));
1627 // printf ( "\n = " );
1628 // printExp(stdout, snd(hd(cc)));
1632 // printf ( "\n\n\n" );
1637 mapProc(transAlt,defs);
1638 stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1642 static Name local compileSelFunction(p) /* Produce code for selector func */
1643 Pair p; { /* Should be merged with genDefns, */
1644 Name s = fst(p); /* but the name(_).defn field is */
1645 List defs = snd(p); /* already used for other purposes */
1646 Int arity = length(fst(hd(defs))); /* in selector functions. */
1649 mapProc(transAlt,defs);
1650 stgDefn(s,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1655 /* --------------------------------------------------------------------------
1657 * ------------------------------------------------------------------------*/
1663 case RESET : freeVars = NIL;
1665 freeBegin = mkOffset(0);
1672 case MARK : mark(freeVars);
1679 /*-------------------------------------------------------------------------*/