ghc/interpreter/free.c

   1 /* -*- mode: hugs-c; -*- */
   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.2 $
  11  * $Date: 1998/12/02 13:22:08 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "connect.h"
  17 #include "errors.h"
  18 #include "stg.h"
  19 #include "free.h"
  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     StgPat pat = stgCaseAltPat(alt);
  76     acc = freeVarsExpr(acc,stgCaseAltBody(alt));
  77     if (!isDefaultPat(pat)) {
  78         acc = diffList(acc,stgPatVars(pat));
  79     }
  80     return deleteCell(acc,pat);
  81 }
  82
  83 static List freeVarsPrimAlt( List acc, StgPrimAlt alt )
  84 {
  85     List vs = stgPrimAltPats(alt);
  86     acc = freeVarsExpr(acc,stgPrimAltBody(alt));
  87     return diffList(acc,vs);
  88 }
  89
  90 static List freeVarsExpr( List acc, StgExpr e )
  91 {
  92     switch (whatIs(e)) {
  93     case LETREC:
  94             mapAccum(freeVarsBind,acc,stgLetBinds(e));
  95             return diffList(freeVarsExpr(acc,stgLetBody(e)),stgLetBinds(e));
  96     case LAMBDA:
  97             return diffList(freeVarsExpr(acc,stgLambdaBody(e)),stgLambdaArgs(e));
  98     case CASE:
  99             mapAccum(freeVarsAlt,acc,stgCaseAlts(e));
 100             return freeVarsExpr(acc,stgCaseScrut(e));
 101     case PRIMCASE:
 102             mapAccum(freeVarsPrimAlt,acc,stgPrimCaseAlts(e));
 103             return freeVarsExpr(acc,stgPrimCaseScrut(e));
 104     case STGPRIM:
 105             mapAccum(freeVarsAtom,acc,stgPrimArgs(e));
 106             /* primop is not a var */
 107             return acc;
 108     case STGAPP:
 109             /* Doing fun first causes slightly less stack rearrangement. */
 110             acc = freeVarsExpr(acc,stgAppFun(e));
 111             mapAccum(freeVarsAtom,acc,stgAppArgs(e));
 112             return acc;
 113     case STGVAR:
 114             return freeVarsVar(acc, e);
 115     case NAME:
 116             return acc;  /* Names are never free vars */
 117     default:
 118             internal("freeVarsExpr");
 119     }
 120 }
 121
 122 /*-------------------------------------------------------------------------*/