ghc/interpreter/lift.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Lambda Lifter
   4  *
   5  * This is a very simple lambda lifter - it doesn't try to do Johnsson-style
   6  * lambda lifting (yet).
   7  *
   8  * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
   9  * All rights reserved. See NOTICE for details and conditions of use etc...
  10  * Hugs version 1.4, December 1997
  11  *
  12  * $RCSfile: lift.c,v $
  13  * $Revision: 1.3 $
  14  * $Date: 1999/02/03 17:08:31 $
  15  * ------------------------------------------------------------------------*/
  16
  17 #include "prelude.h"
  18 #include "storage.h"
  19 #include "backend.h"
  20 #include "connect.h"
  21 #include "errors.h"
  22
  23
  24 /* --------------------------------------------------------------------------
  25  * Local function prototypes:
  26  * ------------------------------------------------------------------------*/
  27
  28 static List liftedBinds = NIL;
  29
  30 static StgExpr abstractExpr ( List vars, StgExpr e );
  31 static inline Bool isTopLevel( StgVar v );
  32 static List    filterFreeVars( List vs );
  33 static List    liftLetBinds ( List binds );
  34 static void    liftAlt      ( StgCaseAlt alt );
  35 static void    liftPrimAlt  ( StgPrimAlt alt );
  36 static void    liftExpr     ( StgExpr e );
  37
  38 /* --------------------------------------------------------------------------
  39  * Lambda lifter
  40  * ------------------------------------------------------------------------*/
  41
  42 /* abstract variables out of an expression */
  43 static StgExpr abstractExpr( List vars, StgExpr e )
  44 {
  45     List args = NIL;
  46     List sub  = NIL; /* association list */
  47     for(; nonNull(vars); vars=tl(vars)) {
  48         StgVar var = hd(vars);
  49         StgVar arg = mkStgVar(NIL,NIL);
  50         args = cons(arg,args);
  51         sub  = cons(pair(var,arg),sub);
  52     }
  53     return makeStgLambda(rev(args),substExpr(sub,e));
  54 }
  55
  56 /* ToDo: should be conservative estimate but isn't */
  57 /* Will a variable be floated out to top level - conservative estimate? */
  58 static inline Bool isTopLevel( StgVar v )
  59 {
  60     if (isNull(stgVarBody(v))) {
  61         return FALSE; /* only let bound vars can be floated */
  62     } else if (stgVarInfo(v) == NONE) {
  63         return TRUE;  /* those at top level are already there */
  64     } else {
  65 #if LIFT_CONSTANTS
  66         StgRhs rhs  = stgVarBody(v);
  67         switch (whatIs(rhs)) {
  68         case STGCON:
  69         case STGAPP:
  70                 return isNull(stgVarInfo(v));
  71         default:
  72                 return FALSE;
  73         }
  74 #else
  75         return FALSE;
  76 #endif
  77     }
  78 }
  79
  80 static List filterFreeVars( List vs )
  81 {
  82     List fvs = NIL;
  83     if (vs == NONE) {
  84         return NIL;
  85     } else {
  86         for(; nonNull(vs); vs=tl(vs)) {
  87             StgVar v = hd(vs);
  88             if (!isTopLevel(v)) {
  89                 fvs = cons(v,fvs);
  90             }
  91         }
  92         return fvs;
  93     }
  94 }
  95
  96 static List liftLetBinds( List binds )
  97 {
  98     List bs = NIL;
  99     for(; nonNull(binds); binds=tl(binds)) {
 100         StgVar bind = hd(binds);
 101         StgRhs rhs  = stgVarBody(bind);
 102         List   fvs  = filterFreeVars(stgVarInfo(bind));
 103         /* stgVarInfo(bind) = NIL; */ /* ToDo: discard fv list */
 104
 105         switch (whatIs(rhs)) {
 106         case STGCON:
 107         case STGAPP:
 108 #if LIFT_CONSTANTS
 109                 if (isNull(fvs)) {
 110                     StgVar v = mkStgVar(rhs,NONE);
 111                     stgVarBody(bind) = mkStgLet(singleton(v),v);
 112                     /* ppStg(v); */
 113                     liftedBinds = cons(bind,liftedBinds);
 114                     break;
 115                 }
 116                 /* deliberate fall through */
 117 #endif
 118         case STGVAR:
 119         case NAME:
 120                 bs = cons(bind,bs);
 121                 break;
 122         default:
 123                 liftExpr(rhs);
 124                 if (nonNull(fvs)) {
 125                     StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE);
 126                     /* ppStg(v); */
 127                     liftedBinds = cons(v,liftedBinds);
 128                     stgVarBody(bind) = makeStgApp(v, fvs);
 129                 }
 130 #if LIFT_CONSTANTS
 131                 else {
 132                     StgVar r = mkStgVar(rhs,NIL); /* copy the var */
 133                     StgVar v = mkStgVar(mkStgLet(singleton(r),r),NONE);
 134                     stgVarBody(bind) = v; /* indirection to r */
 135                     /* ppStg(v); */
 136                     liftedBinds = cons(v,liftedBinds);
 137                     bs = cons(bind,bs); /* keep the old binding */
 138                     break;
 139                 }
 140                 /* deliberate fall through */
 141 #endif
 142                 bs = cons(bind,bs);
 143                 break;
 144         }
 145     }
 146     return bs;
 147 }
 148
 149 static void liftAlt( StgCaseAlt alt )
 150 {
 151     liftExpr(stgCaseAltBody(alt));
 152 }
 153
 154 static void liftPrimAlt( StgPrimAlt alt )
 155 {
 156     liftExpr(stgPrimAltBody(alt));
 157 }
 158
 159 static void liftExpr( StgExpr e )
 160 {
 161     switch (whatIs(e)) {
 162     case LETREC:
 163             stgLetBinds(e) = liftLetBinds(stgLetBinds(e));
 164             liftExpr(stgLetBody(e));
 165             break;
 166     case LAMBDA:
 167             liftExpr(stgLambdaBody(e));
 168             break;
 169     case CASE:
 170             liftExpr(stgCaseScrut(e));
 171             mapProc(liftAlt,stgCaseAlts(e));
 172             break;
 173     case PRIMCASE:
 174             liftExpr(stgPrimCaseScrut(e));
 175             mapProc(liftPrimAlt,stgPrimCaseAlts(e));
 176             break;
 177     case STGPRIM:
 178             break;
 179     case STGAPP:
 180             break;
 181     case STGVAR:
 182     case NAME:
 183             break;
 184     default:
 185             internal("liftExpr");
 186     }
 187 }
 188
 189 List liftBinds( List binds )
 190 {
 191     List bs;
 192     for(bs=binds; nonNull(bs); bs=tl(bs)) {
 193         StgVar bind = hd(bs);
 194         freeVarsBind(NIL,bind);
 195         stgVarInfo(bind) = NONE; /* mark as top level */
 196     }
 197     liftedBinds = NIL;
 198     binds = liftLetBinds(binds);
 199     binds = revOnto(liftedBinds,binds);
 200     liftedBinds = NIL;
 201     return binds;
 202 }
 203
 204 /* --------------------------------------------------------------------------
 205  * Compiler control:
 206  * ------------------------------------------------------------------------*/
 207
 208 Void liftControl(what)
 209 Int what; {
 210     switch (what) {
 211     case INSTALL:
 212             /* deliberate fall though */
 213     case RESET:
 214             liftedBinds = NIL;
 215             break;
 216     case MARK:
 217             mark(liftedBinds);
 218             break;
 219     }
 220 }
 221
 222 /*-------------------------------------------------------------------------*/