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