ghc/interpreter/stgSubst.c

   1 /* -*- mode: hugs-c; -*- */
   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.2 $
  11  * $Date: 1998/12/02 13:22:40 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "connect.h"
  17 #include "errors.h"
  18 #include "stg.h"
  19
  20 #include "stgSubst.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     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 STGVAR:
 105     case NAME:
 106             return substVar(sub,e);
 107     default:
 108             internal("substExpr");
 109     }
 110     return e;
 111 }
 112
 113 /*-------------------------------------------------------------------------*/