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