Annotation of /sml/trunk/src/compiler/FLINT/flint/flint2lambda.sml

Parent Directory | Revision Log

---

Revision 21 - (view) (download)

1 :	monnier	21	signature FLINT2LAMBDA =
2 :			sig
3 :			type lvar = LambdaVar.lvar
4 :			type lty = LtyDef.lty
5 :
6 :			val transVal : FLINT.value -> Lambda.value
7 :			val transLexp : FLINT.lexp -> Lambda.lexp
8 :			val transFundec : FLINT.fundec -> Lambda.lexp
9 :			end
10 :
11 :			structure Flint2Lambda :> FLINT2LAMBDA =
12 :			struct
13 :			structure F = FLINT
14 :			structure L = Lambda
15 :
16 :			structure A = Access
17 :			structure LV = LambdaVar
18 :			structure PO = PrimOp
19 :			structure S = Symbol
20 :			structure LT = LtyExtern
21 :
22 :			type lvar = LambdaVar.lvar
23 :			type lty = LtyDef.lty
24 :
25 :			fun bug msg = ErrorMsg.impossible("flint2lambda: "^msg)
26 :
27 :			(* tuple up a list of ltys into a single lty *)
28 :			fun ltTuple [lty] = lty
29 :			| ltTuple ltys = LT.ltc_tuple ltys
30 :
31 :			fun transVal fval =
32 :			case fval of
33 :			F.VAR lvar => L.VAR lvar
34 :			| F.INT i => L.INT i
35 :			| F.INT32 i => L.INT32 i
36 :			| F.WORD w => L.WORD w
37 :			| F.WORD32 w => L.WORD32 w
38 :			| F.REAL s => L.REAL s
39 :			| F.STRING s => L.STRING s
40 :
41 :			fun id (value : L.value) (x : L.lexp) = x
42 :
43 :			fun transCon fcon =
44 :			case fcon of
45 :			F.INTcon i => L.INTcon i
46 :			| F.INT32con i => L.INT32con i
47 :			| F.WORDcon w => L.WORDcon w
48 :			| F.WORD32con w => L.WORD32con w
49 :			| F.REALcon s => L.REALcon s
50 :			| F.STRINGcon s => L.STRINGcon s
51 :			| F.VLENcon i => L.VLENcon i
52 :			| F.DATAcon (dcon,_,_) => L.DATAcon dcon
53 :
54 :			fun selectLoop record body =
55 :			let
56 :			fun loop (_, []) = transLexp body
57 :			| loop (i, lvar::lvars) =
58 :			L.LET (lvar,
59 :			L.SELECT (i, L.VAR record),
60 :			loop (i+1, lvars))
61 :			in
62 :			loop
63 :			end
64 :
65 :			and transFundec (fkind, lvar, (* lty, *) formals, lexpBody) =
66 :			(case formals of
67 :			[(lvarArg, ltyArg)] => (* single arg function *)
68 :			L.FN (lvarArg, ltyArg, transLexp lexpBody)
69 :			| _ =>
70 :			let
71 :			val (lvarArgs, ltyArgs) = ListPair.unzip formals
72 :			val lvarArg = LV.mkLvar()
73 :			val ltyArg = ltTuple ltyArgs
74 :			in
75 :			L.FN (lvarArg, ltyArg,
76 :			selectLoop lvarArg lexpBody (0, lvarArgs))
77 :			end)
78 :
79 :			(**
80 :			** Warning: I think we need to wrap the result as well !!! (ZHONG)
81 :			**)
82 :			and transFundecRec (fk as {isrec=NONE, raw, isfct}, _, _, _) =
83 :			bug "unexpected case in transFundecRec"
84 :			| transFundecRec (fk as {isrec=SOME zs, raw, isfct},
85 :			lvar, formals, lexpBody) =
86 :			(case formals of
87 :			[(lvarArg, ltyArg)] => (* single arg function *)
88 :			(lvar, LT.ltc_arrow(raw, [ltyArg], zs),
89 :			L.FN (lvarArg, ltyArg, transLexp lexpBody))
90 :			| _ =>
91 :			let
92 :			val (lvarArgs, ltyArgs) = ListPair.unzip formals
93 :			val lvarArg = LV.mkLvar()
94 :			val ltyArg = ltTuple ltyArgs
95 :			in
96 :			(lvar, LT.ltc_arrow(raw, [ltyArg], zs),
97 :			L.FN (lvarArg, ltyArg,
98 :			selectLoop lvarArg lexpBody (0, lvarArgs)))
99 :			end)
100 :
101 :			and transLexp lexp =
102 :			case lexp of
103 :			F.RET [aValue] =>
104 :			L.SVAL (transVal aValue)
105 :
106 :			| F.RET valueList =>
107 :			L.RECORD (map transVal valueList)
108 :
109 :			| F.APP (funValue, [singleArg]) =>
110 :			L.APP (transVal funValue,
111 :			transVal singleArg)
112 :
113 :			| F.APP (funValue, argList) =>
114 :			let val v = LV.mkLvar()
115 :			in
116 :			L.LET (v,
117 :			L.RECORD (map transVal argList),
118 :			L.APP (transVal funValue, L.VAR v))
119 :			end
120 :
121 :			| F.TAPP (tfunValue, tycList) =>
122 :			L.TAPP (transVal tfunValue,
123 :			tycList)
124 :
125 :			(* LET can be tricky. If we're binding a singleton, it can be
126 :			* translated directly. If it's multiple vars and the binding
127 :			* expression is RET [v1,v2,v3] then we can do an iterated LET.
128 :			* Otherwise, the binding function could be a function call or
129 :			* something with multiple values. In this case, we will have
130 :			* to do a series of record selections.
131 :			*)
132 :			| F.LET ([lvar], lexpBinding, lexpBody) =>
133 :			let
134 :			val lexpBinding' = transLexp lexpBinding
135 :			in
136 :			(* case lexpBinding' of *)
137 :			(* L.LET (lvar', lexp', lexpBody') => *)
138 :			(* L.LET (lvar', lexp', *)
139 :			(* L.LET (lvar, lexpBody', *)
140 :			(* transLexp lexpBody)) *)
141 :			(* | _ => *)
142 :			L.LET (lvar, lexpBinding',
143 :			transLexp lexpBody)
144 :			end
145 :
146 :			| F.LET (lvarList, lexpBinding, lexpBody) =>
147 :			let
148 :			val lvarRecord = LV.mkLvar();
149 :			val lexpBinding' = transLexp lexpBinding
150 :			in
151 :			(* case lexpBinding' of *)
152 :			(* L.LET (lvar', lexp', lexpBody') => *)
153 :			(* L.LET (lvar', lexp', *)
154 :			(* L.LET (lvarRecord, lexpBody', *)
155 :			(* selectLoop lvarRecord lexpBody *)
156 :			(* (0, lvarList))) *)
157 :			(* | _ => *)
158 :			L.LET (lvarRecord, lexpBinding',
159 :			selectLoop lvarRecord lexpBody (0, lvarList))
160 :			end
161 :
162 :			| F.FIX ([x as (fk as {isrec=NONE,...},v,_,_)], lexpBody) =>
163 :			L.LET(v, transFundec x, transLexp lexpBody)
164 :
165 :			| F.FIX (fundecs, lexpBody) =>
166 :			let
167 :			fun loop [] = ([], [], [])
168 :			| loop (fundec::fundecs) =
169 :			let
170 :			val (lvar, lty, lexp) = transFundecRec fundec
171 :			val (lvars, ltys, lexps) = loop fundecs
172 :			in
173 :			(lvar::lvars, lty::ltys, lexp::lexps)
174 :			end
175 :
176 :			val (lvars, ltys, lexps) = loop fundecs
177 :			in
178 :			L.FIX (lvars, ltys, lexps, transLexp lexpBody)
179 :			end
180 :
181 :			| F.TFN ((lvar, tformals, lexp), lexpBody) =>
182 :			let
183 :			val kinds = map #2 tformals
184 :			in
185 :			L.LET (lvar,
186 :			L.TFN (kinds, transLexp lexp),
187 :			transLexp lexpBody)
188 :			end
189 :
190 :			| F.SWITCH (value, consig, conLexpList, lexpOpt) =>
191 :			let
192 :			val value' = transVal value
193 :
194 :			(* straight out of normalize.sml *)
195 :			fun DECON'(dc as (_, A.REF, lt), ts, x) =
196 :			L.APP (L.PRIM (PrimOp.DEREF, LT.lt_swap lt, ts), x)
197 :			| DECON'(dc as (_, A.SUSP(SOME(_, A.LVAR f)), lt), ts, x) =
198 :			let val v = LV.mkLvar()
199 :			in L.LET(v, L.TAPP (L.VAR f, ts), L.APP (L.VAR v, x))
200 :			end
201 :			| DECON' z = L.DECON z
202 :
203 :			fun tr (F.DATAcon (dcon, tycs, []), lexp) =
204 :			(L.DATAcon dcon, transLexp lexp)
205 :			| tr (F.DATAcon (dcon, tycs, [lvar]), lexp) =
206 :			(L.DATAcon dcon,
207 :			L.LET(lvar, DECON'(dcon, tycs, value'),
208 :			transLexp lexp))
209 :			| tr (F.DATAcon (dcon, tycs, lvars), lexp) =
210 :			let val v = LV.mkLvar()
211 :			in
212 :			(L.DATAcon dcon,
213 :			L.LET (v, DECON'(dcon, tycs, value'),
214 :			selectLoop v lexp (0, lvars)))
215 :			end
216 :			| tr (con, lexp) =
217 :			(transCon con, transLexp lexp)
218 :
219 :			fun mapopt f NONE = NONE
220 :			| mapopt f (SOME x) = SOME (f x)
221 :			in
222 :			L.SWITCH (value',
223 :			consig,
224 :			map tr conLexpList,
225 :			mapopt transLexp lexpOpt)
226 :			end
227 :
228 :			| F.CON (dcon, tycs, [], lvar, lexp) =>
229 :			L.LET (lvar, L.CON (dcon, tycs, L.INT 0),
230 :			transLexp lexp)
231 :			| F.CON (dcon, tycs, [value], lvar, lexp) =>
232 :			L.LET (lvar, L.CON (dcon, tycs, transVal value),
233 :			transLexp lexp)
234 :			| F.CON (dcon, tycs, values, lvar, lexp) =>
235 :			let val v = LV.mkLvar()
236 :			in
237 :			L.LET (v, L.RECORD (map transVal values),
238 :			L.LET (lvar, L.CON (dcon, tycs, L.VAR v),
239 :			transLexp lexp))
240 :			end
241 :
242 :			| F.RECORD (F.RK_RECORD, values, lvar, lexp) =>
243 :			L.LET (lvar, L.RECORD (map transVal values), transLexp lexp)
244 :			| F.RECORD (F.RK_STRUCT, values, lvar, lexp) =>
245 :			L.LET (lvar, L.SRECORD (map transVal values), transLexp lexp)
246 :			| F.RECORD (F.RK_VECTOR tyc, values, lvar, lexp) =>
247 :			L.LET (lvar, L.VECTOR (map transVal values, tyc), transLexp lexp)
248 :
249 :			| F.SELECT (value, i, lvar, lexp) =>
250 :			L.LET (lvar,
251 :			L.SELECT (i, transVal value),
252 :			transLexp lexp)
253 :
254 :			| F.RAISE (value, ltys) =>
255 :			L.RAISE (transVal value, ltTuple ltys)
256 :
257 :			| F.HANDLE (lexp, value) =>
258 :			L.HANDLE (transLexp lexp,
259 :			transVal value)
260 :
261 :			| F.ETAG (tyc, value, lvar, lexp) =>
262 :			L.LET (lvar,
263 :			L.ETAG (transVal value,
264 :			LT.ltc_tyc tyc),
265 :			transLexp lexp)
266 :
267 :			| F.PRIMOP (primop, [value], lvar, lexp) =>
268 :			L.LET (lvar, L.APP (L.PRIM primop, transVal value),
269 :			transLexp lexp)
270 :			| F.PRIMOP (primop, values, lvar, lexp) =>
271 :			let val v = LV.mkLvar()
272 :			in
273 :			L.LET (v, L.RECORD (map transVal values),
274 :			L.LET (lvar, L.APP (L.PRIM primop, L.VAR v),
275 :			transLexp lexp))
276 :			end
277 :
278 :			| F.GENOP (dict, (po,lty,tycs), [value], lvar, lexp) =>
279 :			L.LET (lvar, L.APP (L.GENOP (dict,po,lty,tycs), transVal value),
280 :			transLexp lexp)
281 :			| F.GENOP (dict, (po,lty,tycs), values, lvar, lexp) =>
282 :			let val v = LV.mkLvar()
283 :			in
284 :			L.LET (v, L.RECORD (map transVal values),
285 :			L.LET (lvar, L.APP (L.GENOP (dict,po,lty,tycs), L.VAR v),
286 :			transLexp lexp))
287 :			end
288 :
289 :			(*
290 :			| F.PACK (lty, tycs1, tycs2, v, lvar, lexp) =>
291 :			L.LET (lvar,
292 :			L.PACK (lty, tycs1, tycs2, transVal v),
293 :			transLexp lexp)
294 :			*)
295 :			| F.WRAP (tyc, v, lvar, lexp) =>
296 :			L.LET (lvar,
297 :			L.WRAP (tyc, true, transVal v),
298 :			transLexp lexp)
299 :
300 :			| F.UNWRAP (tyc, v, lvar, lexp) =>
301 :			L.LET (lvar,
302 :			L.UNWRAP (tyc, true, transVal v),
303 :			transLexp lexp)
304 :
305 :			end

---

root@smlnj-gforge.cs.uchicago.edu	ViewVC Help
Powered by ViewVC 1.0.0