[project @ 2001-01-17 10:14:40 by simonmar]
[ghc-hetmet.git] / 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 /*-------------------------------------------------------------------------*/