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.9 $
  13  * $Date: 2000/04/28 13:03:47 $
  14  * ------------------------------------------------------------------------*/
  15
  16 #include "hugsbasictypes.h"
  17 #include "storage.h"
  18 #include "connect.h"
  19 #include "errors.h"
  20
  21 /* --------------------------------------------------------------------------
  22  * Local function prototypes:
  23  * ------------------------------------------------------------------------*/
  24
  25 static StgVar     substVar     ( List sub, StgVar v );
  26 static StgAtom    substAtom    ( List sub, StgAtom a );
  27 static void       substBind    ( List sub, StgVar bind );
  28 static void       substAlt     ( List sub, StgCaseAlt alt );
  29 static void       substPrimAlt ( List sub, StgPrimAlt alt );
  30
  31 /* --------------------------------------------------------------------------
  32  * Substitute variables throughout an expression - updating in place.
  33  * ------------------------------------------------------------------------*/
  34
  35 static StgVar substVar( List sub, StgVar v )
  36 {
  37     Pair p = cellAssoc(v,sub);
  38     if (nonNull(p)) {
  39         return snd(p);
  40     } else {
  41         return v;
  42     }
  43 }
  44
  45 static StgAtom substAtom ( List sub, StgAtom a )
  46 {
  47     switch (whatIs(a)) {
  48     case STGVAR:
  49             return substVar(sub,a);
  50     default:
  51             return a;
  52     }
  53 }
  54
  55 static Void substBind( List sub, StgVar bind )
  56 {
  57     StgRhs rhs = stgVarBody(bind);
  58     switch (whatIs(rhs)) {
  59     case STGCON:
  60             map1Over(substAtom,sub,stgConArgs(rhs));
  61             return;
  62     default:
  63             stgVarBody(bind) = substExpr(sub,rhs);
  64             return;
  65     }
  66 }
  67
  68 static Void substAlt( List sub, StgCaseAlt alt )
  69 {
  70     if (isDefaultAlt(alt))
  71        stgDefaultBody(alt) = substExpr(sub,stgDefaultBody(alt)); else
  72        stgCaseAltBody(alt) = substExpr(sub,stgCaseAltBody(alt));
  73 }
  74
  75 static Void substPrimAlt( List sub, StgPrimAlt alt )
  76 {
  77     stgPrimAltBody(alt) = substExpr(sub,stgPrimAltBody(alt));
  78 }
  79
  80 StgExpr substExpr( List sub, StgExpr e )
  81 {
  82     switch (whatIs(e)) {
  83     case LETREC:
  84             map1Proc(substBind,sub,stgLetBinds(e));
  85             stgLetBody(e) = substExpr(sub,stgLetBody(e));
  86             break;
  87     case LAMBDA:
  88             stgLambdaBody(e) = substExpr(sub,stgLambdaBody(e));
  89             break;
  90     case CASE:
  91             stgCaseScrut(e) = substExpr(sub,stgCaseScrut(e));
  92             map1Proc(substAlt,sub,stgCaseAlts(e));
  93             break;
  94     case PRIMCASE:
  95             stgPrimCaseScrut(e) = substExpr(sub,stgPrimCaseScrut(e));
  96             map1Proc(substPrimAlt,sub,stgPrimCaseAlts(e));
  97             break;
  98     case STGPRIM:
  99             map1Over(substAtom,sub,stgPrimArgs(e));
 100             break;
 101     case STGAPP:
 102             stgAppFun(e) = substVar(sub,stgAppFun(e));
 103             map1Over(substAtom,sub,stgAppArgs(e));
 104             break;
 105     case STGCON:
 106             map1Over(substAtom,sub,stgConArgs(e));
 107             break;
 108     case STGVAR:
 109     case NAME:
 110     case TUPLE:
 111             return substVar(sub,e);
 112     default:
 113             internal("substExpr");
 114     }
 115     return e;
 116 }
 117
 118
 119 /*-------------------------------------------------------------------------*/