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 24 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/FLINT/reps/wrapping.sml

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

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