Mercurial > urweb

comparison src/unpoly.sml @ 1276:5b5c0b552f59

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Another run of Specialize, using ReduceLocal on datatype parameters
author Adam Chlipala <adamc@hcoop.net>
date Sat, 05 Jun 2010 09:42:37 -0400
parents 338be96f8533
children
comparison
equal deleted inserted replaced
1275:74150edf1134 1276:5b5c0b552f59
114 (e, st) 114 (e, st)
115 else 115 else
116 case IM.find (#funcs st, n) of 116 case IM.find (#funcs st, n) of
117 NONE => (e, st) 117 NONE => (e, st)
118 | SOME {kinds = ks, defs = vis, replacements} => 118 | SOME {kinds = ks, defs = vis, replacements} =>
119 case M.find (replacements, cargs) of 119 let
120 SOME n => (ENamed n, st) 120 val cargs = map ReduceLocal.reduceCon cargs
121 | NONE => 121 in
122 let 122 case M.find (replacements, cargs) of
123 val old_vis = vis 123 SOME n => (ENamed n, st)
124 val (vis, (thisName, nextName)) = 124 | NONE =>
125 ListUtil.foldlMap 125 let
126 (fn ((x, n', t, e, s), (thisName, nextName)) => 126 val old_vis = vis
127 ((x, nextName, n', t, e, s), 127 val (vis, (thisName, nextName)) =
128 (if n' = n then nextName else thisName, 128 ListUtil.foldlMap
129 nextName + 1))) 129 (fn ((x, n', t, e, s), (thisName, nextName)) =>
130 (0, #nextName st) vis 130 ((x, nextName, n', t, e, s),
131 131 (if n' = n then nextName else thisName,
132 fun specialize (x, n, n_old, t, e, s) = 132 nextName + 1)))
133 let 133 (0, #nextName st) vis
134 fun trim (t, e, cargs) = 134
135 case (t, e, cargs) of 135 fun specialize (x, n, n_old, t, e, s) =
136 ((TCFun (_, _, t), _), 136 let
137 (ECAbs (_, _, e), _), 137 fun trim (t, e, cargs) =
138 carg :: cargs) => 138 case (t, e, cargs) of
139 let 139 ((TCFun (_, _, t), _),
140 val t = subConInCon (length cargs, carg) t 140 (ECAbs (_, _, e), _),
141 val e = subConInExp (length cargs, carg) e 141 carg :: cargs) =>
142 in 142 let
143 trim (t, e, cargs) 143 val t = subConInCon (length cargs, carg) t
144 end 144 val e = subConInExp (length cargs, carg) e
145 | (_, _, []) => SOME (t, e) 145 in
146 | _ => NONE 146 trim (t, e, cargs)
147 in 147 end
148 (*Print.prefaces "specialize" 148 | (_, _, []) => SOME (t, e)
149 [("n", Print.PD.string (Int.toString n)), 149 | _ => NONE
150 ("nold", Print.PD.string (Int.toString n_old)), 150 in
151 ("t", CorePrint.p_con CoreEnv.empty t), 151 (*Print.prefaces "specialize"
152 ("e", CorePrint.p_exp CoreEnv.empty e), 152 [("n", Print.PD.string (Int.toString n)),
153 ("|cargs|", Print.PD.string (Int.toString (length cargs)))];*) 153 ("nold", Print.PD.string (Int.toString n_old)),
154 Option.map (fn (t, e) => (x, n, n_old, t, e, s)) 154 ("t", CorePrint.p_con CoreEnv.empty t),
155 (trim (t, e, cargs)) 155 ("e", CorePrint.p_exp CoreEnv.empty e),
156 end 156 ("|cargs|", Print.PD.string (Int.toString (length cargs)))];*)
157 157 Option.map (fn (t, e) => (x, n, n_old, t, e, s))
158 val vis = List.map specialize vis 158 (trim (t, e, cargs))
159 in 159 end
160 if List.exists (not o Option.isSome) vis orelse length cargs > length ks then 160
161 (e, st) 161 val vis = List.map specialize vis
162 else 162 in
163 let 163 if List.exists (not o Option.isSome) vis orelse length cargs > length ks then
164 val vis = List.mapPartial (fn x => x) vis 164 (e, st)
165 165 else
166 val vis = map (fn (x, n, n_old, t, e, s) => 166 let
167 (x ^ "_unpoly", n, n_old, t, e, s)) vis 167 val vis = List.mapPartial (fn x => x) vis
168 val vis' = map (fn (x, n, _, t, e, s) => 168
169 (x, n, t, e, s)) vis 169 val vis = map (fn (x, n, n_old, t, e, s) =>
170 170 (x ^ "_unpoly", n, n_old, t, e, s)) vis
171 val funcs = foldl (fn ((_, n, n_old, _, _, _), funcs) => 171 val vis' = map (fn (x, n, _, t, e, s) =>
172 let 172 (x, n, t, e, s)) vis
173 val replacements = case IM.find (funcs, n_old) of 173
174 NONE => M.empty 174 val funcs = foldl (fn ((_, n, n_old, _, _, _), funcs) =>
175 | SOME {replacements = r, ...} => r 175 let
176 in 176 val replacements = case IM.find (funcs, n_old) of
177 IM.insert (funcs, n_old, 177 NONE => M.empty
178 {kinds = ks, 178 | SOME {replacements = r,
179 defs = old_vis, 179 ...} => r
180 replacements = M.insert (replacements, 180 in
181 cargs, 181 IM.insert (funcs, n_old,
182 n)}) 182 {kinds = ks,
183 end) (#funcs st) vis 183 defs = old_vis,
184 184 replacements = M.insert (replacements,
185 val ks' = List.drop (ks, length cargs) 185 cargs,
186 186 n)})
187 val st = {funcs = foldl (fn (vi, funcs) => 187 end) (#funcs st) vis
188 IM.insert (funcs, #2 vi, 188
189 {kinds = ks', 189 val ks' = List.drop (ks, length cargs)
190 defs = vis', 190
191 replacements = M.empty})) 191 val st = {funcs = foldl (fn (vi, funcs) =>
192 funcs vis', 192 IM.insert (funcs, #2 vi,
193 decls = #decls st, 193 {kinds = ks',
194 nextName = nextName} 194 defs = vis',
195 195 replacements = M.empty}))
196 val (vis', st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) => 196 funcs vis',
197 let 197 decls = #decls st,
198 val (e, st) = polyExp (e, st) 198 nextName = nextName}
199 in 199
200 ((x, n, t, e, s), st) 200 val (vis', st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
201 end) 201 let
202 st vis' 202 val (e, st) = polyExp (e, st)
203 in 203 in
204 (ENamed thisName, 204 ((x, n, t, e, s), st)
205 {funcs = #funcs st, 205 end)
206 decls = (DValRec vis', ErrorMsg.dummySpan) :: #decls st, 206 st vis'
207 nextName = #nextName st}) 207 in
208 end 208 (ENamed thisName,
209 end 209 {funcs = #funcs st,
210 decls = (DValRec vis', ErrorMsg.dummySpan) :: #decls st,
211 nextName = #nextName st})
212 end
213 end
214 end
210 end 215 end
211 | _ => (e, st) 216 | _ => (e, st)
212 217
213 and polyExp (x, st) = U.Exp.foldMap {kind = kind, con = con, exp = exp} st x 218 and polyExp (x, st) = U.Exp.foldMap {kind = kind, con = con, exp = exp} st x
214 219