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/branches/SMLNJ/src/compiler/FLINT/plambda/flintnm.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/compiler/FLINT/plambda/flintnm.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 24 - (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 :     structure L = PLambda
19 :     structure F = FLINT
20 :     structure DA = Access
21 :     in
22 :    
23 :     val say = Control.Print.say
24 :     val mkv = LambdaVar.mkLvar
25 :     val ident = fn le : L.lexp => le
26 :     fun bug msg = ErrorMsg.impossible("FlintNM: "^msg)
27 :    
28 :     fun optmap f (SOME v) = SOME (f v)
29 :     | optmap _ NONE = NONE
30 :    
31 :     fun tocon con =
32 :     let val _ = 1
33 :     in case con of
34 :     L.INTcon x => F.INTcon x
35 :     | L.INT32con x => F.INT32con x
36 :     | L.WORDcon x => F.WORDcon x
37 :     | L.WORD32con x => F.WORD32con x
38 :     | L.REALcon x => F.REALcon x
39 :     | L.STRINGcon x => F.STRINGcon x
40 :     | L.VLENcon x => F.VLENcon x
41 :     | L.DATAcon x => bug "unexpected case in tocon"
42 :     end
43 :    
44 :     fun tofundec (venv,d,f_lv,arg_lv,arg_lty,body,isrec) =
45 :     let val (body',body_lty) =
46 :     (* first, we translate the body (in the extended env) *)
47 :     tolexp (LT.ltInsert(venv, arg_lv, arg_lty, d), d) body
48 :    
49 :     (* detuple the arg type *)
50 : monnier 24 val (arg_ltys,arg_raw,unflatten,_) = FL.all_flatten arg_lty
51 : monnier 16
52 :     (* now, we add tupling code at the beginning of the body *)
53 :     val (arg_lvs, body'') = unflatten(arg_lv, body')
54 :    
55 :     (* construct the return type if necessary *)
56 : monnier 24 val (body_ltys,body_raw,_,_) = FL.all_flatten body_lty
57 : monnier 16 val rettype = if not isrec then NONE
58 :     else SOME(map FL.ltc_raw body_ltys)
59 :    
60 :     val isfct = not (LT.ltp_tyc arg_lty andalso LT.ltp_tyc body_lty)
61 :     val f_lty = if isfct then LT.ltc_pfct(arg_lty, body_lty)
62 :     else LT.ltc_parrow(arg_lty, body_lty)
63 :    
64 : monnier 24 in (({isrec=rettype, raw=(arg_raw, body_raw), isfct=isfct},
65 :     f_lv, ListPair.zip(arg_lvs, map FL.ltc_raw arg_ltys), body''),
66 : monnier 16 f_lty)
67 :     end
68 :    
69 :    
70 :     (* used to translate expressions whose structure is the same
71 :     * in Flint as in PLambda (either both binding or both non-binding)
72 :     * a continuation is unnecessary *)
73 :     and tolexp (venv,d) lexp =
74 :     let fun default_tovalues () =
75 :     tovalues(venv, d, lexp,
76 :     fn (vals, lty) =>
77 :     (F.RET vals, lty))
78 :     in case lexp of
79 :     L.APP (L.PRIM _, arg) => default_tovalues()
80 :     | L.APP (L.GENOP _,arg) => default_tovalues()
81 :     | L.APP (L.FN (arg_lv,arg_lty,body), arg_le) =>
82 :     tolexp (venv,d) (L.LET(arg_lv, arg_le, body))
83 :     | L.APP (f,arg) =>
84 :     (* first, evaluate f to a mere value *)
85 :     tovalue(venv, d, f,
86 :     fn (f_val, f_lty) =>
87 :     (* then eval the argument *)
88 :     tovalues(venv, d, arg,
89 :     fn (arg_vals, arg_lty) =>
90 :     (* now find the return type *)
91 :     let val (_, r_lty) = LT.ltd_pfun f_lty
92 :     (* and finally do the call *)
93 :     in (F.APP(f_val,arg_vals), r_lty)
94 :     end))
95 :    
96 :     | L.FIX (lvs,ltys,lexps,lexp) =>
97 :     (* first, let's setup the enriched environment with those funs *)
98 :     let val venv' = foldl (fn ((lv,lty),ve) =>
99 :     LT.ltInsert(ve, lv, lty, d))
100 :     venv (ListPair.zip(lvs, ltys))
101 :    
102 :     (* then translate each function in turn *)
103 :     val funs = map (fn ((f_lv,f_lty),L.FN(arg_lv,arg_lty,body)) =>
104 :     #1(tofundec(venv', d,
105 :     f_lv, arg_lv, arg_lty, body, true)))
106 :     (ListPair.zip(ListPair.zip(lvs,ltys),lexps))
107 :    
108 :     (* finally, translate the lexp *)
109 :     val (lexp',lty) = tolexp (venv',d) lexp
110 :     in (F.FIX(funs,lexp'), lty)
111 :     end
112 :    
113 :     | L.LET (lvar,lexp1,lexp2) =>
114 :     tolvar(venv, d, lvar, lexp1,
115 :     fn lty1 =>
116 :     tolexp (LT.ltInsert(venv,lvar,lty1,d), d) lexp2)
117 :    
118 :     | L.TAPP (f,tycs) =>
119 :     (* similar to APP *)
120 :     tovalue(venv, d, f,
121 :     fn (f_val,f_lty) =>
122 :     let val r_lty = LT.lt_pinst(f_lty, tycs)
123 :     in (F.TAPP(f_val, map FL.tcc_raw tycs), r_lty)
124 :     end)
125 :    
126 :     | L.RAISE (le, r_lty) =>
127 :     tovalue(venv, d, le,
128 :     fn (le_val,le_lty) =>
129 : monnier 24 let val r_ltys = FL.ltc_flat r_lty
130 : monnier 16 in (F.RAISE(le_val, map FL.ltc_raw r_ltys), r_lty)
131 :     end)
132 :    
133 :     | L.HANDLE (body, handler) =>
134 :     tovalue(venv, d, handler,
135 :     fn (h_val,h_lty) =>
136 :     let val (body', body_lty) = tolexp (venv, d) body
137 :     in (F.HANDLE(body', h_val), body_lty)
138 :     end)
139 :    
140 : monnier 24 | L.SWITCH (le,acs,[],NONE) => raise Match
141 : monnier 16 (* tovalue(venv, d, le, fn _ => (F.RET[], [])) *)
142 :     | L.SWITCH (le,acs,[],SOME lexp) =>
143 :     tovalue(venv, d, le, fn (v,lty) => tolexp (venv,d) lexp)
144 :     | L.SWITCH (le,acs,conlexps,default) =>
145 :     let fun f (L.DATAcon((s,cr,lty),tycs,lvar),le) =
146 :     let val (lv_lty,_) = LT.ltd_parrow(LT.lt_pinst(lty,tycs))
147 :     val newvenv = LT.ltInsert(venv,lvar,lv_lty,d)
148 :     val (le, le_lty) = tolexp (newvenv,d) le
149 : monnier 24 val (lvars, le) = FL.v_unflatten lv_lty (lvar, le)
150 : monnier 16 in
151 : monnier 24 ((F.DATAcon((s,cr,FL.ltc_raw lty),
152 :     map FL.tcc_raw tycs, lvars),
153 : monnier 16 le),
154 :     le_lty)
155 :     end
156 :     | f (con,le) =
157 :     let val (lexp,lty) = tolexp (venv,d) le
158 :     in ((tocon con, lexp), lty)
159 :     end
160 :     in tovalue(venv, d, le,
161 :     fn (v, lty) =>
162 :     let val default = optmap (#1 o tolexp(venv,d)) default
163 :     val conlexps as ((_,lty)::_) = map f conlexps
164 :     in (F.SWITCH(v, acs, map #1 conlexps, default), lty)
165 :     end)
166 :     end
167 :    
168 :     (* for mere values, use tovalues *)
169 :     | _ => default_tovalues ()
170 :     end
171 :    
172 :     (*
173 :     * tovalue: turns a PLambda lexp into a value+type and then calls
174 :     * the continuation that will turn it into an Flint lexp+type
175 :     * (ltyenv * DebIndex * L.lexp * ((value * lty) -> (F.lexp * lty list))) -> (F.lexp * lty)
176 :     *
177 :     * - venv is the type environment for values
178 :     * - conts is the continuation
179 :     *)
180 :     and tovalue (venv,d,lexp,cont) =
181 :     let val _ = 1
182 :     in case lexp of
183 :     (* for simple values, it's trivial *)
184 :     L.VAR v => cont(F.VAR v, LT.ltLookup(venv, v, d))
185 : monnier 24 | L.INT n => cont(F.INT n, LT.ltc_int)
186 : monnier 16 | L.INT32 n => cont(F.INT32 n, LT.ltc_int32)
187 : monnier 24 | L.WORD n => cont(F.WORD n, LT.ltc_int)
188 : monnier 16 | L.WORD32 n => cont(F.WORD32 n, LT.ltc_int32)
189 :     | L.REAL x => cont(F.REAL x, LT.ltc_real)
190 :     | L.STRING s => cont(F.STRING s, LT.ltc_string)
191 :    
192 :     (* for cases where tolvar is more convenient *)
193 :     | _ =>
194 :     let val lv = mkv()
195 :     in tolvar(venv, d, lv, lexp, fn lty => cont(F.VAR lv, lty))
196 :     end
197 :     end
198 :    
199 :    
200 :     (*
201 :     * tovalues: turns a PLambda lexp into a list of values and a list of types
202 :     * and then calls the continuation that will turn it into an Flint lexp+type
203 :     *
204 :     * (ltyenv * DebIndex * L.lexp * ((value list * lty list) -> (F.lexp * lty list))) -> (F.lexp * lty)
205 :     *
206 :     * - venv is the type environment for values
207 :     * - cont is the continuation
208 :     *)
209 :     and tovalues (venv,d,lexp,cont) =
210 :     let val _ = 1
211 :     in case lexp of
212 :     L.RECORD (lexps) =>
213 :     lexps2values(venv,d,lexps,
214 :     fn (vals,ltys) =>
215 :     let val lty = LT.ltc_tuple ltys
216 : monnier 24 val ltys = FL.ltc_flat lty
217 : monnier 16 in
218 :     (* detect the case where flattening is trivial *)
219 :     if LT.lt_eqv(lty, LT.ltc_tuple ltys) then
220 :     cont(vals,lty)
221 :     else
222 :     let val lv = mkv()
223 : monnier 24 val (vs,wrap) = FL.v_flatten lty (F.VAR lv)
224 : monnier 16 val (c_lexp,c_lty) = cont(vs, lty)
225 :     in
226 : monnier 24 (F.RECORD(F.RK_RECORD,
227 : monnier 16 vals, lv, wrap c_lexp),
228 :     c_lty)
229 :     end
230 :     end)
231 :    
232 :     | _ => tovalue(venv,d,lexp,
233 :     fn (v, lty) =>
234 : monnier 24 let val (vs,wrap) = FL.v_flatten lty v
235 : monnier 16 val (c_lexp, c_lty) = cont(vs, lty)
236 :     in (wrap c_lexp, c_lty)
237 :     end)
238 :     end
239 :    
240 :     (* eval each lexp to a value *)
241 :     and lexps2values (venv,d,lexps,cont) =
242 :     let val _ = 1
243 :     fun f [] (vals,ltys) = cont (rev vals, rev ltys)
244 :     | f (lexp::lexps) (vals,ltys) =
245 :     tovalue(venv,d,lexp,
246 :     fn (v, lty) =>
247 :     f lexps (v::vals, lty::ltys))
248 :     in
249 :     f lexps ([], [])
250 :     end
251 :    
252 :     (*
253 :     * tolvar: same as tovalue except that it binds the value of the PLambda
254 :     * to the indicated lvar and passes just the type to the continutation
255 :     *)
256 :     and tolvar (venv,d,lvar,lexp,cont) =
257 :     let fun eta_expand (f, f_lty) =
258 :     let val lv = mkv()
259 :     val (arg_lty, ret_lty) = (LT.ltd_parrow f_lty)
260 :     in tolvar(venv, d, lvar,
261 :     L.FN(lv, arg_lty, L.APP(f, L.VAR lv)),
262 :     cont)
263 :     end
264 :    
265 :     (* inbetween tolvar and tovalue: it binds the lexp to a variable but
266 :     * is free to choose the lvar and passes it to the continutation *)
267 :     fun tolvarvalue (venv,d,lexp,cont) =
268 :     tovalue(venv, d, lexp,
269 :     fn (v,lty) =>
270 :     case v of
271 :     F.VAR lv => cont(lv, lty)
272 :     | _ => let val lv = mkv()
273 :     val (lexp',lty) = cont(lv, lty)
274 :     in (F.LET ([lv], F.RET [v], lexp'), lty)
275 :     end)
276 :    
277 : monnier 24 fun PO_helper (arg,f_lty,filler) =
278 :     (* first, turn args into values *)
279 :     tovalues(venv, d, arg,
280 :     fn (arg_vals, arg_lty) =>
281 :     (* now find the return type(s) *)
282 :     let val (_, r_lty) = LT.ltd_parrow f_lty
283 :     (* translate the continutation *)
284 :     val (c_lexp, c_lty) = cont(r_lty)
285 :     (* put the filling inbetween *)
286 :     in (filler(arg_vals, c_lexp), c_lty)
287 :     end)
288 : monnier 16
289 :     fun default_tolexp () =
290 :     let val (lexp', lty) = tolexp (venv, d) lexp
291 :     val (c_lexp, c_lty) = cont(lty)
292 : monnier 24 val (lvs,c_lexp') = FL.v_unflatten lty (lvar, c_lexp)
293 : monnier 16 in (F.LET(lvs, lexp', c_lexp'), c_lty)
294 :     end
295 :    
296 :     (* fun default_tovalue () = *)
297 :     (* tovalue(venv, d, lexp, *)
298 :     (* fn (v,lty) => *)
299 :     (* let val (lexp', ltys) = cont(lty) *)
300 :     (* in (F.LET([lvar], F.RET[v], lexp'), ltys) *)
301 :     (* end) *)
302 :    
303 :     in case lexp of
304 :     (* primops have to be eta-expanded since they're not valid
305 :     * function values anymore in Flint *)
306 :     L.PRIM (po,lty,tycs) => eta_expand(lexp, LT.lt_pinst(lty, tycs))
307 :     | L.GENOP (dict,po,lty,tycs) => eta_expand(lexp, LT.lt_pinst(lty, tycs))
308 :    
309 :     | L.FN (arg_lv,arg_lty,body) =>
310 :     (* translate the body with the extended env into a fundec *)
311 :     let val (fundec as (fk,f_lv,args,body'), f_lty) =
312 :     tofundec(venv, d, lvar, arg_lv, arg_lty, body, false)
313 :     val (lexp, lty) = cont(f_lty)
314 :     in (F.FIX([fundec], lexp), lty)
315 :     end
316 :    
317 :     (* this is were we really deal with primops *)
318 :     | L.APP (L.PRIM ((po,f_lty,tycs)),arg) =>
319 : monnier 24 PO_helper(arg, LT.lt_pinst(f_lty, tycs),
320 :     fn (arg_vals,c_lexp) =>
321 :     F.PRIMOP((po, FL.ltc_raw f_lty, map FL.tcc_raw tycs),
322 : monnier 16 arg_vals, lvar, c_lexp))
323 :    
324 :     | L.APP (L.GENOP({default,table},po,f_lty,tycs),arg) =>
325 :     let fun f ([],table,cont) = cont (table)
326 :     | f ((tycs,le)::t1,t2,cont) =
327 :     tolvarvalue(venv,d,le,
328 :     fn (le_lv,le_lty) =>
329 :     f(t1, (map FL.tcc_raw tycs,le_lv)::t2, cont))
330 :     (* first, eval default *)
331 :     in tolvarvalue(venv,d,default,
332 :     fn (dflt_lv,dflt_lty) =>
333 :     (* then eval the table *)
334 :     f(table, [],
335 :     fn table' =>
336 : monnier 24 PO_helper(arg, LT.lt_pinst(f_lty, tycs),
337 :     fn (arg_vals,c_lexp) =>
338 :     F.GENOP({default=dflt_lv, table=table'},
339 :     (po, FL.ltc_raw f_lty, map FL.tcc_raw tycs),
340 : monnier 16 arg_vals, lvar, c_lexp))))
341 :     end
342 :    
343 :    
344 :     | L.TFN (tks, body) =>
345 :     let val (body', body_lty) = tolexp (venv, DI.next d) body
346 :     val lty = LT.ltc_ppoly(tks, body_lty)
347 :     val (lexp', lty) = cont(lty)
348 :     in (F.TFN((lvar, map (fn tk => (mkv(), tk)) tks, body'), lexp'),
349 :     lty)
350 :     end
351 :    
352 :     | L.ETAG (le,lty) =>
353 :     tovalue(venv, d, le,
354 :     fn (le_lv, le_lty) =>
355 :     let val (c_lexp, c_lty) = cont(LT.ltc_etag lty)
356 : monnier 24 in (F.ETAG(FL.tcc_raw (LT.ltd_tyc lty), le_lv,
357 :     lvar, c_lexp), c_lty)
358 : monnier 16 end)
359 :     | L.CON ((s,cr,lty),tycs,le) =>
360 : monnier 24 tovalues(venv, d, le,
361 :     fn (vals,_) =>
362 : monnier 16 let val r_lty = LT.lt_pinst(lty, tycs)
363 : monnier 24 val (vals,v_lty) =
364 :     let val (_,v_lty) = LT.ltd_parrow r_lty
365 :     in (vals, v_lty)
366 :     end
367 : monnier 16 val (c_lexp, c_lty) = cont(v_lty)
368 : monnier 24 in (F.CON((s, cr, FL.ltc_raw lty),
369 :     map FL.tcc_raw tycs, vals, lvar, c_lexp),
370 : monnier 16 c_lty)
371 :     end)
372 :    
373 :     | L.VECTOR (lexps,tyc) =>
374 :     lexps2values(venv,d,lexps,
375 :     fn (vals, ltys) =>
376 :     let val lty = LT.ltc_tyc(LT.tcc_vector tyc)
377 :     val (c_lexp, c_lty) = cont(lty)
378 :     in (F.RECORD(F.RK_VECTOR (FL.tcc_raw tyc),
379 :     vals, lvar, c_lexp),
380 :     c_lty)
381 :     end)
382 :     | L.RECORD lexps =>
383 :     lexps2values(venv,d,lexps,
384 :     fn (vals, ltys) =>
385 :     let val lty = LT.ltc_tuple ltys
386 :     val (c_lexp, c_lty) = cont(lty)
387 : monnier 24 in (F.RECORD(F.RK_RECORD, vals, lvar, c_lexp), c_lty)
388 : monnier 16 end)
389 :     | L.SRECORD lexps =>
390 :     lexps2values(venv,d,lexps,
391 :     fn (vals, ltys) =>
392 :     let val lty = LT.ltc_str(ltys)
393 :     val (c_lexp, c_lty) = cont(lty)
394 :     in (F.RECORD(F.RK_STRUCT, vals, lvar, c_lexp), c_lty)
395 :     end)
396 :    
397 :     | L.SELECT (n,lexp) =>
398 :     tovalue(venv, d, lexp,
399 :     fn (v, lty) =>
400 :     let val lty = (LT.lt_select(lty, n))
401 :     val (c_lexp, c_lty) = cont(lty)
402 :     in (F.SELECT(v, n, lvar, c_lexp), c_lty)
403 :     end)
404 :    
405 :     | L.PACK (lty,otycs,ntycs,lexp) =>
406 :     bug "PACK is not currently supported"
407 :     (*
408 :     tovalue(venv, d, lexp,
409 :     fn (v, v_lty) =>
410 :     let val nlty = LT.lt_pinst(lty, ntycs)
411 :     val (c_lexp, c_lty) = cont(nlty)
412 :     in (F.PACK(lty,
413 :     map FL.tcc_raw otycs,
414 :     map FL.tcc_raw ntycs,
415 :     v, lvar, c_lexp),
416 :     c_lty)
417 :     end)
418 :     *)
419 :    
420 :     (* these ones shouldn't matter because they shouldn't appear *)
421 : monnier 24 (* | L.WRAP _ => bug "unexpected WRAP in plamba" *)
422 :     (* | L.UNWRAP _ => bug "unexpected UNWRAP in plamba" *)
423 : monnier 16
424 :     | _ => default_tolexp ()
425 :     end
426 :    
427 :     fun norm (lexp as L.FN(arg_lv,arg_lty,e)) =
428 :     (#1(tofundec(LT.initLtyEnv, DI.top, mkv(), arg_lv, arg_lty, e, false))
429 :     handle x => raise x)
430 :     (* | norm _ = bug "unexpected toplevel lexp" *)
431 :    
432 :     end (* toplevel local *)
433 :     end (* structure FlintNM *)
434 :    

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