53f37080c7037843b27e35cdd2e990318dba846d
[ghc-hetmet.git] / ghc / interpreter / compiler.c
1
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).
6  *
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.
12  *
13  * $RCSfile: compiler.c,v $
14  * $Revision: 1.23 $
15  * $Date: 2000/03/15 23:27:16 $
16  * ------------------------------------------------------------------------*/
17
18 #include "prelude.h"
19 #include "storage.h"
20 #include "connect.h"
21 #include "errors.h"
22
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                   */
26 #include "Schedule.h"
27
28 /* --------------------------------------------------------------------------
29  * Local function prototypes:
30  * ------------------------------------------------------------------------*/
31
32 static Cell local translate             ( Cell );
33 static Void local transPair             ( Pair );
34 static Void local transTriple           ( Triple );
35 static Void local transAlt              ( Cell );
36 static Void local transCase             ( Cell );
37 static List local transBinds            ( List );
38 static Cell local transRhs              ( Cell );
39 static Cell local mkConsList            ( List );
40 static Cell local expandLetrec          ( Cell );
41 static Cell local transComp             ( Cell,List,Cell );
42 static Cell local transDo               ( Cell,Cell,List );
43 static Cell local transConFlds          ( Cell,List );
44 static Cell local transUpdFlds          ( Cell,List,List );
45
46 static Cell local refutePat             ( Cell );
47 static Cell local refutePatAp           ( Cell );
48 static Cell local matchPat              ( Cell );
49 static List local remPat                ( Cell,Cell,List );
50 static List local remPat1               ( Cell,Cell,List );
51
52 static Cell local pmcTerm               ( Int,List,Cell );
53 static Cell local pmcPair               ( Int,List,Pair );
54 static Cell local pmcTriple             ( Int,List,Triple );
55 static Cell local pmcVar                ( List,Text );
56 static Void local pmcLetrec             ( Int,List,Pair );
57 static Cell local pmcVarDef             ( Int,List,List );
58 static Void local pmcFunDef             ( Int,List,Triple );
59 static List local altsMatch             ( Int,Int,List,List );
60 static Cell local match                 ( Int,List );
61 static Cell local joinMas               ( Int,List );
62 static Bool local canFail               ( Cell );
63 static List local addConTable           ( Cell,Cell,List );
64 static Void local advance               ( Int,Int,Cell );
65 static Bool local emptyMatch            ( Cell );
66 static Cell local maDiscr               ( Cell );
67 static Bool local isNumDiscr            ( Cell );
68 static Bool local eqNumDiscr            ( Cell,Cell );
69 #if TREX
70 static Bool local isExtDiscr            ( Cell );
71 static Bool local eqExtDiscr            ( Cell,Cell );
72 #endif
73
74 static Void local compileGlobalFunction ( Pair );
75 static Void local compileGenFunction    ( Name );
76 static Name local compileSelFunction    ( Pair );
77 static List local addStgVar             ( List,Pair );
78
79 static Name currentName;               /* Top level name being processed   */
80 static Int  lineNumber = 0;            /* previously discarded line number */
81
82 /* --------------------------------------------------------------------------
83  * Translation:    Convert input expressions into a less complex language
84  *                 of terms using only LETREC, AP, constants and vars.
85  *                 Also remove pattern definitions on lhs of eqns.
86  * ------------------------------------------------------------------------*/
87
88 static Cell local translate(e)         /* Translate expression:            */
89 Cell e; {
90 #if 0
91     printf ( "translate: " );print(e,100);printf("\n");
92 #endif
93     switch (whatIs(e)) {
94         case LETREC     : snd(snd(e)) = translate(snd(snd(e)));
95                           return expandLetrec(e);
96
97         case COND       : transTriple(snd(e));
98                           return e;
99
100         case AP         : fst(e) = translate(fst(e));
101
102           /* T [id <exp>]        ==> T[<exp>]
103            * T [indirect <exp> ] ==> T[<exp>]
104            */
105                           if (fst(e)==nameId || fst(e)==nameInd)
106                               return translate(snd(e));
107                           if (isName(fst(e)) &&
108                               isMfun(fst(e)) &&
109                               mfunOf(fst(e))==0)
110                               return translate(snd(e));
111
112                           snd(e) = translate(snd(e));
113
114                           return e;
115
116         case NAME       : 
117
118           /* T [otherwise] ==> True
119            */
120
121                            if (e==nameOtherwise)
122                               return nameTrue;
123           /* T [assert]    ==> T[assertError "<location info>"]
124            */
125                            if (flagAssert && e==nameAssert) {
126                              Cell str = errAssert(lineNumber);
127                              return (ap(nameAssertError,str));
128                            }
129
130                           if (isCfun(e)) {
131                               if (isName(name(e).defn))
132                                   return name(e).defn;
133                               if (isPair(name(e).defn))
134                                   return snd(name(e).defn);
135                           }
136                           return e;
137
138 #if TREX
139         case RECSEL     : return nameRecSel;
140
141         case EXT        :
142 #endif
143         case TUPLE      :
144         case VAROPCELL  :
145         case VARIDCELL  :
146         case DICTVAR    :
147         case INTCELL    :
148         case FLOATCELL  :
149         case STRCELL    :
150         case BIGCELL    :
151         case CHARCELL   : return e;
152 #if IPARAM
153         case IPVAR      : return nameId;
154 #endif
155         case FINLIST    : mapOver(translate,snd(e));
156                           return mkConsList(snd(e));
157
158         case DOCOMP     : {   Cell m = translate(fst(snd(e)));
159                               Cell r = translate(fst(snd(snd(e))));
160                               return transDo(m,r,snd(snd(snd(e))));
161                           }
162
163         case MONADCOMP  : {   Cell m  = translate(fst(snd(e)));
164                               Cell r  = translate(fst(snd(snd(e))));
165                               Cell qs = snd(snd(snd(e)));
166                               if (m == nameListMonad)
167                                   return transComp(r,qs,nameNil);
168                               else {
169 #if MONAD_COMPS
170                                   r = ap(ap(nameReturn,m),r);
171                                   return transDo(m,r,qs);
172 #else
173                                   internal("translate: monad comps");
174 #endif
175                               }
176                           }
177
178         case CONFLDS    : return transConFlds(fst(snd(e)),snd(snd(e)));
179
180         case UPDFLDS    : return transUpdFlds(fst3(snd(e)),
181                                               snd3(snd(e)),
182                                               thd3(snd(e)));
183
184         case CASE       : {   Cell nv = inventVar();
185                               mapProc(transCase,snd(snd(e)));
186                               return ap(LETREC,
187                                         pair(singleton(pair(nv,snd(snd(e)))),
188                                              ap(nv,translate(fst(snd(e))))));
189                           }
190
191         case LAMBDA     : {   Cell nv = inventVar();
192                               transAlt(snd(e));
193                               return ap(LETREC,
194                                         pair(singleton(pair(
195                                                         nv,
196                                                         singleton(snd(e)))),
197                                              nv));
198                           }
199
200         default         : fprintf(stderr, "stuff=%d\n",whatIs(e));
201                           internal("translate");
202     }
203     return e;
204 }
205
206 static Void local transPair(pr)        /* Translate each component in a    */
207 Pair pr; {                             /* pair of expressions.             */
208     fst(pr) = translate(fst(pr));
209     snd(pr) = translate(snd(pr));
210 }
211
212 static Void local transTriple(tr)      /* Translate each component in a    */
213 Triple tr; {                           /* triple of expressions.           */
214     fst3(tr) = translate(fst3(tr));
215     snd3(tr) = translate(snd3(tr));
216     thd3(tr) = translate(thd3(tr));
217 }
218
219 static Void local transAlt(e)          /* Translate alt:                   */
220 Cell e; {                              /* ([Pat], Rhs) ==> ([Pat], Rhs')   */
221 #if 0
222     printf ( "transAlt:  " );print(snd(e),100);printf("\n");
223 #endif
224     snd(e) = transRhs(snd(e));
225 }
226
227 static Void local transCase(c)         /* Translate case:                  */
228 Cell c; {                              /* (Pat, Rhs) ==> ([Pat], Rhs')     */
229     fst(c) = singleton(fst(c));
230     snd(c) = transRhs(snd(c));
231 }
232
233 static List local transBinds(bs)        /* Translate list of bindings:     */
234 List bs; {                              /* eliminating pattern matching on */
235     List newBinds = NIL;                /* lhs of bindings.                */
236     for (; nonNull(bs); bs=tl(bs)) {
237 #if IPARAM
238         Cell v = fst(hd(bs));
239         while (isAp(v) && fst(v) == nameInd)
240             v = arg(v);
241         fst(hd(bs)) = v;
242         if (isVar(v)) {
243 #else
244         if (isVar(fst(hd(bs)))) {
245 #endif
246             mapProc(transAlt,snd(hd(bs)));
247             newBinds = cons(hd(bs),newBinds);
248         }
249         else
250             newBinds = remPat(fst(snd(hd(bs))),
251                               snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))),
252                               newBinds);
253     }
254     return newBinds;
255 }
256
257 static Cell local transRhs(rhs)        /* Translate rhs: removing line nos */
258 Cell rhs; {
259     switch (whatIs(rhs)) {
260         case LETREC  : snd(snd(rhs)) = transRhs(snd(snd(rhs)));
261                        return expandLetrec(rhs);
262
263         case GUARDED : mapOver(snd,snd(rhs));       /* discard line number */
264                        mapProc(transPair,snd(rhs));
265                        return rhs;
266
267         default      : {
268                          Cell tmp;
269                          Int prev = lineNumber;
270                          lineNumber = intOf(fst(rhs));
271                          tmp = translate(snd(rhs));  /* discard line number */
272                          lineNumber = prev;
273                          return tmp;
274                        }
275     }
276 }
277
278 static Cell local mkConsList(es)       /* Construct expression for list es */
279 List es; {                             /* using nameNil and nameCons       */
280     if (isNull(es))
281         return nameNil;
282     else
283         return ap(ap(nameCons,hd(es)),mkConsList(tl(es)));
284 }
285
286 static Cell local expandLetrec(root)   /* translate LETREC with list of    */
287 Cell root; {                           /* groups of bindings (from depend. */
288     Cell e   = snd(snd(root));         /* analysis) to use nested LETRECs  */
289     List bss = fst(snd(root));
290     Cell temp;
291
292     if (isNull(bss))                   /* should never happen, but just in */
293         return e;                      /* case:  LETREC [] IN e  ==>  e    */
294
295     mapOver(transBinds,bss);           /* translate each group of bindings */
296
297     for (temp=root; nonNull(tl(bss)); bss=tl(bss)) {
298         fst(snd(temp)) = hd(bss);
299         snd(snd(temp)) = ap(LETREC,pair(NIL,e));
300         temp           = snd(snd(temp));
301     }
302     fst(snd(temp)) = hd(bss);
303
304     return root;
305 }
306
307 /* --------------------------------------------------------------------------
308  * Translation of list comprehensions is based on the description in
309  * `The Implementation of Functional Programming Languages':
310  *
311  * [ e | qs ] ++ l            => transComp e qs l
312  * transComp e []           l => e : l
313  * transComp e ((p<-xs):qs) l => LETREC _h []      = l
314  *                                      _h (p:_xs) = transComp e qs (_h _xs)
315  *                                      _h (_:_xs) = _h _xs --if p !failFree
316  *                               IN _h xs
317  * transComp e (b:qs)       l => if b then transComp e qs l else l
318  * transComp e (decls:qs)   l => LETREC decls IN transComp e qs l
319  * ------------------------------------------------------------------------*/
320
321 static Cell local transComp(e,qs,l)    /* Translate [e | qs] ++ l          */
322 Cell e;
323 List qs;
324 Cell l; {
325     if (nonNull(qs)) {
326         Cell q   = hd(qs);
327         Cell qs1 = tl(qs);
328
329         switch (fst(q)) {
330             case FROMQUAL : {   Cell ld    = NIL;
331                                 Cell hVar  = inventVar();
332                                 Cell xsVar = inventVar();
333
334                                 if (!failFree(fst(snd(q))))
335                                     ld = cons(pair(singleton(
336                                                     ap(ap(nameCons,
337                                                           WILDCARD),
338                                                           xsVar)),
339                                                    ap(hVar,xsVar)),
340                                               ld);
341
342                                 ld = cons(pair(singleton(
343                                                 ap(ap(nameCons,
344                                                       fst(snd(q))),
345                                                       xsVar)),
346                                                transComp(e,
347                                                          qs1,
348                                                          ap(hVar,xsVar))),
349                                           ld);
350                                 ld = cons(pair(singleton(nameNil),
351                                                l),
352                                           ld);
353
354                                 return ap(LETREC,
355                                           pair(singleton(pair(hVar,
356                                                               ld)),
357                                                ap(hVar,
358                                                   translate(snd(snd(q))))));
359                             }
360
361             case QWHERE   : return
362                                 expandLetrec(ap(LETREC,
363                                                 pair(snd(q),
364                                                      transComp(e,qs1,l))));
365
366             case BOOLQUAL : return ap(COND,
367                                       triple(translate(snd(q)),
368                                              transComp(e,qs1,l),
369                                              l));
370         }
371     }
372
373     return ap(ap(nameCons,e),l);
374 }
375
376 /* --------------------------------------------------------------------------
377  * Translation of monad comprehensions written using do-notation:
378  *
379  * do { e }               =>  e
380  * do { p <- exp; qs }    =>  LETREC _h p = do { qs }
381  *                                   _h _ = fail m "match fails"
382  *                            IN bind m exp _h
383  * do { LET decls; qs }   =>  LETREC decls IN do { qs }
384  * do { IF guard; qs }    =>  if guard then do { qs } else fail m  "guard fails"
385  * do { e; qs }           =>  LETREC _h _ = [ e | qs ] in bind m exp _h
386  *
387  * where m :: Monad f
388  * ------------------------------------------------------------------------*/
389
390 static Cell local transDo(m,e,qs)       /* Translate do { qs ; e }         */
391 Cell m;
392 Cell e;
393 List qs; {
394     if (nonNull(qs)) {
395         Cell q   = hd(qs);
396         Cell qs1 = tl(qs);
397
398         switch (fst(q)) {
399             case FROMQUAL : {   Cell ld   = NIL;
400                                 Cell hVar = inventVar();
401
402                                 if (!failFree(fst(snd(q)))) {
403                                     Cell str = mkStr(findText("match fails"));
404                                     ld = cons(pair(singleton(WILDCARD),
405                                                    ap2(nameMFail,m,str)),
406                                               ld);
407                                 }
408
409                                 ld = cons(pair(singleton(fst(snd(q))),
410                                                transDo(m,e,qs1)),
411                                           ld);
412
413                                 return ap(LETREC,
414                                           pair(singleton(pair(hVar,ld)),
415                                                ap(ap(ap(nameBind,
416                                                         m),
417                                                      translate(snd(snd(q)))),
418                                                   hVar)));
419                             }
420
421             case DOQUAL :   {   Cell hVar = inventVar();
422                                 Cell ld   = cons(pair(singleton(WILDCARD),
423                                                       transDo(m,e,qs1)),
424                                                  NIL);
425                                 return ap(LETREC,
426                                           pair(singleton(pair(hVar,ld)),
427                                                ap(ap(ap(nameBind,
428                                                         m),
429                                                      translate(snd(q))),
430                                                   hVar)));
431                             }
432
433             case QWHERE   : return
434                                 expandLetrec(ap(LETREC,
435                                                 pair(snd(q),
436                                                      transDo(m,e,qs1))));
437
438             case BOOLQUAL : return
439                                 ap(COND,
440                                    triple(translate(snd(q)),
441                                           transDo(m,e,qs1),
442                                           ap2(nameMFail,m,
443                                             mkStr(findText("guard fails")))));
444         }
445     }
446     return e;
447 }
448
449 /* --------------------------------------------------------------------------
450  * Translation of named field construction and update:
451  *
452  * Construction is implemented using the following transformation:
453  *
454  *   C{x1=e1, ..., xn=en} =  C v1 ... vm
455  * where:
456  *   vi = e1,        if the ith component of C is labelled with x1
457  *       ...
458  *      = en,        if the ith component of C is labelled with xn
459  *      = undefined, otherwise
460  *
461  * Update is implemented using the following transformation:
462  *
463  *   e{x1=e1, ..., xn=en}
464  *      =  let nv (C a1 ... am) v1 ... vn = C a1' .. am'
465  *             nv (D b1 ... bk) v1 ... vn = D b1' .. bk
466  *             ...
467  *             nv _             v1 ... vn = error "failed update"
468  *         in nv e e1 ... en
469  * where:
470  *   nv, v1, ..., vn, a1, ..., am, b1, ..., bk, ... are new variables,
471  *   C,D,... = { K | K is a constr fun s.t. {x1,...,xn} subset of sels(K)}
472  * and:
473  *   ai' = v1,   if the ith component of C is labelled with x1
474  *       ...
475  *       = vn,   if the ith component of C is labelled with xn
476  *       = ai,   otherwise
477  *  etc...
478  *
479  * The error case may be omitted if C,D,... is an enumeration of all of the
480  * constructors for the datatype concerned.  Strictly speaking, error case
481  * isn't needed at all -- the only benefit of including it is that the user
482  * will get a "failed update" message rather than a cryptic {v354 ...}.
483  * So, for now, we'll go with the second option!
484  *
485  * For the time being, code for each update operation is generated
486  * independently of any other updates.  However, if updates are used
487  * frequently, then we might want to consider changing the implementation
488  * at a later stage to cache definitions of functions like nv above.  This
489  * would create a shared library of update functions, indexed by a set of
490  * constructors {C,D,...}.
491  * ------------------------------------------------------------------------*/
492
493 static Cell local transConFlds(c,flds)  /* Translate C{flds}               */
494 Name c;
495 List flds; {
496     Cell e = c;
497     Int  m = name(c).arity;
498     Int  i;
499     for (i=m; i>0; i--)
500         e = ap(e,nameUndefined);
501     for (; nonNull(flds); flds=tl(flds)) {
502         Cell a = e;
503         for (i=m-sfunPos(fst(hd(flds)),c); i>0; i--)
504             a = fun(a);
505         arg(a) = translate(snd(hd(flds)));
506     }
507     return e;
508 }
509
510 static Cell local transUpdFlds(e,cs,flds)/* Translate e{flds}              */
511 Cell e;                                 /* (cs is corresp list of constrs) */
512 List cs;
513 List flds; {
514     Cell nv   = inventVar();
515     Cell body = ap(nv,translate(e));
516     List fs   = flds;
517     List args = NIL;
518     List alts = NIL;
519
520     for (; nonNull(fs); fs=tl(fs)) {    /* body = nv e1 ... en             */
521         Cell b = hd(fs);                /* args = [v1, ..., vn]            */
522         body   = ap(body,translate(snd(b)));
523         args   = cons(inventVar(),args);
524     }
525
526     for (; nonNull(cs); cs=tl(cs)) {    /* Loop through constructors to    */
527         Cell c   = hd(cs);              /* build up list of alts.          */
528         Cell pat = c;
529         Cell rhs = c;
530         List as  = args;
531         Int  m   = name(c).arity;
532         Int  i;
533
534         for (i=m; i>0; i--) {           /* pat  = C a1 ... am              */
535             Cell a = inventVar();       /* rhs  = C a1 ... am              */
536             pat    = ap(pat,a);
537             rhs    = ap(rhs,a);
538         }
539
540         for (fs=flds; nonNull(fs); fs=tl(fs), as=tl(as)) {
541             Name s = fst(hd(fs));       /* Replace approp ai in rhs with   */
542             Cell r = rhs;               /* vars from [v1,...,vn]           */
543             for (i=m-sfunPos(s,c); i>0; i--)
544                 r = fun(r);
545             arg(r) = hd(as);
546         }
547
548         alts     = cons(pair(cons(pat,args),rhs),alts);
549     }
550     return ap(LETREC,pair(singleton(pair(nv,alts)),body));
551 }
552
553 /* --------------------------------------------------------------------------
554  * Elimination of pattern bindings:
555  *
556  * The following code adopts the definition of failure free patterns as given
557  * in the Haskell 1.3 report; the term "irrefutable" is also used there for
558  * a subset of the failure free patterns described here, but has no useful
559  * role in this implementation.  Basically speaking, the failure free patterns
560  * are:         variable, wildcard, ~apat
561  *              var@apat,               if apat is failure free
562  *              C apat1 ... apatn       if C is a product constructor
563  *                                      (i.e. an only constructor) and
564  *                                      apat1,...,apatn are failure free
565  * Note that the last case automatically covers the case where C comes from
566  * a newtype construction.
567  * ------------------------------------------------------------------------*/
568
569 Bool failFree(pat)                /* is pattern failure free? (do we need  */
570 Cell pat; {                       /* a conformality check?)                */
571     Cell c = getHead(pat);
572
573     switch (whatIs(c)) {
574         case ASPAT     : return failFree(snd(snd(pat)));
575
576         case NAME      : if (!isCfun(c) || cfunOf(c)!=0)
577                              return FALSE;
578                          /*intentional fall-thru*/
579         case TUPLE     : for (; isAp(pat); pat=fun(pat))
580                              if (!failFree(arg(pat)))
581                                 return FALSE;
582                          /*intentional fall-thru*/
583         case LAZYPAT   :
584         case VAROPCELL :
585         case VARIDCELL :
586         case DICTVAR   :
587         case WILDCARD  : return TRUE;
588
589 #if TREX
590         case EXT       : return failFree(extField(pat)) &&
591                                 failFree(extRow(pat));
592 #endif
593
594         case CONFLDS   : if (cfunOf(fst(snd(c)))==0) {
595                              List fs = snd(snd(c));
596                              for (; nonNull(fs); fs=tl(fs))
597                                  if (!failFree(snd(hd(fs))))
598                                      return FALSE;
599                              return TRUE;
600                          }
601                          /*intentional fall-thru*/
602         default        : return FALSE;
603     }
604 }
605
606 static Cell local refutePat(pat)  /* find pattern to refute in conformality*/
607 Cell pat; {                       /* test with pat.                        */
608                                   /* e.g. refPat  (x:y) == (_:_)           */
609                                   /*      refPat ~(x:y) == _      etc..    */
610
611     switch (whatIs(pat)) {
612         case ASPAT     : return refutePat(snd(snd(pat)));
613
614         case FINLIST   : {   Cell ys = snd(pat);
615                              Cell xs = NIL;
616                              for (; nonNull(ys); ys=tl(ys))
617                                  xs = ap(ap(nameCons,refutePat(hd(ys))),xs);
618                              return revOnto(xs,nameNil);
619                          }
620
621         case CONFLDS   : {   Cell ps = NIL;
622                              Cell fs = snd(snd(pat));
623                              for (; nonNull(fs); fs=tl(fs)) {
624                                  Cell p = refutePat(snd(hd(fs)));
625                                  ps     = cons(pair(fst(hd(fs)),p),ps);
626                              }
627                              return pair(CONFLDS,pair(fst(snd(pat)),rev(ps)));
628                          }
629
630         case VAROPCELL :
631         case VARIDCELL :
632         case DICTVAR   :
633         case WILDCARD  :
634         case LAZYPAT   : return WILDCARD;
635
636         case STRCELL   :
637         case CHARCELL  :
638         case ADDPAT    :
639         case TUPLE     :
640         case NAME      : return pat;
641
642         case AP        : return refutePatAp(pat);
643
644         default        : internal("refutePat");
645                          return NIL; /*NOTREACHED*/
646     }
647 }
648
649 static Cell local refutePatAp(p)  /* find pattern to refute in conformality*/
650 Cell p; {
651     Cell h = getHead(p);
652     if (h==nameFromInt || h==nameFromInteger || h==nameFromDouble)
653         return p;
654     else if (whatIs(h)==ADDPAT)
655         return ap(fun(p),refutePat(arg(p)));
656 #if TREX
657     else if (isExt(h)) {
658         Cell pf = refutePat(extField(p));
659         Cell pr = refutePat(extRow(p));
660         return ap(ap(fun(fun(p)),pf),pr);
661     }
662 #endif
663     else {
664         List as = getArgs(p);
665         mapOver(refutePat,as);
666         return applyToArgs(h,as);
667     }
668 }
669
670 static Cell local matchPat(pat) /* find pattern to match against           */
671 Cell pat; {                     /* replaces parts of pattern that do not   */
672                                 /* include variables with wildcards        */
673     switch (whatIs(pat)) {
674         case ASPAT     : {   Cell p = matchPat(snd(snd(pat)));
675                              return (p==WILDCARD) ? fst(snd(pat))
676                                                   : ap(ASPAT,
677                                                        pair(fst(snd(pat)),p));
678                          }
679
680         case FINLIST   : {   Cell ys = snd(pat);
681                              Cell xs = NIL;
682                              for (; nonNull(ys); ys=tl(ys))
683                                  xs = cons(matchPat(hd(ys)),xs);
684                              while (nonNull(xs) && hd(xs)==WILDCARD)
685                                  xs = tl(xs);
686                              for (ys=nameNil; nonNull(xs); xs=tl(xs))
687                                  ys = ap(ap(nameCons,hd(xs)),ys);
688                              return ys;
689                          }
690
691         case CONFLDS   : {   Cell ps   = NIL;
692                              Name c    = fst(snd(pat));
693                              Cell fs   = snd(snd(pat));
694                              Bool avar = FALSE;
695                              for (; nonNull(fs); fs=tl(fs)) {
696                                  Cell p = matchPat(snd(hd(fs)));
697                                  ps     = cons(pair(fst(hd(fs)),p),ps);
698                                  if (p!=WILDCARD)
699                                      avar = TRUE;
700                              }
701                              return avar ? pair(CONFLDS,pair(c,rev(ps)))
702                                          : WILDCARD;
703                          }
704
705         case VAROPCELL :
706         case VARIDCELL :
707         case DICTVAR   : return pat;
708
709         case LAZYPAT   : {   Cell p = matchPat(snd(pat));
710                              return (p==WILDCARD) ? WILDCARD : ap(LAZYPAT,p);
711                          }
712
713         case WILDCARD  :
714         case STRCELL   :
715         case CHARCELL  : return WILDCARD;
716
717         case TUPLE     :
718         case NAME      :
719         case AP        : {   Cell h = getHead(pat);
720                              if (h==nameFromInt     ||
721                                  h==nameFromInteger || h==nameFromDouble)
722                                  return WILDCARD;
723                              else if (whatIs(h)==ADDPAT)
724                                  return pat;
725 #if TREX
726                              else if (isExt(h)) {
727                                  Cell pf = matchPat(extField(pat));
728                                  Cell pr = matchPat(extRow(pat));
729                                  return (pf==WILDCARD && pr==WILDCARD)
730                                           ? WILDCARD
731                                           : ap(ap(fun(fun(pat)),pf),pr);
732                              }
733 #endif
734                              else {
735                                  List args = NIL;
736                                  Bool avar = FALSE;
737                                  for (; isAp(pat); pat=fun(pat)) {
738                                      Cell p = matchPat(arg(pat));
739                                      if (p!=WILDCARD)
740                                          avar = TRUE;
741                                      args = cons(p,args);
742                                  }
743                                  return avar ? applyToArgs(pat,args)
744                                              : WILDCARD;
745                              }
746                          }
747
748         default        : internal("matchPat");
749                          return NIL; /*NOTREACHED*/
750     }
751 }
752
753 #define addEqn(v,val,lds)  cons(pair(v,singleton(pair(NIL,val))),lds)
754
755 static List local remPat(pat,expr,lds)
756 Cell pat;                         /* Produce list of definitions for eqn   */
757 Cell expr;                        /* pat = expr, including a conformality  */
758 List lds; {                       /* check if required.                    */
759
760     /* Conformality test (if required):
761      *   pat = expr  ==>    nv = LETREC confCheck nv@pat = nv
762      *                           IN confCheck expr
763      *                      remPat1(pat,nv,.....);
764      */
765
766     if (!failFree(pat)) {
767         Cell confVar = inventVar();
768         Cell nv      = inventVar();
769         Cell locfun  = pair(confVar,         /* confVar [([nv@refPat],nv)] */
770                             singleton(pair(singleton(ap(ASPAT,
771                                                         pair(nv,
772                                                              refutePat(pat)))),
773                                            nv)));
774
775         if (whatIs(expr)==GUARDED) {         /* A spanner ... special case */
776             lds  = addEqn(nv,expr,lds);      /* for guarded pattern binding*/
777             expr = nv;
778             nv   = inventVar();
779         }
780
781         if (whatIs(pat)==ASPAT) {            /* avoid using new variable if*/
782             nv   = fst(snd(pat));            /* a variable is already given*/
783             pat  = snd(snd(pat));            /* by an as-pattern           */
784         }
785
786         lds = addEqn(nv,                                /* nv =            */
787                      ap(LETREC,pair(singleton(locfun),  /* LETREC [locfun] */
788                                     ap(confVar,expr))), /* IN confVar expr */
789                      lds);
790
791         return remPat1(matchPat(pat),nv,lds);
792     }
793
794     return remPat1(matchPat(pat),expr,lds);
795 }
796
797 static List local remPat1(pat,expr,lds)
798 Cell pat;                         /* Add definitions for: pat = expr to    */
799 Cell expr;                        /* list of local definitions in lds.     */
800 List lds; {
801     Cell c = getHead(pat);
802
803     switch (whatIs(c)) {
804         case WILDCARD  :
805         case STRCELL   :
806         case CHARCELL  : break;
807
808         case ASPAT     : return remPat1(snd(snd(pat)),     /* v@pat = expr */
809                                         fst(snd(pat)),
810                                         addEqn(fst(snd(pat)),expr,lds));
811
812         case LAZYPAT   : {   Cell nv;
813
814                              if (isVar(expr) || isName(expr))
815                                  nv  = expr;
816                              else {
817                                  nv  = inventVar();
818                                  lds = addEqn(nv,expr,lds);
819                              }
820
821                              return remPat(snd(pat),nv,lds);
822                          }
823
824         case ADDPAT    : return remPat1(arg(pat),       /* n + k = expr */
825                                         ap(ap(ap(namePmSub,
826                                                  arg(fun(pat))),
827                                                  mkInt(snd(fun(fun(pat))))),
828                                                  expr),
829                                         lds);
830
831         case FINLIST   : return remPat1(mkConsList(snd(pat)),expr,lds);
832
833         case CONFLDS   : {   Name h  = fst(snd(pat));
834                              Int  m  = name(h).arity;
835                              Cell p  = h;
836                              List fs = snd(snd(pat));
837                              Int  i  = m;
838                              while (0<i--)
839                                  p = ap(p,WILDCARD);
840                              for (; nonNull(fs); fs=tl(fs)) {
841                                  Cell r = p;
842                                  for (i=m-sfunPos(fst(hd(fs)),h); i>0; i--)
843                                      r = fun(r);
844                                  arg(r) = snd(hd(fs));
845                              }
846                              return remPat1(p,expr,lds);
847                          }
848
849         case DICTVAR   : /* shouldn't really occur */
850                          assert(0); /* so let's test for it then! ADR */
851         case VARIDCELL :
852         case VAROPCELL : return addEqn(pat,expr,lds);
853
854         case NAME      : if (c==nameFromInt || c==nameFromInteger
855                                             || c==nameFromDouble) {
856                              if (argCount==2)
857                                  arg(fun(pat)) = translate(arg(fun(pat)));
858                              break;
859                          }
860
861                          if (argCount==1 && isCfun(c)       /* for newtype */
862                              && cfunOf(c)==0 && name(c).defn==nameId)
863                              return remPat1(arg(pat),expr,lds);
864
865                          /* intentional fall-thru */
866         case TUPLE     : {   List ps = getArgs(pat);
867
868                              if (nonNull(ps)) {
869                                  Cell nv, sel;
870                                  Int  i;
871
872                                  if (isVar(expr) || isName(expr))
873                                      nv  = expr;
874                                  else {
875                                      nv  = inventVar();
876                                      lds = addEqn(nv,expr,lds);
877                                  }
878
879                                  sel = ap(ap(nameSel,c),nv);
880                                  for (i=1; nonNull(ps); ++i, ps=tl(ps))
881                                       lds = remPat1(hd(ps),
882                                                     ap(sel,mkInt(i)),
883                                                     lds);
884                              }
885                          }
886                          break;
887
888 #if TREX
889         case EXT       : {   Cell nv = inventVar();
890                              arg(fun(fun(pat)))
891                                  = translate(arg(fun(fun(pat))));
892                              lds = addEqn(nv,
893                                           ap(ap(nameRecBrk,
894                                                 arg(fun(fun(pat)))),
895                                              expr),
896                                           lds);
897                              lds = remPat1(extField(pat),ap(nameFst,nv),lds);
898                              lds = remPat1(extRow(pat),ap(nameSnd,nv),lds);
899                          }
900                          break;
901 #endif
902
903         default        : internal("remPat1");
904                          break;
905     }
906     return lds;
907 }
908
909 /* --------------------------------------------------------------------------
910  * Eliminate pattern matching in function definitions -- pattern matching
911  * compiler:
912  *
913  * The original Gofer/Hugs pattern matching compiler was based on Wadler's
914  * algorithms described in `Implementation of functional programming
915  * languages'.  That should still provide a good starting point for anyone
916  * wanting to understand this part of the system.  However, the original
917  * algorithm has been generalized and restructured in order to implement
918  * new features added in Haskell 1.3.
919  *
920  * During the translation, in preparation for later stages of compilation,
921  * all local and bound variables are replaced by suitable offsets, and
922  * locally defined function symbols are given new names (which will
923  * eventually be their names when lifted to make top level definitions).
924  * ------------------------------------------------------------------------*/
925
926 static Offset freeBegin; /* only variables with offset <= freeBegin are of */
927 static List   freeVars;  /* interest as `free' variables                   */
928 static List   freeFuns;  /* List of `free' local functions                 */
929
930 static Cell local pmcTerm(co,sc,e)     /* apply pattern matching compiler  */
931 Int  co;                               /* co = current offset              */
932 List sc;                               /* sc = scope                       */
933 Cell e;  {                             /* e  = expr to transform           */
934     switch (whatIs(e)) {
935         case GUARDED  : map2Over(pmcPair,co,sc,snd(e));
936                         break;
937
938         case LETREC   : pmcLetrec(co,sc,snd(e));
939                         break;
940
941         case VARIDCELL:
942         case VAROPCELL:
943         case DICTVAR  : return pmcVar(sc,textOf(e));
944
945         case COND     : return ap(COND,pmcTriple(co,sc,snd(e)));
946
947         case AP       : return pmcPair(co,sc,e);
948
949         case ADDPAT   :
950 #if TREX
951         case EXT      :
952 #endif
953         case TUPLE    :
954         case NAME     :
955         case CHARCELL :
956         case INTCELL  :
957         case BIGCELL  :
958         case FLOATCELL:
959         case STRCELL  : break;
960
961         default       : internal("pmcTerm");
962                         break;
963     }
964     return e;
965 }
966
967 static Cell local pmcPair(co,sc,pr)    /* apply pattern matching compiler  */
968 Int  co;                               /* to a pair of exprs               */
969 List sc;
970 Pair pr; {
971     return pair(pmcTerm(co,sc,fst(pr)),
972                 pmcTerm(co,sc,snd(pr)));
973 }
974
975 static Cell local pmcTriple(co,sc,tr)  /* apply pattern matching compiler  */
976 Int    co;                             /* to a triple of exprs             */
977 List   sc;
978 Triple tr; {
979     return triple(pmcTerm(co,sc,fst3(tr)),
980                   pmcTerm(co,sc,snd3(tr)),
981                   pmcTerm(co,sc,thd3(tr)));
982 }
983
984 static Cell local pmcVar(sc,t)         /* find translation of variable     */
985 List sc;                               /* in current scope                 */
986 Text t; {
987     List xs;
988     Name n;
989
990     for (xs=sc; nonNull(xs); xs=tl(xs)) {
991         Cell x = hd(xs);
992         if (t==textOf(fst(x))) {
993             if (isOffset(snd(x))) {                  /* local variable ... */
994                 if (snd(x)<=freeBegin && !cellIsMember(snd(x),freeVars))
995                     freeVars = cons(snd(x),freeVars);
996                 return snd(x);
997             }
998             else {                                   /* local function ... */
999                 if (!cellIsMember(snd(x),freeFuns))
1000                     freeFuns = cons(snd(x),freeFuns);
1001                 return fst3(snd(x));
1002             }
1003         }
1004     }
1005
1006     if (isNull(n=findName(t)))         /* Lookup global name - the only way*/
1007         n = newName(t,currentName);    /* this (should be able to happen)  */
1008                                        /* is with new global var introduced*/
1009                                        /* after type check; e.g. remPat1   */
1010     return n;
1011 }
1012
1013 static Void local pmcLetrec(co,sc,e)   /* apply pattern matching compiler  */
1014 Int  co;                               /* to LETREC, splitting decls into  */
1015 List sc;                               /* two sections                     */
1016 Pair e; {
1017     List fs = NIL;                     /* local function definitions       */
1018     List vs = NIL;                     /* local variable definitions       */
1019     List ds;
1020
1021     for (ds=fst(e); nonNull(ds); ds=tl(ds)) {      /* Split decls into two */
1022         Cell v     = fst(hd(ds));
1023         Int  arity = length(fst(hd(snd(hd(ds)))));
1024
1025         if (arity==0) {                            /* Variable declaration */
1026             vs = cons(snd(hd(ds)),vs);
1027             sc = cons(pair(v,mkOffset(++co)),sc);
1028         }
1029         else {                                     /* Function declaration */
1030             fs = cons(triple(inventVar(),mkInt(arity),snd(hd(ds))),fs);
1031             sc = cons(pair(v,hd(fs)),sc);
1032         }
1033     }
1034     vs       = rev(vs);                /* Put declaration lists back in    */
1035     fs       = rev(fs);                /* original order                   */
1036     fst(e)   = pair(vs,fs);            /* Store declaration lists          */
1037     map2Over(pmcVarDef,co,sc,vs);      /* Translate variable definitions   */
1038     map2Proc(pmcFunDef,co,sc,fs);      /* Translate function definitions   */
1039     snd(e)   = pmcTerm(co,sc,snd(e));  /* Translate LETREC body            */
1040     freeFuns = diffList(freeFuns,fs);  /* Delete any `freeFuns' bound in fs*/
1041 }
1042
1043 static Cell local pmcVarDef(co,sc,vd)  /* apply pattern matching compiler  */
1044 Int  co;                               /* to variable definition           */
1045 List sc;
1046 List vd; {                             /* vd :: [ ([], rhs) ]              */
1047     Cell d = snd(hd(vd));
1048     if (nonNull(tl(vd)) && canFail(d))
1049         return ap(FATBAR,pair(pmcTerm(co,sc,d),
1050                               pmcVarDef(co,sc,tl(vd))));
1051     return pmcTerm(co,sc,d);
1052 }
1053
1054 static Void local pmcFunDef(co,sc,fd)  /* apply pattern matching compiler  */
1055 Int    co;                             /* to function definition           */
1056 List   sc;
1057 Triple fd; {                           /* fd :: (Var, Arity, [Alt])        */
1058     Offset saveFreeBegin = freeBegin;
1059     List   saveFreeVars  = freeVars;
1060     List   saveFreeFuns  = freeFuns;
1061     Int    arity         = intOf(snd3(fd));
1062     Cell   temp          = altsMatch(co+1,arity,sc,thd3(fd));
1063     Cell   xs;
1064
1065     freeBegin = mkOffset(co);
1066     freeVars  = NIL;
1067     freeFuns  = NIL;
1068     temp      = match(co+arity,temp);
1069     thd3(fd)  = triple(freeVars,freeFuns,temp);
1070
1071     for (xs=freeVars; nonNull(xs); xs=tl(xs))
1072         if (hd(xs)<=saveFreeBegin && !cellIsMember(hd(xs),saveFreeVars))
1073             saveFreeVars = cons(hd(xs),saveFreeVars);
1074
1075     for (xs=freeFuns; nonNull(xs); xs=tl(xs))
1076         if (!cellIsMember(hd(xs),saveFreeFuns))
1077             saveFreeFuns = cons(hd(xs),saveFreeFuns);
1078
1079     freeBegin = saveFreeBegin;
1080     freeVars  = saveFreeVars;
1081     freeFuns  = saveFreeFuns;
1082 }
1083
1084 /* ---------------------------------------------------------------------------
1085  * Main part of pattern matching compiler: convert [Alt] to case constructs
1086  *
1087  * This section of Hugs has been almost completely rewritten to be more
1088  * general, in particular, to allow pattern matching in orders other than the
1089  * strictly left-to-right approach of the previous version.  This is needed
1090  * for the implementation of the so-called Haskell 1.3 `record' syntax.
1091  *
1092  * At each stage, the different branches for the cases to be considered
1093  * are represented by a list of values of type:
1094  *   Match ::= { maPats :: [Pat],       patterns to match
1095  *               maOffs :: [Offs],      offsets of corresponding values
1096  *               maSc   :: Scope,       mapping from vars to offsets
1097  *               maRhs  :: Rhs }        right hand side
1098  * [Implementation uses nested pairs, ((pats,offs),(sc,rhs)).]
1099  *
1100  * The Scope component has type:
1101  *   Scope  ::= [(Var,Expr)]
1102  * and provides a mapping from variable names to offsets used in the matching
1103  * process.
1104  *
1105  * Matches can be normalized by reducing them to a form in which the list
1106  * of patterns is empty (in which case the match itself is described as an
1107  * empty match), or in which the list is non-empty and the first pattern is
1108  * one that requires either a CASE or NUMCASE (or EXTCASE) to decompose.
1109  * ------------------------------------------------------------------------*/
1110
1111 #define mkMatch(ps,os,sc,r)     pair(pair(ps,os),pair(sc,r))
1112 #define maPats(ma)              fst(fst(ma))
1113 #define maOffs(ma)              snd(fst(ma))
1114 #define maSc(ma)                fst(snd(ma))
1115 #define maRhs(ma)               snd(snd(ma))
1116 #define extSc(v,o,ma)           maSc(ma) = cons(pair(v,o),maSc(ma))
1117
1118 static List local altsMatch(co,n,sc,as) /* Make a list of matches from list*/
1119 Int  co;                                /* of Alts, with initial offsets   */
1120 Int  n;                                 /* reverse (take n [co..])         */
1121 List sc;
1122 List as; {
1123     List mas = NIL;
1124     List us  = NIL;
1125     for (; n>0; n--)
1126         us = cons(mkOffset(co++),us);
1127     for (; nonNull(as); as=tl(as))      /* Each Alt is ([Pat], Rhs)        */
1128         mas = cons(mkMatch(fst(hd(as)),us,sc,snd(hd(as))),mas);
1129     return rev(mas);
1130 }
1131
1132 static Cell local match(co,mas) /* Generate case statement for Matches mas */
1133 Int  co;                        /* at current offset co                    */
1134 List mas; {                     /* N.B. Assumes nonNull(mas).              */
1135     Cell srhs = NIL;            /* Rhs for selected matches                */
1136     List smas = mas;            /* List of selected matches                */
1137     mas       = tl(mas);
1138     tl(smas)  = NIL;
1139
1140     if (emptyMatch(hd(smas))) {         /* The case for empty matches:     */
1141         while (nonNull(mas) && emptyMatch(hd(mas))) {
1142             List temp = tl(mas);
1143             tl(mas)   = smas;
1144             smas      = mas;
1145             mas       = temp;
1146         }
1147         srhs = joinMas(co,rev(smas));
1148     }
1149     else {                              /* Non-empty match                 */
1150         Int  o = offsetOf(hd(maOffs(hd(smas))));
1151         Cell d = maDiscr(hd(smas));
1152         if (isNumDiscr(d)) {            /* Numeric match                   */
1153             Int  da = discrArity(d);
1154             Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
1155             while (nonNull(mas) && !emptyMatch(hd(mas))
1156                                 && o==offsetOf(hd(maOffs(hd(mas))))
1157                                 && isNumDiscr(d=maDiscr(hd(mas)))
1158                                 && eqNumDiscr(d,d1)) {
1159                 List temp = tl(mas);
1160                 tl(mas)   = smas;
1161                 smas      = mas;
1162                 mas       = temp;
1163             }
1164             smas = rev(smas);
1165             map2Proc(advance,co,da,smas);
1166             srhs = ap(NUMCASE,triple(mkOffset(o),d1,match(co+da,smas)));
1167         }
1168 #if TREX
1169         else if (isExtDiscr(d)) {       /* Record match                    */
1170             Int  da = discrArity(d);
1171             Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
1172             while (nonNull(mas) && !emptyMatch(hd(mas))
1173                                 && o==offsetOf(hd(maOffs(hd(mas))))
1174                                 && isExtDiscr(d=maDiscr(hd(mas)))
1175                                 && eqExtDiscr(d,d1)) {
1176                 List temp = tl(mas);
1177                 tl(mas)   = smas;
1178                 smas      = mas;
1179                 mas       = temp;
1180             }
1181             smas = rev(smas);
1182             map2Proc(advance,co,da,smas);
1183             srhs = ap(EXTCASE,triple(mkOffset(o),d1,match(co+da,smas)));
1184         }
1185 #endif
1186         else {                          /* Constructor match               */
1187             List tab = addConTable(d,hd(smas),NIL);
1188             Int  da;
1189             while (nonNull(mas) && !emptyMatch(hd(mas))
1190                                 && o==offsetOf(hd(maOffs(hd(mas))))
1191                                 && !isNumDiscr(d=maDiscr(hd(mas)))) {
1192                 tab = addConTable(d,hd(mas),tab);
1193                 mas = tl(mas);
1194             }
1195             for (tab=rev(tab); nonNull(tab); tab=tl(tab)) {
1196                 d    = fst(hd(tab));
1197                 smas = snd(hd(tab));
1198                 da   = discrArity(d);
1199                 map2Proc(advance,co,da,smas);
1200                 srhs = cons(pair(d,match(co+da,smas)),srhs);
1201             }
1202             srhs = ap(CASE,pair(mkOffset(o),srhs));
1203         }
1204     }
1205     return nonNull(mas) ? ap(FATBAR,pair(srhs,match(co,mas))) : srhs;
1206 }
1207
1208 static Cell local joinMas(co,mas)       /* Combine list of matches into rhs*/
1209 Int  co;                                /* using FATBARs as necessary      */
1210 List mas; {                             /* Non-empty list of empty matches */
1211     Cell ma  = hd(mas);
1212     Cell rhs = pmcTerm(co,maSc(ma),maRhs(ma));
1213     if (nonNull(tl(mas)) && canFail(rhs))
1214         return ap(FATBAR,pair(rhs,joinMas(co,tl(mas))));
1215     else
1216         return rhs;
1217 }
1218
1219 static Bool local canFail(rhs)         /* Determine if expression (as rhs) */
1220 Cell rhs; {                            /* might ever be able to fail       */
1221     switch (whatIs(rhs)) {
1222         case LETREC  : return canFail(snd(snd(rhs)));
1223         case GUARDED : return TRUE;    /* could get more sophisticated ..? */
1224         default      : return FALSE;
1225     }
1226 }
1227
1228 /* type Table a b = [(a, [b])]
1229  *
1230  * addTable                 :: a -> b -> Table a b -> Table a b
1231  * addTable x y []           = [(x,[y])]
1232  * addTable x y (z@(n,sws):zs)
1233  *              | n == x     = (n,sws++[y]):zs
1234  *              | otherwise  = (n,sws):addTable x y zs
1235  */
1236
1237 static List local addConTable(x,y,tab) /* add element (x,y) to table       */
1238 Cell x, y;
1239 List tab; {
1240     if (isNull(tab))
1241         return singleton(pair(x,singleton(y)));
1242     else if (fst(hd(tab))==x)
1243         snd(hd(tab)) = appendOnto(snd(hd(tab)),singleton(y));
1244     else
1245         tl(tab) = addConTable(x,y,tl(tab));
1246
1247     return tab;
1248 }
1249
1250 static Void local advance(co,a,ma)      /* Advance non-empty match by      */
1251 Int  co;                                /* processing head pattern         */
1252 Int  a;                                 /* discriminator arity             */
1253 Cell ma; {
1254     Cell p  = hd(maPats(ma));
1255     List ps = tl(maPats(ma));
1256     List us = tl(maOffs(ma));
1257     if (whatIs(p)==CONFLDS) {           /* Special case for record syntax  */
1258         Name c  = fst(snd(p));
1259         List fs = snd(snd(p));
1260         List qs = NIL;
1261         List vs = NIL;
1262         for (; nonNull(fs); fs=tl(fs)) {
1263             vs = cons(mkOffset(co+a+1-sfunPos(fst(hd(fs)),c)),vs);
1264             qs = cons(snd(hd(fs)),qs);
1265         }
1266         ps = revOnto(qs,ps);
1267         us = revOnto(vs,us);
1268     }
1269     else                                /* Normally just spool off patterns*/
1270         for (; a>0; --a) {              /* and corresponding offsets ...   */
1271             us = cons(mkOffset(++co),us);
1272             ps = cons(arg(p),ps);
1273             p  = fun(p);
1274         }
1275
1276     maPats(ma) = ps;
1277     maOffs(ma) = us;
1278 }
1279
1280 /* --------------------------------------------------------------------------
1281  * Normalize and test for empty match:
1282  * ------------------------------------------------------------------------*/
1283
1284 static Bool local emptyMatch(ma)/* Normalize and test to see if a given    */
1285 Cell ma; {                      /* match, ma, is empty.                    */
1286
1287     while (nonNull(maPats(ma))) {
1288         Cell p;
1289 tidyHd: switch (whatIs(p=hd(maPats(ma)))) {
1290             case LAZYPAT   : {   Cell nv   = inventVar();
1291                                  maRhs(ma) = ap(LETREC,
1292                                                 pair(remPat(snd(p),nv,NIL),
1293                                                      maRhs(ma)));
1294                                  p         = nv;
1295                              }
1296                              /* intentional fall-thru */
1297             case VARIDCELL :
1298             case VAROPCELL :
1299             case DICTVAR   : extSc(p,hd(maOffs(ma)),ma);
1300             case WILDCARD  : maPats(ma) = tl(maPats(ma));
1301                              maOffs(ma) = tl(maOffs(ma));
1302                              continue;
1303
1304             /* So-called "as-patterns"are really just pattern intersections:
1305              *    (p1@p2:ps, o:os, sc, e) ==> (p1:p2:ps, o:o:os, sc, e)
1306              * (But the input grammar probably doesn't let us take
1307              * advantage of this, so we stick with the special case
1308              * when p1 is a variable.)
1309              */
1310             case ASPAT     : extSc(fst(snd(p)),hd(maOffs(ma)),ma);
1311                              hd(maPats(ma)) = snd(snd(p));
1312                              goto tidyHd;
1313
1314             case FINLIST   : hd(maPats(ma)) = mkConsList(snd(p));
1315                              return FALSE;
1316
1317             case STRCELL   : {   String s = textToStr(textOf(p));
1318                                  for (p=NIL; *s!='\0'; ++s) {
1319                                      if (*s!='\\' || *++s=='\\')
1320                                          p = ap(consChar(*s),p);
1321                                      else
1322                                          p = ap(consChar('\0'),p);
1323                                  }
1324                                  hd(maPats(ma)) = revOnto(p,nameNil);
1325                              }
1326                              return FALSE;
1327
1328             case AP        : if (isName(fun(p)) && isCfun(fun(p))
1329                                  && cfunOf(fun(p))==0
1330                                  && name(fun(p)).defn==nameId) {
1331                                   hd(maPats(ma)) = arg(p);
1332                                   goto tidyHd;
1333                              }
1334                              /* intentional fall-thru */
1335             case CHARCELL  :
1336             case NAME      :
1337             case CONFLDS   :
1338                              return FALSE;
1339
1340             default        : internal("emptyMatch");
1341         }
1342     }
1343     return TRUE;
1344 }
1345
1346 /* --------------------------------------------------------------------------
1347  * Discriminators:
1348  * ------------------------------------------------------------------------*/
1349
1350 static Cell local maDiscr(ma)   /* Get the discriminator for a non-empty   */
1351 Cell ma; {                      /* match, ma.                              */
1352     Cell p = hd(maPats(ma));
1353     Cell h = getHead(p);
1354     switch (whatIs(h)) {
1355         case CONFLDS : return fst(snd(p));
1356         case ADDPAT  : arg(fun(p)) = translate(arg(fun(p)));
1357                        return fun(p);
1358 #if TREX
1359         case EXT     : h      = fun(fun(p));
1360                        arg(h) = translate(arg(h));
1361                        return h;
1362 #endif
1363         case NAME    : if (h==nameFromInt || h==nameFromInteger
1364                                           || h==nameFromDouble) {
1365                            if (argCount==2)
1366                                arg(fun(p)) = translate(arg(fun(p)));
1367                            return p;
1368                        }
1369     }
1370     return h;
1371 }
1372
1373 static Bool local isNumDiscr(d) /* TRUE => numeric discriminator           */
1374 Cell d; {
1375     switch (whatIs(d)) {
1376         case NAME      :
1377         case TUPLE     :
1378         case CHARCELL  : return FALSE;
1379
1380 #if TREX
1381         case AP        : return !isExt(fun(d));
1382 #else
1383         case AP        : return TRUE;   /* must be a literal or (n+k)      */
1384 #endif
1385     }
1386     internal("isNumDiscr");
1387     return 0;/*NOTREACHED*/
1388 }
1389
1390 Int discrArity(d)                      /* Find arity of discriminator      */
1391 Cell d; {
1392     switch (whatIs(d)) {
1393         case NAME      : return name(d).arity;
1394         case TUPLE     : return tupleOf(d);
1395         case CHARCELL  : return 0;
1396 #if TREX
1397         case AP        : switch (whatIs(fun(d))) {
1398                              case ADDPAT : return 1;
1399                              case EXT    : return 2;
1400                              default     : return 0;
1401                          }
1402 #else
1403         case AP        : return (whatIs(fun(d))==ADDPAT) ? 1 : 0;
1404 #endif
1405     }
1406     internal("discrArity");
1407     return 0;/*NOTREACHED*/
1408 }
1409
1410 static Bool local eqNumDiscr(d1,d2)     /* Determine whether two numeric   */
1411 Cell d1, d2; {                          /* descriptors have same value     */
1412     if (whatIs(fun(d1))==ADDPAT)
1413         return whatIs(fun(d2))==ADDPAT && snd(fun(d1))==snd(fun(d2));
1414     if (isInt(arg(d1)))
1415         return isInt(arg(d2)) && intOf(arg(d1))==intOf(arg(d2));
1416     if (isFloat(arg(d1)))
1417         return isFloat(arg(d2)) && floatOf(arg(d1))==floatOf(arg(d2));
1418     internal("eqNumDiscr");
1419     return FALSE;/*NOTREACHED*/
1420 }
1421
1422 #if TREX
1423 static Bool local isExtDiscr(d)         /* Test of extension discriminator */
1424 Cell d; {
1425     return isAp(d) && isExt(fun(d));
1426 }
1427
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);
1431 }
1432 #endif
1433
1434 /*-------------------------------------------------------------------------*/
1435
1436
1437
1438 /* --------------------------------------------------------------------------
1439  * STG stuff
1440  * ------------------------------------------------------------------------*/
1441
1442 static Void local stgCGBinds( List );
1443
1444 static Void local stgCGBinds(binds)
1445 List binds; {
1446     cgBinds(binds);
1447 }
1448
1449 /* --------------------------------------------------------------------------
1450  * Main entry points to compiler:
1451  * ------------------------------------------------------------------------*/
1452
1453 static List addGlobals( List binds )
1454 {
1455     /* stgGlobals = list of top-level STG binds */
1456     for(;nonNull(stgGlobals);stgGlobals=tl(stgGlobals)) {
1457         StgVar bind = snd(hd(stgGlobals));
1458         if (nonNull(stgVarBody(bind))) {
1459             binds = cons(bind,binds);
1460         }
1461     }
1462     return binds;
1463 }
1464
1465 typedef void (*sighandler_t)(int);
1466 void eval_ctrlbrk ( int dunnowhat )
1467 {
1468    interruptStgRts();
1469    /* reinstall the signal handler so that further interrupts which
1470       happen before the thread can return to the scheduler, lead back
1471       here rather than invoking the previous break handler. */
1472    signal(SIGINT, eval_ctrlbrk);
1473 }
1474
1475 Void evalExp ( void ) {             /* compile and run input expression    */
1476     /* ToDo: this name (and other names generated during pattern match?)
1477      * get inserted in the symbol table but never get removed.
1478      */
1479     Name n = newName(inventText(),NIL);
1480     Cell e;
1481     StgVar v = mkStgVar(NIL,NIL);
1482     name(n).stgVar = v;
1483     compiler(RESET);
1484     e = pmcTerm(0,NIL,translate(inputExpr));
1485     stgDefn(n,0,e);
1486     inputExpr = NIL;
1487     stgCGBinds(addGlobals(singleton(v)));
1488     
1489     /* Run thread (and any other runnable threads) */
1490
1491     /* Re-initialise the scheduler - ToDo: do I need this? */
1492     /* JRS, 991118: on SM's advice, don't call initScheduler every time.
1493        This causes an assertion failure in GC.c(revert_dead_cafs)
1494        unless doRevertCAFs below is permanently TRUE.
1495      */
1496     /* initScheduler(); */
1497 #ifdef CRUDE_PROFILING
1498     cp_init();
1499 #endif
1500
1501     {
1502         HaskellObj      result; /* ignored */
1503         sighandler_t    old_ctrlbrk;
1504         SchedulerStatus status;
1505         Bool            doRevertCAFs = TRUE;  /* do not change -- comment above */
1506         old_ctrlbrk         = signal(SIGINT, eval_ctrlbrk);
1507         ASSERT(old_ctrlbrk != SIG_ERR);
1508         status              = rts_eval_(closureOfVar(v),10000,&result);
1509         signal(SIGINT,old_ctrlbrk);
1510         fflush (stderr); 
1511         fflush (stdout);
1512         switch (status) {
1513         case Deadlock:
1514                 printf("{Deadlock or Blackhole}");
1515                 if (doRevertCAFs) RevertCAFs();
1516                 break;
1517         case Interrupted:
1518                 printf("{Interrupted}");
1519                 if (doRevertCAFs) RevertCAFs();
1520                 break;
1521         case Killed:
1522                 printf("{Interrupted or Killed}");
1523                 if (doRevertCAFs) RevertCAFs();
1524                 break;
1525         case Success:
1526                 if (doRevertCAFs) RevertCAFs();
1527                 break;
1528         default:
1529                 internal("evalExp: Unrecognised SchedulerStatus");
1530         }
1531         deleteAllThreads();
1532         fflush(stdout);
1533         fflush(stderr);
1534     }
1535 #ifdef CRUDE_PROFILING
1536     cp_show();
1537 #endif
1538
1539 }
1540
1541
1542 static List local addStgVar( List binds, Pair bind )
1543 {
1544     StgVar nv = mkStgVar(NIL,NIL);
1545     Text   t  = textOf(fst(bind));
1546     Name   n  = findName(t);
1547
1548     if (isNull(n)) {                   /* Lookup global name - the only way*/
1549         n = newName(t,NIL);            /* this (should be able to happen)  */
1550     }                                  /* is with new global var introduced*/
1551                                        /* after type check; e.g. remPat1   */
1552     name(n).stgVar = nv;
1553     return cons(nv,binds);
1554 }
1555
1556
1557 Void compileDefns() {                  /* compile script definitions       */
1558     Target t = length(valDefns) + length(genDefns) + length(selDefns);
1559     Target i = 0;
1560     List binds = NIL;
1561
1562     {
1563         List vss;
1564         List vs;
1565         for(vs=genDefns; nonNull(vs); vs=tl(vs)) {
1566             Name   n  = hd(vs);
1567             StgVar nv = mkStgVar(NIL,NIL);
1568             assert(isName(n));
1569             name(n).stgVar = nv;
1570             binds = cons(nv,binds);
1571         }
1572         for(vss=selDefns; nonNull(vss); vss=tl(vss)) {
1573             for(vs=hd(vss); nonNull(vs); vs=tl(vs)) {
1574                 Pair p = hd(vs);
1575                 Name n = fst(p);
1576                 StgVar nv = mkStgVar(NIL,NIL);
1577                 assert(isName(n));
1578                 name(n).stgVar = nv;
1579                 binds = cons(nv,binds);
1580             }
1581         }
1582     }
1583
1584     setGoal("Translating",t);
1585     /* do valDefns before everything else so that all stgVar's get added. */
1586     for (; nonNull(valDefns); valDefns=tl(valDefns)) {
1587         hd(valDefns) = transBinds(hd(valDefns));
1588         mapAccum(addStgVar,binds,hd(valDefns));
1589         mapProc(compileGlobalFunction,hd(valDefns));
1590         soFar(i++);
1591     }
1592     for (; nonNull(genDefns); genDefns=tl(genDefns)) {
1593         compileGenFunction(hd(genDefns));
1594         soFar(i++);
1595     }
1596     for (; nonNull(selDefns); selDefns=tl(selDefns)) {
1597         mapOver(compileSelFunction,hd(selDefns));
1598         soFar(i++);
1599     }
1600
1601     binds = addGlobals(binds);
1602     done();
1603     setGoal("Generating code",t);
1604     stgCGBinds(binds);
1605
1606     done();
1607 }
1608
1609 static Void local compileGlobalFunction(bind)
1610 Pair bind; {
1611     Name n     = findName(textOf(fst(bind)));
1612     List defs  = snd(bind);
1613     Int  arity = length(fst(hd(defs)));
1614     assert(isName(n));
1615     compiler(RESET);
1616     stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1617 }
1618
1619 static Void local compileGenFunction(n) /* Produce code for internally     */
1620 Name n; {                               /* generated function              */
1621     List defs  = name(n).defn;
1622     Int  arity = length(fst(hd(defs)));
1623 #if 0
1624     printf ( "compGenFn: " );print(defs,100);printf("\n");
1625 #endif
1626     compiler(RESET);
1627     currentName = n;
1628     mapProc(transAlt,defs);
1629     stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1630     name(n).defn = NIL;
1631 }
1632
1633 static Name local compileSelFunction(p) /* Produce code for selector func  */
1634 Pair p; {                               /* Should be merged with genDefns, */
1635     Name s     = fst(p);                /* but the name(_).defn field is   */
1636     List defs  = snd(p);                /* already used for other purposes */
1637     Int  arity = length(fst(hd(defs))); /* in selector functions.          */
1638
1639     compiler(RESET);
1640     mapProc(transAlt,defs);
1641     stgDefn(s,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1642     return s;
1643 }
1644
1645
1646 /* --------------------------------------------------------------------------
1647  * Compiler control:
1648  * ------------------------------------------------------------------------*/
1649
1650 Void compiler(what)
1651 Int what; {
1652     switch (what) {
1653         case PREPREL :
1654         case RESET   : freeVars      = NIL;
1655                        freeFuns      = NIL;
1656                        lineNumber    = 0;
1657                        freeBegin     = mkOffset(0);
1658                        break;
1659
1660         case MARK    : mark(freeVars);
1661                        mark(freeFuns);
1662                        break;
1663
1664         case POSTPREL: break;
1665     }
1666 }
1667
1668 /*-------------------------------------------------------------------------*/