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