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