Mercurial > urweb

comparison src/especialize.sml @ 453:787d4931fb07

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Almost have that nested save function compiling
author Adam Chlipala <adamc@hcoop.net>
date Sat, 01 Nov 2008 21:19:43 -0400
parents f45f23ae20ed
children b393c2fc80f8
comparison
equal deleted inserted replaced
452:222cbc1da232 453:787d4931fb07
30 open Core 30 open Core
31 31
32 structure E = CoreEnv 32 structure E = CoreEnv
33 structure U = CoreUtil 33 structure U = CoreUtil
34 34
35 structure ILK = struct 35 datatype skey =
36 type ord_key = int list 36 Named of int
37 val compare = Order.joinL Int.compare 37 | App of skey * skey
38
39 structure K = struct
40 type ord_key = skey list
41 fun compare' (k1, k2) =
42 case (k1, k2) of
43 (Named n1, Named n2) => Int.compare (n1, n2)
44 | (Named _, _) => LESS
45 | (_, Named _) => GREATER
46
47 | (App (x1, y1), App (x2, y2)) => Order.join (compare' (x1, x2), fn () => compare' (y1, y2))
48
49 val compare = Order.joinL compare'
38 end 50 end
39 51
40 structure ILM = BinaryMapFn(ILK) 52 structure KM = BinaryMapFn(K)
41 structure IM = IntBinaryMap 53 structure IM = IntBinaryMap
54
55 fun skeyIn (e, _) =
56 case e of
57 ENamed n => SOME (Named n)
58 | EApp (e1, e2) =>
59 (case (skeyIn e1, skeyIn e2) of
60 (SOME k1, SOME k2) => SOME (App (k1, k2))
61 | _ => NONE)
62 | _ => NONE
63
64 fun skeyOut (k, loc) =
65 case k of
66 Named n => (ENamed n, loc)
67 | App (k1, k2) => (EApp (skeyOut (k1, loc), skeyOut (k2, loc)), loc)
42 68
43 type func = { 69 type func = {
44 name : string, 70 name : string,
45 args : int ILM.map, 71 args : int KM.map,
46 body : exp, 72 body : exp,
47 typ : con, 73 typ : con,
48 tag : string 74 tag : string
49 } 75 }
50 76
60 fun exp (e, st : state) = 86 fun exp (e, st : state) =
61 let 87 let
62 fun getApp e = 88 fun getApp e =
63 case e of 89 case e of
64 ENamed f => SOME (f, [], []) 90 ENamed f => SOME (f, [], [])
65 | EApp (e1, (ENamed x, _)) =>
66 (case getApp (#1 e1) of
67 NONE => NONE
68 | SOME (f, xs, xs') => SOME (f, xs @ [x], xs'))
69 | EApp (e1, e2) => 91 | EApp (e1, e2) =>
70 (case getApp (#1 e1) of 92 (case getApp (#1 e1) of
71 NONE => NONE 93 NONE => NONE
72 | SOME (f, xs, xs') => SOME (f, xs, xs' @ [e2])) 94 | SOME (f, xs, xs') =>
95 let
96 val k =
97 if List.null xs' then
98 skeyIn e2
99 else
100 NONE
101 in
102 case k of
103 NONE => SOME (f, xs, xs' @ [e2])
104 | SOME k => SOME (f, xs @ [k], xs')
105 end)
73 | _ => NONE 106 | _ => NONE
74 in 107 in
75 case getApp e of 108 case getApp e of
76 NONE => (e, st) 109 NONE => (e, st)
77 | SOME (_, [], _) => (e, st) 110 | SOME (_, [], _) => (e, st)
78 | SOME (f, xs, xs') => 111 | SOME (f, xs, xs') =>
79 case IM.find (#funcs st, f) of 112 case IM.find (#funcs st, f) of
80 NONE => (e, st) 113 NONE => ((*print "SHOT DOWN!\n";*) (e, st))
81 | SOME {name, args, body, typ, tag} => 114 | SOME {name, args, body, typ, tag} =>
82 case ILM.find (args, xs) of 115 case KM.find (args, xs) of
83 SOME f' => (#1 (foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) 116 SOME f' => ((*Print.prefaces "Pre-existing" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*)
84 (ENamed f', ErrorMsg.dummySpan) xs'), 117 (#1 (foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan))
85 st) 118 (ENamed f', ErrorMsg.dummySpan) xs'),
119 st))
86 | NONE => 120 | NONE =>
87 let 121 let
122 (*val () = Print.prefaces "New" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]*)
123
88 fun subBody (body, typ, xs) = 124 fun subBody (body, typ, xs) =
89 case (#1 body, #1 typ, xs) of 125 case (#1 body, #1 typ, xs) of
90 (_, _, []) => SOME (body, typ) 126 (_, _, []) => SOME (body, typ)
91 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => 127 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) =>
92 subBody (E.subExpInExp (0, (ENamed x, ErrorMsg.dummySpan)) body', 128 let
93 typ', 129 val body'' = E.subExpInExp (0, skeyOut (x, #2 body)) body'
94 xs) 130 in
131 (*Print.prefaces "espec" [("body'", CorePrint.p_exp CoreEnv.empty body'),
132 ("body''", CorePrint.p_exp CoreEnv.empty body'')];*)
133 subBody (body'',
134 typ',
135 xs)
136 end
95 | _ => NONE 137 | _ => NONE
96 in 138 in
97 case subBody (body, typ, xs) of 139 case subBody (body, typ, xs) of
98 NONE => (e, st) 140 NONE => (e, st)
99 | SOME (body', typ') => 141 | SOME (body', typ') =>
100 let 142 let
101 val f' = #maxName st 143 val f' = #maxName st
144 (*val () = print ("f' = " ^ Int.toString f' ^ "\n")*)
102 val funcs = IM.insert (#funcs st, f, {name = name, 145 val funcs = IM.insert (#funcs st, f, {name = name,
103 args = ILM.insert (args, xs, f'), 146 args = KM.insert (args, xs, f'),
104 body = body, 147 body = body,
105 typ = typ, 148 typ = typ,
106 tag = tag}) 149 tag = tag})
107 val st = { 150 val st = {
108 maxName = f' + 1, 151 maxName = f' + 1,
126 169
127 fun decl (d, st) = (d, st) 170 fun decl (d, st) = (d, st)
128 171
129 val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} 172 val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl}
130 173
131 fun specialize file = 174 fun specialize' file =
132 let 175 let
133 fun doDecl (d, st) = 176 fun doDecl (d, (st : state, changed)) =
134 let 177 let
178 val funcs = #funcs st
179 val funcs =
180 case #1 d of
181 DValRec vis =>
182 foldl (fn ((x, n, c, e, tag), funcs) =>
183 IM.insert (funcs, n, {name = x,
184 args = KM.empty,
185 body = e,
186 typ = c,
187 tag = tag}))
188 funcs vis
189 | _ => funcs
190
191 val st = {maxName = #maxName st,
192 funcs = funcs,
193 decls = []}
194
135 val (d', st) = specDecl st d 195 val (d', st) = specDecl st d
136 196
137 val funcs = #funcs st 197 val funcs = #funcs st
138 val funcs = 198 val funcs =
139 case #1 d of 199 case #1 d of
140 DVal (x, n, c, e as (EAbs _, _), tag) => 200 DVal (x, n, c, e as (EAbs _, _), tag) =>
141 IM.insert (funcs, n, {name = x, 201 IM.insert (funcs, n, {name = x,
142 args = ILM.empty, 202 args = KM.empty,
143 body = e, 203 body = e,
144 typ = c, 204 typ = c,
145 tag = tag}) 205 tag = tag})
146 | DValRec vis =>
147 foldl (fn ((x, n, c, e, tag), funcs) =>
148 IM.insert (funcs, n, {name = x,
149 args = ILM.empty,
150 body = e,
151 typ = c,
152 tag = tag}))
153 funcs vis
154 | _ => funcs 206 | _ => funcs
155 207
156 val ds = 208 val (changed, ds) =
157 case #decls st of 209 case #decls st of
158 [] => [d'] 210 [] => (changed, [d'])
159 | vis => [(DValRec vis, ErrorMsg.dummySpan), d'] 211 | vis =>
212 (true, case d' of
213 (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)]
214 | _ => [(DValRec vis, ErrorMsg.dummySpan), d'])
160 in 215 in
161 (ds, {maxName = #maxName st, 216 (ds, ({maxName = #maxName st,
162 funcs = funcs, 217 funcs = funcs,
163 decls = []}) 218 decls = []}, changed))
164 end 219 end
165 220
166 val (ds, _) = ListUtil.foldlMapConcat doDecl 221 val (ds, (_, changed)) = ListUtil.foldlMapConcat doDecl
167 {maxName = U.File.maxName file + 1, 222 ({maxName = U.File.maxName file + 1,
168 funcs = IM.empty, 223 funcs = IM.empty,
169 decls = []} 224 decls = []}, false)
170 file 225 file
171 in 226 in
172 ds 227 (changed, ds)
173 end 228 end
174 229
230 fun specialize file =
231 let
232 val (changed, file) = specialize' file
233 in
234 if changed then
235 specialize file
236 else
237 file
238 end
239
175 240
176 end 241 end