![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to hoist.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 / cps|
Return to hoist.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / cps |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: structure Hoist : sig val hoist : (string->unit)->CPS.cexp->CPS.cexp end =
3: struct
4: open Access CPS SortedList
5:
6: type fv = lvar list
7:
8: datatype cexp'
9: = RECORD' of (lvar * accesspath) list * lvar * cexp' * fv
10: | SELECT' of int * lvar * lvar * cexp' * fv
11: | OFFSET' of int * lvar * lvar * cexp' * fv
12: | APP' of lvar * lvar list
13: | FIX' of function' list * fv * cexp' * fv
14: | SWITCH' of lvar * (cexp' * fv) list
15: | PRIMOP' of Access.primop * lvar list * lvar list * (cexp' * fv) list
16: withtype function' = lvar * lvar list * cexp'
17:
18: fun sum f = let fun h [] = 0
19: | h (a::r) = f a + h r
20: in h
21: end
22:
23: fun hoist click cexp =
24: let (* val _ = CPSprint.show (output std_out) (Intmap.map ctab) cexp *)
25: val clicked = ref false
26: val click = fn x => (clicked := true; click x)
27: infix 6 \/ val op \/ = merge
28: infix 7 /\ val op /\ = intersect
29: infix 6 -- val op -- = fn(a,b) => remove(b,a)
30: val rec hoist =
31: fn RECORD(vl, w, e) =>
32: (case hoist e
33: of (e as FIX'(l,v1,e',v2), v3) =>
34: if member v1 w
35: then (RECORD'(vl, w, e, v3), v3--[w]\/uniq(map #1 vl))
36: else let val defined = uniq(map #1 l)
37: val v4 = v2--[w]\/uniq(map #1 vl)
38: in (FIX'(l,v1,RECORD'(vl,w,e',v2),v4), v1\/(v4--defined))
39: end
40: | (e,v1) => (RECORD'(vl, w, e, v1), v1--[w]\/uniq(map #1 vl)))
41: | SELECT(i,v,w,e) =>
42: (case hoist e of
43: (e as FIX'(l,v1,e',v2), v3) => if member v1 w
44: then (SELECT'(i, v, w, e, v3), v3--[w]\/[v])
45: else let val defined = uniq(map #1 l)
46: val v4 = v2--[w]\/[v]
47: in (FIX'(l,v1,SELECT'(i,v,w,e',v2),v4),v1\/(v4--defined))
48: end
49: | (e,v1) => (SELECT'(i, v, w, e, v1),v1--[w]\/[v]))
50: | PRIMOP(i,vl,wl,[e]) =>
51: (case hoist e
52: of(e as FIX'(l,v1,e',v2),v3) =>
53: (case uniq wl /\ v1
54: of [] => let val v4 = v2--uniq wl\/uniq vl
55: val defined = uniq(map #1 l)
56: in (FIX'(l,v1,PRIMOP'(i,vl,wl,[(e',v2)]),v4),v1\/(v4--defined))
57: end
58: | _ => (PRIMOP'(i, vl, wl, [(e,v3)]),v3--uniq wl\/uniq vl))
59: | (e,v1) => (PRIMOP'(i, vl, wl, [(e,v1)]),v1--uniq wl\/uniq vl))
60: | PRIMOP(i,vl,wl,el) =>
61: let val el' = map hoist el
62: in (PRIMOP'(i,vl,wl,el'), foldmerge(map #2 el')--uniq wl\/uniq vl)
63: end
64: | APP(f,vl) => (APP'(f,vl), uniq(f::vl))
65: | SWITCH(v,el) =>
66: let val el' = map hoist el
67: in (SWITCH'(v, el'), foldmerge(map #2 el')\/[v])
68: end
69: | FIX(l,e) =>
70: let fun h((f,vl,(e as FIX'(l',v1,e',v2),v3))::r) =
71: let val (ll, v4) = h r
72: in case uniq vl /\ v1
73: of [] => (click "p";
74: ((f,vl,e')::l'@ll,
75: v2--(uniq vl)\/v1\/v4))
76: | _ => ((f,vl,e) :: ll, v3--(uniq vl)\/v4)
77: end
78: | h((f,vl,(e,v3)):: r) =
79: let val (ll, v4) = h r
80: in ((f,vl,e) :: ll, v3--(uniq vl)\/v4)
81: end
82: | h [] = ([],[])
83: val (l,v1) = h (map (fn(f,vl,a)=>(f,vl,hoist a)) l)
84: val defined = uniq(map #1 l)
85: val v1 = v1 -- defined
86: val (e,v2) = hoist e
87: exception Down
88: fun check vl = case defined /\ uniq vl of [] => ()
89: | _ => raise Down
90: fun present (_,vx) = case defined/\vx
91: of []=>0 | _ => 1
92: val rec down' = fn (cexp,vx) =>
93: case defined /\ vx
94: of [] => (cexp,vx)
95: | _ => down cexp
96: handle Down => (FIX'(l,v1,cexp,vx),
97: vx--defined\/v1)
98: and down =
99: fn RECORD'(vl,w,e,v3) => (check(map #1 vl);
100: let val (e',v4) = down e
101: in (RECORD'(vl,w,e',v4),v4--[w]\/uniq(map #1 vl))
102: end)
103: | SELECT'(i,v,w,e,v3) =>
104: let val (e',v4) = down e
105: in (SELECT'(i,v,w,e',v4), v4--[w]\/[v])
106: end
107: | PRIMOP'(i,vl,wl,[(e,_)]) => (check vl;
108: let val (e',v4) = down e
109: in (PRIMOP'(i,vl,wl,[(e',v4)]), v4--uniq wl\/uniq vl)
110: end)
111: | PRIMOP'(i,vl,wl,el) =>
112: (check vl;
113: if sum present el < 2
114: then let val el' = map down' el
115: in (PRIMOP'(i,vl,wl,el'), foldmerge(map #2 el')--uniq wl\/uniq vl)
116: end
117: else raise Down)
118: | SWITCH'(v,el) => (* can't switch on a function *)
119: if sum present el < 2
120: then let val el' = map down' el
121: in (SWITCH'(v,el'), foldmerge(map #2 el')\/[v])
122: end
123: else raise Down
124: | e as APP'(f,vl) => (check(f::vl); click "s"; (e, uniq(f::vl)))
125: | FIX'(m,v3,e',v4) =>
126: let val v5 = v1\/(v3--defined)
127: in click "r";
128: (FIX'(l@m,v5,e',v4),v5\/(v4--(defined\/uniq(map #1 m))))
129: end
130: in down e handle Down => (FIX'(l,v1,e,v2),
131: v2--defined\/v1)
132: end
133: val rec clean =
134: fn RECORD'(vl,w,e,_) => RECORD(vl,w,clean e)
135: | SELECT'(i,v,w,e,_) => SELECT(i,v,w, clean e)
136: | PRIMOP'(i,vl,wl,el) => PRIMOP(i,vl,wl,map (clean o #1) el)
137: | SWITCH'(v,el) => SWITCH(v, map (clean o #1) el)
138: | APP'(f,vl) => APP(f,vl)
139: | FIX'(l,_,e,_) => FIX(map (fn (f,vl,e)=>(f,vl,clean e)) l, clean e)
140: val cexp' = #1(hoist cexp)
141: in if !clicked then clean cexp' else cexp
142: end
143:
144: end
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.