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  * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
   9  * Yale Haskell Group, and the Oregon Graduate Institute of Science and
  10  * Technology, 1994-1999, All rights reserved.  It is distributed as
  11  * free software under the license in the file "License", which is
  12  * included in the distribution.
  13  *
  14  * $RCSfile: lift.c,v $
  15  * $Revision: 1.6 $
  16  * $Date: 1999/10/15 21:40:51 $
  17  * ------------------------------------------------------------------------*/
  18
  19 #include "prelude.h"
  20 #include "storage.h"
  21 #include "backend.h"
  22 #include "connect.h"
  23 #include "errors.h"
  24
  25
  26 /* --------------------------------------------------------------------------
  27  * Local function prototypes:
  28  * ------------------------------------------------------------------------*/
  29
  30 static List liftedBinds    = NIL;
  31 static Bool makeInlineable = FALSE;
  32 static Int  inlineCounter  = 0;
  33
  34 static StgExpr abstractExpr ( List vars, StgExpr e );
  35 static inline Bool isTopLevel( StgVar v );
  36 static List    filterFreeVars( List vs );
  37 static List    liftLetBinds ( List binds, Bool topLevel );
  38 static void    liftAlt      ( StgCaseAlt alt );
  39 static void    liftPrimAlt  ( StgPrimAlt alt );
  40 static void    liftExpr     ( StgExpr e );
  41
  42 /* --------------------------------------------------------------------------
  43  * Lambda lifter
  44  * ------------------------------------------------------------------------*/
  45
  46 /* abstract variables out of an expression */
  47 static StgExpr abstractExpr( List vars, StgExpr e )
  48 {
  49     List args = NIL;
  50     List sub  = NIL; /* association list */
  51     for(; nonNull(vars); vars=tl(vars)) {
  52         StgVar var = hd(vars);
  53         StgVar arg = mkStgVar(NIL,NIL);
  54         stgVarRep(arg) = stgVarRep(var);
  55         args = cons(arg,args);
  56         sub  = cons(pair(var,arg),sub);
  57     }
  58     return makeStgLambda(rev(args),substExpr(sub,e));
  59 }
  60
  61 /* ToDo: should be conservative estimate but isn't */
  62 /* Will a variable be floated out to top level - conservative estimate? */
  63 static inline Bool isTopLevel( StgVar v )
  64 {
  65     if (isNull(stgVarBody(v))) {
  66         return FALSE; /* only let bound vars can be floated */
  67     } else if (stgVarInfo(v) == NONE) {
  68         return TRUE;  /* those at top level are already there */
  69     } else {
  70 #if LIFT_CONSTANTS
  71 #error lift constants
  72         StgRhs rhs  = stgVarBody(v);
  73         switch (whatIs(rhs)) {
  74         case STGCON:
  75         case STGAPP:
  76                 return isNull(stgVarInfo(v));
  77         default:
  78                 return FALSE;
  79         }
  80 #else
  81         return FALSE;
  82 #endif
  83     }
  84 }
  85
  86 static List filterFreeVars( List vs )
  87 {
  88     List fvs = NIL;
  89     if (vs == NONE) {
  90         return NIL;
  91     } else {
  92         for(; nonNull(vs); vs=tl(vs)) {
  93             StgVar v = hd(vs);
  94             if (!isTopLevel(v)) {
  95                 fvs = cons(v,fvs);
  96             }
  97         }
  98         return fvs;
  99     }
 100 }
 101
 102 static List liftLetBinds( List binds, Bool topLevel )
 103 {
 104     List bs = NIL;
 105     for(; nonNull(binds); binds=tl(binds)) {
 106         StgVar bind = hd(binds);
 107         StgRhs rhs  = stgVarBody(bind);
 108         List   fvs  = filterFreeVars(stgVarInfo(bind));
 109         /* stgVarInfo(bind) = NIL; */ /* ToDo: discard fv list */
 110
 111         /* if starting on a new top-level inlineable bind, ensure that
 112            the lifted-out binds get marked inlineable too
 113         */
 114         if (topLevel) {
 115            Name n         = nameFromStgVar(bind);
 116            makeInlineable = FALSE;
 117            if (nonNull(n) && name(n).inlineMe==TRUE) makeInlineable = TRUE;
 118         }
 119
 120         switch (whatIs(rhs)) {
 121         case STGCON:
 122         case STGAPP:
 123 #if LIFT_CONSTANTS
 124 #error lift constants
 125                 if (isNull(fvs)) {
 126                     StgVar v = mkStgVar(rhs,NONE);
 127                     stgVarBody(bind) = mkStgLet(singleton(v),v);
 128                     /* ppStg(v); */ /* check inlinable */
 129                     liftedBinds = cons(bind,liftedBinds);
 130                     break;
 131                 }
 132                 /* deliberate fall through */
 133 #endif
 134         case STGVAR:
 135         case NAME:
 136                 bs = cons(bind,bs);
 137                 break;
 138         default:
 139                 liftExpr(rhs);
 140                 if (nonNull(fvs)) {
 141                     StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE);
 142                     liftedBinds = cons(v,liftedBinds);
 143                     if (makeInlineable) {
 144                        Name n;
 145                        char s[16];
 146                        sprintf(s,"lam%d",inlineCounter++);
 147                        n = newName(findText(s),NIL);
 148                        name(n).stgVar = v;
 149                        name(n).simplified = TRUE; /* optimiser is upstream of lifter */
 150                        if (makeInlineable) name(n).inlineMe = TRUE;
 151                        stgVarBody(bind) = makeStgApp(n, fvs);
 152                     } else {
 153                        stgVarBody(bind) = makeStgApp(v, fvs);
 154                     }
 155                 }
 156 #if LIFT_CONSTANTS
 157 #error lift constants
 158                 else {
 159                     StgVar r = mkStgVar(rhs,NIL); /* copy the var */
 160                     StgVar v = mkStgVar(mkStgLet(singleton(r),r),NONE);
 161                     stgVarBody(bind) = v; /* indirection to r */
 162                     /* ppStg(v); */
 163                     liftedBinds = cons(v,liftedBinds);
 164                     bs = cons(bind,bs); /* keep the old binding */
 165                     break;
 166                 }
 167                 /* deliberate fall through */
 168 #endif
 169                 bs = cons(bind,bs);
 170                 break;
 171         }
 172     }
 173     return bs;
 174 }
 175
 176 static void liftAlt( StgCaseAlt alt )
 177 {
 178     if (isDefaultAlt(alt))
 179        liftExpr(stgDefaultBody(alt)); else
 180        liftExpr(stgCaseAltBody(alt));
 181 }
 182
 183 static void liftPrimAlt( StgPrimAlt alt )
 184 {
 185     liftExpr(stgPrimAltBody(alt));
 186 }
 187
 188 static void liftExpr( StgExpr e )
 189 {
 190     switch (whatIs(e)) {
 191     case LETREC:
 192             stgLetBinds(e) = liftLetBinds(stgLetBinds(e),FALSE);
 193             liftExpr(stgLetBody(e));
 194             break;
 195     case LAMBDA:
 196             liftExpr(stgLambdaBody(e));
 197             break;
 198     case CASE:
 199             liftExpr(stgCaseScrut(e));
 200             mapProc(liftAlt,stgCaseAlts(e));
 201             break;
 202     case PRIMCASE:
 203             liftExpr(stgPrimCaseScrut(e));
 204             mapProc(liftPrimAlt,stgPrimCaseAlts(e));
 205             break;
 206     case STGPRIM:
 207             break;
 208     case STGAPP:
 209             break;
 210     case STGVAR:
 211     case NAME:
 212             break;
 213     default:
 214             internal("liftExpr");
 215     }
 216 }
 217
 218 /* Lift a list of top-level binds. */
 219 List liftBinds( List binds )
 220 {
 221     List bs;
 222
 223     for(bs=binds; nonNull(bs); bs=tl(bs)) {
 224         StgVar bind = hd(bs);
 225         freeVarsBind(NIL,bind);
 226         stgVarInfo(bind) = NONE; /* mark as top level */
 227     }
 228
 229     liftedBinds = NIL;
 230     binds = liftLetBinds(binds,TRUE);
 231     binds = revOnto(liftedBinds,binds);
 232
 233     for (bs=binds; nonNull(bs); bs=tl(bs)) {
 234        Name n = nameFromStgVar(hd(bs));
 235        if (nonNull(n))
 236           name(n).stgSize = stgSize(stgVarBody(name(n).stgVar));
 237     }
 238
 239     liftedBinds = NIL;
 240     return binds;
 241 }
 242
 243 /* --------------------------------------------------------------------------
 244  * Compiler control:
 245  * ------------------------------------------------------------------------*/
 246
 247 Void liftControl(what)
 248 Int what; {
 249     switch (what) {
 250     case INSTALL:
 251             /* deliberate fall though */
 252     case RESET:
 253             liftedBinds = NIL;
 254             break;
 255     case MARK:
 256             mark(liftedBinds);
 257             break;
 258     }
 259 }
 260
 261 /*-------------------------------------------------------------------------*/