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