ghc/interpreter/stgSubst.c

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