ghc/interpreter/lift.c

   1 /* -*- mode: hugs-c; -*- */
   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.2 $
  14  * $Date: 1998/12/02 13:22:17 $
  15  * ------------------------------------------------------------------------*/
  16
  17 #include "prelude.h"
  18 #include "storage.h"
  19 #include "connect.h"
  20 #include "errors.h"
  21 #include "stg.h"
  22 #include "lift.h"
  23 #include "free.h"
  24 #include "stgSubst.h"
  25 /* #include "pp.h" */
  26
  27 /* --------------------------------------------------------------------------
  28  * Local function prototypes:
  29  * ------------------------------------------------------------------------*/
  30
  31 static List liftedBinds = NIL;
  32
  33 static StgExpr abstractExpr ( List vars, StgExpr e );
  34 static inline Bool isTopLevel( StgVar v );
  35 static List    filterFreeVars( List vs );
  36 static List    liftLetBinds ( List binds );
  37 static void    liftAlt      ( StgCaseAlt alt );
  38 static void    liftPrimAlt  ( StgPrimAlt alt );
  39 static void    liftExpr     ( StgExpr e );
  40
  41 /* --------------------------------------------------------------------------
  42  * Lambda lifter
  43  * ------------------------------------------------------------------------*/
  44
  45 /* abstract variables out of an expression */
  46 static StgExpr abstractExpr( List vars, StgExpr e )
  47 {
  48     List args = NIL;
  49     List sub  = NIL; /* association list */
  50     for(; nonNull(vars); vars=tl(vars)) {
  51         StgVar var = hd(vars);
  52         StgVar arg = mkStgVar(NIL,NIL);
  53         args = cons(arg,args);
  54         sub  = cons(pair(var,arg),sub);
  55     }
  56     return makeStgLambda(rev(args),substExpr(sub,e));
  57 }
  58
  59 /* ToDo: should be conservative estimate but isn't */
  60 /* Will a variable be floated out to top level - conservative estimate? */
  61 static inline Bool isTopLevel( StgVar v )
  62 {
  63     if (isNull(stgVarBody(v))) {
  64         return FALSE; /* only let bound vars can be floated */
  65     } else if (stgVarInfo(v) == NONE) {
  66         return TRUE;  /* those at top level are already there */
  67     } else {
  68 #if LIFT_CONSTANTS
  69         StgRhs rhs  = stgVarBody(v);
  70         switch (whatIs(rhs)) {
  71         case STGCON:
  72         case STGAPP:
  73                 return isNull(stgVarInfo(v));
  74         default:
  75                 return FALSE;
  76         }
  77 #else
  78         return FALSE;
  79 #endif
  80     }
  81 }
  82
  83 static List filterFreeVars( List vs )
  84 {
  85     List fvs = NIL;
  86     if (vs == NONE) {
  87         return NIL;
  88     } else {
  89         for(; nonNull(vs); vs=tl(vs)) {
  90             StgVar v = hd(vs);
  91             if (!isTopLevel(v)) {
  92                 fvs = cons(v,fvs);
  93             }
  94         }
  95         return fvs;
  96     }
  97 }
  98
  99 static List liftLetBinds( List binds )
 100 {
 101     List bs = NIL;
 102     for(; nonNull(binds); binds=tl(binds)) {
 103         StgVar bind = hd(binds);
 104         StgRhs rhs  = stgVarBody(bind);
 105         List   fvs  = filterFreeVars(stgVarInfo(bind));
 106         /* stgVarInfo(bind) = NIL; */ /* ToDo: discard fv list */
 107
 108         switch (whatIs(rhs)) {
 109         case STGCON:
 110         case STGAPP:
 111 #if LIFT_CONSTANTS
 112                 if (isNull(fvs)) {
 113                     StgVar v = mkStgVar(rhs,NONE);
 114                     stgVarBody(bind) = mkStgLet(singleton(v),v);
 115                     /* ppStg(v); */
 116                     liftedBinds = cons(bind,liftedBinds);
 117                     break;
 118                 }
 119                 /* deliberate fall through */
 120 #endif
 121         case STGVAR:
 122         case NAME:
 123                 bs = cons(bind,bs);
 124                 break;
 125         default:
 126                 liftExpr(rhs);
 127                 if (nonNull(fvs)) {
 128                     StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE);
 129                     /* ppStg(v); */
 130                     liftedBinds = cons(v,liftedBinds);
 131                     stgVarBody(bind) = makeStgApp(v, fvs);
 132                 }
 133 #if 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 /*-------------------------------------------------------------------------*/