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/src/compiler/FLINT/opt/lcontract.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/opt/lcontract.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 24 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/FLINT/opt/lcontract.sml

1 : monnier 16 (* Copyright 1996 by Bell Laboratories *)
2 :     (* lcontract.sml *)
3 :    
4 :     signature LCONTRACT =
5 :     sig
6 : monnier 24 val lcontract : Lambda.lexp -> Lambda.lexp
7 : monnier 16 end
8 :    
9 :     structure LContract : LCONTRACT =
10 :     struct
11 :    
12 :     local structure DI = DebIndex
13 : monnier 24 open Access Lambda
14 : monnier 16 in
15 :    
16 : monnier 24 val sameName = LambdaVar.sameName
17 :     fun bug s = ErrorMsg.impossible ("LambdaOpt: "^s)
18 :     val ident = fn le => le
19 : monnier 16 fun all p (a::r) = p a andalso all p r | all p nil = true
20 :    
21 : monnier 24 fun isDiff(x, VAR v) = (x <> v)
22 :     | isDiff(x, GENOP({default,table}, _, _, _)) =
23 :     (x <> default) andalso (all (fn (_, w) => (x <> w)) table)
24 :     | isDiff _ = true
25 : monnier 16
26 :     datatype info
27 : monnier 24 = CompExp
28 :     | SimpVal of value
29 : monnier 16 | ListExp of value list
30 : monnier 24 | FunExp of lvar * lty * lexp
31 :     | SimpExp
32 : monnier 16
33 : monnier 24 fun isPure(SVAL _) = true
34 :     | isPure(RECORD _) = true
35 :     | isPure(SRECORD _) = true
36 :     | isPure(VECTOR _) = true
37 :     | isPure(SELECT _) = true
38 :     | isPure(FN _) = true
39 :     | isPure(TFN _) = true
40 :     | isPure(CON _) = true
41 :     | isPure(DECON _) = true (* this can be problematic *)
42 :     | isPure(ETAG _) = true
43 :     | isPure(PACK _) = true
44 :     | isPure(WRAP _) = true
45 :     | isPure(UNWRAP _) = true
46 :     | isPure(SWITCH(v, _, ces, oe)) =
47 :     let fun g((_,x)::r) = if isPure x then g r else false
48 :     | g [] = case oe of NONE => true | SOME z => isPure z
49 :     in g ces
50 :     end
51 :     | isPure _ = false
52 :     (*** the cases for FIX and LET have already been flattened, thus
53 :     they should not occur ***)
54 :    
55 : monnier 16 exception LContPass1
56 : monnier 24 fun pass1 lexp =
57 : monnier 16 let val zz : (DI.depth option) Intmap.intmap = Intmap.new(32, LContPass1)
58 :     val add = Intmap.add zz
59 :     val get = Intmap.map zz
60 :     val rmv = Intmap.rmv zz
61 :     fun enter(x, d) = add(x, SOME d)
62 :     fun kill x = ((get x; rmv x) handle _ => ())
63 :     fun mark nd x =
64 :     (let val s = get x
65 :     val _ = rmv x
66 :     in case s
67 :     of NONE => ()
68 :     | SOME d => if (d=nd) then add(x, NONE)
69 :     else ()
70 :     end) handle _ => ()
71 :    
72 :     fun cand x = (get x; true) handle _ => false
73 :    
74 : monnier 24 fun loop (e, d) =
75 : monnier 16 let fun psv (VAR x) = kill x
76 :     | psv _ = ()
77 :    
78 : monnier 24 and pse (SVAL v) = psv v
79 :     | pse (FN(v, _, e)) = pse e
80 :     | pse (APP(VAR x, v2)) = (mark d x; psv v2)
81 :     | pse (APP(v1, v2)) = (psv v1; psv v2)
82 :     | pse (FIX(vs, ts, es, be)) = (app pse es; pse be)
83 :     | pse (LET(v, FN (_,_,e1), e2)) = (enter(v, d); pse e1; pse e2)
84 :     | pse (LET(v, e1, e2)) = (pse e1; pse e2)
85 :     | pse (TFN(ks, e)) = loop(e, DI.next d)
86 : monnier 16 | pse (TAPP(v, _)) = psv v
87 : monnier 24 | pse (VECTOR(vs,_)) = app psv vs
88 :     | pse (RECORD vs) = app psv vs
89 :     | pse (SRECORD vs) = app psv vs
90 :     | pse (SELECT(_,v)) = psv v
91 :     | pse (CON(_,_,v)) = psv v
92 :     | pse (DECON(_,_,v)) = psv v
93 :     | pse (SWITCH(v, _, ces, oe)) =
94 :     (psv v; app (fn (_,x) => pse x) ces;
95 : monnier 16 case oe of NONE => () | SOME x => pse x)
96 : monnier 24 | pse (ETAG(v, _)) = psv v
97 :     | pse (HANDLE(e,v)) = (pse e; psv v)
98 :     | pse (PACK(_,_,_,v)) = psv v
99 :     | pse (WRAP(_,_,v)) = psv v
100 :     | pse (UNWRAP(_,_,v)) = psv v
101 : monnier 16 | pse (RAISE _) = ()
102 :    
103 :     in pse e
104 :     end
105 :    
106 : monnier 24 in loop (lexp, DI.top); cand
107 :     end
108 : monnier 16
109 :     (************************************************************************
110 :     * THE MAIN FUNCTION *
111 :     ************************************************************************)
112 : monnier 24 fun lcontract lexp =
113 : monnier 16 let
114 :    
115 : monnier 24 val isCand = pass1 lexp
116 : monnier 16
117 :     exception LContract
118 :     val m : (int ref * info) Intmap.intmap = Intmap.new(32, LContract)
119 :    
120 :     val enter = Intmap.add m
121 :     val get = Intmap.map m
122 :     val kill = Intmap.rmv m
123 :    
124 :     fun chkIn (v, info) = enter(v, (ref 0, info))
125 :    
126 : monnier 24 fun refer v =
127 :     ((case get v
128 :     of (_, SimpVal sv) => SOME sv
129 :     | (x, _) => (x := (!x) + 1; NONE)) handle _ => NONE)
130 : monnier 16
131 : monnier 24 fun selInfo v = (SOME(get v)) handle _ => NONE
132 : monnier 16
133 : monnier 24 fun chkOut v =
134 :     (let val x = get v
135 :     in kill v; SOME x
136 :     end handle _ => NONE)
137 : monnier 16
138 :    
139 : monnier 24 fun mkInfo (_, RECORD vs) = ListExp vs
140 :     | mkInfo (_, SRECORD vs) = ListExp vs
141 :     | mkInfo (v, SELECT(i, VAR x)) =
142 :     let fun h z =
143 :     (case selInfo z
144 :     of SOME(_, ListExp vs) =>
145 :     let val nv = List.nth(vs, i)
146 :     handle _ => bug "unexpected List.Nth in SELECT"
147 :     in SimpVal nv
148 : monnier 16 end
149 : monnier 24 | SOME(_, SimpVal (VAR w)) => h w
150 :     | _ => SimpExp)
151 :     in h x
152 :     end
153 : monnier 16
154 : monnier 24 | mkInfo (v, e as FN x) = if isCand v then FunExp x else SimpExp
155 :     | mkInfo (_, e) = if isPure e then SimpExp else CompExp
156 : monnier 16
157 : monnier 24 fun lpacc (LVAR v) =
158 :     (case lpsv (VAR v)
159 :     of VAR w => LVAR w
160 :     | _ => bug "unexpected in lpacc")
161 :     | lpacc _ = bug "unexpected path in lpacc"
162 : monnier 16
163 : monnier 24 and lpdc (s, EXN acc, t) = (s, EXN(lpacc acc), t)
164 :     | lpdc x = x
165 : monnier 16
166 : monnier 24 and lpcon (DATAcon dc) = DATAcon(lpdc dc)
167 :     | lpcon c = c
168 : monnier 16
169 : monnier 24 and lpdt {default=v, table=ws} =
170 :     let fun h x = case (refer x)
171 :     of SOME(VAR nv) => nv
172 :     | NONE => x
173 :     in {default=h v, table=map (fn (ts,w) => (ts,h w)) ws}
174 :     end
175 : monnier 16
176 : monnier 24 and lpsv x =
177 :     (case x
178 :     of VAR v => (case (refer v) of SOME nsv => lpsv nsv
179 :     | NONE => (x : value))
180 :     | GENOP(dict, p, lt, ts) => GENOP(lpdt dict, p, lt, ts)
181 :     | _ => x)
182 : monnier 16
183 : monnier 24 and loop le =
184 :     (case le
185 :     of SVAL v => SVAL(lpsv v)
186 :     | FN(v, t, e) => FN(v, t, loop e)
187 :     | APP(v1 as VAR x, v2) =>
188 :     (case selInfo x
189 :     of SOME(ref c, FunExp(z,_,b)) =>
190 :     (if (c = 0) then loop(LET(z, SVAL v2, b))
191 :     else bug "unexpected FunExp in APP")
192 :     (* commented out because it won't have any effect for the time being.
193 :     | SOME(_, SimpVal (y as VAR _)) => loop(APP(y, v2))
194 :     *)
195 :     | _ => APP(lpsv v1, lpsv v2))
196 :     | APP(v1, v2) => APP(lpsv v1, lpsv v2)
197 :     | FIX(vs, ts, es, b) =>
198 :     let fun g ((FN _)::r) = g r
199 :     | g (_::r) = false
200 :     | g [] = true
201 :     val _ = if g es then () else bug "unexpected cases in loop-FIX"
202 :     val _ = app (fn x => chkIn(x, SimpExp)) vs
203 :     val nb = loop b
204 :     val ws = map chkOut vs
205 : monnier 16
206 : monnier 24 fun h ((SOME(ref 0, _))::r) = h r
207 :     | h (_::r) = false
208 :     | h [] = true
209 :     in if h ws then nb
210 :     else FIX(vs, ts, map loop es, nb)
211 :     end
212 :     | LET(v, LET(u, e1, e2), e3) =>
213 :     loop(LET(u, e1, LET(v, e2, e3)))
214 :     | LET(v, FIX(vs, ts, es, b), e) =>
215 :     loop(FIX(vs, ts, es, LET(v, b, e)))
216 :     | LET(v, SVAL sv, e2) =>
217 :     (chkIn(v, SimpVal sv); loop e2)
218 :     | LET(v, e1, e2 as SVAL (VAR x)) =>
219 :     if (v = x) then loop e1
220 :     else if isPure e1 then loop e2
221 :     else LET(v, loop e1, loop e2)
222 :     | LET(v, e1 as FN(v1, t1, b1), e2 as APP(VAR x, sv)) =>
223 :     if isDiff(v, sv) then
224 :     (if (v = x) then loop(LET(v1, SVAL sv, b1)) else loop e2)
225 :     else LET(v, loop e1, loop e2)
226 :     | LET(v, e1, e2) =>
227 :     let val _ = chkIn(v, mkInfo(v,e1))
228 :     val ne2 = loop e2
229 :     val w = chkOut v
230 :     in case w
231 :     of SOME(_, CompExp) => LET(v, loop e1, ne2)
232 :     | SOME(ref 0, _) => ne2
233 :     | _ => (case (e1, ne2)
234 :     of (FN(v1,t1,b1), APP(VAR x, sv)) =>
235 :     if isDiff(v, sv) then
236 :     (if (v=x) then loop(LET(v1, SVAL sv,b1))
237 :     else ne2)
238 :     else LET(v, loop e1, ne2)
239 :     | (_, SVAL(VAR x)) =>
240 :     if isPure e1 then (if v=x then loop e1
241 :     else ne2)
242 :     else LET(v, loop e1, ne2)
243 :     | _ => LET(v, loop e1, ne2))
244 :     end
245 :     | TFN(ks, e) => TFN(ks, loop e)
246 :     | TAPP(v, ts) => TAPP(lpsv v, ts)
247 :     | VECTOR(vs, t) => VECTOR(map lpsv vs, t)
248 :     | RECORD vs => RECORD (map lpsv vs)
249 :     | SRECORD vs => SRECORD (map lpsv vs)
250 :     | SELECT(i, v as VAR x) =>
251 :     (case selInfo x
252 :     of SOME(_, ListExp vs) =>
253 :     let val nv = List.nth(vs, i)
254 :     handle _ => bug "unexpected List.Nth in SELECT"
255 :     in SVAL(lpsv nv)
256 :     end
257 :     | SOME(_, SimpVal (y as VAR _)) => loop(SELECT(i, y))
258 :     | _ => SELECT(i, lpsv v))
259 :     | SELECT(i, v) => SELECT(i, lpsv v)
260 :     | CON(c, ts, v) => CON(lpdc c, ts, lpsv v)
261 :     | DECON(c, ts, v) => DECON(lpdc c, ts, lpsv v)
262 :     | SWITCH (v, cs, ces, oe) =>
263 :     let val nv = lpsv v
264 :     val nces = map (fn (c, e) => (lpcon c, loop e)) ces
265 :     val noe = case oe of NONE => NONE | SOME e => SOME (loop e)
266 :     in SWITCH(nv, cs, nces, noe)
267 :     end
268 :     | ETAG(v, t) => ETAG(lpsv v, t)
269 :     | RAISE(v, t) => RAISE(lpsv v, t)
270 :     | HANDLE(e, v) => HANDLE(loop e, lpsv v)
271 :     | PACK(t, ts1, ts2, v) => PACK(t, ts1, ts2, lpsv v)
272 :     | WRAP(t, b, v) => WRAP(t, b, lpsv v)
273 :     | UNWRAP(t, b, v) => UNWRAP(t, b, lpsv v))
274 : monnier 16
275 : monnier 24 val nlexp = loop lexp
276 :     in (Intmap.clear m; nlexp)
277 :     end
278 : monnier 16
279 :     end (* toplevel local *)
280 :     end (* structure LContract *)
281 :    

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