Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/compiler/FLINT/cpsopt/eta.sml
ViewVC logotype

Annotation of /sml/trunk/compiler/FLINT/cpsopt/eta.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2162 - (view) (download)

1 : monnier 245 (* Copyright 1996 by Bell Laboratories *)
2 :     (* eta.sml *)
3 :    
4 :     (***********************************************************************
5 :     * *
6 :     * The function eta is an eta reducer for cps expressions. It is *
7 :     * guaranteed to reach an eta normal form in at most two passes. A *
8 :     * high-level description of the algorithm follows. *
9 :     * *
10 :     * eta essentially takes two arguments, a cps expression and an *
11 :     * environment mapping variables to values. (In practice, the *
12 :     * environment is a global variable.) The environment is used to *
13 :     * keep track of the eta reductions performed. The algorithm can be *
14 :     * explained by the two key clauses below (written in pseudo-cps *
15 :     * notation): *
16 :     * *
17 :     * [FIX] eta(env, *let* f[x1,...,xN] = M1 *
18 :     * *in* M2) *
19 :     * *
20 :     * --> let M1' = eta(env,M1) *
21 :     * in if M1' = g[x1,...,xN] *
22 :     * then eta(env[f := g],M2) *
23 :     * else *let* f[x1,...,xN] = M1' *
24 :     * *in* eta(env,M2) *
25 :     * end *
26 :     * *
27 :     * [APP] eta(env,f[v1,...,vN]) *
28 :     * *
29 :     * --> env(f)[env(v1),...,env(vN)] *
30 :     * *
31 :     * In the [FIX] case of function definition, we first eta reduce the *
32 :     * body M1 of the function f, then see if f is itself an eta *
33 :     * redex f[x1,...,xN] = g[x1,...,xN]. If so, we will use g for f *
34 :     * elsewhere in the cps expression. *
35 :     * *
36 :     * The [APP] case shows where we must rename variables. *
37 :     * *
38 :     * This would get all eta redexes in one pass, except for the *
39 :     * following problem. Consider the cps code below: *
40 :     * *
41 :     * *let* f[x1,...,xN] = M1 *
42 :     * *and* g[y1,...,yN] = f[x1,...,xN] *
43 :     * *in* M2 *
44 :     * *
45 :     * Suppose M1 does not reduce to an application h[x1,...,xN]. *
46 :     * If we naively reduce the expression as above, first reducing *
47 :     * the body M1 of f, then the body of g, then M2, we would get: *
48 :     * *
49 :     * let M1' = eta(env,M1) *
50 :     * in *let* f[x1,...,xN] = M1' *
51 :     * *in* eta(env[g := f],M2) *
52 :     * end *
53 :     * *
54 :     * The problem with this is that M1 might have contained occurrences *
55 :     * of g. Thus g may appear in M1'. There are a number of ways to *
56 :     * handle this: *
57 :     * *
58 :     * 1) Once we perform an eta reduction on any function in a FIX, we *
59 :     * must go back and re-reduce any other functions of the FIX *
60 :     * that we previously reduced; *
61 :     * 2) We do not go back to other functions in the FIX, but instead *
62 :     * make a second pass over the output of eta. *
63 :     * *
64 :     * As (1) can lead to quadratic behaviour, we implemented (2). *
65 :     * *
66 :     * *
67 :     * A final note: we recognize more than just *
68 :     * f[x1,...,xN] = g[x1,...,xN] *
69 :     * as an eta reduction. We regard the function definition *
70 :     * f[x1,...,xN] = SELECT[1,v,g,g[x1,...,xN]] *
71 :     * as an eta redex as well, and so we reduce *
72 :     * eta(env,*let* f[x1,...,xN] = SELECT[i,v,g,g[x1,...,xN]] *
73 :     * *in* M1) *
74 :     * --> SELECT(i,v,g,eta(env[f := g],M1)) *
75 :     * This is implemented with the selectapp function below. *
76 :     * *
77 :     ***********************************************************************)
78 :    
79 :     signature ETA = sig
80 :     val eta : {function: CPS.function,
81 :     click: string -> unit} -> CPS.function
82 :     end (* signature ETA *)
83 :    
84 :     structure Eta : ETA =
85 :     struct
86 :    
87 :     local open CPS
88 :     structure LV = LambdaVar
89 : monnier 498 structure Intset = struct
90 :     type intset = IntRedBlackSet.set ref
91 :     fun new() = ref IntRedBlackSet.empty
92 :     fun add set i = set := IntRedBlackSet.add(!set, i)
93 :     fun mem set i = IntRedBlackSet.member(!set, i)
94 :     fun rmv set i = set := IntRedBlackSet.delete(!set, i)
95 :     end
96 :    
97 : monnier 245 in
98 :    
99 :     fun eta {function=(fkind,fvar,fargs,ctyl,cexp),
100 :     click} =
101 :     let
102 :    
103 :     val debug = !Control.CG.debugcps (* false *)
104 :     fun debugprint s = if debug then Control.Print.say s else ()
105 :     fun debugflush() = if debug then Control.Print.flush() else ()
106 :    
107 :     fun map1 f (a,b) = (f a, b)
108 :     fun member(i : int, a::b) = i=a orelse member(i,b)
109 :     | member(i,[]) = false
110 :     fun same(v::vl, (VAR w)::wl) = v=w andalso same(vl,wl)
111 :     | same(nil,nil) = true
112 :     | same _ = false
113 :     fun sameName(x,VAR y) = LV.sameName(x,y)
114 :     | sameName(x,LABEL y) = LV.sameName(x,y)
115 :     | sameName _ = ()
116 :     exception M2
117 : blume 733 val m : value IntHashTable.hash_table = IntHashTable.mkTable(32, M2)
118 :     val name = IntHashTable.lookup m
119 : monnier 245 fun rename(v0 as VAR v) = (rename(name v) handle M2 => v0)
120 :     | rename(v0 as LABEL v) = (rename(name v) handle M2 => v0)
121 :     | rename x = x
122 : blume 733 fun newname x = (sameName x; IntHashTable.insert m x)
123 : monnier 245
124 :     local val km : Intset.intset = Intset.new()
125 :     in
126 :     fun addvt (v, CNTt) = Intset.add km v
127 :     | addvt _ = ()
128 :     fun addft (CONT, v, _, _, _) = Intset.add km v
129 :     | addft _ = ()
130 :     fun isCont v = Intset.mem km v
131 :     end (* local *)
132 :    
133 :     val id = (fn x => x)
134 :     val doagain = ref false
135 :     val rec pass2 =
136 :     fn RECORD(k,vl,w,e) => RECORD(k, map (map1 rename) vl, w, pass2 e)
137 :     | SELECT(i,v,w,t,e) => SELECT(i, v, w, t, pass2 e)
138 :     | OFFSET(i,v,w,e) => OFFSET(i, v, w, pass2 e)
139 :     | APP(f,vl) => APP(rename f, map rename vl)
140 :     | SWITCH(v,c,el) => SWITCH(v, c,map pass2 el)
141 :     | BRANCH(i,vl,c,e1,e2) =>
142 :     BRANCH(i, map rename vl, c, pass2 e1, pass2 e2)
143 :     | LOOKER(i,vl,w,t,e) => LOOKER(i,map rename vl, w, t, pass2 e)
144 :     | ARITH(i,vl,w,t,e) => ARITH(i,map rename vl, w, t, pass2 e)
145 :     | PURE(i,vl,w,t,e) => PURE(i,map rename vl, w, t, pass2 e)
146 :     | SETTER(i,vl,e) => SETTER(i,map rename vl, pass2 e)
147 : mblume 1755 | RCC(k,l,p,vl,wtl,e) => RCC (k, l, p, map rename vl, wtl, pass2 e)
148 : monnier 245 | FIX(l,e) =>
149 :     FIX(map (fn (fk,f,vl,cl,body) => (fk,f,vl,cl,pass2 body)) l,
150 :     pass2 e)
151 :    
152 :     val rec reduce =
153 :     fn RECORD(k,vl,w,e) => RECORD(k, map (map1 rename) vl, w, reduce e)
154 :     | SELECT(i,v,w,t,e) => (addvt(w,t); SELECT(i, v, w, t, reduce e))
155 :     | OFFSET(i,v,w,e) => OFFSET(i, v, w, reduce e)
156 :     | APP(f,vl) => APP(rename f, map rename vl)
157 :     | SWITCH(v,c,el) => SWITCH(v, c,map reduce el)
158 :     | BRANCH(i,vl,c,e1,e2) =>
159 :     BRANCH(i, map rename vl, c, reduce e1, reduce e2)
160 :     | LOOKER(i,vl,w,t,e) =>
161 :     (addvt(w, t); LOOKER(i,map rename vl, w, t, reduce e))
162 :     | ARITH(i,vl,w,t,e) =>
163 :     (addvt(w, t); ARITH(i,map rename vl, w, t, reduce e))
164 :     | PURE(i,vl,w,t,e) =>
165 :     (addvt(w, t); PURE(i,map rename vl, w, t, reduce e))
166 :     | SETTER(i,vl,e) => SETTER(i,map rename vl, reduce e)
167 : mblume 1755 | RCC (k,l,p,vl,wtl,e) =>
168 :     (app addvt wtl; RCC (k, l, p, map rename vl, wtl, reduce e))
169 : monnier 245 | FIX(l,e) =>
170 :     let val _ = app addft l
171 :     fun eta_elim nil = (nil,id,false)
172 :     | eta_elim((fk as NO_INLINE_INTO,f,vl,cl,body)::r) =
173 :     let val (r',h,leftover) = eta_elim r
174 :     val body' = reduce body
175 :     in ((fk,f,vl,cl,body')::r',h,true)
176 :     end
177 :     | eta_elim((fk,f,vl,cl,body)::r) =
178 :     let val (r',h,leftover) = eta_elim r
179 :     fun rightKind (VAR v | LABEL v) =
180 :     ((fk = CONT) = (isCont v))
181 :     | rightKind _ = false
182 :    
183 :     fun selectapp(SELECT(i,VAR w,v,t,e)) =
184 :     (case selectapp e
185 :     of NONE => NONE
186 :     | SOME(h',u) =>
187 :     if not (member(w,f::vl)) then
188 :     SOME(fn ce => SELECT(i,VAR w,v,t,h' ce),u)
189 :     else NONE)
190 :     | selectapp(APP(g,wl)) =
191 :     let val g' = rename g
192 :     val z = (case g' of VAR x => member(x,f::vl)
193 :     | LABEL x => member(x,f::vl)
194 :     | _ => false)
195 :    
196 :     in if ((not z) andalso (same(vl,wl))
197 :     andalso (rightKind g')) then
198 :     SOME(fn ce => ce, g')
199 :     else NONE
200 :     end
201 :     | selectapp _ = NONE
202 :     val _ = ListPair.app addvt (vl, cl)
203 :     val body' = reduce body
204 :     in case selectapp(body')
205 :     of NONE => ((fk,f,vl,cl,body')::r',h,true)
206 :     | SOME(h',u) => (if leftover then doagain := true
207 :     else ();
208 :     click "e";
209 :     newname(f,u);
210 :     (r',h' o h,leftover))
211 :     end
212 :     in case (eta_elim l)
213 :     of ([],h,_) => h(reduce e)
214 :     | (l',h,_) => h(FIX(l',reduce e))
215 :     end
216 :    
217 :     in (* body of eta *)
218 :     debugprint "Eta: ";
219 :     debugflush();
220 :     let val cexp' = reduce cexp
221 :     in debugprint "\n";
222 :     debugflush();
223 :     if not(!doagain) then (fkind, fvar, fargs, ctyl, cexp')
224 :     else (debugprint "Eta: needed second pass\n";
225 :     debugflush();
226 :     (fkind, fvar, fargs, ctyl, pass2 cexp'))
227 :     end
228 :     end (* fun eta *)
229 :    
230 :     end (* toplevel local *)
231 :     end (* structure Eta *)
232 :    

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0