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

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