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.4 $
  14  * $Date: 1999/03/01 14:46:47 $
  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 #error lift constants
  67         StgRhs rhs  = stgVarBody(v);
  68         switch (whatIs(rhs)) {
  69         case STGCON:
  70         case STGAPP:
  71                 return isNull(stgVarInfo(v));
  72         default:
  73                 return FALSE;
  74         }
  75 #else
  76         return FALSE;
  77 #endif
  78     }
  79 }
  80
  81 static List filterFreeVars( List vs )
  82 {
  83     List fvs = NIL;
  84     if (vs == NONE) {
  85         return NIL;
  86     } else {
  87         for(; nonNull(vs); vs=tl(vs)) {
  88             StgVar v = hd(vs);
  89             if (!isTopLevel(v)) {
  90                 fvs = cons(v,fvs);
  91             }
  92         }
  93         return fvs;
  94     }
  95 }
  96
  97 static List liftLetBinds( List binds )
  98 {
  99     List bs = NIL;
 100     for(; nonNull(binds); binds=tl(binds)) {
 101         StgVar bind = hd(binds);
 102         StgRhs rhs  = stgVarBody(bind);
 103         List   fvs  = filterFreeVars(stgVarInfo(bind));
 104         /* stgVarInfo(bind) = NIL; */ /* ToDo: discard fv list */
 105
 106         switch (whatIs(rhs)) {
 107         case STGCON:
 108         case STGAPP:
 109 #if LIFT_CONSTANTS
 110 #error lift constants
 111                 if (isNull(fvs)) {
 112                     StgVar v = mkStgVar(rhs,NONE);
 113                     stgVarBody(bind) = mkStgLet(singleton(v),v);
 114                     /* ppStg(v); */
 115                     liftedBinds = cons(bind,liftedBinds);
 116                     break;
 117                 }
 118                 /* deliberate fall through */
 119 #endif
 120         case STGVAR:
 121         case NAME:
 122                 bs = cons(bind,bs);
 123                 break;
 124         default:
 125                 liftExpr(rhs);
 126                 if (nonNull(fvs)) {
 127                     StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE);
 128                     /* ppStg(v); */
 129                     liftedBinds = cons(v,liftedBinds);
 130                     stgVarBody(bind) = makeStgApp(v, fvs);
 131                 }
 132 #if LIFT_CONSTANTS
 133 #error lift constants
 134                 else {
 135                     StgVar r = mkStgVar(rhs,NIL); /* copy the var */
 136                     StgVar v = mkStgVar(mkStgLet(singleton(r),r),NONE);
 137                     stgVarBody(bind) = v; /* indirection to r */
 138                     /* ppStg(v); */
 139                     liftedBinds = cons(v,liftedBinds);
 140                     bs = cons(bind,bs); /* keep the old binding */
 141                     break;
 142                 }
 143                 /* deliberate fall through */
 144 #endif
 145                 bs = cons(bind,bs);
 146                 break;
 147         }
 148     }
 149     return bs;
 150 }
 151
 152 static void liftAlt( StgCaseAlt alt )
 153 {
 154     liftExpr(stgCaseAltBody(alt));
 155 }
 156
 157 static void liftPrimAlt( StgPrimAlt alt )
 158 {
 159     liftExpr(stgPrimAltBody(alt));
 160 }
 161
 162 static void liftExpr( StgExpr e )
 163 {
 164     switch (whatIs(e)) {
 165     case LETREC:
 166             stgLetBinds(e) = liftLetBinds(stgLetBinds(e));
 167             liftExpr(stgLetBody(e));
 168             break;
 169     case LAMBDA:
 170             liftExpr(stgLambdaBody(e));
 171             break;
 172     case CASE:
 173             liftExpr(stgCaseScrut(e));
 174             mapProc(liftAlt,stgCaseAlts(e));
 175             break;
 176     case PRIMCASE:
 177             liftExpr(stgPrimCaseScrut(e));
 178             mapProc(liftPrimAlt,stgPrimCaseAlts(e));
 179             break;
 180     case STGPRIM:
 181             break;
 182     case STGAPP:
 183             break;
 184     case STGVAR:
 185     case NAME:
 186             break;
 187     default:
 188             internal("liftExpr");
 189     }
 190 }
 191
 192 List liftBinds( List binds )
 193 {
 194     List bs;
 195     for(bs=binds; nonNull(bs); bs=tl(bs)) {
 196         StgVar bind = hd(bs);
 197         freeVarsBind(NIL,bind);
 198         stgVarInfo(bind) = NONE; /* mark as top level */
 199     }
 200     liftedBinds = NIL;
 201     binds = liftLetBinds(binds);
 202     binds = revOnto(liftedBinds,binds);
 203     liftedBinds = NIL;
 204     return binds;
 205 }
 206
 207 /* --------------------------------------------------------------------------
 208  * Compiler control:
 209  * ------------------------------------------------------------------------*/
 210
 211 Void liftControl(what)
 212 Int what; {
 213     switch (what) {
 214     case INSTALL:
 215             /* deliberate fall though */
 216     case RESET:
 217             liftedBinds = NIL;
 218             break;
 219     case MARK:
 220             mark(liftedBinds);
 221             break;
 222     }
 223 }
 224
 225 /*-------------------------------------------------------------------------*/