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.14 $
  16  * $Date: 2000/04/27 16:35:29 $
  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
  31 static StgExpr abstractExpr   ( List vars, StgExpr e );
  32 static Bool    isTopLevel     ( StgVar v );
  33 static List    filterFreeVars ( List vs );
  34 static List    liftLetBinds   ( List binds, Bool topLevel );
  35 static void    liftAlt        ( StgCaseAlt alt );
  36 static void    liftPrimAlt    ( StgPrimAlt alt );
  37 static void    liftExpr       ( StgExpr e );
  38
  39 /* --------------------------------------------------------------------------
  40  * Lambda lifter
  41  * ------------------------------------------------------------------------*/
  42
  43 /* abstract variables out of an expression */
  44 static StgExpr abstractExpr( List vars, StgExpr e )
  45 {
  46     List args = NIL;
  47     List sub  = NIL; /* association list */
  48     for(; nonNull(vars); vars=tl(vars)) {
  49         StgVar var = hd(vars);
  50         StgVar arg = mkStgVar(NIL,NIL);
  51         stgVarRep(arg) = stgVarRep(var);
  52         args = cons(arg,args);
  53         sub  = cons(pair(var,arg),sub);
  54     }
  55     return makeStgLambda(rev(args),substExpr(sub,e));
  56 }
  57
  58 /* ToDo: should be conservative estimate but isn't */
  59 /* Will a variable be floated out to top level - conservative estimate? */
  60 static Bool isTopLevel( StgVar v )
  61 {
  62     if (isNull(stgVarBody(v))) {
  63         return FALSE; /* only let bound vars can be floated */
  64     } else if (stgVarInfo(v) == NONE) {
  65         return TRUE;  /* those at top level are already there */
  66     } else {
  67         return FALSE;
  68     }
  69 }
  70
  71 static List filterFreeVars( List vs )
  72 {
  73     List fvs = NIL;
  74     if (vs == NONE) {
  75         return NIL;
  76     } else {
  77         for(; nonNull(vs); vs=tl(vs)) {
  78             StgVar v = hd(vs);
  79             if (!isTopLevel(v)) {
  80                 fvs = cons(v,fvs);
  81             }
  82         }
  83         return fvs;
  84     }
  85 }
  86
  87 static Int nameCounter;
  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                     {
 109                        Name n;
 110                        char s[16];
 111                        sprintf(s,"(lift%d)",nameCounter++);
 112                        n = newName(findText(s),NIL);
 113                        name(n).closure = v;
 114                        stgVarBody(bind) = makeStgApp(n, fvs);
 115                        liftedBinds = cons(n,liftedBinds);
 116                     }
 117                 }
 118                 bs = cons(bind,bs);
 119                 break;
 120         }
 121     }
 122     return bs;
 123 }
 124
 125 static void liftAlt( StgCaseAlt alt )
 126 {
 127     if (isDefaultAlt(alt))
 128        liftExpr(stgDefaultBody(alt)); else
 129        liftExpr(stgCaseAltBody(alt));
 130 }
 131
 132 static void liftPrimAlt( StgPrimAlt alt )
 133 {
 134     liftExpr(stgPrimAltBody(alt));
 135 }
 136
 137 static void liftExpr( StgExpr e )
 138 {
 139     switch (whatIs(e)) {
 140     case LETREC:
 141             stgLetBinds(e) = liftLetBinds(stgLetBinds(e),FALSE);
 142             liftExpr(stgLetBody(e));
 143             break;
 144     case LAMBDA:
 145             liftExpr(stgLambdaBody(e));
 146             break;
 147     case CASE:
 148             liftExpr(stgCaseScrut(e));
 149             mapProc(liftAlt,stgCaseAlts(e));
 150             break;
 151     case PRIMCASE:
 152             liftExpr(stgPrimCaseScrut(e));
 153             mapProc(liftPrimAlt,stgPrimCaseAlts(e));
 154             break;
 155     case STGPRIM:
 156             break;
 157     case STGAPP:
 158             break;
 159     case STGVAR:
 160     case NAME:
 161     case TUPLE:
 162             break;
 163     default:
 164             internal("liftExpr");
 165     }
 166 }
 167
 168 /* Lift the list of top-level binds for a module. */
 169 void liftModule ( Module mod )
 170 {
 171     List binds = NIL;
 172     List cl;
 173
 174     nameCounter = 0;
 175     for (cl = module(mod).codeList; nonNull(cl); cl = tl(cl)) {
 176         StgVar bind = getNameOrTupleClosure(hd(cl));
 177         if (isCPtr(bind)) continue;
 178         assert(nonNull(bind));
 179         if (debugSC) {
 180            if (currentModule != modulePrelude) {
 181               fprintf(stderr, "\n");
 182               ppStg(bind);
 183               fprintf(stderr, "\n");
 184            }
 185         }
 186         freeVarsBind(NIL,bind);
 187         stgVarInfo(bind) = NONE; /* mark as top level */
 188         binds = cons(bind,binds);
 189     }
 190
 191     liftedBinds = NIL;
 192     binds       = liftLetBinds(binds,TRUE);
 193     module(mod).codeList = revOnto(liftedBinds, module(mod).codeList);
 194     liftedBinds = NIL;
 195 }
 196
 197 /* --------------------------------------------------------------------------
 198  * Compiler control:
 199  * ------------------------------------------------------------------------*/
 200
 201 Void liftControl(what)
 202 Int what; {
 203     switch (what) {
 204        case POSTPREL: break;
 205
 206        case PREPREL:
 207        case RESET:
 208           liftedBinds = NIL;
 209           break;
 210        case MARK:
 211           mark(liftedBinds);
 212           break;
 213     }
 214 }
 215
 216 /*-------------------------------------------------------------------------*/