ghc/interpreter/optimise.c

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