Mercurial > urweb

comparison src/cloconv.sml @ 26:4ab19c19665f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Closure conversion
author Adam Chlipala <adamc@hcoop.net>
date Tue, 10 Jun 2008 15:56:33 -0400
parents
children 537db4ee89f4
comparison
equal deleted inserted replaced
25:0a762c73824d 26:4ab19c19665f
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 Cloconv :> CLOCONV = struct
29
30 structure L = Mono
31 structure L' = Flat
32
33 structure IS = IntBinarySet
34
35 structure U = FlatUtil
36 structure E = FlatEnv
37
38 open Print.PD
39 open Print
40
41 val liftExpInExp =
42 U.Exp.mapB {typ = fn t => t,
43 exp = fn bound => fn e =>
44 case e of
45 L'.ERel xn =>
46 if xn < bound then
47 e
48 else
49 L'.ERel (xn + 1)
50 | _ => e,
51 bind = fn (bound, U.Exp.RelE _) => bound + 1
52 | (bound, _) => bound}
53 val subExpInExp =
54 U.Exp.mapB {typ = fn t => t,
55 exp = fn (xn, rep) => fn e =>
56 case e of
57 L'.ERel xn' =>
58 if xn = xn' then
59 #1 rep
60 else
61 e
62 | _ => e,
63 bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
64 | (ctx, _) => ctx}
65
66
67 fun ccTyp (t, loc) =
68 case t of
69 L.TFun (t1, t2) => (L'.TFun (ccTyp t1, ccTyp t2), loc)
70 | L.TRecord xts => (L'.TRecord (map (fn (x, t) => (x, ccTyp t)) xts), loc)
71 | L.TNamed n => (L'.TNamed n, loc)
72
73 structure Ds :> sig
74 type t
75
76 val empty : t
77
78 val exp : t -> string * int * L'.typ * L'.exp -> t
79 val func : t -> string * L'.typ * L'.typ * L'.exp -> t * int
80 val decls : t -> L'.decl list
81
82 val enter : t -> t
83 val used : t * int -> t
84 val leave : t -> t
85 val listUsed : t -> int list
86 end = struct
87
88 type t = int * L'.decl list * IS.set
89
90 val empty = (0, [], IS.empty)
91
92 fun exp (fc, ds, vm) (v as (_, _, _, (_, loc))) = (fc, (L'.DVal v, loc) :: ds, vm)
93
94 fun func (fc, ds, vm) (x, dom, ran, e as (_, loc)) =
95 ((fc+1, (L'.DFun (fc, x, dom, ran, e), loc) :: ds, vm), fc)
96
97 fun decls (_, ds, _) = rev ds
98
99 fun enter (fc, ds, vm) = (fc, ds, IS.map (fn n => n + 1) vm)
100 fun used ((fc, ds, vm), n) = (fc, ds, IS.add (vm, n))
101 fun leave (fc, ds, vm) = (fc, ds, IS.map (fn n => n - 1) (IS.delete (vm, 0) handle NotFound => vm))
102
103 fun listUsed (_, _, vm) = IS.listItems vm
104
105 end
106
107
108 fun ccExp env ((e, loc), D) =
109 case e of
110 L.EPrim p => ((L'.EPrim p, loc), D)
111 | L.ERel n => ((L'.ERel n, loc), Ds.used (D, n))
112 | L.ENamed n => ((L'.ENamed n, loc), D)
113 | L.EApp (e1, e2) =>
114 let
115 val (e1, D) = ccExp env (e1, D)
116 val (e2, D) = ccExp env (e2, D)
117 in
118 ((L'.ELet ([("closure", e1),
119 ("arg", liftExpInExp 0 e2),
120 ("code", (L'.EField ((L'.ERel 1, loc), "func"), loc)),
121 ("env", (L'.EField ((L'.ERel 2, loc), "env"), loc))],
122 (L'.EApp ((L'.ERel 1, loc),
123 (L'.ERecord [("env", (L'.ERel 0, loc)),
124 ("arg", (L'.ERel 2, loc))], loc)), loc)), loc), D)
125 end
126 | L.EAbs (x, dom, ran, e) =>
127 let
128 val dom = ccTyp dom
129 val ran = ccTyp ran
130 val (e, D) = ccExp (E.pushERel env x dom) (e, Ds.enter D)
131 val ns = Ds.listUsed D
132 val ns = List.filter (fn n => n <> 0) ns
133 val D = Ds.leave D
134
135 (*val () = Print.preface ("Before", FlatPrint.p_exp FlatEnv.basis e)
136 val () = List.app (fn (x, t) => preface ("Bound", box [string x,
137 space,
138 string ":",
139 space,
140 FlatPrint.p_typ env t]))
141 (E.listERels env)
142 val () = List.app (fn n => preface ("Free", FlatPrint.p_exp (E.pushERel env x dom)
143 (L'.ERel n, loc))) ns*)
144 val body = foldl (fn (n, e) =>
145 subExpInExp (n, (L'.EField ((L'.ERel 1, loc), "fv" ^ Int.toString n), loc)) e)
146 e ns
147 (*val () = Print.preface (" After", FlatPrint.p_exp FlatEnv.basis body)*)
148 val body = (L'.ELet ([("env", (L'.EField ((L'.ERel 0, loc), "env"), loc)),
149 ("arg", (L'.EField ((L'.ERel 1, loc), "arg"), loc))],
150 body), loc)
151
152 val envT = (L'.TRecord (map (fn n => ("fv" ^ Int.toString n, #2 (E.lookupERel env (n-1)))) ns), loc)
153 val (D, fi) = Ds.func D (x, (L'.TRecord [("env", envT), ("arg", dom)], loc), ran, body)
154 in
155 ((L'.ERecord [("code", (L'.ECode fi, loc)),
156 ("env", (L'.ERecord (map (fn n => ("fv" ^ Int.toString n,
157 (L'.ERel (n-1), loc))) ns), loc))], loc), D)
158 end
159
160 | L.ERecord xes =>
161 let
162 val (xes, D) = ListUtil.foldlMap (fn ((x, e), D) =>
163 let
164 val (e, D) = ccExp env (e, D)
165 in
166 ((x, e), D)
167 end) D xes
168 in
169 ((L'.ERecord xes, loc), D)
170 end
171 | L.EField (e1, x) =>
172 let
173 val (e1, D) = ccExp env (e1, D)
174 in
175 ((L'.EField (e1, x), loc), D)
176 end
177
178 fun ccDecl ((d, loc), D) =
179 case d of
180 L.DVal (x, n, t, e) =>
181 let
182 val t = ccTyp t
183 val (e, D) = ccExp E.basis (e, D)
184 in
185 Ds.exp D (x, n, t, e)
186 end
187
188 fun cloconv ds =
189 let
190 val D = foldl ccDecl Ds.empty ds
191 in
192 Ds.decls D
193 end
194
195 end