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