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.13 $
  16  * $Date: 2000/03/23 14:54:21 $
  17  * ------------------------------------------------------------------------*/
  18
  19 #include "hugsbasictypes.h"
  20 #include "storage.h"
  21 #include "connect.h"
  22 #include "errors.h"
  23
  24
  25 /* --------------------------------------------------------------------------
  26  * Local function prototypes:
  27  * ------------------------------------------------------------------------*/
  28
  29 static List liftedBinds    = NIL;
  30 static Bool makeInlineable = FALSE;
  31 static Int  inlineCounter  = 0;
  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, Bool topLevel );
  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         stgVarRep(arg) = stgVarRep(var);
  54         args = cons(arg,args);
  55         sub  = cons(pair(var,arg),sub);
  56     }
  57     return makeStgLambda(rev(args),substExpr(sub,e));
  58 }
  59
  60 /* ToDo: should be conservative estimate but isn't */
  61 /* Will a variable be floated out to top level - conservative estimate? */
  62 static inline Bool isTopLevel( StgVar v )
  63 {
  64     if (isNull(stgVarBody(v))) {
  65         return FALSE; /* only let bound vars can be floated */
  66     } else if (stgVarInfo(v) == NONE) {
  67         return TRUE;  /* those at top level are already there */
  68     } else {
  69         return FALSE;
  70     }
  71 }
  72
  73 static List filterFreeVars( List vs )
  74 {
  75     List fvs = NIL;
  76     if (vs == NONE) {
  77         return NIL;
  78     } else {
  79         for(; nonNull(vs); vs=tl(vs)) {
  80             StgVar v = hd(vs);
  81             if (!isTopLevel(v)) {
  82                 fvs = cons(v,fvs);
  83             }
  84         }
  85         return fvs;
  86     }
  87 }
  88
  89 static List liftLetBinds( List binds, Bool topLevel )
  90 {
  91     List bs = NIL;
  92     for(; nonNull(binds); binds=tl(binds)) {
  93         StgVar bind = hd(binds);
  94         StgRhs rhs  = stgVarBody(bind);
  95         List   fvs  = filterFreeVars(stgVarInfo(bind));
  96
  97         switch (whatIs(rhs)) {
  98         case STGCON:
  99         case STGAPP:
 100         case STGVAR:
 101         case NAME:
 102                 bs = cons(bind,bs);
 103                 break;
 104         default:
 105                 liftExpr(rhs);
 106                 if (nonNull(fvs)) {
 107                     StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE);
 108                     liftedBinds = cons(v,liftedBinds);
 109                     if (makeInlineable) {
 110                        Name n;
 111                        char s[16];
 112                        sprintf(s,"lam%d",inlineCounter++);
 113                        n = newName(findText(s),NIL);
 114                        name(n).stgVar = v;
 115                        stgVarBody(bind) = makeStgApp(n, fvs);
 116                     } else {
 117                        stgVarBody(bind) = makeStgApp(v, fvs);
 118                     }
 119                 }
 120                 bs = cons(bind,bs);
 121                 break;
 122         }
 123     }
 124     return bs;
 125 }
 126
 127 static void liftAlt( StgCaseAlt alt )
 128 {
 129     if (isDefaultAlt(alt))
 130        liftExpr(stgDefaultBody(alt)); else
 131        liftExpr(stgCaseAltBody(alt));
 132 }
 133
 134 static void liftPrimAlt( StgPrimAlt alt )
 135 {
 136     liftExpr(stgPrimAltBody(alt));
 137 }
 138
 139 static void liftExpr( StgExpr e )
 140 {
 141     switch (whatIs(e)) {
 142     case LETREC:
 143             stgLetBinds(e) = liftLetBinds(stgLetBinds(e),FALSE);
 144             liftExpr(stgLetBody(e));
 145             break;
 146     case LAMBDA:
 147             liftExpr(stgLambdaBody(e));
 148             break;
 149     case CASE:
 150             liftExpr(stgCaseScrut(e));
 151             mapProc(liftAlt,stgCaseAlts(e));
 152             break;
 153     case PRIMCASE:
 154             liftExpr(stgPrimCaseScrut(e));
 155             mapProc(liftPrimAlt,stgPrimCaseAlts(e));
 156             break;
 157     case STGPRIM:
 158             break;
 159     case STGAPP:
 160             break;
 161     case STGVAR:
 162     case NAME:
 163             break;
 164     default:
 165             internal("liftExpr");
 166     }
 167 }
 168
 169 /* Lift a list of top-level binds. */
 170 List liftBinds( List binds )
 171 {
 172     List bs;
 173
 174     for(bs=binds; nonNull(bs); bs=tl(bs)) {
 175         StgVar bind = hd(bs);
 176
 177         if (debugSC) {
 178            if (currentModule != modulePrelude) {
 179               fprintf(stderr, "\n");
 180               ppStg(hd(bs));
 181               fprintf(stderr, "\n");
 182            }
 183         }
 184         freeVarsBind(NIL,bind);
 185         stgVarInfo(bind) = NONE; /* mark as top level */
 186     }
 187
 188     liftedBinds = NIL;
 189     binds       = liftLetBinds(binds,TRUE);
 190     binds       = revOnto(liftedBinds,binds);
 191     liftedBinds = NIL;
 192     return binds;
 193 }
 194
 195 /* --------------------------------------------------------------------------
 196  * Compiler control:
 197  * ------------------------------------------------------------------------*/
 198
 199 Void liftControl(what)
 200 Int what; {
 201     switch (what) {
 202        case POSTPREL: break;
 203
 204        case PREPREL:
 205        case RESET:
 206           liftedBinds = NIL;
 207           break;
 208        case MARK:
 209           mark(liftedBinds);
 210           break;
 211     }
 212 }
 213
 214 /*-------------------------------------------------------------------------*/