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.28 $
  15  * $Date: 2000/04/14 15:18:06 $
  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
1494     /* Further comments, JRS 000411.
1495        When control returns to Hugs, you have to be pretty careful about
1496        the state of the heap.  In particular, hugs.c may subsequently call
1497        nukeModule() in storage.c, which removes modules from the system.
1498        If a module defines a particular data constructor, the relevant
1499        info table is also free()d.  That gives a problem if there are
1500        still closures hanging round in the heap with references to that
1501        info table.
1502
1503        The solution is to firstly to revert CAFs, and then force a major
1504        collection in between transitions from the mutation, ie actually
1505        running Haskell, and nukeModule.  Since major GCs are potentially
1506        expensive, we don't want to do one at every call to nukeModule,
1507        so the flag nukeModule_needs_major_gc is used to signal when one
1508        is needed.
1509
1510        This all also seems to imply that doRevertCAFs should always
1511        be TRUE.
1512     */
1513
1514 #   ifdef CRUDE_PROFILING
1515     cp_init();
1516 #   endif
1517
1518     {
1519         HaskellObj      result; /* ignored */
1520         SchedulerStatus status;
1521         Bool            doRevertCAFs = TRUE;  /* do not change -- comment above */
1522         HugsBreakAction brkOld = setBreakAction ( HugsRtsInterrupt );
1523         nukeModule_needs_major_gc = TRUE;
1524         status              = rts_eval_(closureOfVar(v),10000,&result);
1525         setBreakAction ( brkOld );
1526         fflush (stderr);
1527         fflush (stdout);
1528         switch (status) {
1529         case Deadlock:
1530                 printf("{Deadlock or Blackhole}");
1531                 break;
1532         case Interrupted:
1533                 printf("{Interrupted}");
1534                 break;
1535         case Killed:
1536                 printf("{Interrupted or Killed}");
1537                 break;
1538         case Success:
1539                 break;
1540         default:
1541                 internal("evalExp: Unrecognised SchedulerStatus");
1542         }
1543
1544         /* Begin heap cleanup sequence */
1545         do {
1546            /* fprintf ( stderr, "finalisation loop START\n" ); */
1547            finishAllThreads();
1548            finalizeWeakPointersNow();
1549            /* fprintf ( stderr, "finalisation loop END %d\n",
1550                                 howManyThreadsAvail() ); */
1551         }
1552            while (howManyThreadsAvail() > 0);
1553
1554         RevertCAFs();
1555         performMajorGC();
1556         if (combined && SPT_size != 0) {
1557            FPrintf ( stderr,
1558              "hugs: fatal: stable pointers are not yet allowed in combined mode" );
1559            internal("evalExp");
1560         }
1561         /* End heap cleanup sequence */
1562
1563         fflush(stdout);
1564         fflush(stderr);
1565     }
1566 #   ifdef CRUDE_PROFILING
1567     cp_show();
1568 #   endif
1569
1570 }
1571
1572
1573 static List local addStgVar( List binds, Pair bind )
1574 {
1575     StgVar nv = mkStgVar(NIL,NIL);
1576     Text   t  = textOf(fst(bind));
1577     Name   n  = findName(t);
1578
1579     if (isNull(n)) {                   /* Lookup global name - the only way*/
1580         n = newName(t,NIL);            /* this (should be able to happen)  */
1581     }                                  /* is with new global var introduced*/
1582                                        /* after type check; e.g. remPat1   */
1583     name(n).stgVar = nv;
1584     return cons(nv,binds);
1585 }
1586
1587
1588 Void compileDefns() {                  /* compile script definitions       */
1589     Target t = length(valDefns) + length(genDefns) + length(selDefns);
1590     Target i = 0;
1591     List binds = NIL;
1592
1593     {
1594         List vss;
1595         List vs;
1596         for(vs=genDefns; nonNull(vs); vs=tl(vs)) {
1597             Name   n  = hd(vs);
1598             StgVar nv = mkStgVar(NIL,NIL);
1599             assert(isName(n));
1600             name(n).stgVar = nv;
1601             binds = cons(nv,binds);
1602         }
1603         for(vss=selDefns; nonNull(vss); vss=tl(vss)) {
1604             for(vs=hd(vss); nonNull(vs); vs=tl(vs)) {
1605                 Pair p = hd(vs);
1606                 Name n = fst(p);
1607                 StgVar nv = mkStgVar(NIL,NIL);
1608                 assert(isName(n));
1609                 name(n).stgVar = nv;
1610                 binds = cons(nv,binds);
1611             }
1612         }
1613     }
1614
1615     setGoal("Translating",t);
1616     /* do valDefns before everything else so that all stgVar's get added. */
1617     for (; nonNull(valDefns); valDefns=tl(valDefns)) {
1618         hd(valDefns) = transBinds(hd(valDefns));
1619         mapAccum(addStgVar,binds,hd(valDefns));
1620         mapProc(compileGlobalFunction,hd(valDefns));
1621         soFar(i++);
1622     }
1623     for (; nonNull(genDefns); genDefns=tl(genDefns)) {
1624         compileGenFunction(hd(genDefns));
1625         soFar(i++);
1626     }
1627     for (; nonNull(selDefns); selDefns=tl(selDefns)) {
1628         mapOver(compileSelFunction,hd(selDefns));
1629         soFar(i++);
1630     }
1631
1632     binds = addGlobals(binds);
1633     done();
1634     setGoal("Generating code",t);
1635     stgCGBinds(binds);
1636
1637     done();
1638 }
1639
1640 static Void local compileGlobalFunction(bind)
1641 Pair bind; {
1642     Name n     = findName(textOf(fst(bind)));
1643     List defs  = snd(bind);
1644     Int  arity = length(fst(hd(defs)));
1645     assert(isName(n));
1646     compiler(RESET);
1647     stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1648 }
1649
1650 static Void local compileGenFunction(n) /* Produce code for internally     */
1651 Name n; {                               /* generated function              */
1652     List defs  = name(n).defn;
1653     Int  arity = length(fst(hd(defs)));
1654 #if 0
1655     printf ( "compGenFn: " );print(defs,100);printf("\n");
1656 #endif
1657     compiler(RESET);
1658     currentName = n;
1659     mapProc(transAlt,defs);
1660     stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1661     name(n).defn = NIL;
1662 }
1663
1664 static Name local compileSelFunction(p) /* Produce code for selector func  */
1665 Pair p; {                               /* Should be merged with genDefns, */
1666     Name s     = fst(p);                /* but the name(_).defn field is   */
1667     List defs  = snd(p);                /* already used for other purposes */
1668     Int  arity = length(fst(hd(defs))); /* in selector functions.          */
1669
1670     compiler(RESET);
1671     mapProc(transAlt,defs);
1672     stgDefn(s,arity,match(arity,altsMatch(1,arity,NIL,defs)));
1673     return s;
1674 }
1675
1676
1677 /* --------------------------------------------------------------------------
1678  * Compiler control:
1679  * ------------------------------------------------------------------------*/
1680
1681 Void compiler(what)
1682 Int what; {
1683     switch (what) {
1684         case PREPREL :
1685         case RESET   : freeVars      = NIL;
1686                        freeFuns      = NIL;
1687                        lineNumber    = 0;
1688                        freeBegin     = mkOffset(0);
1689                        break;
1690
1691         case MARK    : mark(freeVars);
1692                        mark(freeFuns);
1693                        break;
1694
1695         case POSTPREL: break;
1696     }
1697 }
1698
1699 /*-------------------------------------------------------------------------*/