ghc/interpreter/compiler.c

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