ghc/interpreter/compiler.c

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