Annotation of /sml/trunk/src/compiler/FLINT/plambda/flintnm.sml

Parent Directory | Revision Log

---

Revision 256 - (view) (download)

1 :	monnier	16	(* COPYRIGHT (c) 1997 YALE FLINT PROJECT *)
2 :	monnier	161	(* monnier@cs.yale.edu *)
3 :	monnier	16
4 :			(* Converting the Standard PLambda.lexp into the FLINT IL *)
5 :			signature FLINTNM =
6 :			sig
7 :			val norm : PLambda.lexp -> FLINT.fundec
8 :			end (* signature FLINTNM *)
9 :
10 :			structure FlintNM : FLINTNM =
11 :			struct
12 :
13 :			local structure LT = PLambdaType
14 :			structure FL = PFlatten (* argument flattening *)
15 :			structure DI = DebIndex
16 :			structure PT = PrimTyc
17 :	monnier	45	structure PO = PrimOp
18 :	monnier	16	structure L = PLambda
19 :			structure F = FLINT
20 :	monnier	45	structure FU = FlintUtil
21 :	monnier	16	structure DA = Access
22 :	monnier	71	structure BT = BasicTypes
23 :	monnier	16	in
24 :
25 :	monnier	220	val say = Control_Print.say
26 :	monnier	16	val mkv = LambdaVar.mkLvar
27 :	monnier	161	val cplv = LambdaVar.dupLvar
28 :	monnier	16	val ident = fn le : L.lexp => le
29 :	monnier	45
30 :			val (iadd_prim, uadd_prim) =
31 :			let val lt_int = LT.ltc_int
32 :			val intOpTy = LT.ltc_parrow(LT.ltc_tuple[lt_int,lt_int],lt_int)
33 :			val addu = PO.ARITH{oper=PO.+, overflow=false, kind=PO.UINT 31}
34 :			in (L.PRIM(PO.IADD,intOpTy,[]), L.PRIM(addu, intOpTy, []))
35 :			end
36 :
37 :	monnier	16	fun bug msg = ErrorMsg.impossible("FlintNM: "^msg)
38 :
39 :
40 :	monnier	71	local val (trueDcon', falseDcon') =
41 :			let val lt = LT.ltc_arrow(LT.ffc_rrflint, [LT.ltc_unit], [LT.ltc_bool])
42 :			fun h (Types.DATACON{name, rep, ...}) = (name, rep, lt)
43 :			in (h BT.trueDcon, h BT.falseDcon)
44 :			end
45 :
46 :			fun boolLexp b =
47 :			let val v = mkv() and w = mkv()
48 :			val dc = if b then trueDcon' else falseDcon'
49 :			in F.RECORD(FU.rk_tuple, [], v,
50 :			F.CON(dc, [], F.VAR v, w, F.RET[F.VAR w]))
51 :			end
52 :			in
53 :
54 :			fun flint_prim (po as (d, p, lt, ts), vs, v, e) =
55 :			(case p
56 :			of (PO.BOXED | PO.UNBOXED | PO.CMP _ | PO.PTREQL |
57 :			PO.PTRNEQ | PO.POLYEQL | PO.POLYNEQ) =>
58 :	monnier	184	(*** branch primops get translated into F.BRANCH ***)
59 :	monnier	71	F.LET([v], F.BRANCH(po, vs, boolLexp true, boolLexp false), e)
60 :			| (PO.GETRUNVEC | PO.GETHDLR | PO.GETVAR | PO.DEFLVAR) =>
61 :			(*** primops that take zero arguments; argument types
62 :			must be unit ***)
63 :			let fun fix t =
64 :			LT.ltw_arrow(t,
65 :			fn (ff,[t1],ts2) =>
66 :			(if LT.tc_eqv(t1, LT.tcc_unit)
67 :			then LT.ltc_tyc(LT.tcc_arrow(ff, [], ts2))
68 :			else bug "unexpected zero-args prims 1 in flint_prim"),
69 :			fn _ => bug "unexpected zero-args prims 2 in flint_prim")
70 :			val nlt =
71 :			LT.ltw_ppoly(lt,
72 :			fn (ks, t) => LT.ltc_ppoly(ks, fix t),
73 :			fn _ => fix lt)
74 :			in F.PRIMOP((d,p,nlt,ts), [], v, e)
75 :			end
76 :			| _ =>
77 :			F.PRIMOP(po, vs, v, e))
78 :
79 :			end (* local flint_prim *)
80 :
81 :	monnier	45	(* force_raw freezes the calling conventions of a data constructor;
82 :			strictly used by the CON and DATAcon only
83 :			*)
84 :			fun force_raw (pty) =
85 :			if LT.ltp_ppoly pty then
86 :			let val (ks, body) = LT.ltd_ppoly pty
87 :			val (aty, rty) = LT.ltd_parrow body
88 :			in LT.ltc_ppoly(ks,
89 :			LT.ltc_arrow(LT.ffc_rrflint, [FL.ltc_raw aty], [FL.ltc_raw rty]))
90 :			end
91 :			else
92 :			let val (aty, rty) = LT.ltd_parrow pty
93 :			in LT.ltc_arrow(LT.ffc_rrflint, [FL.ltc_raw aty], [FL.ltc_raw rty])
94 :			end (* function force_raw *)
95 :
96 :	monnier	16	fun tocon con =
97 :			let val _ = 1
98 :			in case con of
99 :			L.INTcon x => F.INTcon x
100 :			| L.INT32con x => F.INT32con x
101 :			| L.WORDcon x => F.WORDcon x
102 :			| L.WORD32con x => F.WORD32con x
103 :			| L.REALcon x => F.REALcon x
104 :			| L.STRINGcon x => F.STRINGcon x
105 :			| L.VLENcon x => F.VLENcon x
106 :			| L.DATAcon x => bug "unexpected case in tocon"
107 :			end
108 :
109 :			fun tofundec (venv,d,f_lv,arg_lv,arg_lty,body,isrec) =
110 :			let val (body',body_lty) =
111 :			(* first, we translate the body (in the extended env) *)
112 :			tolexp (LT.ltInsert(venv, arg_lv, arg_lty, d), d) body
113 :
114 :			(* detuple the arg type *)
115 :	monnier	45	val ((arg_raw, arg_ltys, _), unflatten) = FL.v_punflatten arg_lty
116 :	monnier	16
117 :			(* now, we add tupling code at the beginning of the body *)
118 :			val (arg_lvs, body'') = unflatten(arg_lv, body')
119 :
120 :			(* construct the return type if necessary *)
121 :	monnier	45	val (body_raw, body_ltys, _) = FL.t_pflatten body_lty
122 :	monnier	16	val rettype = if not isrec then NONE
123 :	monnier	184	else SOME(map FL.ltc_raw body_ltys, F.LK_UNKNOWN)
124 :	monnier	16
125 :	monnier	184	val (f_lty, fkind) =
126 :			if (LT.ltp_tyc arg_lty andalso LT.ltp_tyc body_lty) then
127 :			(* a function *)
128 :			(LT.ltc_parrow(arg_lty, body_lty),
129 :			{isrec=rettype, known=false, inline=F.IH_SAFE,
130 :			cconv=F.CC_FUN(LT.ffc_var(arg_raw, body_raw))})
131 :			else
132 :			(* a functor *)
133 :			(LT.ltc_pfct(arg_lty, body_lty),
134 :			{isrec=rettype, known=false, inline=F.IH_SAFE,
135 :			cconv=F.CC_FCT})
136 :	monnier	16
137 :	monnier	45	in ((fkind, f_lv, ListPair.zip(arg_lvs, map FL.ltc_raw arg_ltys), body''),
138 :	monnier	16	f_lty)
139 :			end
140 :
141 :
142 :			(* used to translate expressions whose structure is the same
143 :			* in Flint as in PLambda (either both binding or both non-binding)
144 :			* a continuation is unnecessary *)
145 :			and tolexp (venv,d) lexp =
146 :			let fun default_tovalues () =
147 :			tovalues(venv, d, lexp,
148 :			fn (vals, lty) =>
149 :			(F.RET vals, lty))
150 :			in case lexp of
151 :			L.APP (L.PRIM _, arg) => default_tovalues()
152 :			| L.APP (L.GENOP _,arg) => default_tovalues()
153 :			| L.APP (L.FN (arg_lv,arg_lty,body), arg_le) =>
154 :			tolexp (venv,d) (L.LET(arg_lv, arg_le, body))
155 :			| L.APP (f,arg) =>
156 :			(* first, evaluate f to a mere value *)
157 :			tovalue(venv, d, f,
158 :			fn (f_val, f_lty) =>
159 :			(* then eval the argument *)
160 :			tovalues(venv, d, arg,
161 :			fn (arg_vals, arg_lty) =>
162 :			(* now find the return type *)
163 :	monnier	71	let val (_, r_lty) =
164 :			if LT.ltp_pfct f_lty then LT.ltd_pfct f_lty
165 :			else LT.ltd_parrow f_lty
166 :	monnier	16	(* and finally do the call *)
167 :			in (F.APP(f_val,arg_vals), r_lty)
168 :			end))
169 :
170 :			| L.FIX (lvs,ltys,lexps,lexp) =>
171 :			(* first, let's setup the enriched environment with those funs *)
172 :			let val venv' = foldl (fn ((lv,lty),ve) =>
173 :			LT.ltInsert(ve, lv, lty, d))
174 :			venv (ListPair.zip(lvs, ltys))
175 :
176 :			(* then translate each function in turn *)
177 :			val funs = map (fn ((f_lv,f_lty),L.FN(arg_lv,arg_lty,body)) =>
178 :			#1(tofundec(venv', d,
179 :	monnier	161	f_lv, arg_lv, arg_lty, body, true))
180 :			| _ => bug "non-function in L.FIX")
181 :	monnier	16	(ListPair.zip(ListPair.zip(lvs,ltys),lexps))
182 :
183 :			(* finally, translate the lexp *)
184 :			val (lexp',lty) = tolexp (venv',d) lexp
185 :			in (F.FIX(funs,lexp'), lty)
186 :			end
187 :
188 :			| L.LET (lvar,lexp1,lexp2) =>
189 :			tolvar(venv, d, lvar, lexp1,
190 :			fn lty1 =>
191 :			tolexp (LT.ltInsert(venv,lvar,lty1,d), d) lexp2)
192 :
193 :			| L.RAISE (le, r_lty) =>
194 :			tovalue(venv, d, le,
195 :			fn (le_val,le_lty) =>
196 :	monnier	45	let val (_, r_ltys, _) = FL.t_pflatten r_lty
197 :	monnier	16	in (F.RAISE(le_val, map FL.ltc_raw r_ltys), r_lty)
198 :			end)
199 :
200 :			| L.HANDLE (body, handler) =>
201 :			tovalue(venv, d, handler,
202 :			fn (h_val,h_lty) =>
203 :			let val (body', body_lty) = tolexp (venv, d) body
204 :			in (F.HANDLE(body', h_val), body_lty)
205 :			end)
206 :
207 :	monnier	45	| L.SWITCH (le,acs,[],NONE) => bug "unexpected case in L.SWITCH"
208 :	monnier	16	(* tovalue(venv, d, le, fn _ => (F.RET[], [])) *)
209 :			| L.SWITCH (le,acs,[],SOME lexp) =>
210 :			tovalue(venv, d, le, fn (v,lty) => tolexp (venv,d) lexp)
211 :			| L.SWITCH (le,acs,conlexps,default) =>
212 :			let fun f (L.DATAcon((s,cr,lty),tycs,lvar),le) =
213 :			let val (lv_lty,_) = LT.ltd_parrow(LT.lt_pinst(lty,tycs))
214 :			val newvenv = LT.ltInsert(venv,lvar,lv_lty,d)
215 :			val (le, le_lty) = tolexp (newvenv,d) le
216 :			in
217 :	monnier	45	((F.DATAcon((s, cr, force_raw lty),
218 :			map FL.tcc_raw tycs, lvar),
219 :	monnier	16	le),
220 :			le_lty)
221 :			end
222 :			| f (con,le) =
223 :			let val (lexp,lty) = tolexp (venv,d) le
224 :			in ((tocon con, lexp), lty)
225 :			end
226 :			in tovalue(venv, d, le,
227 :			fn (v, lty) =>
228 :	monnier	184	let val default = Option.map (#1 o tolexp(venv,d)) default
229 :	monnier	16	val conlexps as ((_,lty)::_) = map f conlexps
230 :			in (F.SWITCH(v, acs, map #1 conlexps, default), lty)
231 :			end)
232 :			end
233 :
234 :			(* for mere values, use tovalues *)
235 :			| _ => default_tovalues ()
236 :			end
237 :
238 :			(*
239 :			* tovalue: turns a PLambda lexp into a value+type and then calls
240 :			* the continuation that will turn it into an Flint lexp+type
241 :			* (ltyenv * DebIndex * L.lexp * ((value * lty) -> (F.lexp * lty list))) -> (F.lexp * lty)
242 :			*
243 :			* - venv is the type environment for values
244 :			* - conts is the continuation
245 :			*)
246 :			and tovalue (venv,d,lexp,cont) =
247 :			let val _ = 1
248 :			in case lexp of
249 :			(* for simple values, it's trivial *)
250 :			L.VAR v => cont(F.VAR v, LT.ltLookup(venv, v, d))
251 :	monnier	45	| L.INT i =>
252 :			((i+i+2; cont(F.INT i, LT.ltc_int)) handle Overflow =>
253 :			(let val z = i div 2
254 :			val ne = L.APP(iadd_prim, L.RECORD [L.INT z, L.INT (i-z)])
255 :			in tovalue(venv, d, ne, cont)
256 :			end))
257 :			| L.WORD i =>
258 :			let val maxWord = 0wx20000000
259 :			in if Word.<(i, maxWord) then cont(F.WORD i, LT.ltc_int)
260 :			else let val x1 = Word.div(i, 0w2)
261 :			val x2 = Word.-(i, x1)
262 :			val ne = L.APP(uadd_prim,
263 :			L.RECORD [L.WORD x1, L.WORD x2])
264 :			in tovalue(venv, d, ne, cont)
265 :			end
266 :			end
267 :	monnier	16	| L.INT32 n => cont(F.INT32 n, LT.ltc_int32)
268 :			| L.WORD32 n => cont(F.WORD32 n, LT.ltc_int32)
269 :			| L.REAL x => cont(F.REAL x, LT.ltc_real)
270 :			| L.STRING s => cont(F.STRING s, LT.ltc_string)
271 :
272 :			(* for cases where tolvar is more convenient *)
273 :			| _ =>
274 :			let val lv = mkv()
275 :			in tolvar(venv, d, lv, lexp, fn lty => cont(F.VAR lv, lty))
276 :			end
277 :			end
278 :
279 :
280 :			(*
281 :			* tovalues: turns a PLambda lexp into a list of values and a list of types
282 :			* and then calls the continuation that will turn it into an Flint lexp+type
283 :			*
284 :			* (ltyenv * DebIndex * L.lexp * ((value list * lty list) -> (F.lexp * lty list))) -> (F.lexp * lty)
285 :			*
286 :			* - venv is the type environment for values
287 :			* - cont is the continuation
288 :			*)
289 :			and tovalues (venv,d,lexp,cont) =
290 :			let val _ = 1
291 :			in case lexp of
292 :			L.RECORD (lexps) =>
293 :			lexps2values(venv,d,lexps,
294 :			fn (vals,ltys) =>
295 :			let val lty = LT.ltc_tuple ltys
296 :	monnier	45	val (_, ltys, _) = FL.t_pflatten lty
297 :	monnier	16	in
298 :			(* detect the case where flattening is trivial *)
299 :			if LT.lt_eqv(lty, LT.ltc_tuple ltys) then
300 :			cont(vals,lty)
301 :			else
302 :			let val lv = mkv()
303 :	monnier	45	val (_, pflatten) = FL.v_pflatten lty
304 :			val (vs,wrap) = pflatten (F.VAR lv)
305 :	monnier	16	val (c_lexp,c_lty) = cont(vs, lty)
306 :			in
307 :	monnier	45	(F.RECORD(FU.rk_tuple,
308 :	monnier	16	vals, lv, wrap c_lexp),
309 :			c_lty)
310 :			end
311 :			end)
312 :
313 :			| _ => tovalue(venv,d,lexp,
314 :			fn (v, lty) =>
315 :	monnier	45	let val (vs,wrap) = (#2(FL.v_pflatten lty)) v
316 :	monnier	16	val (c_lexp, c_lty) = cont(vs, lty)
317 :			in (wrap c_lexp, c_lty)
318 :			end)
319 :			end
320 :
321 :			(* eval each lexp to a value *)
322 :			and lexps2values (venv,d,lexps,cont) =
323 :			let val _ = 1
324 :			fun f [] (vals,ltys) = cont (rev vals, rev ltys)
325 :			| f (lexp::lexps) (vals,ltys) =
326 :			tovalue(venv,d,lexp,
327 :			fn (v, lty) =>
328 :			f lexps (v::vals, lty::ltys))
329 :			in
330 :			f lexps ([], [])
331 :			end
332 :
333 :			(*
334 :			* tolvar: same as tovalue except that it binds the value of the PLambda
335 :			* to the indicated lvar and passes just the type to the continutation
336 :			*)
337 :			and tolvar (venv,d,lvar,lexp,cont) =
338 :			let fun eta_expand (f, f_lty) =
339 :			let val lv = mkv()
340 :			val (arg_lty, ret_lty) = (LT.ltd_parrow f_lty)
341 :			in tolvar(venv, d, lvar,
342 :			L.FN(lv, arg_lty, L.APP(f, L.VAR lv)),
343 :			cont)
344 :			end
345 :
346 :			(* inbetween tolvar and tovalue: it binds the lexp to a variable but
347 :			* is free to choose the lvar and passes it to the continutation *)
348 :			fun tolvarvalue (venv,d,lexp,cont) =
349 :			tovalue(venv, d, lexp,
350 :			fn (v,lty) =>
351 :			case v of
352 :			F.VAR lv => cont(lv, lty)
353 :			| _ => let val lv = mkv()
354 :			val (lexp',lty) = cont(lv, lty)
355 :			in (F.LET ([lv], F.RET [v], lexp'), lty)
356 :			end)
357 :
358 :	monnier	45	fun PO_helper (arg,f_lty,tycs,filler) =
359 :			(* invariants: primop's types are always fully closed *)
360 :			let (* pty is the resulting FLINT type of the underlying primop,
361 :			r_lty is the result PLambda type of this primop expression,
362 :			and flat indicates whether we should flatten the arguments
363 :			or not. The results of primops are never flattened.
364 :			*)
365 :			val (pty, r_lty, flat) =
366 :			(case (LT.ltp_ppoly f_lty, tycs)
367 :			of (true, _) =>
368 :			let val (ks, lt) = LT.ltd_ppoly f_lty
369 :			val (aty, rty) = LT.ltd_parrow lt
370 :			val r_lty =
371 :			LT.lt_pinst(LT.ltc_ppoly(ks, rty), tycs)
372 :	monnier	16
373 :	monnier	45	val (_, atys, flat) = FL.t_pflatten aty
374 :			(*** you really want to have a simpler
375 :			flattening heuristics here; in fact,
376 :			primop can have its own flattening
377 :			strategy. The key is that primop's
378 :			type never escape outside.
379 :			***)
380 :
381 :			val atys = map FL.ltc_raw atys
382 :			val nrty = FL.ltc_raw rty
383 :			val pty = LT.ltc_arrow(LT.ffc_rrflint,atys,[nrty])
384 :			in ( LT.ltc_ppoly(ks, pty), r_lty, flat)
385 :			end
386 :			| (false, []) => (* monomorphic case *)
387 :			let val (aty, rty) = LT.ltd_parrow f_lty
388 :			val (_, atys, flat) = FL.t_pflatten aty
389 :			val atys = map FL.ltc_raw atys
390 :			val nrty = FL.ltc_raw rty
391 :			val pty = LT.ltc_arrow(LT.ffc_rrflint,atys,[nrty])
392 :			in (pty, rty, flat)
393 :			end
394 :			| _ => bug "unexpected case in PO_helper")
395 :			in if flat then
396 :			(* ZHONG asks: is the following definitely safe ?
397 :			what would happen if ltc_raw is not an identity function ?
398 :			*)
399 :			tovalues(venv, d, arg,
400 :			fn (arg_vals, arg_lty) =>
401 :			let val (c_lexp, c_lty) = cont(r_lty)
402 :			(* put the filling inbetween *)
403 :			in (filler(arg_vals, pty, c_lexp), c_lty)
404 :			end)
405 :			else
406 :			tovalue(venv, d, arg,
407 :			fn (arg_val, arg_lty) =>
408 :			let val (c_lexp, c_lty) = cont(r_lty)
409 :			(* put the filling inbetween *)
410 :			in (filler([arg_val], pty, c_lexp), c_lty)
411 :			end)
412 :			end (* function PO_helper *)
413 :
414 :	monnier	16	fun default_tolexp () =
415 :			let val (lexp', lty) = tolexp (venv, d) lexp
416 :			val (c_lexp, c_lty) = cont(lty)
417 :	monnier	45	val (_, punflatten) = FL.v_punflatten lty
418 :			val (lvs,c_lexp') = punflatten (lvar, c_lexp)
419 :	monnier	16	in (F.LET(lvs, lexp', c_lexp'), c_lty)
420 :			end
421 :
422 :			(* fun default_tovalue () = *)
423 :			(* tovalue(venv, d, lexp, *)
424 :			(* fn (v,lty) => *)
425 :			(* let val (lexp', ltys) = cont(lty) *)
426 :			(* in (F.LET([lvar], F.RET[v], lexp'), ltys) *)
427 :			(* end) *)
428 :
429 :			in case lexp of
430 :			(* primops have to be eta-expanded since they're not valid
431 :			* function values anymore in Flint *)
432 :			L.PRIM (po,lty,tycs) => eta_expand(lexp, LT.lt_pinst(lty, tycs))
433 :			| L.GENOP (dict,po,lty,tycs) => eta_expand(lexp, LT.lt_pinst(lty, tycs))
434 :
435 :			| L.FN (arg_lv,arg_lty,body) =>
436 :			(* translate the body with the extended env into a fundec *)
437 :			let val (fundec as (fk,f_lv,args,body'), f_lty) =
438 :			tofundec(venv, d, lvar, arg_lv, arg_lty, body, false)
439 :			val (lexp, lty) = cont(f_lty)
440 :			in (F.FIX([fundec], lexp), lty)
441 :			end
442 :
443 :			(* this is were we really deal with primops *)
444 :			| L.APP (L.PRIM ((po,f_lty,tycs)),arg) =>
445 :	monnier	45	PO_helper(arg, f_lty, tycs,
446 :			fn (arg_vals,pty, c_lexp) =>
447 :	monnier	71	flint_prim((NONE, po, pty, map FL.tcc_raw tycs),
448 :			arg_vals, lvar, c_lexp))
449 :	monnier	16
450 :			| L.APP (L.GENOP({default,table},po,f_lty,tycs),arg) =>
451 :			let fun f ([],table,cont) = cont (table)
452 :			| f ((tycs,le)::t1,t2,cont) =
453 :			tolvarvalue(venv,d,le,
454 :			fn (le_lv,le_lty) =>
455 :			f(t1, (map FL.tcc_raw tycs,le_lv)::t2, cont))
456 :			(* first, eval default *)
457 :			in tolvarvalue(venv,d,default,
458 :			fn (dflt_lv,dflt_lty) =>
459 :			(* then eval the table *)
460 :			f(table, [],
461 :			fn table' =>
462 :	monnier	45	PO_helper(arg, f_lty, tycs,
463 :			fn (arg_vals,pty,c_lexp) =>
464 :	monnier	71	flint_prim((SOME {default=dflt_lv,
465 :			table=table'},
466 :			po, pty,
467 :			map FL.tcc_raw tycs),
468 :			arg_vals, lvar, c_lexp))))
469 :	monnier	16	end
470 :
471 :
472 :	monnier	256	(* | L.TFN ([], body) => bug "TFN[]" *)
473 :	monnier	16	| L.TFN (tks, body) =>
474 :	monnier	45	let val (body', body_lty) =
475 :			tovalue(venv, DI.next d, body,
476 :			fn (le_val, le_lty) => (F.RET [le_val], le_lty))
477 :	monnier	16	val lty = LT.ltc_ppoly(tks, body_lty)
478 :			val (lexp', lty) = cont(lty)
479 :	monnier	220	val args = map (fn tk => (mkv(), tk)) tks
480 :			in (F.TFN(({inline=F.IH_SAFE}, lvar, args, body'), lexp'),
481 :	monnier	45	lty)
482 :	monnier	16	end
483 :
484 :	monnier	256	(* | L.TAPP (f,[]) => bug "TAPP[]" *)
485 :	monnier	50	| L.TAPP (f,tycs) =>
486 :			(* similar to APP *)
487 :			tovalue(venv, d, f,
488 :			fn (f_val,f_lty) =>
489 :			let val f_lty = LT.lt_pinst(f_lty, tycs)
490 :			val (c_lexp, c_lty) = cont(f_lty)
491 :			in (F.LET([lvar], F.TAPP(f_val, map FL.tcc_raw tycs),
492 :			c_lexp), c_lty)
493 :			end)
494 :
495 :	monnier	16	| L.ETAG (le,lty) =>
496 :			tovalue(venv, d, le,
497 :			fn (le_lv, le_lty) =>
498 :			let val (c_lexp, c_lty) = cont(LT.ltc_etag lty)
499 :	monnier	45	val mketag = FU.mketag (FL.tcc_raw (LT.ltd_tyc lty))
500 :	monnier	71	in (flint_prim(mketag, [le_lv], lvar, c_lexp), c_lty)
501 :	monnier	16	end)
502 :			| L.CON ((s,cr,lty),tycs,le) =>
503 :	monnier	45	tovalue(venv, d, le,
504 :			fn (v,_) =>
505 :	monnier	16	let val r_lty = LT.lt_pinst(lty, tycs)
506 :	monnier	45	val (_,v_lty) = LT.ltd_parrow r_lty
507 :	monnier	16	val (c_lexp, c_lty) = cont(v_lty)
508 :	monnier	45	in (F.CON((s, cr, force_raw lty),
509 :			map FL.tcc_raw tycs, v, lvar, c_lexp),
510 :	monnier	16	c_lty)
511 :			end)
512 :
513 :			| L.VECTOR (lexps,tyc) =>
514 :			lexps2values(venv,d,lexps,
515 :			fn (vals, ltys) =>
516 :			let val lty = LT.ltc_tyc(LT.tcc_vector tyc)
517 :			val (c_lexp, c_lty) = cont(lty)
518 :			in (F.RECORD(F.RK_VECTOR (FL.tcc_raw tyc),
519 :			vals, lvar, c_lexp),
520 :			c_lty)
521 :			end)
522 :			| L.RECORD lexps =>
523 :			lexps2values(venv,d,lexps,
524 :			fn (vals, ltys) =>
525 :			let val lty = LT.ltc_tuple ltys
526 :			val (c_lexp, c_lty) = cont(lty)
527 :	monnier	45	in (F.RECORD(FU.rk_tuple,
528 :			vals, lvar, c_lexp), c_lty)
529 :	monnier	16	end)
530 :			| L.SRECORD lexps =>
531 :			lexps2values(venv,d,lexps,
532 :			fn (vals, ltys) =>
533 :			let val lty = LT.ltc_str(ltys)
534 :			val (c_lexp, c_lty) = cont(lty)
535 :			in (F.RECORD(F.RK_STRUCT, vals, lvar, c_lexp), c_lty)
536 :			end)
537 :
538 :			| L.SELECT (n,lexp) =>
539 :			tovalue(venv, d, lexp,
540 :			fn (v, lty) =>
541 :			let val lty = (LT.lt_select(lty, n))
542 :			val (c_lexp, c_lty) = cont(lty)
543 :			in (F.SELECT(v, n, lvar, c_lexp), c_lty)
544 :			end)
545 :
546 :			| L.PACK (lty,otycs,ntycs,lexp) =>
547 :			bug "PACK is not currently supported"
548 :			(*
549 :			tovalue(venv, d, lexp,
550 :			fn (v, v_lty) =>
551 :			let val nlty = LT.lt_pinst(lty, ntycs)
552 :			val (c_lexp, c_lty) = cont(nlty)
553 :			in (F.PACK(lty,
554 :			map FL.tcc_raw otycs,
555 :			map FL.tcc_raw ntycs,
556 :			v, lvar, c_lexp),
557 :			c_lty)
558 :			end)
559 :			*)
560 :
561 :			(* these ones shouldn't matter because they shouldn't appear *)
562 :	monnier	45	(* | L.WRAP _ => bug "unexpected WRAP in plambda" *)
563 :			(* | L.UNWRAP _ => bug "unexpected UNWRAP in plambda" *)
564 :	monnier	16
565 :			| _ => default_tolexp ()
566 :			end
567 :
568 :			fun norm (lexp as L.FN(arg_lv,arg_lty,e)) =
569 :			(#1(tofundec(LT.initLtyEnv, DI.top, mkv(), arg_lv, arg_lty, e, false))
570 :			handle x => raise x)
571 :	monnier	161	| norm _ = bug "unexpected toplevel lexp"
572 :	monnier	16
573 :			end (* toplevel local *)
574 :			end (* structure FlintNM *)

---

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