ghc/interpreter/desugar.c

   1 /* -*- mode: hugs-c; -*- */
   2 /* --------------------------------------------------------------------------
   3  * Desugarer
   4  *
   5  * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
   6  * All rights reserved. See NOTICE for details and conditions of use etc...
   7  * Hugs version 1.4, December 1997
   8  *
   9  * $RCSfile: desugar.c,v $
  10  * $Revision: 1.2 $
  11  * $Date: 1998/12/02 13:22:05 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "connect.h"
  17 #include "errors.h"
  18 #include "link.h"
  19
  20 #include "desugar.h"
  21 #include "pat.h"
  22
  23 /* --------------------------------------------------------------------------
  24  * Local function prototypes:
  25  * ------------------------------------------------------------------------*/
  26
  27 static Void local transPair             Args((Pair));
  28 static Void local transTriple           Args((Triple));
  29 static Void local transCase             Args((Cell));
  30 static Cell local transRhs              Args((Cell));
  31 static Cell local expandLetrec          Args((Cell));
  32 static Cell local transComp             Args((Cell,List,Cell));
  33 static Cell local transDo               Args((Cell,Cell,Cell,List));
  34 static Cell local transConFlds          Args((Cell,List));
  35 static Cell local transUpdFlds          Args((Cell,List,List));
  36
  37 /* --------------------------------------------------------------------------
  38  * Translation:    Convert input expressions into a less complex language
  39  *                 of terms using only LETREC, AP, constants and vars.
  40  *                 Also remove pattern definitions on lhs of eqns.
  41  * ------------------------------------------------------------------------*/
  42
  43 Cell translate(e)                       /* Translate expression:            */
  44 Cell e; {
  45     switch (whatIs(e)) {
  46         case LETREC     : snd(snd(e)) = translate(snd(snd(e)));
  47                           return expandLetrec(e);
  48
  49         case COND       : transTriple(snd(e));
  50                           return e;
  51
  52         case AP         : fst(e) = translate(fst(e));
  53
  54                           if (fst(e)==nameId || fst(e)==nameInd)
  55                               return translate(snd(e));
  56 #if USE_NEWTYPE_FOR_DICTS
  57                           if (isName(fst(e)) &&
  58                               isMfun(fst(e)) &&
  59                               mfunOf(fst(e))==0)
  60                               return translate(snd(e));
  61 #endif
  62                           snd(e) = translate(snd(e));
  63                           return e;
  64
  65         case NAME       : if (e==nameOtherwise)
  66                               return nameTrue;
  67                           if (isCfun(e)) {
  68                               if (isName(name(e).defn))
  69                                   return name(e).defn;
  70                               if (isPair(name(e).defn))
  71                                   return snd(name(e).defn);
  72                           }
  73                           return e;
  74
  75 #if TREX
  76         case RECSEL     : return nameRecSel;
  77
  78         case EXT        :
  79 #endif
  80         case TUPLE      :
  81         case VAROPCELL  :
  82         case VARIDCELL  :
  83         case DICTVAR    :
  84         case INTCELL    :
  85         case BIGCELL    :
  86         case FLOATCELL  :
  87         case STRCELL    :
  88         case CHARCELL   : return e;
  89
  90         case FINLIST    : mapOver(translate,snd(e));
  91                           return mkConsList(snd(e));
  92
  93         case DOCOMP     : {   Cell m  = translate(fst(fst(snd(e))));
  94                               Cell m0 = snd(fst(snd(e)));
  95                               Cell r  = translate(fst(snd(snd(e))));
  96                               if (nonNull(m0))
  97                                   m0 = translate(m0);
  98                               return transDo(m,m0,r,snd(snd(snd(e))));
  99                           }
 100
 101         case COMP       : return transComp(translate(fst(snd(e))),
 102                                            snd(snd(e)),
 103                                            nameNil);
 104
 105         case CONFLDS    : return transConFlds(fst(snd(e)),snd(snd(e)));
 106
 107         case UPDFLDS    : return transUpdFlds(fst3(snd(e)),
 108                                               snd3(snd(e)),
 109                                               thd3(snd(e)));
 110
 111         case CASE       : {   Cell nv = inventVar();
 112                               mapProc(transCase,snd(snd(e)));
 113                               return ap(LETREC,
 114                                         pair(singleton(pair(nv,snd(snd(e)))),
 115                                              ap(nv,translate(fst(snd(e))))));
 116                           }
 117
 118         case LAMBDA     : {   Cell nv = inventVar();
 119                               transAlt(snd(e));
 120                               return ap(LETREC,
 121                                         pair(singleton(pair(
 122                                                         nv,
 123                                                         singleton(snd(e)))),
 124                                              nv));
 125                           }
 126
 127         default         : internal("translate");
 128     }
 129     return e;
 130 }
 131
 132 static Void local transPair(pr)        /* Translate each component in a    */
 133 Pair pr; {                             /* pair of expressions.             */
 134     fst(pr) = translate(fst(pr));
 135     snd(pr) = translate(snd(pr));
 136 }
 137
 138 static Void local transTriple(tr)      /* Translate each component in a    */
 139 Triple tr; {                           /* triple of expressions.           */
 140     fst3(tr) = translate(fst3(tr));
 141     snd3(tr) = translate(snd3(tr));
 142     thd3(tr) = translate(thd3(tr));
 143 }
 144
 145 Void transAlt(e)                       /* Translate alt:                   */
 146 Cell e; {                              /* ([Pat], Rhs) ==> ([Pat], Rhs')   */
 147     snd(e) = transRhs(snd(e));
 148 }
 149
 150 static Void local transCase(c)         /* Translate case:                  */
 151 Cell c; {                              /* (Pat, Rhs) ==> ([Pat], Rhs')     */
 152     fst(c) = singleton(fst(c));
 153     snd(c) = transRhs(snd(c));
 154 }
 155
 156 List transBinds(bs)                    /* Translate list of bindings:      */
 157 List bs; {                             /* eliminating pattern matching on  */
 158     List newBinds=NIL;                 /* lhs of bindings.                 */
 159     for (; nonNull(bs); bs=tl(bs)) {
 160         if (isVar(fst(hd(bs)))) {
 161             mapProc(transAlt,snd(hd(bs)));
 162             newBinds = cons(hd(bs),newBinds);
 163         }
 164         else
 165             newBinds = remPat(fst(snd(hd(bs))),
 166                               snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))),
 167                               newBinds);
 168     }
 169     return newBinds;
 170 }
 171
 172 static Cell local transRhs(rhs)        /* Translate rhs: removing line nos */
 173 Cell rhs; {
 174     switch (whatIs(rhs)) {
 175         case LETREC  : snd(snd(rhs)) = transRhs(snd(snd(rhs)));
 176                        return expandLetrec(rhs);
 177
 178         case GUARDED : mapOver(snd,snd(rhs));       /* discard line number */
 179                        mapProc(transPair,snd(rhs));
 180                        return rhs;
 181
 182         default      : return translate(snd(rhs));  /* discard line number */
 183     }
 184 }
 185
 186 Cell mkConsList(es)                    /* Construct expression for list es */
 187 List es; {                             /* using nameNil and nameCons       */
 188     if (isNull(es))
 189         return nameNil;
 190     else
 191         return ap2(nameCons,hd(es),mkConsList(tl(es)));
 192 }
 193
 194 static Cell local expandLetrec(root)   /* translate LETREC with list of    */
 195 Cell root; {                           /* groups of bindings (from depend. */
 196     Cell e   = snd(snd(root));         /* analysis) to use nested LETRECs  */
 197     List bss = fst(snd(root));
 198     Cell temp;
 199
 200     if (isNull(bss))                   /* should never happen, but just in */
 201         return e;                      /* case:  LETREC [] IN e  ==>  e    */
 202
 203     mapOver(transBinds,bss);           /* translate each group of bindings */
 204
 205     for (temp=root; nonNull(tl(bss)); bss=tl(bss)) {
 206         fst(snd(temp)) = hd(bss);
 207         snd(snd(temp)) = ap(LETREC,pair(NIL,e));
 208         temp           = snd(snd(temp));
 209     }
 210     fst(snd(temp)) = hd(bss);
 211
 212     return root;
 213 }
 214
 215 /* --------------------------------------------------------------------------
 216  * Translation of list comprehensions is based on the description in
 217  * `The Implementation of Functional Programming Languages':
 218  *
 219  * [ e | qs ] ++ l            => transComp e qs l
 220  * transComp e []           l => e : l
 221  * transComp e ((p<-xs):qs) l => LETREC _h []      = l
 222  *                                      _h (p:_xs) = transComp e qs (_h _xs)
 223  *                                      _h (_:_xs) = _h _xs --if p !failFree
 224  *                               IN _h xs
 225  * transComp e (b:qs)       l => if b then transComp e qs l else l
 226  * transComp e (decls:qs)   l => LETREC decls IN transComp e qs l
 227  * ------------------------------------------------------------------------*/
 228
 229 static Cell local transComp(e,qs,l)    /* Translate [e | qs] ++ l          */
 230 Cell e;
 231 List qs;
 232 Cell l; {
 233     if (nonNull(qs)) {
 234         Cell q   = hd(qs);
 235         Cell qs1 = tl(qs);
 236
 237         switch (fst(q)) {
 238             case FROMQUAL : {   Cell ld    = NIL;
 239                                 Cell hVar  = inventVar();
 240                                 Cell xsVar = inventVar();
 241
 242                                 if (!failFree(fst(snd(q))))
 243                                     ld = cons(pair(singleton(
 244                                                     ap2(nameCons,
 245                                                         WILDCARD,
 246                                                         xsVar)),
 247                                                    ap(hVar,xsVar)),
 248                                               ld);
 249
 250                                 ld = cons(pair(singleton(
 251                                                 ap2(nameCons,
 252                                                     fst(snd(q)),
 253                                                     xsVar)),
 254                                                transComp(e,
 255                                                          qs1,
 256                                                          ap(hVar,xsVar))),
 257                                           ld);
 258                                 ld = cons(pair(singleton(nameNil),
 259                                                l),
 260                                           ld);
 261
 262                                 return ap(LETREC,
 263                                           pair(singleton(pair(hVar,
 264                                                               ld)),
 265                                                ap(hVar,
 266                                                   translate(snd(snd(q))))));
 267                             }
 268
 269             case QWHERE   : return
 270                                 expandLetrec(ap(LETREC,
 271                                                 pair(snd(q),
 272                                                      transComp(e,qs1,l))));
 273
 274             case BOOLQUAL : return ap(COND,
 275                                       triple(translate(snd(q)),
 276                                              transComp(e,qs1,l),
 277                                              l));
 278         }
 279     }
 280
 281     return ap2(nameCons,e,l);
 282 }
 283
 284 /* --------------------------------------------------------------------------
 285  * Translation of monad comprehensions written using do-notation:
 286  *
 287  * do { e }               =>  e
 288  * do { p <- exp; qs }    =>  LETREC _h p = do { qs }
 289  *                                   _h _ = zero{m0}   -- if monad with 0
 290  *                            IN exp >>={m} _h
 291  * do { LET decls; qs }   =>  LETREC decls IN do { qs }
 292  * do { IF guard; qs }    =>  if guard then do { qs } else zero{m0}
 293  * do { e; qs }           =>  LETREC _h _ = [ e | qs ] in bind m exp _h
 294  *
 295  * where  m :: Monad f,  m0 :: Monad0 f
 296  * ------------------------------------------------------------------------*/
 297
 298 static Cell local transDo(m,m0,e,qs)    /* Translate do { qs ; e }         */
 299 Cell m;
 300 Cell m0;
 301 Cell e;
 302 List qs; {
 303     if (nonNull(qs)) {
 304         Cell q   = hd(qs);
 305         Cell qs1 = tl(qs);
 306
 307         switch (fst(q)) {
 308             case FROMQUAL : {   Cell ld   = NIL;
 309                                 Cell hVar = inventVar();
 310
 311                                 if (!failFree(fst(snd(q))) && nonNull(m0))
 312                                     ld = cons(pair(singleton(WILDCARD),
 313                                                    ap(nameZero,m0)),ld);
 314
 315                                 ld = cons(pair(singleton(fst(snd(q))),
 316                                                transDo(m,m0,e,qs1)),
 317                                           ld);
 318
 319                                 return ap(LETREC,
 320                                           pair(singleton(pair(hVar,ld)),
 321                                                ap3(nameBind,
 322                                                    m,
 323                                                    translate(snd(snd(q))),
 324                                                    hVar)));
 325                             }
 326
 327             case DOQUAL :   {   Cell hVar = inventVar();
 328                                 Cell ld   = cons(pair(singleton(WILDCARD),
 329                                                       transDo(m,m0,e,qs1)),
 330                                                  NIL);
 331                                 return ap(LETREC,
 332                                           pair(singleton(pair(hVar,ld)),
 333                                                ap3(nameBind,
 334                                                    m,
 335                                                    translate(snd(q)),
 336                                                    hVar)));
 337                             }
 338
 339             case QWHERE   : return
 340                                 expandLetrec(ap(LETREC,
 341                                                 pair(snd(q),
 342                                                      transDo(m,m0,e,qs1))));
 343
 344             case BOOLQUAL : return ap(COND,
 345                                       triple(translate(snd(q)),
 346                                              transDo(m,m0,e,qs1),
 347                                              ap(nameZero,m0)));
 348         }
 349     }
 350     return e;
 351 }
 352
 353 /* --------------------------------------------------------------------------
 354  * Translation of named field construction and update:
 355  *
 356  * Construction is implemented using the following transformation:
 357  *
 358  *   C{x1=e1, ..., xn=en} =  C v1 ... vm
 359  * where:
 360  *   vi = e1,        if the ith component of C is labelled with x1
 361  *       ...
 362  *      = en,        if the ith component of C is labelled with xn
 363  *      = undefined, otherwise
 364  *
 365  * Update is implemented using the following transformation:
 366  *
 367  *   e{x1=e1, ..., xn=en}
 368  *      =  let nv (C a1 ... am) v1 ... vn = C a1' .. am'
 369  *             nv (D b1 ... bk) v1 ... vn = D b1' .. bk
 370  *             ...
 371  *             nv _             v1 ... vn = error "failed update"
 372  *         in nv e e1 ... en
 373  * where:
 374  *   nv, v1, ..., vn, a1, ..., am, b1, ..., bk, ... are new variables,
 375  *   C,D,... = { K | K is a constr fun s.t. {x1,...,xn} subset of sels(K)}
 376  * and:
 377  *   ai' = v1,   if the ith component of C is labelled with x1
 378  *       ...
 379  *       = vn,   if the ith component of C is labelled with xn
 380  *       = ai,   otherwise
 381  *  etc...
 382  *
 383  * The error case may be omitted if C,D,... is an enumeration of all of the
 384  * constructors for the datatype concerned.  Strictly speaking, error case
 385  * isn't needed at all -- the only benefit of including it is that the user
 386  * will get a "failed update" message rather than a cryptic {v354 ...}.
 387  * So, for now, we'll go with the second option!
 388  *
 389  * For the time being, code for each update operation is generated
 390  * independently of any other updates.  However, if updates are used
 391  * frequently, then we might want to consider changing the implementation
 392  * at a later stage to cache definitions of functions like nv above.  This
 393  * would create a shared library of update functions, indexed by a set of
 394  * constructors {C,D,...}.
 395  * ------------------------------------------------------------------------*/
 396
 397 static Cell local transConFlds(c,flds)  /* Translate C{flds}               */
 398 Name c;
 399 List flds; {
 400     Cell e = c;
 401     Int  m = name(c).arity;
 402     Int  i;
 403     for (i=m; i>0; i--)
 404         e = ap(e,nameUndefined);
 405     for (; nonNull(flds); flds=tl(flds)) {
 406         Cell a = e;
 407         for (i=m-sfunPos(fst(hd(flds)),c); i>0; i--)
 408             a = fun(a);
 409         arg(a) = translate(snd(hd(flds)));
 410     }
 411     return e;
 412 }
 413
 414 static Cell local transUpdFlds(e,cs,flds)/* Translate e{flds}              */
 415 Cell e;                                 /* (cs is corresp list of constrs) */
 416 List cs;
 417 List flds; {
 418     Cell nv   = inventVar();
 419     Cell body = ap(nv,translate(e));
 420     List fs   = flds;
 421     List args = NIL;
 422     List alts = NIL;
 423
 424     for (; nonNull(fs); fs=tl(fs)) {    /* body = nv e1 ... en             */
 425         Cell b = hd(fs);                /* args = [v1, ..., vn]            */
 426         body   = ap(body,translate(snd(b)));
 427         args   = cons(inventVar(),args);
 428     }
 429
 430     for (; nonNull(cs); cs=tl(cs)) {    /* Loop through constructors to    */
 431         Cell c   = hd(cs);              /* build up list of alts.          */
 432         Cell pat = c;
 433         Cell rhs = c;
 434         List as  = args;
 435         Int  m   = name(c).arity;
 436         Int  i;
 437
 438         for (i=m; i>0; i--) {           /* pat  = C a1 ... am              */
 439             Cell a = inventVar();       /* rhs  = C a1 ... am              */
 440             pat    = ap(pat,a);
 441             rhs    = ap(rhs,a);
 442         }
 443
 444         for (fs=flds; nonNull(fs); fs=tl(fs), as=tl(as)) {
 445             Name s = fst(hd(fs));       /* Replace approp ai in rhs with   */
 446             Cell r = rhs;               /* vars from [v1,...,vn]           */
 447             for (i=m-sfunPos(s,c); i>0; i--)
 448                 r = fun(r);
 449             arg(r) = hd(as);
 450         }
 451
 452         alts     = cons(pair(cons(pat,args),rhs),alts);
 453     }
 454     return ap(LETREC,pair(singleton(pair(nv,alts)),body));
 455 }
 456
 457 /* --------------------------------------------------------------------------
 458  * Desugar control:
 459  * ------------------------------------------------------------------------*/
 460
 461 Void desugarControl(what)
 462 Int what; {
 463     patControl(what);
 464     switch (what) {
 465         case INSTALL :
 466                 /* Fall through */
 467         case RESET   : break;
 468         case MARK    : break;
 469     }
 470 }
 471
 472 /*-------------------------------------------------------------------------*/