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/sml-mode/testcases.sml
ViewVC logotype

Annotation of /sml/trunk/sml-mode/testcases.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1472 - (view) (download)

1 : monnier 1472 (* Copyright 1999, 2004 Stefan Monnier <monnier@gnu.org> *)
2 : monnier 544
3 : monnier 700 (let val a = 1 val b = 2
4 : monnier 887 val c = 3
5 : monnier 700 in 1
6 : monnier 887 end);
7 : monnier 700
8 : monnier 1472 (* sml-mode here treats the second `=' as an equal op because it assumes
9 :     * that the first is the definitional equal for the structure. FIXME! *)
10 :     functor foo (structure s : S) where type t = s.t =
11 :     struct
12 :     val bar = 0
13 :     val ber = 1;
14 :     val sdfg = 1
15 :     end
16 :    
17 : monnier 700 (x := 1;
18 :     case x of
19 :     FOO => 1
20 : monnier 887 | BAR =>
21 :     2;
22 : monnier 700 case x of
23 :     FOO => 1
24 :     | BAR =>
25 :     (case y of
26 :     FAR => 2
27 :     | FRA => 3);
28 : monnier 887 hello);
29 : monnier 700
30 : monnier 544 let datatype foobar
31 :     = FooB of int
32 :     | FooA of bool * int
33 : monnier 878 datatype foo = FOO | BAR of baz
34 : monnier 887 and baz = BAZ | QUUX of foo
35 : monnier 878
36 :     datatype foo = FOO
37 :     | BAR of baz
38 : monnier 887 and baz = BAZ (* fixindent *)
39 :     | QUUX of foo
40 :     and b = g
41 : monnier 878
42 :     datatype foo = datatype M.foo
43 : monnier 887 val _ = 42 val x = 5
44 :    
45 : monnier 878 signature S = S' where type foo = int
46 :     val _ = 42
47 :    
48 : monnier 887 val foo = [
49 :     "blah"
50 :     , let val x = f 42 in g (x,x,44) end
51 :     ]
52 :    
53 : monnier 878 val foo = [ "blah"
54 : monnier 887 , let val x = f 42 in g (x,x,44) end
55 :     , foldl (fn ((p,q),s) => g (p,q,Vector.length q) ^ ":" ^ s)
56 :     "" (Beeblebrox.masterCountList mlist2)
57 : monnier 878 , if null mlist2 then ";" else ""
58 : monnier 887 ]
59 :    
60 : monnier 878 fun foo (true::rest)
61 :     = 1 + 2 * foo rest
62 :     | foo (false::rest)
63 : monnier 887 = let val _ = 1 in 2 end
64 :     + 2 * foo rest
65 : monnier 878
66 : monnier 544 val x = if foo then
67 :     1
68 :     else if bar then
69 :     2
70 :     else
71 :     3
72 :     val y = if foo
73 :     then 1
74 :     else if foo
75 :     then 2
76 :     else 3
77 : monnier 887
78 :     ; val yt = 4
79 :    
80 : monnier 544 in
81 :     if a then b else c;
82 :     case M.find(m,f)
83 :     of SOME(fl, filt) =>
84 :     F.APP(F.VAR fl, OU.filter filt vs)
85 :     | NONE => le;
86 :     x := x + 1;
87 :     (case foo
88 :     of a => f
89 : monnier 887 )
90 :     end;
91 : monnier 544
92 :     let
93 :     in a;
94 : monnier 887 foo("(*")
95 :     * 2;
96 :     end;
97 : monnier 544
98 :     let
99 : monnier 878 in a
100 : monnier 887 ; b
101 :     end;
102 : monnier 878
103 :     let
104 :     in
105 :     a
106 :     ; b
107 : monnier 887 end;
108 : monnier 878
109 :     let
110 : monnier 544 in if a then
111 :     b
112 :     else
113 :     c
114 : monnier 887 end;
115 : monnier 700
116 : monnier 544 let
117 :     in case a of
118 : monnier 887 F => 1
119 :     | D => 2
120 :     end;
121 :    
122 :     let
123 :     in case a
124 :     of F => 1
125 : monnier 544 | D => 2
126 : monnier 887 end;
127 : monnier 544
128 :     let
129 :     in if a then b else
130 :     c
131 : monnier 887 end;
132 :    
133 : monnier 544 structure Foo = struct
134 :     val x = 1
135 :     end
136 :    
137 :     signature FSPLIT =
138 :     sig
139 :     type flint = FLINT.prog
140 :     val split: flint -> flint * flint option
141 :     end
142 : monnier 887
143 : monnier 544 structure FSplit :> FSPLIT =
144 :     struct
145 :    
146 :     local
147 :     structure F = FLINT
148 :     structure S = IntRedBlackSet
149 :     structure M = FLINTIntMap
150 :     structure O = Option
151 :     structure OU = OptUtils
152 :     structure FU = FlintUtil
153 :     structure LT = LtyExtern
154 :     structure PO = PrimOp
155 :     structure PP = PPFlint
156 :     structure CTRL = FLINT_Control
157 :     in
158 :    
159 :     val say = Control_Print.say
160 :     fun bug msg = ErrorMsg.impossible ("FSplit: "^msg)
161 :     fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
162 :     fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
163 :     fun assert p = if p then () else bug ("assertion failed")
164 :    
165 :     type flint = F.prog
166 :     val mklv = LambdaVar.mkLvar
167 :     val cplv = LambdaVar.dupLvar
168 :    
169 :     fun S_rmv(x, s) = S.delete(s, x) handle NotFound => s
170 :    
171 :     fun addv (s,F.VAR lv) = S.add(s, lv)
172 :     | addv (s,_) = s
173 :     fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
174 :     fun rmvs (s,lvs) = foldl (fn (l,s) => S_rmv(l, s)) s lvs
175 :    
176 :     exception Unknown
177 :    
178 :     fun split (fdec as (fk,f,args,body)) = let
179 :     val {getLty,addLty,...} = Recover.recover (fdec, false)
180 :    
181 :     val m = Intmap.new(64, Unknown)
182 :     fun addpurefun f = Intmap.add m (f, false)
183 :     fun funeffect f = (Intmap.map m f) handle Uknown => true
184 :    
185 :     (* sexp: env -> lexp -> (leE, leI, fvI, leRet)
186 :     * - env: IntSetF.set current environment
187 :     * - lexp: lexp expression to split
188 :     * - leRet: lexp the core return expression of lexp
189 :     * - leE: lexp -> lexp recursively split lexp: leE leRet == lexp
190 :     * - leI: lexp option inlinable part of lexp (if any)
191 :     * - fvI: IntSetF.set free variables of leI: FU.freevars leI == fvI
192 :     *
193 :     * sexp splits the lexp into an expansive part and an inlinable part.
194 :     * The inlinable part is guaranteed to be side-effect free.
195 :     * The expansive part doesn't bother to eliminate unused copies of
196 :     * elements copied to the inlinable part.
197 :     * If the inlinable part cannot be constructed, leI is set to F.RET[].
198 :     * This implies that fvI == S.empty, which in turn prevents us from
199 :     * mistakenly adding anything to leI.
200 :     *)
201 :     fun sexp env lexp = (* fixindent *)
202 :     let
203 :     (* non-side effecting binds are copied to leI if exported *)
204 :     fun let1 (le,lewrap,lv,vs,effect) =
205 :     let val (leE,leI,fvI,leRet) = sexp (S.add(env, lv)) le
206 :     val leE = lewrap o leE
207 :     in if effect orelse not (S.member(fvI, lv))
208 :     then (leE, leI, fvI, leRet)
209 :     else (leE, lewrap leI, addvs(S_rmv(lv, fvI), vs), leRet)
210 :     end
211 : monnier 887
212 : monnier 544 in case lexp
213 :     (* we can completely move both RET and TAPP to the I part *)
214 :     of F.RECORD (rk,vs,lv,le as F.RET [F.VAR lv']) =>
215 :     if lv' = lv
216 :     then (fn e => e, lexp, addvs(S.empty, vs), lexp)
217 :     else (fn e => e, le, S.singleton lv', le)
218 :     | F.RET vs =>
219 :     (fn e => e, lexp, addvs(S.empty, vs), lexp)
220 :     | F.TAPP (F.VAR tf,tycs) =>
221 :     (fn e => e, lexp, S.singleton tf, lexp)
222 :    
223 :     (* recursive splittable lexps *)
224 :     | F.FIX (fdecs,le) => sfix env (fdecs, le)
225 :     | F.TFN (tfdec,le) => stfn env (tfdec, le)
226 :    
227 :     (* binding-lexps *)
228 :     | F.CON (dc,tycs,v,lv,le) =>
229 :     let1(le, fn e => F.CON(dc, tycs, v, lv, e), lv, [v], false)
230 :     | F.RECORD (rk,vs,lv,le) =>
231 :     let1(le, fn e => F.RECORD(rk, vs, lv, e), lv, vs, false)
232 :     | F.SELECT (v,i,lv,le) =>
233 :     let1(le, fn e => F.SELECT(v, i, lv, e), lv, [v], false)
234 :     | F.PRIMOP (po,vs,lv,le) =>
235 :     let1(le, fn e => F.PRIMOP(po, vs, lv, e), lv, vs, PO.effect(#2 po))
236 :    
237 :     (* IMPROVEME: lvs should not be restricted to [lv] *)
238 :     | F.LET(lvs as [lv],body as F.TAPP (v,tycs),le) =>
239 :     let1(le, fn e => F.LET(lvs, body, e), lv, [v], false)
240 :     | F.LET (lvs as [lv],body as F.APP (v as F.VAR f,vs),le) =>
241 :     let1(le, fn e => F.LET(lvs, body, e), lv, v::vs, funeffect f)
242 :    
243 :     | F.SWITCH (v,ac,[(dc as F.DATAcon(_,_,lv),le)],NONE) =>
244 :     let1(le, fn e => F.SWITCH(v, ac, [(dc, e)], NONE), lv, [v], false)
245 :    
246 :     | F.LET (lvs,body,le) =>
247 :     let val (leE,leI,fvI,leRet) = sexp (S.union(S.addList(S.empty, lvs), env)) le
248 :     in (fn e => F.LET(lvs, body, leE e), leI, fvI, leRet)
249 :     end
250 : monnier 887
251 : monnier 544 (* useless sophistication *)
252 :     | F.APP (F.VAR f,args) =>
253 :     if funeffect f
254 :     then (fn e => e, F.RET[], S.empty, lexp)
255 :     else (fn e => e, lexp, addvs(S.singleton f, args), lexp)
256 :    
257 :     (* other non-binding lexps result in unsplittable functions *)
258 :     | (F.APP _ | F.TAPP _) => bug "strange (T)APP"
259 :     | (F.SWITCH _ | F.RAISE _ | F.BRANCH _ | F.HANDLE _) =>
260 :     (fn e => e, F.RET[], S.empty, lexp)
261 :     end
262 : monnier 887
263 : monnier 544 (* Functions definitions fall into the following categories:
264 :     * - inlinable: if exported, copy to leI
265 :     * - (mutually) recursive: don't bother
266 :     * - non-inlinable non-recursive: split recursively *)
267 :     and sfix env (fdecs,le) =
268 :     let val nenv = S.union(S.addList(S.empty, map #2 fdecs), env)
269 :     val (leE,leI,fvI,leRet) = sexp nenv le
270 :     val nleE = fn e => F.FIX(fdecs, leE e)
271 :     in case fdecs
272 :     of [({inline=inl as (F.IH_ALWAYS | F.IH_MAYBE _),...},f,args,body)] =>
273 :     let val min = case inl of F.IH_MAYBE(n,_) => n | _ => 0
274 :     in if not(S.member(fvI, f)) orelse min > !CTRL.splitThreshold
275 :     then (nleE, leI, fvI, leRet)
276 :     else (nleE, F.FIX(fdecs, leI),
277 :     rmvs(S.union(fvI, FU.freevars body),
278 :     f::(map #1 args)),
279 :     leRet)
280 :     end
281 :     | [fdec as (fk as {cconv=F.CC_FCT,...},_,_,_)] =>
282 :     sfdec env (leE,leI,fvI,leRet) fdec
283 :    
284 :     | _ => (nleE, leI, fvI, leRet)
285 :     end
286 : monnier 887
287 : monnier 544 and sfdec env (leE,leI,fvI,leRet) (fk,f,args,body) =
288 :     let val benv = S.union(S.addList(S.empty, map #1 args), env)
289 :     val (bodyE,bodyI,fvbI,bodyRet) = sexp benv body
290 :     in case bodyI
291 :     of F.RET[] =>
292 :     (fn e => F.FIX([(fk, f, args, bodyE bodyRet)], e),
293 :     leI, fvI, leRet)
294 :     | _ =>
295 :     let val fvbIs = S.listItems(S.difference(fvbI, benv))
296 :     val (nfk,fkE) = OU.fk_wrap(fk, NONE)
297 :    
298 :     (* fdecE *)
299 :     val fE = cplv f
300 :     val fErets = (map F.VAR fvbIs)
301 :     val bodyE = bodyE(F.RET fErets)
302 :     (* val tmp = mklv()
303 :     val bodyE = bodyE(F.RECORD(F.RK_STRUCT, map F.VAR fvbIs,
304 :     tmp, F.RET[F.VAR tmp])) *)
305 :     val fdecE = (fkE, fE, args, bodyE)
306 :     val fElty = LT.ltc_fct(map #2 args, map getLty fErets)
307 :     val _ = addLty(fE, fElty)
308 :    
309 :     (* fdecI *)
310 :     val fkI = {inline=F.IH_ALWAYS, cconv=F.CC_FCT,
311 :     known=true, isrec=NONE}
312 :     val argsI =
313 :     (map (fn lv => (lv, getLty(F.VAR lv))) fvbIs) @ args
314 :     val fdecI as (_,fI,_,_) = FU.copyfdec(fkI,f,argsI,bodyI)
315 :     val _ = addpurefun fI
316 :    
317 :     (* nfdec *)
318 :     val nargs = map (fn (v,t) => (cplv v, t)) args
319 :     val argsv = map (fn (v,t) => F.VAR v) nargs
320 :     val nbody =
321 :     let val lvs = map cplv fvbIs
322 :     in F.LET(lvs, F.APP(F.VAR fE, argsv),
323 :     F.APP(F.VAR fI, (map F.VAR lvs)@argsv))
324 :     end
325 :     (* let val lv = mklv()
326 :     in F.LET([lv], F.APP(F.VAR fE, argsv),
327 :     F.APP(F.VAR fI, (F.VAR lv)::argsv))
328 :     end *)
329 :     val nfdec = (nfk, f, nargs, nbody)
330 :    
331 :     (* and now, for the whole F.FIX *)
332 :     fun nleE e =
333 :     F.FIX([fdecE], F.FIX([fdecI], F.FIX([nfdec], leE e)))
334 :    
335 :     in if not(S.member(fvI, f)) then (nleE, leI, fvI, leRet)
336 :     else (nleE,
337 :     F.FIX([fdecI], F.FIX([nfdec], leI)),
338 :     S.add(S.union(S_rmv(f, fvI), S.intersection(env, fvbI)), fE),
339 :     leRet)
340 :     end
341 :     end
342 : monnier 887
343 : monnier 544 (* TFNs are kinda like FIX except there's no recursion *)
344 :     and stfn env (tfdec as (tfk,tf,args,body),le) =
345 :     let val (bodyE,bodyI,fvbI,bodyRet) =
346 :     if #inline tfk = F.IH_ALWAYS
347 :     then (fn e => body, body, FU.freevars body, body)
348 :     else sexp env body
349 :     val nenv = S.add(env, tf)
350 :     val (leE,leI,fvI,leRet) = sexp nenv le
351 :     in case (bodyI, S.listItems(S.difference(fvbI, env)))
352 :     of ((F.RET _ | F.RECORD(_,_,_,F.RET _)),_) =>
353 :     (* split failed *)
354 :     (fn e => F.TFN((tfk, tf, args, bodyE bodyRet), leE e),
355 :     leI, fvI, leRet)
356 :     | (_,[]) =>
357 :     (* everything was split out *)
358 :     let val ntfdec = ({inline=F.IH_ALWAYS}, tf, args, bodyE bodyRet)
359 :     val nlE = fn e => F.TFN(ntfdec, leE e)
360 :     in if not(S.member(fvI, tf)) then (nlE, leI, fvI, leRet)
361 :     else (nlE, F.TFN(ntfdec, leI),
362 :     S_rmv(tf, S.union(fvI, fvbI)), leRet)
363 :     end
364 :     | (_,fvbIs) =>
365 :     let (* tfdecE *)
366 :     val tfE = cplv tf
367 :     val tfEvs = map F.VAR fvbIs
368 :     val bodyE = bodyE(F.RET tfEvs)
369 :     val tfElty = LT.lt_nvpoly(args, map getLty tfEvs)
370 :     val _ = addLty(tfE, tfElty)
371 :    
372 :     (* tfdecI *)
373 :     val tfkI = {inline=F.IH_ALWAYS}
374 :     val argsI = map (fn (v,k) => (cplv v, k)) args
375 : monnier 887 (* val tmap = ListPair.map (fn (a1,a2) =>
376 :     * (#1 a1, LT.tcc_nvar(#1 a2)))
377 :     * (args, argsI) *)
378 : monnier 544 val bodyI = FU.copy tmap M.empty
379 :     (F.LET(fvbIs, F.TAPP(F.VAR tfE, map #2 tmap),
380 :     bodyI))
381 :     (* F.TFN *)
382 :     fun nleE e =
383 :     F.TFN((tfk, tfE, args, bodyE),
384 :     F.TFN((tfkI, tf, argsI, bodyI), leE e))
385 :    
386 :     in if not(S.member(fvI, tf)) then (nleE, leI, fvI, leRet)
387 :     else (nleE,
388 :     F.TFN((tfkI, tf, argsI, bodyI), leI),
389 :     S.add(S.union(S_rmv(tf, fvI), S.intersection(env, fvbI)), tfE),
390 :     leRet)
391 :     end
392 :     end
393 : monnier 887
394 : monnier 544 (* here, we use B-decomposition, so the args should not be
395 :     * considered as being in scope *)
396 :     val (bodyE,bodyI,fvbI,bodyRet) = sexp S.empty body
397 :     in case (bodyI, bodyRet)
398 :     of (F.RET _,_) => ((fk, f, args, bodyE bodyRet), NONE)
399 :     | (_,F.RECORD (rk,vs,lv,F.RET[lv'])) =>
400 :     let val fvbIs = S.listItems fvbI
401 :    
402 :     (* fdecE *)
403 :     val bodyE = bodyE(F.RECORD(rk, vs@(map F.VAR fvbIs), lv, F.RET[lv']))
404 :     val fdecE as (_,fE,_,_) = (fk, cplv f, args, bodyE)
405 :    
406 :     (* fdecI *)
407 :     val argI = mklv()
408 :     val argLtys = (map getLty vs) @ (map (getLty o F.VAR) fvbIs)
409 :     val argsI = [(argI, LT.ltc_str argLtys)]
410 :     val (_,bodyI) = foldl (fn (lv,(n,le)) =>
411 :     (n+1, F.SELECT(F.VAR argI, n, lv, le)))
412 :     (length vs, bodyI) fvbIs
413 :     val fdecI as (_,fI,_,_) = FU.copyfdec (fk, f, argsI, bodyI)
414 :    
415 :     val nargs = map (fn (v,t) => (cplv v, t)) args
416 :     in
417 :     (fdecE, SOME fdecI)
418 :     (* ((fk, f, nargs,
419 :     F.FIX([fdecE],
420 :     F.FIX([fdecI],
421 :     F.LET([argI],
422 :     F.APP(F.VAR fE, map (F.VAR o #1) nargs),
423 :     F.APP(F.VAR fI, [F.VAR argI]))))),
424 :     NONE) *)
425 :     end
426 : monnier 887
427 : monnier 544 | _ => (fdec, NONE) (* sorry, can't do that *)
428 :     (* (PPFlint.printLexp bodyRet; bug "couldn't find the returned record") *)
429 :    
430 :     end
431 : monnier 887
432 : monnier 544 end
433 :     end

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