Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/FLINT/plambda/flintnm.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 95 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1997 YALE FLINT PROJECT *)
2 :     (* flintnm.sml *)
3 :    
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 LV = LambdaVar
16 :     structure DI = DebIndex
17 :     structure PT = PrimTyc
18 : monnier 45 structure PO = PrimOp
19 : monnier 16 structure L = PLambda
20 :     structure F = FLINT
21 : monnier 45 structure FU = FlintUtil
22 : monnier 16 structure DA = Access
23 : monnier 71 structure BT = BasicTypes
24 : monnier 16 in
25 :    
26 :     val say = Control.Print.say
27 :     val mkv = LambdaVar.mkLvar
28 :     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 :     fun optmap f (SOME v) = SOME (f v)
40 :     | optmap _ NONE = NONE
41 :    
42 : monnier 71
43 :     local val (trueDcon', falseDcon') =
44 :     let val lt = LT.ltc_arrow(LT.ffc_rrflint, [LT.ltc_unit], [LT.ltc_bool])
45 :     fun h (Types.DATACON{name, rep, ...}) = (name, rep, lt)
46 :     in (h BT.trueDcon, h BT.falseDcon)
47 :     end
48 :    
49 :     fun boolLexp b =
50 :     let val v = mkv() and w = mkv()
51 :     val dc = if b then trueDcon' else falseDcon'
52 :     in F.RECORD(FU.rk_tuple, [], v,
53 :     F.CON(dc, [], F.VAR v, w, F.RET[F.VAR w]))
54 :     end
55 :     in
56 :    
57 :     fun flint_prim (po as (d, p, lt, ts), vs, v, e) =
58 :     (case p
59 :     of (PO.BOXED | PO.UNBOXED | PO.CMP _ | PO.PTREQL |
60 :     PO.PTRNEQ | PO.POLYEQL | PO.POLYNEQ) =>
61 :     (*** branch primops gets translated into F.BRANCH ***)
62 :     F.LET([v], F.BRANCH(po, vs, boolLexp true, boolLexp false), e)
63 :     | (PO.GETRUNVEC | PO.GETHDLR | PO.GETVAR | PO.DEFLVAR) =>
64 :     (*** primops that take zero arguments; argument types
65 :     must be unit ***)
66 :     let fun fix t =
67 :     LT.ltw_arrow(t,
68 :     fn (ff,[t1],ts2) =>
69 :     (if LT.tc_eqv(t1, LT.tcc_unit)
70 :     then LT.ltc_tyc(LT.tcc_arrow(ff, [], ts2))
71 :     else bug "unexpected zero-args prims 1 in flint_prim"),
72 :     fn _ => bug "unexpected zero-args prims 2 in flint_prim")
73 :     val nlt =
74 :     LT.ltw_ppoly(lt,
75 :     fn (ks, t) => LT.ltc_ppoly(ks, fix t),
76 :     fn _ => fix lt)
77 :     in F.PRIMOP((d,p,nlt,ts), [], v, e)
78 :     end
79 :     | _ =>
80 :     F.PRIMOP(po, vs, v, e))
81 :    
82 :     end (* local flint_prim *)
83 :    
84 : monnier 45 (* force_raw freezes the calling conventions of a data constructor;
85 :     strictly used by the CON and DATAcon only
86 :     *)
87 :     fun force_raw (pty) =
88 :     if LT.ltp_ppoly pty then
89 :     let val (ks, body) = LT.ltd_ppoly pty
90 :     val (aty, rty) = LT.ltd_parrow body
91 :     in LT.ltc_ppoly(ks,
92 :     LT.ltc_arrow(LT.ffc_rrflint, [FL.ltc_raw aty], [FL.ltc_raw rty]))
93 :     end
94 :     else
95 :     let val (aty, rty) = LT.ltd_parrow pty
96 :     in LT.ltc_arrow(LT.ffc_rrflint, [FL.ltc_raw aty], [FL.ltc_raw rty])
97 :     end (* function force_raw *)
98 :    
99 : monnier 16 fun tocon con =
100 :     let val _ = 1
101 :     in case con of
102 :     L.INTcon x => F.INTcon x
103 :     | L.INT32con x => F.INT32con x
104 :     | L.WORDcon x => F.WORDcon x
105 :     | L.WORD32con x => F.WORD32con x
106 :     | L.REALcon x => F.REALcon x
107 :     | L.STRINGcon x => F.STRINGcon x
108 :     | L.VLENcon x => F.VLENcon x
109 :     | L.DATAcon x => bug "unexpected case in tocon"
110 :     end
111 :    
112 :     fun tofundec (venv,d,f_lv,arg_lv,arg_lty,body,isrec) =
113 :     let val (body',body_lty) =
114 :     (* first, we translate the body (in the extended env) *)
115 :     tolexp (LT.ltInsert(venv, arg_lv, arg_lty, d), d) body
116 :    
117 :     (* detuple the arg type *)
118 : monnier 45 val ((arg_raw, arg_ltys, _), unflatten) = FL.v_punflatten arg_lty
119 : monnier 16
120 :     (* now, we add tupling code at the beginning of the body *)
121 :     val (arg_lvs, body'') = unflatten(arg_lv, body')
122 :    
123 :     (* construct the return type if necessary *)
124 : monnier 45 val (body_raw, body_ltys, _) = FL.t_pflatten body_lty
125 : monnier 16 val rettype = if not isrec then NONE
126 :     else SOME(map FL.ltc_raw body_ltys)
127 :    
128 :     val isfct = not (LT.ltp_tyc arg_lty andalso LT.ltp_tyc body_lty)
129 :     val f_lty = if isfct then LT.ltc_pfct(arg_lty, body_lty)
130 :     else LT.ltc_parrow(arg_lty, body_lty)
131 : monnier 45
132 :     val fkind = if isfct then F.FK_FCT
133 : monnier 80 else F.FK_FUN{isrec=rettype,
134 : monnier 45 fixed=LT.ffc_var(arg_raw, body_raw),
135 :     known=false,
136 : monnier 80 inline=false}
137 : monnier 16
138 : monnier 45 in ((fkind, f_lv, ListPair.zip(arg_lvs, map FL.ltc_raw arg_ltys), body''),
139 : monnier 16 f_lty)
140 :     end
141 :    
142 :    
143 :     (* used to translate expressions whose structure is the same
144 :     * in Flint as in PLambda (either both binding or both non-binding)
145 :     * a continuation is unnecessary *)
146 :     and tolexp (venv,d) lexp =
147 :     let fun default_tovalues () =
148 :     tovalues(venv, d, lexp,
149 :     fn (vals, lty) =>
150 :     (F.RET vals, lty))
151 :     in case lexp of
152 :     L.APP (L.PRIM _, arg) => default_tovalues()
153 :     | L.APP (L.GENOP _,arg) => default_tovalues()
154 :     | L.APP (L.FN (arg_lv,arg_lty,body), arg_le) =>
155 :     tolexp (venv,d) (L.LET(arg_lv, arg_le, body))
156 :     | L.APP (f,arg) =>
157 :     (* first, evaluate f to a mere value *)
158 :     tovalue(venv, d, f,
159 :     fn (f_val, f_lty) =>
160 :     (* then eval the argument *)
161 :     tovalues(venv, d, arg,
162 :     fn (arg_vals, arg_lty) =>
163 :     (* now find the return type *)
164 : monnier 71 let val (_, r_lty) =
165 :     if LT.ltp_pfct f_lty then LT.ltd_pfct f_lty
166 :     else LT.ltd_parrow f_lty
167 : monnier 16 (* and finally do the call *)
168 :     in (F.APP(f_val,arg_vals), r_lty)
169 :     end))
170 :    
171 :     | L.FIX (lvs,ltys,lexps,lexp) =>
172 :     (* first, let's setup the enriched environment with those funs *)
173 :     let val venv' = foldl (fn ((lv,lty),ve) =>
174 :     LT.ltInsert(ve, lv, lty, d))
175 :     venv (ListPair.zip(lvs, ltys))
176 :    
177 :     (* then translate each function in turn *)
178 :     val funs = map (fn ((f_lv,f_lty),L.FN(arg_lv,arg_lty,body)) =>
179 :     #1(tofundec(venv', d,
180 :     f_lv, arg_lv, arg_lty, body, true)))
181 :     (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 :     let val default = optmap (#1 o tolexp(venv,d)) default
229 :     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 :     | L.TFN (tks, body) =>
473 : monnier 45 let val (body', body_lty) =
474 :     tovalue(venv, DI.next d, body,
475 :     fn (le_val, le_lty) => (F.RET [le_val], le_lty))
476 : monnier 16 val lty = LT.ltc_ppoly(tks, body_lty)
477 :     val (lexp', lty) = cont(lty)
478 : monnier 45 in (F.TFN((lvar, map (fn tk => (mkv(), tk)) tks, body'), lexp'),
479 :     lty)
480 : monnier 16 end
481 :    
482 : monnier 50 | L.TAPP (f,tycs) =>
483 :     (* similar to APP *)
484 :     tovalue(venv, d, f,
485 :     fn (f_val,f_lty) =>
486 :     let val f_lty = LT.lt_pinst(f_lty, tycs)
487 :     val (c_lexp, c_lty) = cont(f_lty)
488 :     in (F.LET([lvar], F.TAPP(f_val, map FL.tcc_raw tycs),
489 :     c_lexp), c_lty)
490 :     end)
491 :    
492 : monnier 16 | L.ETAG (le,lty) =>
493 :     tovalue(venv, d, le,
494 :     fn (le_lv, le_lty) =>
495 :     let val (c_lexp, c_lty) = cont(LT.ltc_etag lty)
496 : monnier 45 val mketag = FU.mketag (FL.tcc_raw (LT.ltd_tyc lty))
497 : monnier 71 in (flint_prim(mketag, [le_lv], lvar, c_lexp), c_lty)
498 : monnier 16 end)
499 :     | L.CON ((s,cr,lty),tycs,le) =>
500 : monnier 45 tovalue(venv, d, le,
501 :     fn (v,_) =>
502 : monnier 16 let val r_lty = LT.lt_pinst(lty, tycs)
503 : monnier 45 val (_,v_lty) = LT.ltd_parrow r_lty
504 : monnier 16 val (c_lexp, c_lty) = cont(v_lty)
505 : monnier 45 in (F.CON((s, cr, force_raw lty),
506 :     map FL.tcc_raw tycs, v, lvar, c_lexp),
507 : monnier 16 c_lty)
508 :     end)
509 :    
510 :     | L.VECTOR (lexps,tyc) =>
511 :     lexps2values(venv,d,lexps,
512 :     fn (vals, ltys) =>
513 :     let val lty = LT.ltc_tyc(LT.tcc_vector tyc)
514 :     val (c_lexp, c_lty) = cont(lty)
515 :     in (F.RECORD(F.RK_VECTOR (FL.tcc_raw tyc),
516 :     vals, lvar, c_lexp),
517 :     c_lty)
518 :     end)
519 :     | L.RECORD lexps =>
520 :     lexps2values(venv,d,lexps,
521 :     fn (vals, ltys) =>
522 :     let val lty = LT.ltc_tuple ltys
523 :     val (c_lexp, c_lty) = cont(lty)
524 : monnier 45 in (F.RECORD(FU.rk_tuple,
525 :     vals, lvar, c_lexp), c_lty)
526 : monnier 16 end)
527 :     | L.SRECORD lexps =>
528 :     lexps2values(venv,d,lexps,
529 :     fn (vals, ltys) =>
530 :     let val lty = LT.ltc_str(ltys)
531 :     val (c_lexp, c_lty) = cont(lty)
532 :     in (F.RECORD(F.RK_STRUCT, vals, lvar, c_lexp), c_lty)
533 :     end)
534 :    
535 :     | L.SELECT (n,lexp) =>
536 :     tovalue(venv, d, lexp,
537 :     fn (v, lty) =>
538 :     let val lty = (LT.lt_select(lty, n))
539 :     val (c_lexp, c_lty) = cont(lty)
540 :     in (F.SELECT(v, n, lvar, c_lexp), c_lty)
541 :     end)
542 :    
543 :     | L.PACK (lty,otycs,ntycs,lexp) =>
544 :     bug "PACK is not currently supported"
545 :     (*
546 :     tovalue(venv, d, lexp,
547 :     fn (v, v_lty) =>
548 :     let val nlty = LT.lt_pinst(lty, ntycs)
549 :     val (c_lexp, c_lty) = cont(nlty)
550 :     in (F.PACK(lty,
551 :     map FL.tcc_raw otycs,
552 :     map FL.tcc_raw ntycs,
553 :     v, lvar, c_lexp),
554 :     c_lty)
555 :     end)
556 :     *)
557 :    
558 :     (* these ones shouldn't matter because they shouldn't appear *)
559 : monnier 45 (* | L.WRAP _ => bug "unexpected WRAP in plambda" *)
560 :     (* | L.UNWRAP _ => bug "unexpected UNWRAP in plambda" *)
561 : monnier 16
562 :     | _ => default_tolexp ()
563 :     end
564 :    
565 :     fun norm (lexp as L.FN(arg_lv,arg_lty,e)) =
566 :     (#1(tofundec(LT.initLtyEnv, DI.top, mkv(), arg_lv, arg_lty, e, false))
567 :     handle x => raise x)
568 :     (* | norm _ = bug "unexpected toplevel lexp" *)
569 :    
570 :     end (* toplevel local *)
571 :     end (* structure FlintNM *)
572 :    
573 : monnier 95
574 :     (*
575 :     * $Log: flintnm.sml,v $
576 :     * Revision 1.1.1.1 1998/04/08 18:39:38 george
577 :     * Version 110.5
578 :     *
579 :     *)

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