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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 46 - (view) (download)

1 : monnier 16 (* Copyright 1996 by Bell Laboratories *)
2 :     (* coerce.sml *)
3 :    
4 :     signature COERCE = sig
5 :    
6 :     type wpEnv
7 :    
8 :     val initWpEnv : unit -> wpEnv
9 :     val wpNew : wpEnv * DebIndex.depth -> wpEnv
10 :     val wpBuild : wpEnv * Lambda.lexp -> Lambda.lexp
11 :    
12 :     val unwrapOp : wpEnv * LtyDef.lty * LtyDef.lty * DebIndex.depth
13 :     -> (Lambda.lexp -> Lambda.lexp)
14 :    
15 :     val wrapOp : wpEnv * LtyDef.lty * LtyDef.lty * DebIndex.depth
16 :     -> (Lambda.lexp -> Lambda.lexp)
17 :    
18 :     end (* signature COERCE *)
19 :    
20 :     structure Coerce : COERCE =
21 :     struct
22 :    
23 :     local structure DI = DebIndex
24 :     structure LT = LtyExtern
25 :     structure LU = LtyUtil
26 :     structure LV = LambdaVar
27 :     open LtyKernel Lambda
28 :     in
29 :    
30 :     (****************************************************************************
31 :     * UTILITY FUNCTIONS AND CONSTANTS *
32 :     ****************************************************************************)
33 :    
34 :     fun bug s = ErrorMsg.impossible ("CoerceLexp: " ^ s)
35 :     fun say (s : string) = Control.Print.say s
36 :    
37 :     val mkv = LV.mkLvar
38 :     val ident = fn le => le
39 :    
40 :     fun split(SVAL v) = (v, ident)
41 :     | split x = let val v = mkv()
42 :     in (VAR v, fn z => LET(v, x, z))
43 :     end
44 :    
45 :     fun APPg(e1, e2) =
46 :     let val (v1, h1) = split e1
47 :     val (v2, h2) = split e2
48 :     in h1(h2(APP(v1, v2)))
49 :     end
50 :    
51 :     fun RECORDg es =
52 :     let fun f ([], vs, hdr) = hdr(RECORD (rev vs))
53 :     | f (e::r, vs, hdr) =
54 :     let val (v, h) = split e
55 :     in f(r, v::vs, hdr o h)
56 :     end
57 :     in f(es, [], ident)
58 :     end
59 :    
60 :     fun SRECORDg es =
61 :     let fun f ([], vs, hdr) = hdr(SRECORD (rev vs))
62 :     | f (e::r, vs, hdr) =
63 :     let val (v, h) = split e
64 :     in f(r, v::vs, hdr o h)
65 :     end
66 :     in f(es, [], ident)
67 :     end
68 :    
69 :     fun WRAPg (z, b, e) =
70 :     let val (v, h) = split e
71 :     in h(WRAP(z, b, v))
72 :     end
73 :    
74 :     fun UNWRAPg (z, b, e) =
75 :     let val (v, h) = split e
76 :     in h(UNWRAP(z, b, v))
77 :     end
78 :    
79 :     fun fromto(i,j) = if i < j then (i::fromto(i+1,j)) else []
80 :    
81 :     fun option(NONE) = false
82 :     | option(SOME _) = true
83 :    
84 :     fun exists(p, a::r) = if p a then true else exists(p, r)
85 :     | exists(p, []) = false
86 :    
87 :     fun opList l = exists(option, l)
88 :    
89 :     fun force (NONE, le) = le
90 :     | force (SOME f, le) = f le
91 :    
92 :     fun minList (a : int, []) = a
93 :     | minList (a, b::r) = if a > b then minList(b, r) else minList(a, r)
94 :    
95 :     (****************************************************************************
96 :     * WRAPPER CACHES *
97 :     ****************************************************************************)
98 :     type tpairs = lty * lty
99 :     type hdr = lexp -> lexp
100 :     type hdrOp = hdr option
101 :    
102 :     type wpCache = (lty * hdrOp) list IntmapF.intmap
103 :    
104 :     val initWpCache : wpCache = IntmapF.empty
105 :    
106 :     (*
107 :     * Warning: because the hash key is not unique, so the following
108 :     * code is problematic. It should be corrected in the future (ZHONG)
109 :     *)
110 :     fun wcEnter([], t, x) = bug "unexpected wenv in wcEnter"
111 :     | wcEnter((_, z as ref m)::_, t, x) =
112 :     let val h = lt_key t
113 :     in z := IntmapF.add(m, h,
114 :     (t,x)::(IntmapF.lookup m h handle IntmapF => nil))
115 :     end
116 :    
117 :     fun wcLook([], t) = bug "unexpected wenv in wcLook"
118 :     | wcLook((_, z as ref m)::_, t) =
119 :     (let fun loop((t',x)::rest) = if lt_eqv(t,t') then SOME x else loop rest
120 :     | loop [] = NONE
121 :     in loop(IntmapF.lookup m (lt_key t))
122 :     end handle IntmapF.IntmapF => NONE)
123 :    
124 :     (****************************************************************************
125 :     * WRAPPER ENVIRONMENTS *
126 :     ****************************************************************************)
127 :     type wpEnv = ((lvar * lexp) list ref * wpCache ref) list
128 :     fun initWpEnv () = [(ref [], ref initWpCache)]
129 :    
130 :     fun wpNew(wpEnv, d) =
131 :     let val od = length wpEnv
132 :     val _ = if (d+1 = od) then () else bug "inconsistent state in wpNew"
133 :     in (ref [], ref initWpCache)::wpEnv
134 :     end
135 :    
136 :     fun wpBuild ([], base) = base
137 :     | wpBuild ((wref,_)::_, base) =
138 :     foldl (fn ((v, le), b) => LET(v, le, b)) base (!wref)
139 :    
140 :     fun addWrappers(wenv, p, d) =
141 :     let (** the d value is ignored now but we may use it in the future *)
142 :     val (wref, _) = (hd wenv (* (List.nth(wenv, d)) *)
143 :     handle _ => bug "unexpected cases in addWrappers")
144 :     in (wref := (p::(!wref)))
145 :     end
146 :    
147 :     (****************************************************************************
148 :     * MAIN FUNCTIONS *
149 :     ****************************************************************************)
150 :     fun wrapperGen (wflag, sflag) (wenv, nt, ot, d) =
151 :     let
152 :    
153 :     val doWrap =
154 :     if sflag then fn exp => let val w = mkv()
155 :     in addWrappers(wenv, (w,exp), d); SVAL(VAR w)
156 :     end
157 :     else ident
158 :    
159 :     fun getWTC(wflag, nx, ox, doit) =
160 :     if tc_eqv(nx, ox) then NONE
161 :     else (if sflag then
162 :     (let val mark = if wflag then LT.ltc_int else LT.ltc_real (* hack *)
163 :     val key = LT.ltc_str [LT.ltc_tyc nx, LT.ltc_tyc ox, mark]
164 :     in case wcLook(wenv, key)
165 :     of SOME x => x
166 :     | NONE => (let val res = doit (tc_out nx, tc_out ox)
167 :     in wcEnter(wenv, key, res); res
168 :     end)
169 :     end)
170 :     else doit (tc_out nx, tc_out ox))
171 :    
172 :     fun getWLT(wflag, nx, ox, doit) =
173 :     if lt_eqv(nx, ox) then NONE
174 :     else (if sflag then
175 :     (let val mark = if wflag then LT.ltc_int else LT.ltc_real (* hack *)
176 :     val key = LT.ltc_str [nx, ox, mark]
177 :     in case wcLook(wenv, key)
178 :     of SOME x => x
179 :     | NONE => (let val res = doit (lt_out nx, lt_out ox)
180 :     in wcEnter(wenv, key, res); res
181 :     end)
182 :     end)
183 :     else doit (lt_out nx, lt_out ox))
184 :    
185 :     fun tcLoop wflag (nx, ox) =
186 :     getWTC(wflag, nx, ox,
187 :     (fn (TC_BOX nz, _) =>
188 :     let (* major gross hack mode ON ----- *)
189 :     val nz = case LU.tcWrap ox (* was nz *)
190 :     of NONE => nz
191 :     | SOME x =>
192 :     if tc_eqv(x, nx) then nz
193 :     else (case tc_out x of TC_BOX z => z
194 :     | _ => nz)
195 :     (* major gross hack mode OFF ----- *)
196 :    
197 :     val wp = tcLoop wflag (nz, ox)
198 :     fun hdr le =
199 :     case wp of NONE => le
200 :     | SOME _ => force(wp, le)
201 :     in if wflag then SOME(fn le => WRAPg(nz, true, hdr le))
202 :     else SOME(fn le => hdr(UNWRAPg(nz, true, le)))
203 :     end
204 :     (*
205 :     if tc_eqv(nz, ox) then
206 :     (if wflag then SOME(fn le => WRAPg(ox, true, le))
207 :     else SOME(fn le => UNWRAPg(ox, true, le)))
208 :     else (say " Type nx is : \n"; say (LT.tc_print nx);
209 :     say "\n Type ox is : \n"; say (LT.tc_print ox); say "\n";
210 :     bug "unexpected TC_BOX in tcLoop")
211 :     *)
212 :     | (TC_ABS _, TC_ABS _) =>
213 :     if LT.tc_eqv_bx(nx, ox) then NONE
214 :     else (say " Type nx is : \n"; say (LT.tc_print nx);
215 :     say "\n Type ox is : \n"; say (LT.tc_print ox); say "\n";
216 :     bug "unexpected abs tycs in tcLoop")
217 :    
218 :     | (TC_ABS nz, _) =>
219 :     let val nt = LU.tcWrap nz
220 :     in case nt
221 :     of NONE =>
222 :     if wflag then SOME(fn le => WRAPg(ox, false, le))
223 :     else SOME(fn le => UNWRAPg(ox, false, le))
224 :     | SOME zz =>
225 :     (case tc_out zz
226 :     of TC_BOX nnz =>
227 :     let val wp = tcLoop wflag (nnz, ox)
228 :     fun hdr le =
229 :     case wp of NONE => le
230 :     | SOME _ => force(wp, le)
231 :     in if wflag then
232 :     SOME(fn le => WRAPg(nnz, false, hdr le))
233 :     else SOME(fn le => hdr(UNWRAPg(nnz, false, le)))
234 :     end
235 :     | _ => bug "unexpected non-box-tyc in tcLoop")
236 :     end
237 :     (*
238 :     if LT.tc_eqv_bx(nz, ox) then
239 :     (if wflag then SOME(fn le => WRAPg(ox, false, le))
240 :     else SOME(fn le => UNWRAPg(ox, false, le)))
241 :     else (say " Type nx is : \n"; say (LT.tc_print nx);
242 :     say "\n Type ox is : \n"; say (LT.tc_print ox); say "\n";
243 :     bug "unexpected TC_ABS in tcLoop")
244 :     *)
245 : monnier 45 | (TC_TUPLE (_, nxs), TC_TUPLE (_, oxs)) =>
246 : monnier 16 let val wps = ListPair.map (tcLoop wflag) (nxs, oxs)
247 :     in if opList wps then
248 :     let val v = mkv()
249 :     val nl = fromto(0, length nxs)
250 :     val base = map (fn i => SELECT(i, VAR v)) nl
251 :     val res = ListPair.map force (wps, base)
252 :     val ax = if wflag then LT.ltc_tyc ox else LT.ltc_tyc nx
253 :     val e = doWrap(FN(v, ax, RECORDg res))
254 :     in SOME(fn le => APPg(e, le))
255 :     end
256 :     else NONE
257 :     end
258 :     | (TC_ARROW _, TC_ARROW _) =>
259 : monnier 45 let val (nx1, nx2) = LT.tcd_parrow nx
260 :     val (ox1, ox2) = LT.tcd_parrow ox
261 : monnier 16 val wp1 = tcLoop (not wflag) (nx1, ox1)
262 :     val wp2 = tcLoop wflag (nx2, ox2)
263 :     in (case (wp1, wp2)
264 :     of (NONE, NONE) => NONE
265 :     | _ =>
266 :     let val r = mkv() and v = mkv() and w = mkv()
267 :     val ve = force(wp1, SVAL(VAR v))
268 :     val re = force(wp2, SVAL(VAR r))
269 :     val (ax, rx) = if wflag then (ox, nx1) else (nx, ox1)
270 :     val (ax, rx) = (LT.ltc_tyc ax, LT.ltc_tyc rx)
271 :     val e = doWrap(FN(w, ax, FN(v, rx,
272 :     LET(r, APPg(SVAL(VAR w), ve), re))))
273 :     in SOME (fn le => APPg(e, le))
274 :     end)
275 :     end
276 :     | (_, _) =>
277 :     if LT.tc_eqv_bx(nx, ox) then NONE
278 :     else (say " Type nx is : \n"; say (LT.tc_print nx);
279 :     say "\n Type ox is : \n"; say (LT.tc_print ox); say "\n";
280 :     bug "unexpected other tycs in tcLoop")))
281 :    
282 :     fun ltLoop wflag (nx, ox) =
283 :     getWLT(wflag, nx, ox,
284 :     (fn (LT_TYC nz, LT_TYC oz) => tcLoop wflag (nz, oz)
285 :     | (LT_STR nxs, LT_STR oxs) =>
286 :     let val wps = ListPair.map (ltLoop wflag) (nxs, oxs)
287 :     in if opList wps then
288 :     let val v = mkv()
289 :     val nl = fromto(0, length nxs)
290 :     val base = map (fn i => SELECT(i, VAR v)) nl
291 :     val res = ListPair.map force (wps, base)
292 :     val ax = if wflag then ox else nx
293 :     val e = doWrap(FN(v, ax, SRECORDg res))
294 :     in SOME(fn le => APPg(e, le))
295 :     end
296 :     else NONE
297 :     end
298 :     | (LT_FCT _, LT_FCT _) =>
299 :     let val (nx1, nx2) =
300 :     case LT.ltd_fct nx of ([a],[b]) => (a,b)
301 :     | _ => bug "unexpected LT_FCT"
302 :     val (ox1, ox2) =
303 :     case LT.ltd_fct ox of ([a],[b]) => (a,b)
304 :     | _ => bug "unexpected LT_FCT"
305 :     val wp1 = ltLoop (not wflag) (nx1, ox1)
306 :     val wp2 = ltLoop wflag (nx2, ox2)
307 :     in (case (wp1, wp2)
308 :     of (NONE, NONE) => NONE
309 :     | _ =>
310 :     let val r = mkv() and v = mkv() and w = mkv()
311 :     val ve = force(wp1, SVAL (VAR v))
312 :     val re = force(wp2, SVAL (VAR r))
313 :     val (ax, rx) = if wflag then (ox, nx1) else (nx, ox1)
314 :     val e = doWrap(FN(w, ax, FN(v, rx,
315 :     LET(r, APPg(SVAL(VAR w), ve), re))))
316 :     in SOME (fn le => APPg(e, le))
317 :     end)
318 :     end
319 :     | (LT_POLY(nks, [nz]), LT_POLY(oks, [oz])) =>
320 :     let val nwenv = wpNew(wenv, d)
321 :     val nd = DI.next d
322 :     val wp = wrapperGen (wflag, sflag) (nwenv, nz, oz, nd)
323 :     in (case wp
324 :     of NONE => NONE
325 :     | SOME z =>
326 :     let val nl = fromto(0, length nks)
327 :     val ts = map (fn i => LT.tcc_var(DI.innermost, i)) nl
328 :     val v = mkv() and w = mkv()
329 :     val ax = if wflag then ox else nx
330 :     val we = LET(v, TAPP(VAR w, ts),
331 :     force(wp, SVAL(VAR v)))
332 :     val nwe = wpBuild(nwenv, we)
333 :     val e = doWrap(FN(w, ax, TFN(nks, nwe)))
334 :     in SOME(fn le => APPg(e, le))
335 :     end)
336 :     end
337 :     | _ => bug "unexpected pair of ltys in ltTrans"))
338 :    
339 :     in ltLoop wflag (nt, ot)
340 :     end (* function wrapperGen *)
341 :    
342 :     (** share or not share ? currently, module wrappers share ! *)
343 :     fun sFlag lt = (case (lt_out lt)
344 :     of LT_TYC _ => !Control.CG.sharewrap (* was always false *)
345 :     | _ => true)
346 :    
347 :     fun unwrapOp (wenv, nt, ot, d) =
348 :     (case (wrapperGen (false, sFlag nt) (wenv, nt, ot, d))
349 :     of NONE => ident
350 :     | SOME wp =>
351 :     let fun h (x as SVAL(VAR _)) = wp(x)
352 :     | h x = let val v = mkv()
353 :     in LET(v, x, wp(SVAL(VAR v)))
354 :     end
355 :     in h
356 :     end)
357 :    
358 :     fun wrapOp (wenv, nt, ot, d) =
359 :     (case (wrapperGen (true, sFlag nt) (wenv, nt, ot, d))
360 :     of NONE => ident
361 :     | SOME wp =>
362 :     let fun h (x as SVAL(VAR _)) = wp(x)
363 :     | h x = let val v = mkv()
364 :     in LET(v, x, wp(SVAL(VAR v)))
365 :     end
366 :     in h
367 :     end)
368 :    
369 :     end (* toplevel local *)
370 :     end (* structure Coerce *)
371 :    
372 :    
373 :     (*
374 :     * $Log: coerce.sml,v $
375 :     * Revision 1.4 1997/08/22 18:39:07 george
376 :     * Sharing the wrappers for core-language polymorphic functions also.
377 :     * The sharing can be turned off by setting Compiler.Control.CG.sharewrap
378 :     * to false.
379 :     *
380 :     * -- zsh
381 :     *
382 :     * Revision 1.3 1997/07/15 16:21:25 dbm
383 :     * Fix representation bug (#1209).
384 :     *
385 :     * Revision 1.2 1997/05/05 20:00:09 george
386 :     * Change the term language into the quasi-A-normal form. Added a new round
387 :     * of lambda contraction before and after type specialization and
388 :     * representation analysis. Type specialization including minimum type
389 :     * derivation is now turned on all the time. Real array is now implemented
390 :     * as realArray. A more sophisticated partial boxing scheme is added and
391 :     * used as the default.
392 :     *
393 :     * Revision 1.1.1.1 1997/01/14 01:38:46 george
394 :     * Version 109.24
395 :     *
396 :     *)

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