ghc/interpreter/optimise.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Optimiser
   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: optimise.c,v $
  10  * $Revision: 1.3 $
  11  * $Date: 1999/02/03 17:08:33 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "backend.h"
  17 #include "connect.h"
  18 #include "errors.h"
  19
  20 /* --------------------------------------------------------------------------
  21  * Local functions
  22  * ------------------------------------------------------------------------*/
  23
  24 static StgAtom    optimiseAtom    Args((StgAtom));
  25 static StgVar     optimiseVar     Args((StgVar));
  26 static StgCaseAlt optimiseAlt     Args((StgCaseAlt));
  27 static StgPrimAlt optimisePrimAlt Args((StgPrimAlt));
  28 static StgExpr    optimiseExpr    Args((StgExpr));
  29
  30 /* --------------------------------------------------------------------------
  31  * A simple optimiser
  32  * ------------------------------------------------------------------------*/
  33
  34 static StgAtom optimiseAtom(StgAtom a)
  35 {
  36     switch (whatIs(a)) {
  37     case STGVAR:
  38             return optimiseVar(a);
  39     /* Note that NAMEs have no free vars. */
  40     default:
  41             return a;
  42     }
  43 }
  44
  45 static StgVar optimiseVar(StgVar v)
  46 {
  47     StgRhs rhs = stgVarBody(v);
  48     /* short circuit: let x = y in ...x... --> let x = y ...y... */
  49     if (whatIs(rhs) == STGVAR && rhs != v) {
  50         StgVar v1 = rhs;
  51
  52         /* find last variable in chain */
  53         rhs = stgVarBody(v1);
  54         while (whatIs(rhs) == STGVAR
  55                && rhs != v  /* infinite loop */
  56                ) {
  57             v1 = rhs;
  58             rhs = stgVarBody(rhs);
  59         }
  60
  61         /* Make all variables in chain point to v1
  62          * This makes sure we always resolve cycles the same way
  63          * as well as making things faster if we call optimiseVar again
  64          */
  65         while (v != v1) {
  66             StgRhs r = stgVarBody(v);
  67             assert(whatIs(r) == STGVAR);
  68             stgVarBody(v) = v1;
  69             v = r;
  70         }
  71         return v1;
  72     }
  73     return v;
  74 }
  75
  76 void optimiseBind( StgVar v )
  77 {
  78     StgRhs rhs = stgVarBody(v);
  79     switch (whatIs(rhs)) {
  80     case STGCON:
  81             mapOver(optimiseAtom,stgConArgs(rhs));
  82             break;
  83     default:
  84             stgVarBody(v) = optimiseExpr(rhs);
  85             break;
  86     }
  87 }
  88
  89 static StgCaseAlt optimiseAlt( StgCaseAlt alt )
  90 {
  91     /* StgPat pat = stgCaseAltPat(alt); */
  92     stgCaseAltBody(alt) = optimiseExpr(stgCaseAltBody(alt));
  93     return alt;
  94 }
  95
  96 static StgPrimAlt optimisePrimAlt( StgPrimAlt alt )
  97 {
  98     /* List vs = stgPrimAltPats(alt); */
  99     stgPrimAltBody(alt) = optimiseExpr(stgPrimAltBody(alt));
 100     return alt;
 101 }
 102
 103 static StgExpr optimiseExpr( StgExpr e )
 104 {
 105     switch (whatIs(e)) {
 106     case LETREC:
 107         {
 108             List binds = stgLetBinds(e);
 109             {
 110                 /* First we filter out trivial bindings.
 111                  * this has to be done before optimising the individual
 112                  * bindings so that we don't get confused by the results
 113                  * of other optimisations.
 114                  */
 115                 List bs = binds;
 116                 binds = NIL;
 117                 for(; nonNull(bs); bs=tl(bs)) {
 118                     StgVar b = optimiseVar(hd(bs));
 119                     StgRhs rhs = stgVarBody(b);
 120                     if (whatIs(rhs) == STGVAR && b != rhs) {
 121                         /* This variable will be short-circuited
 122                          * by optimiseVar so we can drop the binding
 123                          * right now.
 124                          */
 125                     } else {
 126                         binds = cons(hd(bs),binds);
 127                     }
 128                 }
 129                 binds = rev(binds); /* preserve original order */
 130             }
 131             stgLetBody(e) = optimiseExpr(stgLetBody(e));
 132             if (isNull(binds)) {
 133                 return stgLetBody(e);
 134             } else {
 135                 mapProc(optimiseBind,binds);
 136                 stgLetBinds(e) = binds;
 137             }
 138             break;
 139         }
 140     case LAMBDA:
 141             stgLambdaBody(e) = optimiseExpr(stgLambdaBody(e));
 142             break;
 143     case CASE:
 144         {
 145             StgExpr scrut = optimiseExpr(stgCaseScrut(e));
 146             StgExpr alts  = stgCaseAlts(e);
 147             if (whatIs(scrut) == STGVAR
 148                 && whatIs(stgVarBody(scrut)) == STGCON
 149                 ) {
 150                 StgRhs rhs = stgVarBody(scrut);
 151                 StgDiscr d = stgConCon(rhs);
 152                 List  args = stgConArgs(rhs);
 153                 for(; nonNull(alts); alts=tl(alts)) {
 154                     StgCaseAlt alt = hd(alts);
 155                     StgPat     pat = stgCaseAltPat(alt);
 156                     if (isDefaultPat(pat)) {  /* the easy case */
 157                         StgExpr body = stgCaseAltBody(alt);
 158                         stgVarBody(pat) = rhs;
 159                         return optimiseExpr(body);
 160                     } else if (stgPatDiscr(pat) == d) {
 161                         /* The tricky case:
 162                          * rebind all the pattern args to the con args
 163                          * and rebind the pattern var to con
 164                          * and run optimiser (to eliminate the binding)
 165                          */
 166                         StgExpr body  = stgCaseAltBody(alt);
 167                         List    binds = stgPatVars(pat);
 168                         {
 169                             List vs = binds;
 170                             for(;
 171                                 nonNull(vs) && nonNull(args);
 172                                 vs = tl(vs), args=tl(args)
 173                                 ) {
 174                                 stgVarBody(hd(vs)) = hd(args);
 175                             }
 176                         }
 177                         binds = cons(pat,binds);  /* turn patvar into a var! */
 178                         stgVarBody(pat) = rhs;
 179
 180                         /* This letrec will always be optimised away */
 181                         body = makeStgLet(binds,body);
 182                         return optimiseExpr(body);
 183                     }
 184                 }
 185                 internal("optimiseExpr: no patterns matched");
 186             }
 187             stgCaseScrut(e) = scrut;
 188             mapOver(optimiseAlt,alts);
 189             break;
 190         }
 191     case PRIMCASE:
 192             mapOver(optimisePrimAlt,stgPrimCaseAlts(e));
 193             stgPrimCaseScrut(e) = optimiseExpr(stgPrimCaseScrut(e));
 194             break;
 195     case STGPRIM:
 196             mapOver(optimiseAtom,stgPrimArgs(e));
 197             /* primop is not a var */
 198             break;
 199     case STGAPP:
 200             stgAppFun(e) = optimiseExpr(stgAppFun(e));
 201             mapOver(optimiseAtom,stgAppArgs(e));
 202             break;
 203     case STGVAR:
 204             return optimiseVar(e);
 205     case NAME:
 206             break;  /* Names are never free vars */
 207     default:
 208             internal("optimiseExpr");
 209     }
 210     return e;
 211 }
 212
 213 /*-------------------------------------------------------------------------*/