1 /* -*- mode: hugs-c; -*- */
2 /* --------------------------------------------------------------------------
3 * Pattern matching Compiler
5 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
6 * All rights reserved. See NOTICE for details and conditions of use etc...
7 * Hugs version 1.4, December 1997
11 * $Date: 1998/12/02 13:22:29 $
12 * ------------------------------------------------------------------------*/
24 /* --------------------------------------------------------------------------
25 * Eliminate pattern matching in function definitions -- pattern matching
28 * The original Gofer/Hugs pattern matching compiler was based on Wadler's
29 * algorithms described in `Implementation of functional programming
30 * languages'. That should still provide a good starting point for anyone
31 * wanting to understand this part of the system. However, the original
32 * algorithm has been generalized and restructured in order to implement
33 * new features added in Haskell 1.3.
35 * During the translation, in preparation for later stages of compilation,
36 * all local and bound variables are replaced by suitable offsets, and
37 * locally defined function symbols are given new names (which will
38 * eventually be their names when lifted to make top level definitions).
39 * ------------------------------------------------------------------------*/
41 /* --------------------------------------------------------------------------
42 * Local function prototypes:
43 * ------------------------------------------------------------------------*/
45 static Cell local pmcPair Args((Int,List,Pair));
46 static Cell local pmcTriple Args((Int,List,Triple));
47 static Cell local pmcVar Args((List,Text));
48 static Void local pmcLetrec Args((Int,List,Pair));
49 static Cell local pmcVarDef Args((Int,List,List));
50 static Void local pmcFunDef Args((Int,List,Triple));
51 static Cell local joinMas Args((Int,List));
52 static Bool local canFail Args((Cell));
53 static List local addConTable Args((Cell,Cell,List));
54 static Void local advance Args((Int,Int,Cell));
55 static Bool local emptyMatch Args((Cell));
56 static Cell local maDiscr Args((Cell));
57 static Bool local isNumDiscr Args((Cell));
58 static Bool local eqNumDiscr Args((Cell,Cell));
60 static Bool local isExtDiscr Args((Cell));
61 static Bool local eqExtDiscr Args((Cell,Cell));
64 /* --------------------------------------------------------------------------
66 * ------------------------------------------------------------------------*/
68 Cell pmcTerm(co,sc,e) /* apply pattern matching compiler */
69 Int co; /* co = current offset */
70 List sc; /* sc = scope */
71 Cell e; { /* e = expr to transform */
73 case GUARDED : map2Over(pmcPair,co,sc,snd(e));
76 case LETREC : pmcLetrec(co,sc,snd(e));
81 case DICTVAR : return pmcVar(sc,textOf(e));
83 case COND : return ap(COND,pmcTriple(co,sc,snd(e)));
85 case AP : return pmcPair(co,sc,e);
101 default : internal("pmcTerm");
107 static Cell local pmcPair(co,sc,pr) /* apply pattern matching compiler */
108 Int co; /* to a pair of exprs */
111 return pair(pmcTerm(co,sc,fst(pr)),
112 pmcTerm(co,sc,snd(pr)));
115 static Cell local pmcTriple(co,sc,tr) /* apply pattern matching compiler */
116 Int co; /* to a triple of exprs */
119 return triple(pmcTerm(co,sc,fst3(tr)),
120 pmcTerm(co,sc,snd3(tr)),
121 pmcTerm(co,sc,thd3(tr)));
124 static Cell local pmcVar(sc,t) /* find translation of variable */
125 List sc; /* in current scope */
130 for (xs=sc; nonNull(xs); xs=tl(xs)) {
132 if (t==textOf(fst(x)))
133 if (isOffset(snd(x))) { /* local variable ... */
136 else { /* local function ... */
146 static Void local pmcLetrec(co,sc,e) /* apply pattern matching compiler */
147 Int co; /* to LETREC, splitting decls into */
148 List sc; /* two sections */
150 List fs = NIL; /* local function definitions */
151 List vs = NIL; /* local variable definitions */
154 for (ds=fst(e); nonNull(ds); ds=tl(ds)) { /* Split decls into two */
155 Cell v = fst(hd(ds));
156 Int arity = length(fst(hd(snd(hd(ds)))));
158 if (arity==0) { /* Variable declaration */
159 vs = cons(snd(hd(ds)),vs);
160 sc = cons(pair(v,mkOffset(++co)),sc);
162 else { /* Function declaration */
163 fs = cons(triple(inventVar(),mkInt(arity),snd(hd(ds))),fs);
164 sc = cons(pair(v,hd(fs)),sc);
167 vs = rev(vs); /* Put declaration lists back in */
168 fs = rev(fs); /* original order */
169 fst(e) = pair(vs,fs); /* Store declaration lists */
170 map2Over(pmcVarDef,co,sc,vs); /* Translate variable definitions */
171 map2Proc(pmcFunDef,co,sc,fs); /* Translate function definitions */
172 snd(e) = pmcTerm(co,sc,snd(e)); /* Translate LETREC body */
175 static Cell local pmcVarDef(co,sc,vd) /* apply pattern matching compiler */
176 Int co; /* to variable definition */
178 List vd; { /* vd :: [ ([], rhs) ] */
179 Cell d = snd(hd(vd));
180 if (nonNull(tl(vd)) && canFail(d))
181 return ap(FATBAR,pair(pmcTerm(co,sc,d),
182 pmcVarDef(co,sc,tl(vd))));
183 return pmcTerm(co,sc,d);
186 static Void local pmcFunDef(co,sc,fd) /* apply pattern matching compiler */
187 Int co; /* to function definition */
189 Triple fd; { /* fd :: (Var, Arity, [Alt]) */
190 Int arity = intOf(snd3(fd));
191 Cell temp = altsMatch(co+1,arity,sc,thd3(fd));
194 temp = match(co+arity,temp);
195 thd3(fd) = triple(NIL,NIL,temp); /* used to be freevar info */
199 /* ---------------------------------------------------------------------------
200 * Main part of pattern matching compiler: convert [Alt] to case constructs
202 * This section of Hugs has been almost completely rewritten to be more
203 * general, in particular, to allow pattern matching in orders other than the
204 * strictly left-to-right approach of the previous version. This is needed
205 * for the implementation of the so-called Haskell 1.3 `record' syntax.
207 * At each stage, the different branches for the cases to be considered
208 * are represented by a list of values of type:
209 * Match ::= { maPats :: [Pat], patterns to match
210 * maOffs :: [Offs], offsets of corresponding values
211 * maSc :: Scope, mapping from vars to offsets
212 * maRhs :: Rhs } right hand side
213 * [Implementation uses nested pairs, ((pats,offs),(sc,rhs)).]
215 * The Scope component has type:
216 * Scope ::= [(Var,Expr)]
217 * and provides a mapping from variable names to offsets used in the matching
220 * Matches can be normalized by reducing them to a form in which the list
221 * of patterns is empty (in which case the match itself is described as an
222 * empty match), or in which the list is non-empty and the first pattern is
223 * one that requires either a CASE or NUMCASE (or EXTCASE) to decompose.
224 * ------------------------------------------------------------------------*/
226 #define mkMatch(ps,os,sc,r) pair(pair(ps,os),pair(sc,r))
227 #define maPats(ma) fst(fst(ma))
228 #define maOffs(ma) snd(fst(ma))
229 #define maSc(ma) fst(snd(ma))
230 #define maRhs(ma) snd(snd(ma))
231 #define extSc(v,o,ma) maSc(ma) = cons(pair(v,o),maSc(ma))
233 List altsMatch(co,n,sc,as) /* Make a list of matches from list*/
234 Int co; /* of Alts, with initial offsets */
235 Int n; /* reverse (take n [co..]) */
241 us = cons(mkOffset(co++),us);
242 for (; nonNull(as); as=tl(as)) /* Each Alt is ([Pat], Rhs) */
243 mas = cons(mkMatch(fst(hd(as)),us,sc,snd(hd(as))),mas);
247 Cell match(co,mas) /* Generate case statement for Matches mas */
248 Int co; /* at current offset co */
249 List mas; { /* N.B. Assumes nonNull(mas). */
250 Cell srhs = NIL; /* Rhs for selected matches */
251 List smas = mas; /* List of selected matches */
255 if (emptyMatch(hd(smas))) { /* The case for empty matches: */
256 while (nonNull(mas) && emptyMatch(hd(mas))) {
262 srhs = joinMas(co,rev(smas));
264 else { /* Non-empty match */
265 Int o = offsetOf(hd(maOffs(hd(smas))));
266 Cell d = maDiscr(hd(smas));
267 if (isNumDiscr(d)) { /* Numeric match */
268 Int da = discrArity(d);
269 Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
270 while (nonNull(mas) && !emptyMatch(hd(mas))
271 && o==offsetOf(hd(maOffs(hd(mas))))
272 && isNumDiscr(d=maDiscr(hd(mas)))
273 && eqNumDiscr(d,d1)) {
280 map2Proc(advance,co,da,smas);
281 srhs = ap(NUMCASE,triple(mkOffset(o),d1,match(co+da,smas)));
284 else if (isExtDiscr(d)) { /* Record match */
285 Int da = discrArity(d);
286 Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
287 while (nonNull(mas) && !emptyMatch(hd(mas))
288 && o==offsetOf(hd(maOffs(hd(mas))))
289 && isExtDiscr(d=maDiscr(hd(mas)))
290 && eqExtDiscr(d,d1)) {
297 map2Proc(advance,co,da,smas);
298 srhs = ap(EXTCASE,triple(mkOffset(o),d1,match(co+da,smas)));
301 else { /* Constructor match */
302 List tab = addConTable(d,hd(smas),NIL);
304 while (nonNull(mas) && !emptyMatch(hd(mas))
305 && o==offsetOf(hd(maOffs(hd(mas))))
306 && !isNumDiscr(d=maDiscr(hd(mas)))) {
307 tab = addConTable(d,hd(mas),tab);
310 for (tab=rev(tab); nonNull(tab); tab=tl(tab)) {
314 map2Proc(advance,co,da,smas);
315 srhs = cons(pair(d,match(co+da,smas)),srhs);
317 srhs = ap(CASE,pair(mkOffset(o),srhs));
320 return nonNull(mas) ? ap(FATBAR,pair(srhs,match(co,mas))) : srhs;
323 static Cell local joinMas(co,mas) /* Combine list of matches into rhs*/
324 Int co; /* using FATBARs as necessary */
325 List mas; { /* Non-empty list of empty matches */
327 Cell rhs = pmcTerm(co,maSc(ma),maRhs(ma));
328 if (nonNull(tl(mas)) && canFail(rhs))
329 return ap(FATBAR,pair(rhs,joinMas(co,tl(mas))));
334 static Bool local canFail(rhs) /* Determine if expression (as rhs) */
335 Cell rhs; { /* might ever be able to fail */
336 switch (whatIs(rhs)) {
337 case LETREC : return canFail(snd(snd(rhs)));
338 case GUARDED : return TRUE; /* could get more sophisticated ..? */
339 default : return FALSE;
343 /* type Table a b = [(a, [b])]
345 * addTable :: a -> b -> Table a b -> Table a b
346 * addTable x y [] = [(x,[y])]
347 * addTable x y (z@(n,sws):zs)
348 * | n == x = (n,sws++[y]):zs
349 * | otherwise = (n,sws):addTable x y zs
352 static List local addConTable(x,y,tab) /* add element (x,y) to table */
356 return singleton(pair(x,singleton(y)));
357 else if (fst(hd(tab))==x)
358 snd(hd(tab)) = appendOnto(snd(hd(tab)),singleton(y));
360 tl(tab) = addConTable(x,y,tl(tab));
365 static Void local advance(co,a,ma) /* Advance non-empty match by */
366 Int co; /* processing head pattern */
367 Int a; /* discriminator arity */
369 Cell p = hd(maPats(ma));
370 List ps = tl(maPats(ma));
371 List us = tl(maOffs(ma));
372 if (whatIs(p)==CONFLDS) { /* Special case for record syntax */
373 Name c = fst(snd(p));
374 List fs = snd(snd(p));
377 for (; nonNull(fs); fs=tl(fs)) {
378 vs = cons(mkOffset(co+a+1-sfunPos(fst(hd(fs)),c)),vs);
379 qs = cons(snd(hd(fs)),qs);
384 else /* Normally just spool off patterns*/
385 for (; a>0; --a) { /* and corresponding offsets ... */
386 us = cons(mkOffset(++co),us);
387 ps = cons(arg(p),ps);
395 /* --------------------------------------------------------------------------
396 * Normalize and test for empty match:
397 * ------------------------------------------------------------------------*/
399 static Bool local emptyMatch(ma)/* Normalize and test to see if a given */
400 Cell ma; { /* match, ma, is empty. */
402 while (nonNull(maPats(ma))) {
404 tidyHd: switch (whatIs(p=hd(maPats(ma)))) {
405 case LAZYPAT : { Cell nv = inventVar();
406 maRhs(ma) = ap(LETREC,
407 pair(remPat(snd(p),nv,NIL),
411 /* intentional fall-thru */
414 case DICTVAR : extSc(p,hd(maOffs(ma)),ma);
415 case WILDCARD : maPats(ma) = tl(maPats(ma));
416 maOffs(ma) = tl(maOffs(ma));
419 /* So-called "as-patterns"are really just pattern intersections:
420 * (p1@p2:ps, o:os, sc, e) ==> (p1:p2:ps, o:o:os, sc, e)
421 * (But the input grammar probably doesn't let us take
422 * advantage of this, so we stick with the special case
423 * when p1 is a variable.)
425 case ASPAT : extSc(fst(snd(p)),hd(maOffs(ma)),ma);
426 hd(maPats(ma)) = snd(snd(p));
429 case FINLIST : hd(maPats(ma)) = mkConsList(snd(p));
432 case STRCELL : { String s = textToStr(textOf(p));
433 for (p=NIL; *s!='\0'; ++s) {
434 if (*s!='\\' || *++s=='\\') {
435 p = ap2(nameCons,mkChar(*s),p);
437 p = ap2(nameCons,mkChar('\0'),p);
440 hd(maPats(ma)) = revOnto(p,nameNil);
444 case AP : if (isName(fun(p)) && isCfun(fun(p))
446 && name(fun(p)).defn==nameId) {
447 hd(maPats(ma)) = arg(p);
450 /* intentional fall-thru */
452 #if !OVERLOADED_CONSTANTS
461 default : internal("emptyMatch");
467 /* --------------------------------------------------------------------------
469 * ------------------------------------------------------------------------*/
471 static Cell local maDiscr(ma) /* Get the discriminator for a non-empty */
472 Cell ma; { /* match, ma. */
473 Cell p = hd(maPats(ma));
476 case CONFLDS : return fst(snd(p));
478 case ADDPAT : arg(fun(p)) = translate(arg(fun(p)));
482 case EXT : h = fun(fun(p));
483 arg(h) = translate(arg(h));
486 #if OVERLOADED_CONSTANTS
487 case NAME : if (h==nameFromInt || h==nameFromInteger
488 || h==nameFromDouble) {
490 arg(fun(p)) = translate(arg(fun(p)));
498 static Bool local isNumDiscr(d) /* TRUE => numeric discriminator */
503 case CHARCELL : return FALSE;
504 #if OVERLOADED_CONSTANTS
506 case AP : return !isExt(fun(d));
508 case AP : return TRUE; /* must be a literal or (n+k) */
517 internal("isNumDiscr");
518 return 0;/*NOTREACHED*/
521 Int discrArity(d) /* Find arity of discriminator */
524 case NAME : return name(d).arity;
525 case TUPLE : return tupleOf(d);
526 case CHARCELL : return 0;
527 #if !OVERLOADED_CONSTANTS
530 case FLOATCELL : return 0;
531 #endif /* !OVERLOADED_CONSTANTS */
534 case AP : switch (whatIs(fun(d))) {
536 case ADDPAT : return 1;
543 case AP : return (whatIs(fun(d))==ADDPAT) ? 1 : 0;
545 case AP : return 0; /* must be an Int or Float lit */
549 internal("discrArity");
550 return 0;/*NOTREACHED*/
553 static Bool local eqNumDiscr(d1,d2) /* Determine whether two numeric */
554 Cell d1, d2; { /* descriptors have same value */
556 if (whatIs(fun(d1))==ADDPAT)
557 return whatIs(fun(d2))==ADDPAT && bignumEq(snd(fun(d1)),snd(fun(d2)));
559 #if OVERLOADED_CONSTANTS
564 return isInt(d2) && intEq(d1,d2);
566 return isFloat(d2) && floatEq(d1,d2);
568 return isBignum(d2) && bignumEq(d1,d2);
569 internal("eqNumDiscr");
570 return FALSE;/*NOTREACHED*/
574 static Bool local isExtDiscr(d) /* Test of extension discriminator */
576 return isAp(d) && isExt(fun(d));
579 static Bool local eqExtDiscr(d1,d2) /* Determine whether two extension */
580 Cell d1, d2; { /* discriminators have same label */
581 return fun(d1)==fun(d2);
585 /*-------------------------------------------------------------------------*/