Mercurial > urweb

comparison src/especialize.sml @ 443:bd9ee9aeca2f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Especialize
author Adam Chlipala <adamc@hcoop.net>
date Thu, 30 Oct 2008 16:58:54 -0400
parents
children f45f23ae20ed
comparison
equal deleted inserted replaced
442:9095a95a1bf9 443:bd9ee9aeca2f
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 ESpecialize :> ESPECIALIZE = struct
29
30 open Core
31
32 structure E = CoreEnv
33 structure U = CoreUtil
34
35 structure ILK = struct
36 type ord_key = int list
37 val compare = Order.joinL Int.compare
38 end
39
40 structure ILM = BinaryMapFn(ILK)
41 structure IM = IntBinaryMap
42
43 type func = {
44 name : string,
45 args : int ILM.map,
46 body : exp,
47 typ : con,
48 tag : string
49 }
50
51 type state = {
52 maxName : int,
53 funcs : func IM.map,
54 decls : (string * int * con * exp * string) list
55 }
56
57 fun kind (k, st) = (k, st)
58 fun con (c, st) = (c, st)
59
60 fun exp (e, st : state) =
61 let
62 fun getApp e =
63 case e of
64 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) =>
70 (case getApp (#1 e1) of
71 NONE => NONE
72 | SOME (f, xs, xs') => SOME (f, xs, xs' @ [e2]))
73 | _ => NONE
74 in
75 case getApp e of
76 NONE => (e, st)
77 | SOME (_, [], _) => (e, st)
78 | SOME (f, xs, xs') =>
79 case IM.find (#funcs st, f) of
80 NONE => (e, st)
81 | SOME {name, args, body, typ, tag} =>
82 case ILM.find (args, xs) of
83 SOME f' => (#1 (foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan))
84 (ENamed f', ErrorMsg.dummySpan) xs'),
85 st)
86 | NONE =>
87 let
88 fun subBody (body, typ, xs) =
89 case (#1 body, #1 typ, xs) of
90 (_, _, []) => SOME (body, typ)
91 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) =>
92 subBody (E.subExpInExp (0, (ENamed x, ErrorMsg.dummySpan)) body',
93 typ',
94 xs)
95 | _ => NONE
96 in
97 case subBody (body, typ, xs) of
98 NONE => (e, st)
99 | SOME (body', typ') =>
100 let
101 val f' = #maxName st
102 val funcs = IM.insert (#funcs st, f, {name = name,
103 args = ILM.insert (args, xs, f'),
104 body = body,
105 typ = typ,
106 tag = tag})
107 val st = {
108 maxName = f' + 1,
109 funcs = funcs,
110 decls = #decls st
111 }
112
113 val (body', st) = specExp st body'
114 val e' = foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan))
115 (ENamed f', ErrorMsg.dummySpan) xs'
116 in
117 (#1 e',
118 {maxName = #maxName st,
119 funcs = #funcs st,
120 decls = (name, f', typ', body', tag ^ "_espec") :: #decls st})
121 end
122 end
123 end
124
125 and specExp st = U.Exp.foldMap {kind = kind, con = con, exp = exp} st
126
127 fun decl (d, st) = (d, st)
128
129 val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl}
130
131 fun specialize file =
132 let
133 fun doDecl (d, st) =
134 let
135 val (d', st) = specDecl st d
136
137 val funcs = #funcs st
138 val funcs =
139 case #1 d of
140 DVal (x, n, c, e as (EAbs _, _), tag) =>
141 IM.insert (funcs, n, {name = x,
142 args = ILM.empty,
143 body = e,
144 typ = c,
145 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
155
156 val ds =
157 case #decls st of
158 [] => [d']
159 | vis => [(DValRec vis, ErrorMsg.dummySpan), d']
160 in
161 (ds, {maxName = #maxName st,
162 funcs = funcs,
163 decls = []})
164 end
165
166 val (ds, _) = ListUtil.foldlMapConcat doDecl
167 {maxName = U.File.maxName file + 1,
168 funcs = IM.empty,
169 decls = []}
170 file
171 in
172 ds
173 end
174
175
176 end