![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to opt.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / codegen|
Return to opt.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / codegen |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: (* structure Opt: extended by NICK, to add a new lambda-lifting function,
3: bareCloseTop, a more general form of closeTop. *)
4:
5: structure CGoptions = System.Control.CG
6:
7: signature OPT =
8: sig
9: structure L : LAMBDA sharing L=Lambda
10: structure A : ACCESS sharing A=Access
11: val reduce : L.lexp -> L.lexp
12: exception BadSwitch
13: val switch : L.lexp -> L.lexp
14: val hoist : L.lexp -> L.lexp
15: val closestr : (int -> string) * L.lexp * int list -> L.lexp
16: val bareCloseTop:
17: {lambda: L.lexp, looker: int, extras: int list, keepFree: int list} -> L.lexp
18: (* bareCloseTop is a more general form of closetop. It is passed an already
19: existing looker lvar, and also a keepFree list of lvars which it must
20: keep free (they'll be abstracted later). *)
21:
22: val closetop : L.lexp * int list -> L.lexp
23: val closeModDecl: L.lexp * A.lvar list * int list -> L.lexp
24: (* closeModDecl will be obselete when I finish the new moduleComp, but I'll
25: keep it here for the old moduleComp. *)
26: exception Freevars
27: val free : L.lexp -> A.lvar -> A.lvar list
28: val mix0free : L.lexp -> A.lvar -> A.lvar list * A.lvar list
29: val alphaConvert : L.lexp -> L.lexp
30: val mapfree : (A.lvar -> L.lexp) -> (L.lexp -> L.lexp)
31: val pure : L.lexp -> bool
32: end
33:
34: structure Opt : OPT =
35: struct
36:
37: structure A : ACCESS = Access
38: structure L : LAMBDA = Lambda
39:
40: open A Basics L
41:
42: fun root [v] = v | root (_::p) = root p
43: | root _ = ErrorMsg.impossible "root [] in codegen/opt";
44:
45: exception Freevars
46:
47: fun mapfree lookfree =
48: let val m = Intmap.new(32, Freevars) : lexp Intmap.intmap
49: val add = Intmap.add m
50: fun look v = Intmap.map m v
51: handle Freevars =>
52: let val x = lookfree v in add(v,x); x end
53: fun copycon (DATAcon(DATACON{rep=(VARIABLE(Access.PATH p)),const,name,typ,sign})) =
54: let fun f [v] = let val VAR w = look v in [w] end
55: | f (i::r) = i::(f r)
56: in DATAcon(DATACON{rep=(VARIABLE (Access.PATH(f p))),const=const,
57: name=name,typ=typ,sign=sign})
58: end
59: | copycon c = c
60: fun newvar v = let val w = dupLvar v in add(v,VAR w); w end
61: val rec f =
62: fn VAR v => look v
63: | FN(v,b) => FN(newvar v, f b)
64: | FIX(vl,el,b) => FIX(map newvar vl, map f el, f b)
65: | APP(a,b) => APP(f a, f b)
66: | SELECT(i,a) => SELECT(i, f a)
67: | RECORD l => RECORD(map f l)
68: | SWITCH(a, l, SOME d) =>
69: SWITCH(f a, map(fn(c,x)=>(copycon c, f x))l, SOME(f d))
70: | SWITCH(a, l, NONE) =>
71: SWITCH(f a,map(fn(c,x)=>(copycon c, f x))l,NONE)
72: | HANDLE(a,b) => HANDLE(f a, f b)
73: | RAISE x => RAISE(f x)
74: | e as INT _ => e
75: | e as STRING _ => e
76: | e as REAL _ => e
77: | e as PRIM _ => e
78: in f
79: end
80:
81: val alphaConvert = mapfree VAR
82:
83: val simple = fn VAR _ => true
84: | RECORD [] => true
85: | INT _ => true
86: | STRING s => size s = 1
87: | _ => false
88:
89: fun all f = not o (exists (not o f))
90:
91: val rec pure =
92: fn VAR _ => true
93: | APP(FN(_,a),b) => pure a andalso pure b
94: | FIX(vl,el,b) => pure b
95: | APP(PRIM P.callcc, FN(_,b)) => pure b
96: | APP(PRIM i, z) => Prim.pure i andalso pure z
97: | FN _ => true
98: | INT _ => true
99: | REAL _ => true
100: | PRIM _ => true
101: | STRING _ => true
102: | SELECT(_, x) => pure x
103: | RECORD l => all pure l
104: | SWITCH(a, l, NONE) => pure a andalso all (pure o #2) l
105: | SWITCH(a, l, SOME d) => pure a andalso pure d andalso
106: all (pure o #2) l
107: | _ => false
108:
109: exception BadSwitch
110:
111: fun testint i = fn INTcon j => i=j
112: | DATAcon(DATACON{rep=(CONSTANT j),...}) => i=j
113: | STRINGcon j => size j = 1 andalso i = ord j
114: | DATAcon(DATACON{rep=(TRANSU),...}) => true
115: | _ => false
116: val testboxed = fn DATAcon(DATACON{rep=(TRANSB),...}) => true
117: | DATAcon(DATACON{rep=(TRANSPARENT),...}) => true
118: | DATAcon(DATACON{rep=(TAGGED j),...}) => raise BadSwitch
119: | DATAcon(DATACON{rep=(VARIABLE j),...}) => raise BadSwitch
120: | _ => false
121: fun testtag i = fn DATAcon(DATACON{rep=(TRANSB),...}) => true
122: | DATAcon(DATACON{rep=(TRANSPARENT),...}) => true
123: | DATAcon(DATACON{rep=(TAGGED j),...}) => i=j
124: | _ => false
125: fun teststring s = fn STRINGcon j => s=j
126: | _ => false
127:
128: fun switch(SWITCH(e,l,d)) =
129: let val test = case e
130: of INT i => testint i
131: | STRING s => if size s = 1 then testint(ord s)
132: else teststring s
133: | RECORD[_,INT i] => testtag i
134: | RECORD [] => testtag 0
135: | RECORD _ => testboxed
136: | FN _ => testboxed
137: | FIX _ => testboxed
138: | REAL _ => testboxed
139: | _ => raise BadSwitch
140: fun f ((c,x)::r) = if test c then x else f r
141: | f [] = case d
142: of SOME z => z
143: | NONE => ErrorMsg.impossible "no default"
144: in f l
145: end
146:
147: fun reduce exp =
148: let val clicked = ref false
149: fun click() = clicked := true
150: exception Reducemap
151: val t = Intmap.new(32, Reducemap) : lexp Intmap.intmap
152: val set = Intmap.add t
153: val set = fn x as (v, VAR w) => (sameName(v,w); set x)
154: | x => set x
155: val unset = Intmap.rem t
156: val imap = Intmap.map t
157: val s = Intset.new()
158: val mark = Intset.add s
159: val marked = Intset.mem s
160: fun mapvar v = (imap v handle Reducemap => VAR v)
161: fun makp [v] = ((case imap v of VAR w => makp[w]
162: | _ => (mark v; [v]))
163: handle Reducemap => (mark v; [v]))
164: | makp (i::p) = i :: makp p
165: val rec makcon =
166: fn (DATAcon(DATACON{rep=(VARIABLE(PATH p)),
167: name,const,typ,sign}), e) =>
168: (DATAcon(DATACON{rep=(VARIABLE(PATH(makp p))),
169: name=name,const=const,typ=typ,sign=sign}),
170: mak e)
171: | (c,e) => (c, mak e)
172: and mak =
173: fn FN(v,b as APP(l,VAR w)) =>
174: if v=w andalso pure l
175: then let val body = mak l
176: in if marked v then FN(v,mak(APP(body,VAR v)))
177: else (click(); body)
178: end
179: else FN(v, mak b)
180: | APP(FN(v, sw as SWITCH(VAR v',l,d)), e) =>
181: if v=v' then
182: let val e' = mak e
183: val _ = set(v,e')
184: in let val sw' = mak(switch(SWITCH(e',l,d)))
185: val _ = unset v
186: in if marked v orelse not (pure e')
187: then APP(FN(v,sw'),e') else (click(); sw')
188: end
189: handle BadSwitch =>
190: let val l' = map makcon l
191: val d' = case d of NONE => NONE | SOME a => SOME(mak a)
192: val _ = unset v
193: in if marked v then APP(FN (v, SWITCH(VAR v, l', d')), e')
194: else (click(); SWITCH(e', l', d'))
195: end
196: end
197: else let val arg = mak e
198: val body = (set(v, arg); mak sw before unset v)
199: in if marked v orelse not(pure arg)
200: then APP(FN(v,body),arg)
201: else (click(); body)
202: end
203: | APP(FN(v,e'),e) =>
204: let val arg = mak e
205: val body = (set(v, arg); mak e' before unset v)
206: in if marked v orelse not(pure arg)
207: then APP(FN(v,body),arg)
208: else (click(); body)
209: end
210: | FIX([],[],b) => (click(); mak b)
211: | FIX(vl,el,b) => FIX(vl,map (fn FN(v,e) => FN(v,mak e)) el,mak b)
212: | e as VAR v => (let val e' = imap v
213: in if simple e' then (click(); mak e')
214: else (mark v; e)
215: end handle Reducemap => (mark v; e))
216: | e as SELECT(i, VAR v) =>
217: ((case imap v
218: of RECORD l =>
219: let val e' = nth(l,i)
220: in if simple e' then (click(); e')
221: else (mark v; e)
222: end
223: | ew as VAR w => mak(SELECT(i,ew))
224: | _ => (mark v; e))
225: handle Reducemap => (mark v; e))
226: | FN (w,b) => FN(w,mak b)
227: | APP (f,a) => APP(mak f, mak a)
228: | SWITCH(e,l,d) =>
229: ((case e
230: of VAR v => mak(switch(SWITCH(imap v
231: handle Reducemap => raise BadSwitch
232: , l, d)))
233: | _ => raise BadSwitch
234: ) handle BadSwitch =>
235: let val e' = mak e
236: in mak(switch(SWITCH(e', l, d)))
237: handle BadSwitch => SWITCH(e', map makcon l,
238: case d of NONE => NONE
239: | SOME a => SOME(mak a))
240: end)
241: | RECORD l => RECORD(map mak l)
242: | SELECT (i,e) => SELECT(i,mak e)
243: | HANDLE (a,h) => HANDLE(mak a, mak h)
244: | RAISE e => RAISE(mak e)
245: | e as INT _ => e
246: | e as REAL _ => e
247: | e as STRING _ => e
248: | e as PRIM _ => e
249: val exp' = mak exp
250: in if !clicked then reduce exp' else exp'
251: end
252:
253: (* minimal hoist function: does not move bindings around, evaluation order
254: is unchanged. *)
255: fun hoist (FN(v,b)) = FN(v,hoist b)
256: | hoist (APP(FN(v,b),f as FN _)) = hoist(FIX([v],[f],b))
257: | hoist (APP(l,r)) = APP(hoist l,hoist r)
258: | hoist (FIX(vl,bl,FIX(vs,bs,b))) = hoist(FIX(vl@vs,bl@bs,b))
259: | hoist (FIX(vl,bl,APP(FN(v,b),f as FN _))) = hoist(FIX(v::vl,f::bl,b))
260: | hoist (FIX(vl,bl,b)) = FIX(vl,map hoist bl, hoist b)
261: | hoist (SWITCH(e,l,d)) =
262: SWITCH(hoist e, map (fn (c,e) => (c, hoist e)) l,
263: case d of NONE => NONE
264: | SOME a => SOME(hoist a))
265: | hoist (RECORD l) = RECORD(map hoist l)
266: | hoist (SELECT (i,e)) = SELECT(i,hoist e)
267: | hoist (RAISE e) = RAISE(hoist e)
268: | hoist (HANDLE (a,h)) = HANDLE(hoist a, hoist h)
269: | hoist x = x
270:
271: fun freevars e =
272: let val t = Intset.new()
273: val set = Intset.add t
274: val unset = Intset.rem t
275: val done = Intset.mem t
276: val free : int list ref = ref []
277: val rec mak =
278: fn VAR w => if done w then () else (set w; free := w :: !free)
279: | FN (w,b) => (set w; mak b; unset w)
280: | FIX (vl,el,b) => (app set vl; app mak (b::el); app unset vl)
281: | APP (f,a) => (mak f; mak a)
282: | SWITCH(e,l,d) =>
283: (mak e;
284: app (fn (DATAcon(DATACON{rep=(VARIABLE(PATH p)),...}),e) =>
285: (mak(VAR(root p)); mak e)
286: | (c,e) => mak e)
287: l;
288: case d of NONE => () | SOME a => mak a)
289: | RECORD l => app mak l
290: | SELECT (i,e) => mak e
291: | HANDLE (a,h) => (mak a; mak h)
292: | RAISE e => mak e
293: | INT _ => ()
294: | REAL _ => ()
295: | STRING _ => ()
296: | PRIM _ => ()
297: in mak e; !free
298: end
299:
300: local val save = (!saveLvarNames before saveLvarNames := true)
301: in
302: val boot_zero = namedLvar(Symbol.symbol "boot_zero") (* receives unit *)
303: val boot_one = namedLvar(Symbol.symbol "boot_one") (* traverses free list *)
304: val boot_two = namedLvar(Symbol.symbol "boot_two") (* final bogus arg *)
305:
306: val (lookLvar, indexerLvar) =
307: (saveLvarNames := save;
308: (namedLvar(Symbol.symbol "lookup"),
309: namedLvar(Symbol.symbol "indexer"))
310: )
311: end
312:
313: fun closestr(lookup: int->string, e:lexp, extras : int list) : lexp =
314: let val fv = extras @ freevars e
315: val names = map lookup fv
316: in if !ErrorMsg.debugging
317: then app (fn s => (print s; print " ")) names
318: else ();
319: FN(dupLvar boot_zero,
320: RECORD
321: [fold (fn (v,f) =>
322: let val w = dupLvar boot_one
323: in FN(w,APP(FN(v,APP(f,SELECT(1,(VAR w)))),
324: SELECT(0,(VAR w))))
325: end)
326: fv
327: (FN(dupLvar boot_two,e)),
328: fold (fn (s,f) => RECORD[STRING s, f])
329: names
330: (RECORD [])])
331: end
332:
333: fun remove(v :: vs: int list, from: int list) =
334: let
335: fun removeV(x :: xs) = if x=v then xs else x :: removeV xs
336: | removeV [] = []
337: in
338: remove(vs, removeV from)
339: end
340: | remove([], from) = from
341:
342: fun bareCloseTop{lambda, looker, extras, keepFree} =
343: let
344: val fv = extras @ freevars lambda (* Free vars plus extras *)
345: val fv' = remove(keepFree, fv) (* The ones we actually abstract *)
346: in
347: FN(looker,
348: fold (fn (v, f) => APP(FN(v, f), APP(VAR looker, INT v)))
349: fv' lambda
350: )
351: end
352:
353: (***
354: val bareCloseTop =
355: fn (args as {lambda, looker, extras, keepFree}) =>
356: (print(implode ["bareCloseTop: looker=",
357: Integer.makestring looker,
358: ", extras=[ ",
359: fold (fn (i, s) => makestring i ^ " " ^ s) extras "]",
360: ", keepFree=[ ",
361: fold (fn (i, s) => makestring i ^ " " ^ s) keepFree "]",
362: ", lambda:\n"
363: ]
364: );
365: MCprint.printLexp lambda;
366: print ".\n";
367: let val resultLamb = bareCloseTop args
368: in
369: print "bareCloseTop: result:\n";
370: MCprint.printLexp resultLamb;
371: print ".\n";
372: resultLamb
373: end
374: )
375: ***)
376:
377: fun closetop(e: lexp, extras: int list): lexp =
378: bareCloseTop{lambda=e, looker=dupLvar lookLvar, extras=extras, keepFree=[]}
379:
380: fun closeModDecl(lambda: lexp, slotLvars: lvar list, extras: int list): lexp =
381: let
382: val looker = dupLvar lookLvar
383: val indexer = dupLvar indexerLvar
384: val fv = extras @ freevars lambda
385:
386: fun findLvarSlot(lvar: lvar, this :: rest, n) =
387: if lvar = this then SOME n else findLvarSlot(lvar, rest, n+1)
388: | findLvarSlot(_, [], _) = NONE
389:
390: fun liftVar(freevar, lambda) =
391: APP(FN(freevar, lambda),
392: case findLvarSlot(freevar, slotLvars, 0)
393: of SOME slot => APP(VAR indexer, INT slot)
394: | NONE => APP(VAR looker, INT freevar)
395: )
396: in
397: FN(looker, FN(indexer, fold liftVar fv lambda))
398: end
399:
400: (* free variable analysis *)
401: open SortedList
402:
403: fun free e =
404: let val vars : lvar list Intmap.intmap = Intmap.new(32, Freevars)
405: val setvars = Intmap.add vars
406: val rec freevars =
407: fn PRIM _ => []
408: | VAR w => [w]
409: | APP(FN(w,b),a) => rem(w,merge(freevars b, freevars a))
410: | APP(f,a) => merge(freevars f, freevars a)
411: | FN(w,b) => let val z = rem(w,freevars b)
412: in setvars(w,z); z
413: end
414: | FIX([],_,b) => freevars b
415: | FIX(vl as v::_,el,b) =>
416: let val z' = foldmerge(map (fn FN(v,a) => rem(v,freevars a)) el)
417: val uvl = uniq vl
418: val z = remove(uvl, z')
419: in setvars(v,z);
420: merge(remove(uvl, freevars b), z)
421: end
422: | SWITCH(e,l,d) =>
423: let fun freevcon(DATAcon(DATACON{rep=(VARIABLE(Access.PATH p)),
424: ...})) = [root p]
425: | freevcon _ = []
426: val zz = (case d of
427: NONE => freevars e
428: | SOME x => merge(freevars e, freevars x))
429: in foldmerge(zz::map(fn(c,e')=>merge(freevcon c, freevars e')) l)
430: end
431: | RECORD l => foldmerge(map freevars l)
432: | SELECT(_,e) => freevars e
433: | HANDLE(a,h) => merge(freevars a, freevars h)
434: | RAISE e => freevars e
435: | INT _ => []
436: | REAL _ => []
437: | STRING _ => []
438: in freevars e;
439: Intmap.map vars
440: end
441:
442: fun mix0free e =
443: let val vars : (lvar list * lvar list) Intmap.intmap = Intmap.new(32, Freevars)
444: val setvars = Intmap.add vars
445: val rec freevars =
446: fn PRIM _ => ([],[])
447: | VAR w => let val f = [w] in (f,f) end
448: | APP(FN(w,b),e as FN(_,_)) =>
449: let val (fe,_) = freevars e
450: val (fb,cb) = freevars b
451: in (merge(rem(w,fb),fe),rem(w,cb))
452: end
453: | APP(FN(w,b),a) =>
454: let val (fa,ca) = freevars a
455: val (fb,cb) = freevars b
456: in (merge(rem(w,fb),fa),merge(rem(w,cb),ca))
457: end
458: | APP(f,a) =>
459: let val (fa,ca) = freevars a
460: val (ff,cf) = freevars f
461: in (merge(ff,fa),merge(cf,ca))
462: end
463: | FN(v,b) =>
464: let val (f,c) = freevars b
465: val fr = (rem(v,f),rem(v,c))
466: in setvars(v,fr); fr
467: end
468: | FIX([],_,b) => freevars b
469: | FIX(vl as v::_,el,b) =>
470: let val fr as (f,_) =
471: fold (fn (x,(f,c)) => (rem(x,f),rem(x,c)))
472: vl
473: (fold (fn(FN(v,a),(f',c')) =>
474: let val (f,c) = freevars a
475: in (merge(rem(v,f),f'),
476: merge(rem(v,c),c'))
477: end)
478: el ([],[]))
479: val (fb,cb) = freevars b
480: val uvl = uniq vl
481: in setvars(v,fr); (merge(remove(uvl,fb),f),remove(uvl,cb))
482: end
483: | SWITCH(e,l,d) =>
484: let fun freevcon(DATAcon(DATACON{rep=(VARIABLE(Access.PATH p)),
485: ...})) = [root p]
486: | freevcon _ = []
487: in fold (fn ((con,e'),(f,c)) =>
488: let val (f',c') = freevars e'
489: in (merge(merge(freevcon con, f'),f),
490: merge(merge(freevcon con,c'),c))
491: end)
492: l
493: (let val (fe,ce) = freevars e
494: val (fd,cd) = case d of SOME x => freevars x
495: | NONE => ([],[])
496: in (merge(fe,fd),merge(ce,cd))
497: end)
498: end
499: | RECORD l => fold (fn (a,(f,c)) =>
500: let val (f',c') = freevars a
501: in (merge(f,f'),merge(c,c'))
502: end)
503: l ([],[])
504: | SELECT(_,e) => freevars e
505: | HANDLE(a,h) =>
506: let val (fa,ca) = freevars a
507: val (fh,ch) = freevars h
508: in (merge(fa,fh),merge(ca,ch))
509: end
510: | RAISE e => freevars e
511: | INT _ => ([],[])
512: | REAL _ => ([],[])
513: | STRING _ => ([],[])
514: in freevars e;
515: Intmap.map vars
516: end
517:
518:
519: end (* structure Opt *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.