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.5 $
  14  * $Date: 1999/04/27 10:06:54 $
  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 static Bool makeInlineable = FALSE;
  30 static Int  inlineCounter  = 0;
  31
  32 static StgExpr abstractExpr ( List vars, StgExpr e );
  33 static inline Bool isTopLevel( StgVar v );
  34 static List    filterFreeVars( List vs );
  35 static List    liftLetBinds ( List binds, Bool topLevel );
  36 static void    liftAlt      ( StgCaseAlt alt );
  37 static void    liftPrimAlt  ( StgPrimAlt alt );
  38 static void    liftExpr     ( StgExpr e );
  39
  40 /* --------------------------------------------------------------------------
  41  * Lambda lifter
  42  * ------------------------------------------------------------------------*/
  43
  44 /* abstract variables out of an expression */
  45 static StgExpr abstractExpr( List vars, StgExpr e )
  46 {
  47     List args = NIL;
  48     List sub  = NIL; /* association list */
  49     for(; nonNull(vars); vars=tl(vars)) {
  50         StgVar var = hd(vars);
  51         StgVar arg = mkStgVar(NIL,NIL);
  52         stgVarRep(arg) = stgVarRep(var);
  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 #error lift constants
  70         StgRhs rhs  = stgVarBody(v);
  71         switch (whatIs(rhs)) {
  72         case STGCON:
  73         case STGAPP:
  74                 return isNull(stgVarInfo(v));
  75         default:
  76                 return FALSE;
  77         }
  78 #else
  79         return FALSE;
  80 #endif
  81     }
  82 }
  83
  84 static List filterFreeVars( List vs )
  85 {
  86     List fvs = NIL;
  87     if (vs == NONE) {
  88         return NIL;
  89     } else {
  90         for(; nonNull(vs); vs=tl(vs)) {
  91             StgVar v = hd(vs);
  92             if (!isTopLevel(v)) {
  93                 fvs = cons(v,fvs);
  94             }
  95         }
  96         return fvs;
  97     }
  98 }
  99
 100 static List liftLetBinds( List binds, Bool topLevel )
 101 {
 102     List bs = NIL;
 103     for(; nonNull(binds); binds=tl(binds)) {
 104         StgVar bind = hd(binds);
 105         StgRhs rhs  = stgVarBody(bind);
 106         List   fvs  = filterFreeVars(stgVarInfo(bind));
 107         /* stgVarInfo(bind) = NIL; */ /* ToDo: discard fv list */
 108
 109         /* if starting on a new top-level inlineable bind, ensure that
 110            the lifted-out binds get marked inlineable too
 111         */
 112         if (topLevel) {
 113            Name n         = nameFromStgVar(bind);
 114            makeInlineable = FALSE;
 115            if (nonNull(n) && name(n).inlineMe==TRUE) makeInlineable = TRUE;
 116         }
 117
 118         switch (whatIs(rhs)) {
 119         case STGCON:
 120         case STGAPP:
 121 #if LIFT_CONSTANTS
 122 #error lift constants
 123                 if (isNull(fvs)) {
 124                     StgVar v = mkStgVar(rhs,NONE);
 125                     stgVarBody(bind) = mkStgLet(singleton(v),v);
 126                     /* ppStg(v); */ /* check inlinable */
 127                     liftedBinds = cons(bind,liftedBinds);
 128                     break;
 129                 }
 130                 /* deliberate fall through */
 131 #endif
 132         case STGVAR:
 133         case NAME:
 134                 bs = cons(bind,bs);
 135                 break;
 136         default:
 137                 liftExpr(rhs);
 138                 if (nonNull(fvs)) {
 139                     StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE);
 140                     liftedBinds = cons(v,liftedBinds);
 141                     if (makeInlineable) {
 142                        Name n;
 143                        char s[16];
 144                        sprintf(s,"lam%d",inlineCounter++);
 145                        n = newName(findText(s),NIL);
 146                        name(n).stgVar = v;
 147                        name(n).simplified = TRUE; /* optimiser is upstream of lifter */
 148                        if (makeInlineable) name(n).inlineMe = TRUE;
 149                        stgVarBody(bind) = makeStgApp(n, fvs);
 150                     } else {
 151                        stgVarBody(bind) = makeStgApp(v, fvs);
 152                     }
 153                 }
 154 #if LIFT_CONSTANTS
 155 #error lift constants
 156                 else {
 157                     StgVar r = mkStgVar(rhs,NIL); /* copy the var */
 158                     StgVar v = mkStgVar(mkStgLet(singleton(r),r),NONE);
 159                     stgVarBody(bind) = v; /* indirection to r */
 160                     /* ppStg(v); */
 161                     liftedBinds = cons(v,liftedBinds);
 162                     bs = cons(bind,bs); /* keep the old binding */
 163                     break;
 164                 }
 165                 /* deliberate fall through */
 166 #endif
 167                 bs = cons(bind,bs);
 168                 break;
 169         }
 170     }
 171     return bs;
 172 }
 173
 174 static void liftAlt( StgCaseAlt alt )
 175 {
 176     if (isDefaultAlt(alt))
 177        liftExpr(stgDefaultBody(alt)); else
 178        liftExpr(stgCaseAltBody(alt));
 179 }
 180
 181 static void liftPrimAlt( StgPrimAlt alt )
 182 {
 183     liftExpr(stgPrimAltBody(alt));
 184 }
 185
 186 static void liftExpr( StgExpr e )
 187 {
 188     switch (whatIs(e)) {
 189     case LETREC:
 190             stgLetBinds(e) = liftLetBinds(stgLetBinds(e),FALSE);
 191             liftExpr(stgLetBody(e));
 192             break;
 193     case LAMBDA:
 194             liftExpr(stgLambdaBody(e));
 195             break;
 196     case CASE:
 197             liftExpr(stgCaseScrut(e));
 198             mapProc(liftAlt,stgCaseAlts(e));
 199             break;
 200     case PRIMCASE:
 201             liftExpr(stgPrimCaseScrut(e));
 202             mapProc(liftPrimAlt,stgPrimCaseAlts(e));
 203             break;
 204     case STGPRIM:
 205             break;
 206     case STGAPP:
 207             break;
 208     case STGVAR:
 209     case NAME:
 210             break;
 211     default:
 212             internal("liftExpr");
 213     }
 214 }
 215
 216 /* Lift a list of top-level binds. */
 217 List liftBinds( List binds )
 218 {
 219     List bs;
 220
 221     for(bs=binds; nonNull(bs); bs=tl(bs)) {
 222         StgVar bind = hd(bs);
 223         freeVarsBind(NIL,bind);
 224         stgVarInfo(bind) = NONE; /* mark as top level */
 225     }
 226
 227     liftedBinds = NIL;
 228     binds = liftLetBinds(binds,TRUE);
 229     binds = revOnto(liftedBinds,binds);
 230
 231     for (bs=binds; nonNull(bs); bs=tl(bs)) {
 232        Name n = nameFromStgVar(hd(bs));
 233        if (nonNull(n))
 234           name(n).stgSize = stgSize(stgVarBody(name(n).stgVar));
 235     }
 236
 237     liftedBinds = NIL;
 238     return binds;
 239 }
 240
 241 /* --------------------------------------------------------------------------
 242  * Compiler control:
 243  * ------------------------------------------------------------------------*/
 244
 245 Void liftControl(what)
 246 Int what; {
 247     switch (what) {
 248     case INSTALL:
 249             /* deliberate fall though */
 250     case RESET:
 251             liftedBinds = NIL;
 252             break;
 253     case MARK:
 254             mark(liftedBinds);
 255             break;
 256     }
 257 }
 258
 259 /*-------------------------------------------------------------------------*/