Mercurial > urweb

comparison src/cjrize.sml @ 109:813e5a52063d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Remove closure conversion in favor of zany fun with modules, which also replaces 'page'
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 10:17:06 -0400
parents d101cb1efe55
children 2d6116de9cca
comparison
equal deleted inserted replaced
108:f59553dc1b6a 109:813e5a52063d
25 * POSSIBILITY OF SUCH DAMAGE. 25 * POSSIBILITY OF SUCH DAMAGE.
26 *) 26 *)
27 27
28 structure Cjrize :> CJRIZE = struct 28 structure Cjrize :> CJRIZE = struct
29 29
30 structure L = Flat 30 structure L = Mono
31 structure L' = Cjr 31 structure L' = Cjr
32 32
33 structure Sm :> sig 33 structure Sm :> sig
34 type t 34 type t
35 35
39 val declares : t -> (int * (string * L'.typ) list) list 39 val declares : t -> (int * (string * L'.typ) list) list
40 end = struct 40 end = struct
41 41
42 structure FM = BinaryMapFn(struct 42 structure FM = BinaryMapFn(struct
43 type ord_key = L.typ 43 type ord_key = L.typ
44 val compare = FlatUtil.Typ.compare 44 val compare = MonoUtil.Typ.compare
45 end) 45 end)
46 46
47 type t = int * int FM.map * (int * (string * L'.typ) list) list 47 type t = int * int FM.map * (int * (string * L'.typ) list) list
48 48
49 val empty : t = (1, FM.insert (FM.empty, (L.TRecord [], ErrorMsg.dummySpan), 0), []) 49 val empty : t = (1, FM.insert (FM.empty, (L.TRecord [], ErrorMsg.dummySpan), 0), [])
61 61
62 end 62 end
63 63
64 fun cifyTyp ((t, loc), sm) = 64 fun cifyTyp ((t, loc), sm) =
65 case t of 65 case t of
66 L.TTop => ((L'.TTop, loc), sm) 66 L.TFun (t1, t2) =>
67 | L.TFun (t1, t2) =>
68 let
69 val (_, sm) = cifyTyp (t1, sm)
70 val (_, sm) = cifyTyp (t2, sm)
71 in
72 ((L'.TFun, loc), sm)
73 end
74 | L.TCode (t1, t2) =>
75 let 67 let
76 val (t1, sm) = cifyTyp (t1, sm) 68 val (t1, sm) = cifyTyp (t1, sm)
77 val (t2, sm) = cifyTyp (t2, sm) 69 val (t2, sm) = cifyTyp (t2, sm)
78 in 70 in
79 ((L'.TCode (t1, t2), loc), sm) 71 ((L'.TFun (t1, t2), loc), sm)
80 end 72 end
81 | L.TRecord xts => 73 | L.TRecord xts =>
82 let 74 let
83 val old_xts = xts 75 val old_xts = xts
84 val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => 76 val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
93 ((L'.TRecord si, loc), sm) 85 ((L'.TRecord si, loc), sm)
94 end 86 end
95 | L.TNamed n => ((L'.TNamed n, loc), sm) 87 | L.TNamed n => ((L'.TNamed n, loc), sm)
96 | L.TFfi mx => ((L'.TFfi mx, loc), sm) 88 | L.TFfi mx => ((L'.TFfi mx, loc), sm)
97 89
90 val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)
91
98 fun cifyExp ((e, loc), sm) = 92 fun cifyExp ((e, loc), sm) =
99 case e of 93 case e of
100 L.EPrim p => ((L'.EPrim p, loc), sm) 94 L.EPrim p => ((L'.EPrim p, loc), sm)
101 | L.ERel n => ((L'.ERel n, loc), sm) 95 | L.ERel n => ((L'.ERel n, loc), sm)
102 | L.ENamed n => ((L'.ENamed n, loc), sm) 96 | L.ENamed n => ((L'.ENamed n, loc), sm)
105 let 99 let
106 val (es, sm) = ListUtil.foldlMap cifyExp sm es 100 val (es, sm) = ListUtil.foldlMap cifyExp sm es
107 in 101 in
108 ((L'.EFfiApp (m, x, es), loc), sm) 102 ((L'.EFfiApp (m, x, es), loc), sm)
109 end 103 end
110 | L.ECode n => ((L'.ECode n, loc), sm)
111 | L.EApp (e1, e2) => 104 | L.EApp (e1, e2) =>
112 let 105 let
113 val (e1, sm) = cifyExp (e1, sm) 106 val (e1, sm) = cifyExp (e1, sm)
114 val (e2, sm) = cifyExp (e2, sm) 107 val (e2, sm) = cifyExp (e2, sm)
115 in 108 in
116 ((L'.EApp (e1, e2), loc), sm) 109 ((L'.EApp (e1, e2), loc), sm)
117 end 110 end
111 | L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation";
112 (dummye, sm))
118 113
119 | L.ERecord xes => 114 | L.ERecord xes =>
120 let 115 let
121 val old_xts = map (fn (x, _, t) => (x, t)) xes 116 val old_xts = map (fn (x, _, t) => (x, t)) xes
122 117
141 val (e, sm) = cifyExp (e, sm) 136 val (e, sm) = cifyExp (e, sm)
142 in 137 in
143 ((L'.EField (e, x), loc), sm) 138 ((L'.EField (e, x), loc), sm)
144 end 139 end
145 140
146 | L.ELet (xes, e) =>
147 let
148 val (xes, sm) = ListUtil.foldlMap (fn ((x, t, e), sm) =>
149 let
150 val (t, sm) = cifyTyp (t, sm)
151 val (e, sm) = cifyExp (e, sm)
152 in
153 ((x, t, e), sm)
154 end)
155 sm xes
156 val (e, sm) = cifyExp (e, sm)
157 in
158 ((L'.ELet (xes, e), loc), sm)
159 end
160
161 | L.EStrcat _ => raise Fail "Cjrize EStrcat" 141 | L.EStrcat _ => raise Fail "Cjrize EStrcat"
162 142
163 | L.EWrite e => 143 | L.EWrite e =>
164 let 144 let
165 val (e, sm) = cifyExp (e, sm) 145 val (e, sm) = cifyExp (e, sm)
175 ((L'.ESeq (e1, e2), loc), sm) 155 ((L'.ESeq (e1, e2), loc), sm)
176 end 156 end
177 157
178 fun cifyDecl ((d, loc), sm) = 158 fun cifyDecl ((d, loc), sm) =
179 case d of 159 case d of
180 L.DVal (x, n, t, e) => 160 L.DVal (x, n, t, e, _) =>
181 let 161 let
182 val (t, sm) = cifyTyp (t, sm) 162 val (t, sm) = cifyTyp (t, sm)
183 val (e, sm) = cifyExp (e, sm) 163
184 in 164 val (d, sm) = case #1 t of
185 (SOME (L'.DVal (x, n, t, e), loc), NONE, sm) 165 L'.TFun (dom, ran) =>
186 end 166 (case #1 e of
187 | L.DFun (n, x, dom, ran, e) => 167 L.EAbs (ax, _, _, e) =>
188 let 168 let
189 val (dom, sm) = cifyTyp (dom, sm) 169 val (e, sm) = cifyExp (e, sm)
190 val (ran, sm) = cifyTyp (ran, sm) 170 in
191 val (e, sm) = cifyExp (e, sm) 171 (L'.DFun (x, n, ax, dom, ran, e), sm)
192 in 172 end
193 (SOME (L'.DFun (n, x, dom, ran, e), loc), NONE, sm) 173 | _ => (ErrorMsg.errorAt loc "Function isn't explicit at code generation";
194 end 174 (L'.DVal ("", 0, t, (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)), sm)))
195 | L.DPage (xts, e) => 175 | _ =>
196 let 176 let
197 val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => 177 val (e, sm) = cifyExp (e, sm)
198 let 178 in
199 val (t, sm) = cifyTyp (t, sm) 179 (L'.DVal (x, n, t, e), sm)
200 in 180 end
201 ((x, t), sm) 181 in
202 end) 182 (SOME (d, loc), NONE, sm)
203 sm xts 183 end
204 val (e, sm) = cifyExp (e, sm) 184 | L.DExport n => (NONE, SOME n, sm)
205 in
206 (NONE, SOME (xts, e), sm)
207 end
208 185
209 fun cjrize ds = 186 fun cjrize ds =
210 let 187 let
211 val (ds, ps, sm) = foldl (fn (d, (ds, ps, sm)) => 188 val (ds, ps, sm) = foldl (fn (d, (ds, ps, sm)) =>
212 let 189 let