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 94 - (view) (download)

1 : monnier 69 (* Copyright 1998 YALE FLINT PROJECT *)
2 : monnier 16 (* coerce.sml *)
3 :    
4 :     signature COERCE = sig
5 :    
6 :     type wpEnv
7 : monnier 69 val initWpEnv: unit -> wpEnv
8 :     val wpNew : wpEnv * DebIndex.depth -> wpEnv
9 :     val wpBuild : wpEnv * FLINT.lexp -> FLINT.lexp
10 : monnier 16
11 : monnier 69 val unwrapOp : wpEnv * LtyDef.lty list * LtyDef.lty list * DebIndex.depth
12 :     -> (FLINT.value list -> FLINT.lexp) option
13 : monnier 16
14 : monnier 69 val wrapOp : wpEnv * LtyDef.lty list * LtyDef.lty list * DebIndex.depth
15 :     -> (FLINT.value list -> FLINT.lexp) option
16 : monnier 16
17 :     end (* signature COERCE *)
18 :    
19 : monnier 69 structure Coerce : COERCE =
20 : monnier 16 struct
21 :    
22 :     local structure DI = DebIndex
23 :     structure LT = LtyExtern
24 :     structure LV = LambdaVar
25 : monnier 69 structure PF = PFlatten
26 :     structure FU = FlintUtil
27 :     open LtyKernel FLINT
28 : monnier 16 in
29 :    
30 :     (****************************************************************************
31 :     * UTILITY FUNCTIONS AND CONSTANTS *
32 :     ****************************************************************************)
33 :    
34 : monnier 69 fun bug s = ErrorMsg.impossible ("Coerce: " ^ s)
35 : monnier 16 fun say (s : string) = Control.Print.say s
36 :    
37 : monnier 69 fun mkv _ = LV.mkLvar ()
38 : monnier 16 val ident = fn le => le
39 : monnier 69 val fkfun = FK_FUN{isrec=NONE, known=false, inline=true, fixed=LT.ffc_fixed}
40 :     fun fromto(i,j) = if i < j then (i::fromto(i+1,j)) else []
41 : monnier 16
42 : monnier 69 fun opList (NONE :: r) = opList r
43 :     | opList ((SOME _) :: r) = true
44 :     | opList [] = false
45 : monnier 16
46 : monnier 69 fun WRAP(t, u, kont) =
47 :     let val v = mkv()
48 :     in FU.WRAP(t, [u], v, kont(VAR v))
49 : monnier 16 end
50 :    
51 : monnier 69 fun UNWRAP(t, u, kont) =
52 :     let val v = mkv()
53 :     in FU.UNWRAP(t, [u], v, kont (VAR v))
54 : monnier 16 end
55 :    
56 : monnier 69 fun RETv (v) = RET [v]
57 : monnier 16
58 :     (****************************************************************************
59 : monnier 69 * WRAPPER CACHES AND WRAPPER ENVIRONMENTS *
60 : monnier 16 ****************************************************************************)
61 : monnier 69 type hdr = value -> lexp
62 : monnier 16 type hdrOp = hdr option
63 :    
64 :     type wpCache = (lty * hdrOp) list IntmapF.intmap
65 : monnier 69 type wpEnv = (fundec list ref * wpCache ref) list
66 : monnier 16
67 :     val initWpCache : wpCache = IntmapF.empty
68 : monnier 69 fun initWpEnv () = [(ref [], ref initWpCache)]
69 : monnier 16
70 :     fun wcEnter([], t, x) = bug "unexpected wenv in wcEnter"
71 :     | wcEnter((_, z as ref m)::_, t, x) =
72 :     let val h = lt_key t
73 :     in z := IntmapF.add(m, h,
74 :     (t,x)::(IntmapF.lookup m h handle IntmapF => nil))
75 :     end
76 :    
77 :     fun wcLook([], t) = bug "unexpected wenv in wcLook"
78 :     | wcLook((_, z as ref m)::_, t) =
79 :     (let fun loop((t',x)::rest) = if lt_eqv(t,t') then SOME x else loop rest
80 :     | loop [] = NONE
81 :     in loop(IntmapF.lookup m (lt_key t))
82 :     end handle IntmapF.IntmapF => NONE)
83 :    
84 :     fun wpNew(wpEnv, d) =
85 :     let val od = length wpEnv
86 : monnier 69 val _ = (* sanity check *)
87 :     if (d+1 = od) then ()
88 :     else bug "inconsistent state in wpNew"
89 : monnier 16 in (ref [], ref initWpCache)::wpEnv
90 :     end
91 :    
92 :     fun wpBuild ([], base) = base
93 :     | wpBuild ((wref,_)::_, base) =
94 : monnier 69 foldl (fn (fd, b) => FIX([fd], b)) base (!wref)
95 : monnier 16
96 :     fun addWrappers(wenv, p, d) =
97 :     let (** the d value is ignored now but we may use it in the future *)
98 :     val (wref, _) = (hd wenv (* (List.nth(wenv, d)) *)
99 :     handle _ => bug "unexpected cases in addWrappers")
100 :     in (wref := (p::(!wref)))
101 :     end
102 :    
103 : monnier 69 (* appWraps : hdrOp list * value list * (value list -> lexp) -> lexp *)
104 :     fun appWraps (wps, vs, cont) =
105 :     let fun g (NONE::ws, v::vs, hdr, nvs) = g(ws, vs, hdr, v::nvs)
106 :     | g ((SOME f)::ws, v::vs, hdr, nvs) =
107 :     let val nv = mkv()
108 :     in g(ws, vs, fn le => hdr(LET([nv], f v, le)), (VAR nv)::nvs)
109 :     end
110 :     | g ([], [], hdr, nvs) = hdr(cont(rev nvs))
111 :     | g _ = bug "unexpected cases in appWraps"
112 :     in g(wps, vs, ident, [])
113 :     end (* function appWraps *)
114 :    
115 :     (* appWrapsWithFiller does the same thing as appWraps, except that
116 :     * it also fills in proper coercions when there are mismatches between
117 :     * the original values. Occurs strictly only for TC_ARROW case. The
118 :     * filler is generated by the PFlatten.v_coerce function.
119 :     *
120 :     * The boolean flag indicates if the filler should be applied before
121 :     * wrapping or after wrapping.
122 :     *
123 :     * appWrapsWithFiller:
124 :     * bool -> {filler: (value list -> (value list * (lexp -> lexp))) option,
125 :     * wps: hdrOp list, args: value list, cont: (value list -> lex)}
126 :     * -> lexp
127 :     *)
128 :     fun appWrapsWithFiller before_wrap {filler=NONE, wps, args, cont} =
129 :     appWraps(wps, args, cont)
130 :    
131 :     | appWrapsWithFiller before_wrap {filler=SOME ff, wps, args, cont} =
132 :     let val ((nargs, nhdr), ncont) =
133 :     if before_wrap then (ff args, cont)
134 :     else ((args, ident),
135 :     fn vs => let val (nvs, h) = ff vs
136 :     in h(cont(nvs))
137 :     end)
138 :     in nhdr(appWraps(wps, nargs, ncont))
139 :     end (* function appWrapsWithFiller *)
140 :    
141 : monnier 16 (****************************************************************************
142 :     * MAIN FUNCTIONS *
143 :     ****************************************************************************)
144 : monnier 69 fun wrapperGen (wflag, sflag) (wenv, nts, ots, d) =
145 : monnier 16 let
146 :    
147 :     val doWrap =
148 : monnier 69 if sflag then
149 :     (fn (w, fdec) => (addWrappers(wenv, fdec, d);
150 :     (fn u => APP(VAR w, [u]))))
151 :     else
152 :     (fn (w, fdec) => (fn u => FIX([fdec], APP(VAR w, [u]))))
153 : monnier 16
154 :     fun getWTC(wflag, nx, ox, doit) =
155 :     if tc_eqv(nx, ox) then NONE
156 :     else (if sflag then
157 :     (let val mark = if wflag then LT.ltc_int else LT.ltc_real (* hack *)
158 :     val key = LT.ltc_str [LT.ltc_tyc nx, LT.ltc_tyc ox, mark]
159 :     in case wcLook(wenv, key)
160 :     of SOME x => x
161 :     | NONE => (let val res = doit (tc_out nx, tc_out ox)
162 :     in wcEnter(wenv, key, res); res
163 :     end)
164 :     end)
165 :     else doit (tc_out nx, tc_out ox))
166 :    
167 :     fun getWLT(wflag, nx, ox, doit) =
168 :     if lt_eqv(nx, ox) then NONE
169 : monnier 69 else (if sflag then (*** we could always force the sharing here ***)
170 : monnier 16 (let val mark = if wflag then LT.ltc_int else LT.ltc_real (* hack *)
171 :     val key = LT.ltc_str [nx, ox, mark]
172 :     in case wcLook(wenv, key)
173 :     of SOME x => x
174 :     | NONE => (let val res = doit (lt_out nx, lt_out ox)
175 :     in wcEnter(wenv, key, res); res
176 :     end)
177 :     end)
178 :     else doit (lt_out nx, lt_out ox))
179 :    
180 :     fun tcLoop wflag (nx, ox) =
181 :     getWTC(wflag, nx, ox,
182 : monnier 69 (fn (TC_TOKEN (_, nz), _) => (* sanity check: tcc_wrap(ox) = nx *)
183 :     if LT.tcp_wrap nx then
184 :     let val (ax, act) = if wflag then (ox, WRAP) else (nx, UNWRAP)
185 :     in if LT.tcp_prim ox then SOME (fn u => act(ox, u, RETv))
186 :     else let val wp = tcLoop wflag (nz, ox)
187 :     val f = mkv() and v = mkv()
188 :     val (tx, kont, u, hdr) =
189 :     (case wp
190 :     of NONE => (ox, RETv, VAR v, ident)
191 :     | SOME hh =>
192 :     if wflag then
193 :     let val z = mkv()
194 :     in (nz, RETv, VAR z,
195 :     fn e => LET([z], hh(VAR v), e))
196 :     end
197 :     else (nz, hh, VAR v, ident))
198 :     val fdec = (fkfun, f, [(v, LT.ltc_tyc ax)],
199 :     hdr(act(tx, u, kont)))
200 :     in SOME(doWrap(f, fdec))
201 :     end
202 :     end
203 :     else bug "unexpected TC_TOKEN in tcLoop"
204 :     | (TC_TUPLE (nrf, nxs), TC_TUPLE (orf, oxs)) =>
205 : monnier 16 let val wps = ListPair.map (tcLoop wflag) (nxs, oxs)
206 :     in if opList wps then
207 : monnier 69 let val f = mkv() and v = mkv()
208 : monnier 16 val nl = fromto(0, length nxs)
209 : monnier 69 val u = VAR v
210 :     val (nvs, hdr) = (* take out all the fields *)
211 :     foldr (fn (i, (z,h)) =>
212 :     let val x = mkv()
213 :     in ((VAR x)::z,
214 :     fn le => SELECT(u, i, x, h le))
215 :     end) ([], ident) nl
216 :    
217 :     val (ax, rf) =
218 :     if wflag then (LT.ltc_tyc ox, nrf)
219 :     else (LT.ltc_tyc nx, orf)
220 :     fun cont nvs =
221 :     let val z = mkv()
222 :     in RECORD(RK_TUPLE rf, nvs, z, RET[VAR z])
223 :     end
224 :     val body = hdr(appWraps(wps, nvs, cont))
225 :     val fdec = (fkfun, f, [(v, ax)], body)
226 :     in SOME(doWrap(f, fdec))
227 : monnier 16 end
228 :     else NONE
229 :     end
230 : monnier 69 | (TC_ARROW (_, nxs1, nxs2), TC_ARROW (_, oxs1, oxs2)) =>
231 :     let val (awflag, rwflag) = (not wflag, wflag) (* polarity *)
232 :     val (oxs1', filler1) = PF.v_coerce (awflag, nxs1, oxs1)
233 :     val wps1 = ListPair.map (tcLoop awflag) (nxs1, oxs1')
234 :     val (oxs2', filler2) = PF.v_coerce (rwflag, nxs2, oxs2)
235 :     val wps2 = ListPair.map (tcLoop rwflag) (nxs2, oxs2')
236 :     in (case (opList wps1, opList wps2, filler1, filler2)
237 :     of (false, false, NONE, NONE) => NONE
238 : monnier 16 | _ =>
239 : monnier 69 let val wf = mkv() and f = mkv() and rf = mkv()
240 :     val (ax, rxs1, rxs2) =
241 :     if wflag then (LT.ltc_tyc ox, nxs1, oxs2)
242 :     else (LT.ltc_tyc nx, oxs1, nxs2)
243 :    
244 :     val params = map (fn t => (mkv(), LT.ltc_tyc t)) rxs1
245 :     val avs = map (fn (x, _) => VAR x) params
246 :     val rvs = map mkv rxs2
247 :     val rbody =
248 :     LET(rvs,
249 :     appWrapsWithFiller awflag
250 :     {filler=filler1, wps=wps1, args=avs,
251 :     cont=(fn wvs => APP(VAR f, wvs))},
252 :     appWrapsWithFiller rwflag
253 :     {filler=filler2, wps=wps2,
254 :     args=map VAR rvs, cont=RET})
255 :    
256 :     val rfdec = (fkfun, rf, params, rbody)
257 :     val body = FIX([rfdec], RET[VAR rf])
258 :     val fdec = (fkfun, wf, [(f, ax)], body)
259 :     in SOME (doWrap(wf, fdec))
260 : monnier 16 end)
261 :     end
262 :     | (_, _) =>
263 : monnier 69 if LT.tc_eqv_x(nx, ox) then NONE
264 : monnier 16 else (say " Type nx is : \n"; say (LT.tc_print nx);
265 :     say "\n Type ox is : \n"; say (LT.tc_print ox); say "\n";
266 :     bug "unexpected other tycs in tcLoop")))
267 :    
268 :     fun ltLoop wflag (nx, ox) =
269 :     getWLT(wflag, nx, ox,
270 :     (fn (LT_TYC nz, LT_TYC oz) => tcLoop wflag (nz, oz)
271 :     | (LT_STR nxs, LT_STR oxs) =>
272 :     let val wps = ListPair.map (ltLoop wflag) (nxs, oxs)
273 :     in if opList wps then
274 : monnier 69 let val f = mkv() and v = mkv()
275 : monnier 16 val nl = fromto(0, length nxs)
276 : monnier 69 val u = VAR v
277 :     val (nvs, hdr) = (* take out all the fields *)
278 :     foldr (fn (i, (z,h)) =>
279 :     let val x = mkv()
280 :     in ((VAR x)::z,
281 :     fn le => SELECT(u, i, x, h le))
282 :     end) ([], ident) nl
283 :     fun cont nvs =
284 :     let val z = mkv()
285 :     in RECORD(RK_STRUCT, nvs, z, RET[VAR z])
286 :     end
287 :     val body = hdr(appWraps(wps, nvs, cont))
288 : monnier 16 val ax = if wflag then ox else nx
289 : monnier 69 val fdec = (FK_FCT, f, [(v, ax)], body)
290 :     in SOME(doWrap(f, fdec))
291 : monnier 16 end
292 :     else NONE
293 :     end
294 : monnier 69 | (LT_FCT (nxs1, nxs2), LT_FCT (oxs1, oxs2)) =>
295 :     let val wps1 = ListPair.map (ltLoop (not wflag)) (nxs1, oxs1)
296 :     val wps2 = ListPair.map (ltLoop wflag) (nxs2, oxs2)
297 :     in (case (opList wps1, opList wps2)
298 :     of (false, false) => NONE
299 : monnier 16 | _ =>
300 : monnier 69 let val wf = mkv() and f = mkv() and rf = mkv()
301 :     val (ax, rxs1, rxs2) =
302 :     if wflag then (ox, nxs1, oxs2) else (nx, oxs1, nxs2)
303 :    
304 :     val params = map (fn t => (mkv(), t)) rxs1
305 :     val avs = map (fn (x, _) => VAR x) params
306 :     val rvs = map mkv rxs2
307 :     val rbody =
308 :     LET(rvs,
309 :     appWraps(wps1, avs, fn wvs => APP(VAR f, wvs)),
310 :     appWraps(wps2, map VAR rvs, fn wvs => RET wvs))
311 :    
312 :     val rfdec = (FK_FCT, rf, params, rbody)
313 :     val body = FIX([rfdec], RET[VAR rf])
314 :     val fdec = (FK_FCT, wf, [(f, ax)], body)
315 :     in SOME (doWrap(wf, fdec))
316 : monnier 16 end)
317 :     end
318 : monnier 69 | (LT_POLY(nks, nzs), LT_POLY(oks, ozs)) =>
319 : monnier 16 let val nwenv = wpNew(wenv, d)
320 : monnier 69 val wp = wrapperGen (wflag, sflag) (nwenv, nzs, ozs, DI.next d)
321 : monnier 16 in (case wp
322 :     of NONE => NONE
323 : monnier 69 | SOME (hdr : value list -> lexp) =>
324 :     let val wf = mkv() and f = mkv() and rf = mkv()
325 :     val (ax, aks, rxs) =
326 :     if wflag then (ox, nks, ozs) else (nx, oks, nzs)
327 :     val nl = fromto(0, length nks)
328 : monnier 16 val ts = map (fn i => LT.tcc_var(DI.innermost, i)) nl
329 : monnier 69 val avs = map mkv rxs
330 :     val rbody =
331 :     LET(avs, TAPP(VAR f, ts), hdr (map VAR avs))
332 :     val nrbody = wpBuild(nwenv, rbody)
333 :     val atvks = map (fn k => (LT.mkTvar(),k)) aks
334 :     val body = TFN((rf, atvks, nrbody), RET[VAR rf])
335 :     val fdec = (FK_FCT, wf, [(f, ax)], body)
336 :     in SOME(doWrap(wf, fdec))
337 : monnier 16 end)
338 :     end
339 : monnier 69 | _ =>
340 :     (say " Type nx is : \n"; say (LT.lt_print nx);
341 :     say "\n Type ox is : \n"; say (LT.lt_print ox); say "\n";
342 :     bug "unexpected other ltys in ltLoop")))
343 : monnier 16
344 : monnier 69 val wps = ListPair.map (ltLoop wflag) (nts, ots)
345 :    
346 :     in if opList wps
347 :     then SOME (fn vs => appWraps(wps, vs, RET))
348 :     else NONE
349 : monnier 16 end (* function wrapperGen *)
350 :    
351 : monnier 69 fun unwrapOp (wenv, nts, ots, d) =
352 :     let val nts' = map lt_norm nts
353 :     val ots' = map lt_norm ots
354 :     val sflag = !Control.CG.sharewrap
355 :     in wrapperGen (false, sflag) (wenv, nts', ots', d)
356 :     end (* function unwrapOp *)
357 : monnier 16
358 : monnier 69 fun wrapOp (wenv, nts, ots, d) =
359 :     let val nts' = map lt_norm nts
360 :     val ots' = map lt_norm ots
361 :     val sflag = !Control.CG.sharewrap
362 :     in wrapperGen (true, sflag) (wenv, nts', ots', d)
363 :     end (* function wrapOp *)
364 : monnier 16
365 :     end (* toplevel local *)
366 :     end (* structure Coerce *)
367 :    
368 :    
369 : monnier 93
370 :     (*
371 :     * $Log: coerce.sml,v $
372 :     * Revision 1.1.1.1 1998/04/08 18:39:44 george
373 :     * Version 110.5
374 :     *
375 :     *)

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