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.9 $
  16  * $Date: 1999/11/29 18:59:29 $
  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         return FALSE;
  71     }
  72 }
  73
  74 static List filterFreeVars( List vs )
  75 {
  76     List fvs = NIL;
  77     if (vs == NONE) {
  78         return NIL;
  79     } else {
  80         for(; nonNull(vs); vs=tl(vs)) {
  81             StgVar v = hd(vs);
  82             if (!isTopLevel(v)) {
  83                 fvs = cons(v,fvs);
  84             }
  85         }
  86         return fvs;
  87     }
  88 }
  89
  90 static List liftLetBinds( List binds, Bool topLevel )
  91 {
  92     List bs = NIL;
  93     for(; nonNull(binds); binds=tl(binds)) {
  94         StgVar bind = hd(binds);
  95         StgRhs rhs  = stgVarBody(bind);
  96         List   fvs  = filterFreeVars(stgVarInfo(bind));
  97
  98         switch (whatIs(rhs)) {
  99         case STGCON:
 100         case STGAPP:
 101         case STGVAR:
 102         case NAME:
 103                 bs = cons(bind,bs);
 104                 break;
 105         default:
 106                 liftExpr(rhs);
 107                 if (nonNull(fvs)) {
 108                     StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE);
 109                     liftedBinds = cons(v,liftedBinds);
 110                     if (makeInlineable) {
 111                        Name n;
 112                        char s[16];
 113                        sprintf(s,"lam%d",inlineCounter++);
 114                        n = newName(findText(s),NIL);
 115                        name(n).stgVar = v;
 116                        stgVarBody(bind) = makeStgApp(n, fvs);
 117                     } else {
 118                        stgVarBody(bind) = makeStgApp(v, fvs);
 119                     }
 120                 }
 121                 bs = cons(bind,bs);
 122                 break;
 123         }
 124     }
 125     return bs;
 126 }
 127
 128 static void liftAlt( StgCaseAlt alt )
 129 {
 130     if (isDefaultAlt(alt))
 131        liftExpr(stgDefaultBody(alt)); else
 132        liftExpr(stgCaseAltBody(alt));
 133 }
 134
 135 static void liftPrimAlt( StgPrimAlt alt )
 136 {
 137     liftExpr(stgPrimAltBody(alt));
 138 }
 139
 140 static void liftExpr( StgExpr e )
 141 {
 142     switch (whatIs(e)) {
 143     case LETREC:
 144             stgLetBinds(e) = liftLetBinds(stgLetBinds(e),FALSE);
 145             liftExpr(stgLetBody(e));
 146             break;
 147     case LAMBDA:
 148             liftExpr(stgLambdaBody(e));
 149             break;
 150     case CASE:
 151             liftExpr(stgCaseScrut(e));
 152             mapProc(liftAlt,stgCaseAlts(e));
 153             break;
 154     case PRIMCASE:
 155             liftExpr(stgPrimCaseScrut(e));
 156             mapProc(liftPrimAlt,stgPrimCaseAlts(e));
 157             break;
 158     case STGPRIM:
 159             break;
 160     case STGAPP:
 161             break;
 162     case STGVAR:
 163     case NAME:
 164             break;
 165     default:
 166             internal("liftExpr");
 167     }
 168 }
 169
 170 /* Lift a list of top-level binds. */
 171 List liftBinds( List binds )
 172 {
 173     List bs;
 174
 175     for(bs=binds; nonNull(bs); bs=tl(bs)) {
 176         StgVar bind = hd(bs);
 177
 178         if (debugSC) {
 179            if (lastModule() != modulePrelude) {
 180               fprintf(stderr, "\n");
 181               ppStg(hd(bs));
 182               fprintf(stderr, "\n");
 183            }
 184         }
 185         freeVarsBind(NIL,bind);
 186         stgVarInfo(bind) = NONE; /* mark as top level */
 187     }
 188
 189     liftedBinds = NIL;
 190     binds       = liftLetBinds(binds,TRUE);
 191     binds       = revOnto(liftedBinds,binds);
 192     liftedBinds = NIL;
 193     return binds;
 194 }
 195
 196 /* --------------------------------------------------------------------------
 197  * Compiler control:
 198  * ------------------------------------------------------------------------*/
 199
 200 Void liftControl(what)
 201 Int what; {
 202     switch (what) {
 203     case INSTALL:
 204             /* deliberate fall though */
 205     case RESET:
 206             liftedBinds = NIL;
 207             break;
 208     case MARK:
 209             mark(liftedBinds);
 210             break;
 211     }
 212 }
 213
 214 /*-------------------------------------------------------------------------*/