ghc/interpreter/free.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Free variable analysis
   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: free.c,v $
  12  * $Revision: 1.7 $
  13  * $Date: 1999/11/01 11:07:07 $
  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 /* --------------------------------------------------------------------------
  24  * Local functions
  25  * ------------------------------------------------------------------------*/
  26
  27 static List freeVarsAlt     Args((List, StgCaseAlt));
  28 static List freeVarsPrimAlt Args((List, StgPrimAlt));
  29 static List freeVarsExpr    Args((List, StgExpr));
  30 static List freeVarsAtom    Args((List, StgAtom));
  31 static List freeVarsVar     Args((List, StgVar));
  32
  33 /* --------------------------------------------------------------------------
  34  * Free variable analysis
  35  * ------------------------------------------------------------------------*/
  36
  37 static List freeVarsAtom( List acc, StgAtom a)
  38 {
  39     switch (whatIs(a)) {
  40     case STGVAR:
  41             return freeVarsVar(acc,a);
  42     /* Note that NAMEs have no free vars. */
  43     default:
  44             return acc;
  45     }
  46 }
  47
  48 static List freeVarsVar( List acc, StgVar v)
  49 {
  50     if (cellIsMember(v,acc)) {
  51         return acc;
  52     } else {
  53         return cons(v,acc);
  54     }
  55 }
  56
  57 List freeVarsBind( List acc, StgVar v )
  58 {
  59     StgRhs rhs = stgVarBody(v);
  60     List fvs = NIL;
  61     switch (whatIs(rhs)) {
  62     case STGCON:
  63             mapAccum(freeVarsAtom,fvs,stgConArgs(rhs));
  64             break;
  65     default:
  66             fvs = freeVarsExpr(fvs,rhs);
  67             break;
  68     }
  69     /* fvs = rev(fvs); */  /* todo might cause less stack rearrangement? */
  70     stgVarInfo(v) = fvs;
  71     mapAccum(freeVarsVar,acc,fvs); /* copy onto acc */
  72     return acc;
  73 }
  74
  75 static List freeVarsAlt( List acc, StgCaseAlt alt )
  76 {
  77     if (isDefaultAlt(alt)) {
  78         acc = freeVarsExpr(acc,stgDefaultBody(alt));
  79         return deleteCell(acc,stgDefaultVar(alt));
  80     } else {
  81         acc = freeVarsExpr(acc,stgCaseAltBody(alt));
  82         return diffList(acc,stgCaseAltVars(alt));
  83     }
  84 }
  85
  86 static List freeVarsPrimAlt( List acc, StgPrimAlt alt )
  87 {
  88     List vs = stgPrimAltVars(alt);
  89     acc = freeVarsExpr(acc,stgPrimAltBody(alt));
  90     return diffList(acc,vs);
  91 }
  92
  93 static List freeVarsExpr( List acc, StgExpr e )
  94 {
  95     switch (whatIs(e)) {
  96     case LETREC:
  97             mapAccum(freeVarsBind,acc,stgLetBinds(e));
  98             return diffList(freeVarsExpr(acc,stgLetBody(e)),stgLetBinds(e));
  99     case LAMBDA:
 100             return diffList(freeVarsExpr(acc,stgLambdaBody(e)),stgLambdaArgs(e));
 101     case CASE:
 102             mapAccum(freeVarsAlt,acc,stgCaseAlts(e));
 103             return freeVarsExpr(acc,stgCaseScrut(e));
 104     case PRIMCASE:
 105             mapAccum(freeVarsPrimAlt,acc,stgPrimCaseAlts(e));
 106             return freeVarsExpr(acc,stgPrimCaseScrut(e));
 107     case STGPRIM:
 108             mapAccum(freeVarsAtom,acc,stgPrimArgs(e));
 109             /* primop is not a var */
 110             return acc;
 111     case STGAPP:
 112             /* Doing fun first causes slightly less stack rearrangement. */
 113             acc = freeVarsExpr(acc,stgAppFun(e));
 114             mapAccum(freeVarsAtom,acc,stgAppArgs(e));
 115             return acc;
 116     case STGVAR:
 117             return freeVarsVar(acc, e);
 118     case NAME:
 119             return acc;  /* Names are never free vars */
 120     default:
 121       /*
 122             printf("\n");
 123             ppStgExpr(e);
 124             printf("\n");
 125       */
 126             internal("freeVarsExpr");
 127     }
 128 }
 129
 130 /*-------------------------------------------------------------------------*/