ghc/interpreter/free.c

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