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