ghc/interpreter/stgSubst.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Substitute variables in an expression
   4  *
   5  * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
   6  * Yale Haskell Group, and the Oregon Graduate Institute of Science and
   7  * Technology, 1994-1999, All rights reserved.  It is distributed as
   8  * free software under the license in the file "License", which is
   9  * included in the distribution.
  10  *
  11  * $RCSfile: stgSubst.c,v $
  12  * $Revision: 1.5 $
  13  * $Date: 1999/10/15 21:40:57 $
  14  * ------------------------------------------------------------------------*/
  15
  16 #include "prelude.h"
  17 #include "storage.h"
  18 #include "backend.h"
  19 #include "connect.h"
  20 #include "errors.h"
  21
  22 /* --------------------------------------------------------------------------
  23  * Local function prototypes:
  24  * ------------------------------------------------------------------------*/
  25
  26 static StgVar     substVar     ( List sub, StgVar v );
  27 static StgAtom    substAtom    ( List sub, StgAtom a );
  28 static void       substBind    ( List sub, StgVar bind );
  29 static void       substAlt     ( List sub, StgCaseAlt alt );
  30 static void       substPrimAlt ( List sub, StgPrimAlt alt );
  31
  32 /* --------------------------------------------------------------------------
  33  * Substitute variables throughout an expression - updating in place.
  34  * ------------------------------------------------------------------------*/
  35
  36 static StgVar substVar( List sub, StgVar v )
  37 {
  38     Pair p = cellAssoc(v,sub);
  39     if (nonNull(p)) {
  40         return snd(p);
  41     } else {
  42         return v;
  43     }
  44 }
  45
  46 static StgAtom substAtom ( List sub, StgAtom a )
  47 {
  48     switch (whatIs(a)) {
  49     case STGVAR:
  50             return substVar(sub,a);
  51     default:
  52             return a;
  53     }
  54 }
  55
  56 static Void substBind( List sub, StgVar bind )
  57 {
  58     StgRhs rhs = stgVarBody(bind);
  59     switch (whatIs(rhs)) {
  60     case STGCON:
  61             map1Over(substAtom,sub,stgConArgs(rhs));
  62             return;
  63     default:
  64             stgVarBody(bind) = substExpr(sub,rhs);
  65             return;
  66     }
  67 }
  68
  69 static Void substAlt( List sub, StgCaseAlt alt )
  70 {
  71     if (isDefaultAlt(alt))
  72        stgDefaultBody(alt) = substExpr(sub,stgDefaultBody(alt)); else
  73        stgCaseAltBody(alt) = substExpr(sub,stgCaseAltBody(alt));
  74 }
  75
  76 static Void substPrimAlt( List sub, StgPrimAlt alt )
  77 {
  78     stgPrimAltBody(alt) = substExpr(sub,stgPrimAltBody(alt));
  79 }
  80
  81 StgExpr substExpr( List sub, StgExpr e )
  82 {
  83     switch (whatIs(e)) {
  84     case LETREC:
  85             map1Proc(substBind,sub,stgLetBinds(e));
  86             stgLetBody(e) = substExpr(sub,stgLetBody(e));
  87             break;
  88     case LAMBDA:
  89             stgLambdaBody(e) = substExpr(sub,stgLambdaBody(e));
  90             break;
  91     case CASE:
  92             stgCaseScrut(e) = substExpr(sub,stgCaseScrut(e));
  93             map1Proc(substAlt,sub,stgCaseAlts(e));
  94             break;
  95     case PRIMCASE:
  96             stgPrimCaseScrut(e) = substExpr(sub,stgPrimCaseScrut(e));
  97             map1Proc(substPrimAlt,sub,stgPrimCaseAlts(e));
  98             break;
  99     case STGPRIM:
 100             map1Over(substAtom,sub,stgPrimArgs(e));
 101             break;
 102     case STGAPP:
 103             stgAppFun(e) = substVar(sub,stgAppFun(e));
 104             map1Over(substAtom,sub,stgAppArgs(e));
 105             break;
 106     case STGCON:
 107             map1Over(substAtom,sub,stgConArgs(e));
 108             break;
 109     case STGVAR:
 110     case NAME:
 111             return substVar(sub,e);
 112     default:
 113             internal("substExpr");
 114     }
 115     return e;
 116 }
 117
 118
 119 /* A substitution engine more suitable for the optimiser.
 120    Doesn't make so many assumptions about what is an atom.
 121 */
 122 StgExpr zubstExpr( List sub, StgExpr e )
 123 {
 124     List bs;
 125     switch (whatIs(e)) {
 126     case LETREC:
 127             for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs))
 128                stgVarBody(hd(bs)) = zubstExpr(sub,stgVarBody(hd(bs)));
 129             stgLetBody(e) = zubstExpr(sub,stgLetBody(e));
 130             break;
 131     case LAMBDA:
 132             stgLambdaBody(e) = zubstExpr(sub,stgLambdaBody(e));
 133             break;
 134     case CASE:
 135             stgCaseScrut(e) = zubstExpr(sub,stgCaseScrut(e));
 136             map1Proc(zubstExpr,sub,stgCaseAlts(e));
 137             break;
 138     case PRIMCASE:
 139             stgPrimCaseScrut(e) = zubstExpr(sub,stgPrimCaseScrut(e));
 140             map1Proc(zubstExpr,sub,stgPrimCaseAlts(e));
 141             break;
 142     case CASEALT:
 143             stgCaseAltBody(e) = zubstExpr(sub,stgCaseAltBody(e));
 144             break;
 145     case DEEFALT:
 146             stgDefaultBody(e) = zubstExpr(sub,stgDefaultBody(e));
 147             break;
 148     case PRIMALT:
 149             stgPrimAltBody(e) = zubstExpr(sub,stgPrimAltBody(e));
 150             break;
 151     case STGPRIM:
 152             map1Over(zubstExpr,sub,stgPrimArgs(e));
 153             break;
 154     case STGAPP:
 155             stgAppFun(e) = zubstExpr(sub,stgAppFun(e));
 156             map1Over(zubstExpr,sub,stgAppArgs(e));
 157             break;
 158     case STGCON:
 159             map1Over(zubstExpr,sub,stgConArgs(e));
 160             break;
 161     case STGVAR:
 162             return substVar(sub,e);
 163     case NAME:
 164     case INTCELL:
 165     case STRCELL:
 166     case PTRCELL:
 167     case CHARCELL:
 168     case FLOATCELL:
 169             break;
 170     default:
 171             internal("zubstExpr");
 172     }
 173     return e;
 174 }
 175
 176
 177
 178 /*-------------------------------------------------------------------------*/