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/reps/wrapping.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/reps/wrapping.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *)
2 :     (* wrapping.sml *)
3 :    
4 :     signature WRAPPING =
5 :     sig
6 :     val wrapLexp : Lambda.lexp -> Lambda.lexp
7 :    
8 :     end (* signature WRAPPING *)
9 :    
10 :     structure Wrapping : WRAPPING =
11 :     struct
12 :    
13 :     local structure CO = Coerce
14 :     structure LU = LtyUtil
15 :     structure LT = LtyExtern
16 :     structure DA = Access
17 :     structure DI = DebIndex
18 :     structure PO = PrimOp
19 :     open Lambda
20 :     in
21 :    
22 :     fun bug s = ErrorMsg.impossible ("Wrapping: " ^ s)
23 :     val say = Control.Print.say
24 :    
25 :     val mkv = LambdaVar.mkLvar
26 :     val ident = fn le => le
27 :     val IntOpTy = LT.ltc_parrow(LT.ltc_tuple[LT.ltc_int,LT.ltc_int],LT.ltc_int)
28 :    
29 :     (** based on the given tyc, return its appropriate Update operator *)
30 :     val tcUpd = LT.tc_upd_prim
31 :    
32 :     (****************************************************************************
33 :     * MISC UTILITY FUNCTIONS *
34 :     ****************************************************************************)
35 :     fun ltApply x = case LT.lt_inst x
36 :     of [z] => z
37 :     | _ => bug "unexpected in ltApply"
38 :     fun ltAppSt x = case LT.lt_inst_st x
39 :     of [z] => z
40 :     | _ => bug "unexpected in ltAppSt"
41 :    
42 :     val ltArrow = LT.lt_arrow
43 :     val ltSelect = LT.lt_select
44 :     val ltFun = LT.ltc_fun
45 :     val ltTup = LT.ltc_tuple
46 :     val lt_eqv = LT.lt_eqv
47 :     val tc_eqv = LT.tc_eqv
48 :     val tc_real = LT.tcc_real
49 :    
50 :     val lt_upd =
51 :     let val x = LT.ltc_array (LT.ltc_tv 0)
52 :     in LT.ltc_poly([LT.tkc_mono],
53 :     [LT.ltc_arrow((true, true), [x, LT.ltc_int, LT.ltc_tv 0],
54 :     [LT.ltc_unit])])
55 :     end
56 :    
57 :     val lt_sub =
58 :     let val x = LT.ltc_array (LT.ltc_tv 0)
59 :     in LT.ltc_poly([LT.tkc_mono],
60 :     [LT.ltc_arrow((true,true), [x, LT.ltc_int], [LT.ltc_tv 0])])
61 :     end
62 :    
63 :     datatype primKind = STANDARD | PARRAYOP | RARRAYOP
64 :    
65 :     (*
66 :     * WARN: NEED TO WORK ON GENOP of INLMKARRAY !!!
67 :     *)
68 :    
69 :     fun mkPrim(p as PO.SUBSCRIPT, t, [tc]) =
70 :     if lt_eqv(t, lt_sub)
71 :     then if tc_eqv(tc, tc_real)
72 :     then (PO.NUMSUBSCRIPT{kind=PO.FLOAT 64, checked=false,
73 :     immutable=false}, RARRAYOP)
74 :     else (p, PARRAYOP)
75 :     else (p, STANDARD)
76 :     | mkPrim(PO.UPDATE, t, [tc]) =
77 :     if lt_eqv(t,lt_upd)
78 :     then if tc_eqv(tc,tc_real)
79 :     then (PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}, RARRAYOP)
80 :     else (let val np = tcUpd tc
81 :     in case np
82 :     of PO.UPDATE => (np, PARRAYOP)
83 :     | _ => (np, STANDARD)
84 :     end)
85 :     else (tcUpd tc, STANDARD)
86 :     | mkPrim(PO.SUBSCRIPT, _, _) = bug "unexpected SUBSCRIPT primops in mkPrim"
87 :     | mkPrim(PO.UPDATE, _, _) = bug "unexpected UPDATE primops in mkPrim"
88 :     | mkPrim(p, _, []) = bug "unexpected arguments in mkPrim"
89 :     | mkPrim(p, _, _) = (p, STANDARD)
90 :    
91 :     (****************************************************************************
92 :     * val transform : CO.wpEnv * LT.ltyEnv * DI.depth *
93 :     * -> lexp -> (lexp * LT.lty) *
94 :     * *
95 :     * Transform does the following several things: *
96 :     * (1) representation analysis coercions are inserted; *
97 :     * *
98 :     * (2) all conreps in CON and DECON are given type-specific meanings. *
99 :     * (3) type abstractions TFN are converted into function abstractions; *
100 :     * (4) type applications TAPP are converted into function applications; *
101 :     * (5) all primops in PRIM are given type-specific meanings; *
102 :     * (6) lty is (narrowed) simplified into those with LT.ltc_void; with *
103 :     * the following invariants: *
104 :     * The resulting lexp is a simply-typed lambda expression, and *
105 :     * all explicit type annotations can only be: ltc_int, ltc_int32, *
106 :     * ltc_real, ltc_void, ltc_parrow, ltc_tup, or ltc_cont. *
107 :     * *
108 :     ****************************************************************************)
109 :     fun transform (wenv, venv, d) =
110 :     let
111 :    
112 :     val (tcWrap, ltWrap, tcsWrap) = LU.genWrap true
113 :    
114 :     fun fixDconTy lt =
115 :     let fun fix t =
116 :     (case LT.ltd_arrow t
117 :     of (ff, [aty], rtys) =>
118 :     (case ltWrap aty
119 :     of NONE => t
120 :     | SOME naty => LT.ltc_arrow(ff, [naty], rtys))
121 :     | _ => bug "unexpected type in fixDconTy")
122 :     in if LT.ltp_ppoly lt then
123 :     let val (ks, t) = LT.ltd_ppoly lt
124 :     in LT.ltc_ppoly(ks, fix t)
125 :     end
126 :     else fix lt
127 :     end (* function fixDconTy *)
128 :    
129 :     fun primExp(sv as (PRIM _ | GENOP _), t) =
130 :     let val x = mkv()
131 :     val (argt,_) = ltArrow t
132 :     in FN(x, argt, APP(sv, VAR x))
133 :     end
134 :     | primExp _ = bug "unexpected cases in primExp"
135 :    
136 :     fun lpve sv =
137 :     (case sv
138 :     of VAR v => (SVAL sv, LT.ltLookup(venv, v, d))
139 :     | (INT _ | WORD _) => (SVAL sv, LT.ltc_int)
140 :     | (INT32 _ | WORD32 _) => (SVAL sv, LT.ltc_int32)
141 :     | REAL _ => (SVAL sv, LT.ltc_real)
142 :     | STRING _ => (SVAL sv, LT.ltc_string)
143 :     | PRIM (p, lt, []) => (primExp(sv,lt), lt)
144 :     | PRIM (p as (PO.NUMSUBSCRIPT _ | PO.NUMUPDATE _), lt, ts) =>
145 :     (* the polymorphism in NUMSUB & NUMUPD is used for overloading *)
146 :     let val nt = ltAppSt(lt, ts)
147 :     in (primExp (PRIM(p, nt, []), nt), nt)
148 :     end
149 :     | PRIM (p, lt, ts) =>
150 :     let val (np, pknd) = mkPrim(p, lt, ts)
151 :     in (case (tcsWrap ts, pknd)
152 :     of ((_, RARRAYOP) | (NONE, STANDARD)) =>
153 :     (let val nt = ltAppSt(lt, ts)
154 :     in (primExp(PRIM(np, nt, []), nt), nt)
155 :     end)
156 :     | (NONE, PARRAYOP) =>
157 :     (** these parrayops are not fully determined ***)
158 :     (let val nt = ltAppSt(lt, ts)
159 :     in (primExp(PRIM(np, lt, ts), nt), nt)
160 :     end)
161 :     | (SOME wts, _) =>
162 :     (let val nt = ltAppSt(lt, wts)
163 :     val ot = ltAppSt(lt, ts)
164 :     val hdr = CO.unwrapOp(wenv, nt, ot, d)
165 :     in (hdr(primExp(PRIM(np, nt, []), nt)), ot)
166 :     end))
167 :     end
168 :     | GENOP({default=pv, table=[(_,sv)]}, PO.POLYEQL, _, [tc]) =>
169 :     loop(Equal.equal(pv, sv, tc))
170 :     | GENOP(dict as {default=pv, table=[(_,sv)]},
171 :     p as PO.INLMKARRAY, lt, ts as [tc]) =>
172 :     if tc_eqv(tc, tc_real) then
173 :     let val nt = ltAppSt(lt,ts)
174 :     in (SVAL(VAR sv), nt)
175 :     end
176 :     else (case tcsWrap ts
177 :     of NONE => let val nt = ltAppSt(lt, ts)
178 :     in (primExp(GENOP(dict, p, lt, ts), nt), nt)
179 :     end
180 :     | SOME wts => (** we know it cannot be real64 *)
181 :     let val nt = ltAppSt(lt, wts)
182 :     val ot = ltAppSt(lt, ts)
183 :     val hdr = CO.unwrapOp(wenv, nt, ot, d)
184 :     in (hdr(TAPP(VAR pv, wts)), ot)
185 :     end)
186 :     | GENOP _ => bug "other GENOPs not implemented yet")
187 :    
188 :     and lpev le =
189 :     (case le
190 :     of SVAL nsv => (nsv, ident)
191 :     | e => let val v = mkv()
192 :     in (VAR v, fn x => LET(v, e, x))
193 :     end)
194 :    
195 :     and lpsv sv =
196 :     (case (lpve sv)
197 :     of (SVAL nsv, lt) => (nsv, ident, lt)
198 :     | (e, lt) =>
199 :     let val v = mkv()
200 :     in (VAR v, fn x => LET(v, e, x), lt)
201 :     end)
202 :    
203 :     and loop le =
204 :     (case le
205 :     of SVAL sv => lpve sv
206 :     | TFN (ks, e) =>
207 :     let val nwenv = CO.wpNew(wenv, d)
208 :     val (ne, nt) = transform (nwenv, venv, DI.next d) e
209 :     val ne' = CO.wpBuild(nwenv, ne)
210 :     in (TFN(ks, ne'), LT.ltc_poly(ks, [nt]))
211 :     end
212 :     | TAPP (v, ts) =>
213 :     let val (nv, hdr0, lt) = lpsv v
214 :     in (case tcsWrap ts
215 :     of NONE => (hdr0(TAPP(nv, ts)), ltApply(lt, ts))
216 :     | SOME nts =>
217 :     let val nt = ltAppSt(lt, nts)
218 :     val ot = ltAppSt(lt, ts)
219 :     val hdr = CO.unwrapOp (wenv, nt, ot, d)
220 :    
221 :     in (hdr0(hdr(TAPP(nv, nts))), ot)
222 :     end)
223 :     end
224 :     | PACK (lt, ts, nts, sv) =>
225 :     let val (ne, _) = lpve sv
226 :     val nt = ltAppSt(lt, nts)
227 :     val ot = ltAppSt(lt, ts)
228 :     val hdr = CO.wrapOp (wenv, nt, ot, d)
229 :     in (hdr ne, nt)
230 :     end
231 :     | CON (x as (name, rep, lt), ts, v) =>
232 :     let val (nv, hdr0, _) = lpsv v
233 :     val ot = ltAppSt(lt, ts)
234 :     val (argt, res) = ltArrow(ot)
235 :     in (case ltWrap argt
236 :     of NONE => (hdr0(CON(x, ts, nv)), res)
237 :     | SOME nargt =>
238 :     let val hdr = CO.wrapOp (wenv, nargt, argt, d)
239 :     val x = (name, rep, fixDconTy lt)
240 :     val ne = hdr0(hdr(SVAL nv))
241 :     in case ne
242 :     of SVAL nnv => (CON(x, ts, nnv), res)
243 :     | _ =>
244 :     let val z = mkv()
245 :     in (LET(z, ne, CON(x, ts, VAR z)), res)
246 :     end
247 :     end)
248 :     end
249 :     | DECON ((_, DA.CONSTANT _, _), _, _) => (RECORD[], LT.ltc_unit)
250 :     (* reason: unit-carrying data constructors are considered
251 :     as constants; *)
252 :     | DECON (x as (name, rep, lt), ts, sv) =>
253 :     let val (nv, hdr0, _) = lpsv sv
254 :     val ot = ltAppSt(lt, ts)
255 :     val (res, argt) = ltArrow(ot)
256 :     in (case ltWrap res
257 :     of NONE => (hdr0(DECON(x, ts, nv)), res)
258 :     | SOME nres =>
259 :     let val hdr = CO.unwrapOp (wenv, nres, res, d)
260 :     val x = (name, rep, fixDconTy lt)
261 :     in (hdr(hdr0(DECON(x, ts, nv))), res)
262 :     end)
263 :     end
264 :     | SWITCH (v, reps, cases, opp) =>
265 :     let val (nv, hdr0, _) = lpsv v
266 :     fun g (c, x) = (c, #1 (loop x))
267 :     val (ncases, nt) =
268 :     (case cases
269 :     of ((c, e)::rest) =>
270 :     let val (ne, nt) = loop e
271 :     in ((c, ne)::(map g rest), nt)
272 :     end
273 :     | _ => bug "unexpected empty switch cases")
274 :     val nopp = (case opp of NONE => NONE
275 :     | SOME x => SOME(#1(loop x)))
276 :     in (hdr0(SWITCH(nv, reps, ncases, nopp)), nt)
277 :     end
278 :     | FN(v, t, e) =>
279 :     let val nvenv = LT.ltInsert(venv, v, t, d)
280 :     val (ne, nt) = transform (wenv, nvenv, d) e
281 :     in (FN(v, t, ne), ltFun(t, nt))
282 :     end
283 :     | FIX(vs, ts, es, eb) =>
284 :     let val nvenv =
285 :     let fun h (env, v::r, x::z) = h(LT.ltInsert(env, v, x, d), r, z)
286 :     | h (env, [], []) = env
287 :     | h _ = bug "unexpected FIX bindings"
288 :     in h(venv, vs, ts)
289 :     end
290 :     val nes = map (fn x => (#1 (transform (wenv, nvenv, d) x))) es
291 :     val (neb, nt) = transform (wenv, nvenv, d) eb
292 :     in (FIX(vs, ts, nes, neb), nt)
293 :     end
294 :     | APP(v1, v2) =>
295 :     let val (nv1, hdr1, nt1) = lpsv v1
296 :     val (nv2, hdr2, _) = lpsv v2
297 :     val (_, nt) = ltArrow nt1
298 :     in (hdr1(hdr2(APP(nv1, nv2))), nt)
299 :     end
300 :     | LET(v, e1, e2) =>
301 :     let val (ne1, nt1) = loop e1
302 :     val nvenv = LT.ltInsert(venv, v, nt1, d)
303 :     val (ne2, nt2) = transform (wenv, nvenv, d) e2
304 :     in (LET(v, ne1, ne2), nt2)
305 :     end
306 :    
307 :     | RECORD vs =>
308 :     let fun h([], hdr, nvs, nts) =
309 :     (hdr(RECORD(rev nvs)), ltTup(rev nts))
310 :     | h(v::r, hdr, nvs, nts) =
311 :     let val (nv, h0, nt) = lpsv v
312 :     in h(r, hdr o h0, nv::nvs, nt::nts)
313 :     end
314 :     in h(vs, ident, [], [])
315 :     end
316 :     | SRECORD vs =>
317 :     let fun h([], hdr, nvs, nts) =
318 :     (hdr(SRECORD(rev nvs)), LT.ltc_str(rev nts))
319 :     | h(v::r, hdr, nvs, nts) =
320 :     let val (nv, h0, nt) = lpsv v
321 :     in h(r, hdr o h0, nv::nvs, nt::nts)
322 :     end
323 :     in h(vs, ident, [], [])
324 :     end
325 :     | VECTOR (vs, t) =>
326 :     let val (wt, hdr, mhdr) =
327 :     (case LU.tcWrap t
328 :     of NONE => (t, fn sv => SVAL sv, fn le => le)
329 :     | SOME z =>
330 :     let val z' = LT.ltc_tyc z and t' = LT.ltc_tyc t
331 :     val xh = CO.wrapOp(wenv, z', t', d)
332 :     val x = mkv()
333 :     val y = mkv()
334 :     val mh = (fn le => LET(x, FN(y, t', xh(SVAL(VAR y))),
335 :     le))
336 :     val hh = (fn sv => APP(VAR x, sv))
337 :     in (z, hh, mh)
338 :     end)
339 :    
340 :     fun h([], h2, nvs) = h2(VECTOR(rev nvs, wt))
341 :     | h(v::r, h2, nvs) =
342 :     let val (xv, h1, _) = lpsv v
343 :     val (nv, h0) = lpev (hdr xv)
344 :     in h(r, h2 o h1 o h0, nv::nvs)
345 :     end
346 :     in (h (vs, mhdr, []), LT.ltc_tyc(LT.tcc_vector t))
347 :     end
348 :     | SELECT (i, v) =>
349 :     let val (nv, hdr, nt) = lpsv v
350 :     in (hdr(SELECT(i, nv)), ltSelect(nt, i))
351 :     end
352 :     | ETAG (v, t) =>
353 :     let val (nv, hdr, _) = lpsv v
354 :     in (hdr(ETAG(nv, t)), LT.ltc_etag t)
355 :     end
356 :     | RAISE (v, t) =>
357 :     let val (nv, hdr, _) = lpsv v
358 :     in (hdr(RAISE(nv, t)), t)
359 :     end
360 :     | HANDLE (e, v) =>
361 :     let val (ne, nt) = loop e
362 :     val (nv, hdr, _) = lpsv v
363 :     in (hdr(HANDLE(ne, nv)), nt)
364 :     end
365 :     | WRAP _ => bug "unexpected WRAP lexp"
366 :     | UNWRAP _ => bug "unexpected UNWRAP lexp")
367 :    
368 :     in loop
369 :     end (* function transform *)
370 :    
371 :     fun wrapLexp (FN(v, t, e)) =
372 :     let val wenv = CO.initWpEnv ()
373 :     val venv = LT.initLtyEnv
374 :     val d = DI.top
375 :     val nvenv = LT.ltInsert(venv, v, t, d)
376 :     val (ne, _) = transform (wenv, nvenv, d) e
377 :     in FN(v, t, CO.wpBuild(wenv, ne))
378 :     end
379 :     | wrapLexp _ = bug "unexpected lambda expressions in wrapLexp"
380 :    
381 :     end (* toplevel local *)
382 :     end (* structure Wrapping *)
383 :    
384 :     (*
385 :     * $Log: wrapping.sml,v $
386 :     * Revision 1.4 1997/05/05 20:00:18 george
387 :     * Change the term language into the quasi-A-normal form. Added a new round
388 :     * of lambda contraction before and after type specialization and
389 :     * representation analysis. Type specialization including minimum type
390 :     * derivation is now turned on all the time. Real array is now implemented
391 :     * as realArray. A more sophisticated partial boxing scheme is added and
392 :     * used as the default.
393 :     *
394 :     * Revision 1.3 1997/04/18 15:40:35 george
395 :     * Fixing the DECON on the constant data constructor bug reported
396 :     * by Pichora. -- zsh
397 :     *
398 :     * Revision 1.2 1997/02/26 21:55:31 george
399 :     * Fixing the incorrect wrapper bug, BUG 1158, reported by Ken Cline
400 :     * (zcline.sml). This also fixes the core dump bug, BUG 1153,
401 :     * reported by Nikolaj.
402 :     *
403 :     *)

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