Mercurial > urweb

comparison src/defunc.sml @ 484:685b41e85634

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Defunctionalization gets CommentBlog working
author Adam Chlipala <adamc@hcoop.net>
date Sun, 09 Nov 2008 16:54:42 -0500
parents
children 3ce20b0b6914
comparison
equal deleted inserted replaced
483:a0f47540d8ad 484:685b41e85634
1 (* Copyright (c) 2008, Adam Chlipala
2 * All rights reserved.
3 *
4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met:
6 *
7 * - Redistributions of source code must retain the above copyright notice,
8 * this list of conditions and the following disclaimer.
9 * - Redistributions in binary form must reproduce the above copyright notice,
10 * this list of conditions and the following disclaimer in the documentation
11 * and/or other materials provided with the distribution.
12 * - The names of contributors may not be used to endorse or promote products
13 * derived from this software without specific prior written permission.
14 *
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 * POSSIBILITY OF SUCH DAMAGE.
26 *)
27
28 structure Defunc :> DEFUNC = struct
29
30 open Core
31
32 structure E = CoreEnv
33 structure U = CoreUtil
34
35 structure IS = IntBinarySet
36
37 val functionInside = U.Con.exists {kind = fn _ => false,
38 con = fn TFun _ => true
39 | CFfi ("Basis", "transaction") => true
40 | _ => false}
41
42 val freeVars = U.Exp.foldB {kind = fn (_, xs) => xs,
43 con = fn (_, _, xs) => xs,
44 exp = fn (bound, e, xs) =>
45 case e of
46 ERel x =>
47 if x >= bound then
48 IS.add (xs, x - bound)
49 else
50 xs
51 | _ => xs,
52 bind = fn (bound, b) =>
53 case b of
54 U.Exp.RelE _ => bound + 1
55 | _ => bound}
56 0 IS.empty
57
58 fun positionOf (v : int, ls) =
59 let
60 fun pof (pos, ls) =
61 case ls of
62 [] => raise Fail "Defunc.positionOf"
63 | v' :: ls' =>
64 if v = v' then
65 pos
66 else
67 pof (pos + 1, ls')
68 in
69 pof (0, ls)
70 end
71
72 fun squish fvs =
73 U.Exp.mapB {kind = fn k => k,
74 con = fn _ => fn c => c,
75 exp = fn bound => fn e =>
76 case e of
77 ERel x =>
78 if x >= bound then
79 ERel (positionOf (x - bound, fvs) + bound)
80 else
81 e
82 | _ => e,
83 bind = fn (bound, b) =>
84 case b of
85 U.Exp.RelE _ => bound + 1
86 | _ => bound}
87 0
88
89 fun default (_, x, st) = (x, st)
90
91 datatype 'a search =
92 Yes
93 | No
94 | Maybe of 'a
95
96 structure EK = struct
97 type ord_key = exp
98 val compare = U.Exp.compare
99 end
100
101 structure EM = BinaryMapFn(EK)
102
103 type state = {
104 maxName : int,
105 funcs : int EM.map,
106 vis : (string * int * con * exp * string) list
107 }
108
109 fun exp (env, e, st) =
110 case e of
111 ERecord xes =>
112 let
113 val (xes, st) =
114 ListUtil.foldlMap
115 (fn (tup as (fnam as (CName x, loc), e, xt), st) =>
116 if x <> "Link" andalso x <> "Action" then
117 (tup, st)
118 else
119 let
120 fun needsAttention (e, _) =
121 case e of
122 ENamed f => Maybe (#2 (E.lookupENamed env f))
123 | EApp (f, _) =>
124 (case needsAttention f of
125 No => No
126 | Yes => Yes
127 | Maybe t =>
128 case t of
129 (TFun (dom, _), _) =>
130 if functionInside dom then
131 Yes
132 else
133 No
134 | _ => No)
135 | _ => No
136
137 fun headSymbol (e, _) =
138 case e of
139 ENamed f => f
140 | EApp (e, _) => headSymbol e
141 | _ => raise Fail "Defunc: headSymbol"
142
143 fun rtype (e, _) =
144 case e of
145 ENamed f => #2 (E.lookupENamed env f)
146 | EApp (f, _) =>
147 (case rtype f of
148 (TFun (_, ran), _) => ran
149 | _ => raise Fail "Defunc: rtype [1]")
150 | _ => raise Fail "Defunc: rtype [2]"
151 in
152 (*Print.prefaces "Found one!"
153 [("e", CorePrint.p_exp env e)];*)
154 case needsAttention e of
155 Yes =>
156 let
157 (*val () = print "Yes\n"*)
158 val f = headSymbol e
159
160 val fvs = IS.listItems (freeVars e)
161
162 val e = squish fvs e
163 val (e, t) = foldl (fn (n, (e, t)) =>
164 let
165 val (x, xt) = E.lookupERel env n
166 in
167 ((EAbs (x, xt, t, e), loc),
168 (TFun (xt, t), loc))
169 end)
170 (e, rtype e) fvs
171
172 val (f', st) =
173 case EM.find (#funcs st, e) of
174 SOME f' => (f', st)
175 | NONE =>
176 let
177 val (fx, _, _, tag) = E.lookupENamed env f
178 val f' = #maxName st
179
180 val vi = (fx, f', t, e, tag)
181 in
182 (f', {maxName = f' + 1,
183 funcs = EM.insert (#funcs st, e, f'),
184 vis = vi :: #vis st})
185 end
186
187 val e = foldr (fn (n, e) =>
188 (EApp (e, (ERel n, loc)), loc))
189 (ENamed f', loc) fvs
190 in
191 (*app (fn n => Print.prefaces
192 "Free"
193 [("n", CorePrint.p_exp env (ERel n, ErrorMsg.dummySpan))])
194 fvs;
195 Print.prefaces "Squished"
196 [("e", CorePrint.p_exp CoreEnv.empty e)];*)
197
198 ((fnam, e, xt), st)
199 end
200 | _ => (tup, st)
201 end
202 | (tup, st) => (tup, st))
203 st xes
204 in
205 (ERecord xes, st)
206 end
207 | _ => (e, st)
208
209 fun bind (env, b) =
210 case b of
211 U.Decl.RelC (x, k) => E.pushCRel env x k
212 | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co
213 | U.Decl.RelE (x, t) => E.pushERel env x t
214 | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s
215
216 fun doDecl env = U.Decl.foldMapB {kind = fn x => x,
217 con = default,
218 exp = exp,
219 decl = default,
220 bind = bind}
221 env
222
223 fun defunc file =
224 let
225 fun doDecl' (d, (env, st)) =
226 let
227 val env = E.declBinds env d
228
229 val (d, st) = doDecl env st d
230
231 val ds =
232 case #vis st of
233 [] => [d]
234 | vis =>
235 case d of
236 (DValRec vis', loc) => [(DValRec (vis' @ vis), loc)]
237 | _ => [(DValRec vis, #2 d), d]
238 in
239 (ds,
240 (env,
241 {maxName = #maxName st,
242 funcs = #funcs st,
243 vis = []}))
244 end
245
246 val (file, _) = ListUtil.foldlMapConcat doDecl'
247 (E.empty,
248 {maxName = U.File.maxName file + 1,
249 funcs = EM.empty,
250 vis = []})
251 file
252 in
253 file
254 end
255
256 end