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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* Copyright 1996 by Bell Laboratories *)
2 :     (* typeoper.sml *)
3 :    
4 :     signature TYPEOPER =
5 :     sig
6 :     type kenv
7 :     val initKE : kenv
8 :    
9 :     val tkLexp : kenv * LtyKernel.tkind list ->
10 :     (kenv * (Lambda.lexp -> Lambda.lexp))
11 :    
12 :     val tcLexp : kenv * LtyKernel.tyc -> Lambda.lexp
13 :     val tsLexp : kenv * LtyKernel.tyc list -> Lambda.lexp
14 :    
15 :     val utgc : kenv * LtyKernel.tyc -> Lambda.lexp -> Lambda.lexp
16 :     val utgd : kenv * LtyKernel.tyc -> Lambda.lexp -> Lambda.lexp
17 :     val tgdc : kenv * int * LtyKernel.tyc -> Lambda.lexp -> Lambda.lexp
18 :     val tgdd : kenv * int * LtyKernel.tyc -> Lambda.lexp -> Lambda.lexp
19 :    
20 :     val mkwrp : kenv * bool * LtyKernel.tyc -> Lambda.lexp -> Lambda.lexp
21 :     val mkuwp : kenv * bool * LtyKernel.tyc -> Lambda.lexp -> Lambda.lexp
22 :    
23 :     val arrSub : kenv * LtyKernel.lty * LtyKernel.tyc
24 :     -> Lambda.value -> Lambda.lexp
25 :     val arrUpd : kenv * LtyKernel.lty * LtyKernel.tyc
26 :     -> Lambda.value -> Lambda.lexp
27 :     val arrNew : kenv * LtyKernel.lty * LtyKernel.tyc * LambdaVar.lvar
28 :     * LambdaVar.lvar -> Lambda.value -> Lambda.lexp
29 :    
30 :     end (* signature TYPEOPER *)
31 :    
32 :     structure TypeOper : TYPEOPER =
33 :     struct
34 :    
35 :     local structure DI = DebIndex
36 :     structure LT = LtyExtern
37 :     structure LU = LtyUtil
38 :     structure LV = LambdaVar
39 :     structure PO = PrimOp
40 :     structure PT = PrimTyc
41 :     structure BT = BasicTypes
42 :     structure TP = Types
43 :     open LtyKernel Lambda
44 :     in
45 :    
46 :     (****************************************************************************
47 :     * UTILITY FUNCTIONS AND CONSTANTS *
48 :     ****************************************************************************)
49 :    
50 :     fun bug s = ErrorMsg.impossible ("LtyPrim: " ^ s)
51 :     fun say (s : string) = Control.Print.say s
52 :    
53 :     val mkv = LV.mkLvar
54 :     val ident = fn le => le
55 :    
56 :     fun split(SVAL v) = (v, ident)
57 :     | split x = let val v = mkv()
58 :     in (VAR v, fn z => LET(v, x, z))
59 :     end
60 :    
61 :     fun ltAppSt (lt, ts) =
62 :     (case LT.lt_inst(lt, ts)
63 :     of [b] => b
64 :     | _ => bug "unexpected case in ltAppSt")
65 :    
66 :     fun SELECTg(i, e) =
67 :     let val (v, hdr) = split e
68 :     in hdr(SELECT(i, v))
69 :     end
70 :    
71 :     fun APPg(e1, e2) =
72 :     let val (v1, h1) = split e1
73 :     val (v2, h2) = split e2
74 :     in h1(h2(APP(v1, v2)))
75 :     end
76 :    
77 :     fun RECORDg es =
78 :     let fun f ([], vs, hdr) = hdr(RECORD (rev vs))
79 :     | f (e::r, vs, hdr) =
80 :     let val (v, h) = split e
81 :     in f(r, v::vs, hdr o h)
82 :     end
83 :     in f(es, [], ident)
84 :     end
85 :    
86 :     fun SRECORDg es =
87 :     let fun f ([], vs, hdr) = hdr(SRECORD (rev vs))
88 :     | f (e::r, vs, hdr) =
89 :     let val (v, h) = split e
90 :     in f(r, v::vs, hdr o h)
91 :     end
92 :     in f(es, [], ident)
93 :     end
94 :    
95 :     fun WRAPg (z, b, e) =
96 :     let val (v, h) = split e
97 :     in h(WRAP(z, b, v))
98 :     end
99 :    
100 :     fun UNWRAPg (z, b, e) =
101 :     let val (v, h) = split e
102 :     in h(UNWRAP(z, b, v))
103 :     end
104 :    
105 :     fun WRAPcast (z, b, e) =
106 :     let val (v, h) = split e
107 :     val pt = LT.ltc_arw(LT.ltc_tyc z, LT.ltc_tyc(LT.tcc_box z))
108 :     val pv = PRIM(PO.CAST,pt,[])
109 :     in h(APP(pv, v))
110 :     end
111 :    
112 :     fun UNWRAPcast (z, b, e) =
113 :     let val (v, h) = split e
114 :     val pt = LT.ltc_arw(LT.ltc_tyc(LT.tcc_box z), LT.ltc_tyc z)
115 :     val pv = PRIM(PO.CAST,pt,[])
116 :     in h(APP(pv, v))
117 :     end
118 :    
119 :     fun SWITCHg (e, s, ce, d) =
120 :     let val (v, h) = split e
121 :     in h(SWITCH(v, s, ce, d))
122 :     end
123 :    
124 :     fun fromto(i,j) = if i < j then (i::fromto(i+1,j)) else []
125 :    
126 :     fun option(NONE) = false
127 :     | option(SOME _) = true
128 :    
129 :     fun exists(p, a::r) = if p a then true else exists(p, r)
130 :     | exists(p, []) = false
131 :    
132 :     fun opList l = exists(option, l)
133 :    
134 :     fun force (NONE, le) = le
135 :     | force (SOME f, le) = f le
136 :    
137 :     val boolsign = BT.boolsign
138 :     val (trueDcon', falseDcon') =
139 :     let val lt = LT.ltc_parrow(LT.ltc_unit, LT.ltc_bool)
140 :     fun h (TP.DATACON{name,rep,typ,...}) = (name, rep, lt)
141 :     in (h BT.trueDcon, h BT.falseDcon)
142 :     end
143 :    
144 :     fun COND(a,b,c) =
145 :     SWITCHg(a, boolsign, [(DATAcon(trueDcon'),b),
146 :     (DATAcon(falseDcon'),c)], NONE)
147 :    
148 :     (****************************************************************************
149 :     * KIND ENVIRONMENTS *
150 :     ****************************************************************************)
151 :     type kenv = (LV.lvar list * tkind list) list
152 :    
153 :     val initKE = []
154 :     fun addKE(kenv, vs, ks) = (vs,ks)::kenv
155 :     fun vlookKE(kenv, i, j) =
156 :     let val (vs,_) = (List.nth(kenv, i-1)
157 :     handle _ => bug "unexpected case1 in vlookKE")
158 :     in ((List.nth(vs, j) handle _ => bug "unexpected case2 in vlookKE"))
159 :     end
160 :    
161 :     fun klookKE(kenv, i, j) =
162 :     let val (_,ks) = (List.nth(kenv, i-1)
163 :     handle _ => bug "unexpected case1 in klookKE")
164 :     in ((List.nth(ks, j) handle _ => bug "unexpected case2 in klookKE"))
165 :     end
166 :    
167 :     (****************************************************************************
168 :     * MAIN FUNCTIONS *
169 :     ****************************************************************************)
170 :    
171 :     val tkLty = LU.tkLty
172 :    
173 :     (* val tkLexp: kenv * tkind list -> kenv * (lexp -> lexp) *)
174 :     fun tkLexpG (kenv, ks, record) =
175 :     let val w = mkv()
176 :     val vs = map (fn _ => mkv ()) ks
177 :     val argt = record(map tkLty ks)
178 :     fun h([], i, base) = base
179 :     | h(v::r, i, base) = h(r, i+1, LET(v, SELECT(i, VAR w), base))
180 :     fun hdr le = FN(w, argt, h(vs, 0, le))
181 :     in (addKE(kenv, vs, ks), hdr)
182 :     end
183 :    
184 :     fun tkLexp (kenv, ks) = tkLexpG(kenv, ks, LT.ltc_str)
185 :    
186 :     (** mapping TC_VAR to proper lvars; TC_PRIM to proper constants *)
187 :     (** the actual type calculations should be lifted up till the innermost TFN *)
188 :     (* val tcLexp : kenv * tyc -> lexp *)
189 :    
190 :     val tcode_void = SVAL(INT 0)
191 :     val tcode_record = SVAL(INT 1)
192 :     val tcode_int32 = SVAL(INT 2)
193 :     val tcode_pair = SVAL(INT 3)
194 :     val tcode_fpair = SVAL(INT 4)
195 :     val tcode_real = SVAL(INT 5)
196 :     fun tcode_realN n = SVAL(INT(n * 5))
197 :    
198 :     datatype outcome
199 :     = YES
200 :     | NO
201 :     | MAYBE of lexp
202 :    
203 :     val intty = LT.ltc_int
204 :     val boolty = LT.ltc_bool
205 :     val inteqty = LT.ltc_arw(LT.ltc_tuple [intty, intty], boolty)
206 :     val intopty = LT.ltc_arw(LT.ltc_tuple [intty, intty], intty)
207 :     val ieq = SVAL(PRIM(PO.IEQL, inteqty, []))
208 :     val iadd = SVAL(PRIM(PO.IADD, intopty, []))
209 :    
210 :     fun tcLexp (kenv, tc) =
211 :     let fun loop x =
212 :     (case (tc_out x)
213 :     of (TC_FN(ks, tx)) =>
214 :     let val (nenv, hdr) = tkLexpG(kenv, ks, LT.ltc_tuple)
215 :     in hdr(tcLexp(nenv, tx))
216 :     end
217 :     | (TC_APP(tx, ts)) =>
218 :     (case tc_out tx
219 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>
220 :     APPg(loop tx, tcsLexp(kenv, ts))
221 :     | _ => tcode_void)
222 :     | (TC_SEQ ts) => tcsLexp(kenv, ts)
223 :     | (TC_PROJ(tx, i)) => SELECTg(i, loop tx)
224 :     | (TC_PRIM pt) =>
225 :     if (pt = PT.ptc_real) then tcode_real
226 :     else if (pt = PT.ptc_int32) then tcode_int32
227 :     else tcode_void
228 :     | (TC_VAR(i, j)) => SVAL(VAR(vlookKE(kenv, i, j)))
229 :     | (TC_TUPLE (_, [t1,t2])) =>
230 :     (case (isFloat(kenv,t1), isFloat(kenv,t2))
231 :     of (YES, YES) => tcode_fpair
232 :     | ((NO, _) | (_, NO)) => tcode_pair
233 :     | ((MAYBE e, YES) | (YES, MAYBE e)) =>
234 :     let val test = APPg(ieq, RECORDg[e, tcode_real])
235 :     in COND(test, tcode_fpair, tcode_pair)
236 :     end
237 :     | (MAYBE e1, MAYBE e2) =>
238 :     let val e = APPg(iadd, RECORDg [e1, e2])
239 :     val test = APPg(ieq, RECORDg [e, tcode_realN 2])
240 :     in COND(test, tcode_fpair, tcode_pair)
241 :     end)
242 :     | (TC_TUPLE (_, ts)) => tcode_record
243 :     | (TC_ARROW (_,tc1,tc2)) => tcode_void
244 :     | (TC_ABS tx) => loop tx
245 :     | (TC_BOX tx) => loop tx
246 :     | (TC_FIX((n,tx,ts), i)) =>
247 :     let val ntx =
248 :     (case ts
249 :     of [] => tx
250 :     | _ =>
251 :     (case tc_out tx
252 :     of TC_FN(_, x) => x
253 :     | _ => bug "unexpected FIX 333 in tcLexp-loop"))
254 :     val tk =
255 :     (case tc_out ntx
256 :     of TC_FN (ks, _) => List.nth(ks, i)
257 :     | _ => bug "unexpected FIX tycs in tcLexp-loop")
258 :     in case tk_out tk
259 :     of TK_FUN(ks, _) =>
260 :     (let val (_, hdr) =
261 :     tkLexpG(kenv, ks, LT.ltc_tuple)
262 :     in hdr(tcode_void)
263 :     end)
264 :     | _ => tcode_void
265 :     end
266 :     | (TC_SUM _) => bug "unexpected TC_SUM tyc in tcLexp-loop"
267 :     | (TC_ENV _) => bug "unexpected TC_ENV tyc in tcLexp-loop"
268 :     | (TC_CONT _) => bug "unexpected TC_CONT tyc in tcLexp-loop"
269 :     | (TC_IND _) => bug "unexpected TC_IND tyc in tcLexp-loop"
270 :     | (TC_NVAR _) => bug "unexpected TC_NVAR tyc in tcLexp-loop"
271 :     | _ => bug "unexpected tyc in tcLexp-loop")
272 :     in loop tc
273 :     end (* function tcLexp *)
274 :    
275 :     and tcsLexp (kenv, ts) =
276 :     let fun h tc = tcLexp(kenv, tc)
277 :     in RECORDg(map h ts)
278 :     end (* function tcsLexp *)
279 :    
280 :     and tsLexp (kenv, ts) =
281 :     let fun h tc = tcLexp(kenv, tc)
282 :     in SRECORDg(map h ts)
283 :     end (* function tsLexp *)
284 :    
285 :    
286 :     (** an improvement is to lift all of these code to the start of the
287 :     compilation unit *)
288 :     (*** THE FOLLOWING CODE IS ROUGH AND NEEDS TO BE POLISHED ! ***)
289 :     and isFloat (kenv, tc) =
290 :     let fun loop x =
291 :     (case (tc_out x)
292 :     of (TC_PRIM pt) =>
293 :     if (pt = PT.ptc_real) then YES else NO
294 :     | (TC_TUPLE (_, ts)) => NO
295 :     | (TC_ARROW (_,tc1,tc2)) => NO
296 :     | (TC_BOX tx) => NO (* this requires further thoughts ! *)
297 :     | (TC_FIX(_, i)) => NO
298 :     | (TC_APP(tx, _)) =>
299 :     (case tc_out tx
300 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>
301 :     MAYBE(tcLexp(kenv, x))
302 :     | _ => NO)
303 :     (* | (TC_ABS tx) => loop tx *)
304 :     | (TC_VAR(i,j)) =>
305 :     let val k = klookKE(kenv, i, j)
306 :     in case (tk_out k)
307 :     of TK_BOX => NO
308 :     | _ => MAYBE(tcLexp(kenv, x))
309 :     end
310 :     | _ => MAYBE(tcLexp(kenv, x)))
311 :    
312 :     in loop tc
313 :     end
314 :    
315 :     fun isPair (kenv, tc) =
316 :     let fun loop x =
317 :     (case (tc_out x)
318 :     of (TC_PRIM pt) => NO
319 :     | (TC_TUPLE (_, [_,_])) => YES
320 :     | (TC_TUPLE _) => NO
321 :     | (TC_ARROW _) => NO
322 :     | (TC_BOX tx) => NO (* this requires further thoughts !!! *)
323 :     | (TC_FIX(_, i)) => NO
324 :     | (TC_APP(tx, _)) =>
325 :     (case tc_out tx
326 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _ | TC_NVAR _) =>
327 :     MAYBE(tcLexp(kenv, x))
328 :     | _ => NO)
329 :     (* | (TC_ABS tx) => loop tx *)
330 :     | _ => MAYBE(tcLexp(kenv, x)))
331 :    
332 :     in loop tc
333 :     end
334 :    
335 :     (****************************************************************************
336 :     * TYPED INTERPRETATION OF UNTAGGED *
337 :     ****************************************************************************)
338 :     (** tc is of kind Omega; this function tests whether tc can be int31 ? *)
339 :     fun tcTag (kenv, tc) =
340 :     let fun loop x =
341 :     (case (tc_out x)
342 :     of (TC_PRIM pt) => if PT.unboxed pt then NO else YES
343 :     (* this is just an approximation *)
344 :     | (TC_TUPLE (_, ts)) => NO
345 :     | (TC_ARROW (_,tc1,tc2)) => YES
346 :     | (TC_ABS tx) => loop tx
347 :     | (TC_BOX tx) => loop tx
348 :     | (TC_FIX(_, i)) => YES
349 :     | (TC_APP(tx, _)) =>
350 :     (case tc_out tx
351 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>
352 :     (let val e1 = tcLexp(kenv, x)
353 :     in MAYBE(APPg(ieq, RECORDg[e1, tcode_void]))
354 :     end)
355 :     | _ => YES)
356 :     | _ => (let val e1 = tcLexp(kenv, x)
357 :     in MAYBE(APPg(ieq, RECORDg[e1, tcode_void]))
358 :     end))
359 :     in loop tc
360 :     end (* function tcTag *)
361 :    
362 :     (* val utgc : kenv * tyc -> lexp -> lexp *)
363 :     fun utgc (kenv, tc) =
364 :     (case tcTag(kenv, tc)
365 :     of YES => (fn le => WRAPg(LT.tcc_tuple [tc], true, RECORDg[le]))
366 :     | NO => (fn le => le)
367 :     | MAYBE ne =>
368 :     let fun h(x as (SVAL(VAR v))) =
369 :     COND(ne, WRAPg(LT.tcc_tuple [tc], true, RECORDg [x]),
370 :     x)
371 :     | h x =
372 :     let val w = mkv()
373 :     in LET(w, x,
374 :     COND(ne, WRAPg(LT.tcc_tuple [tc], true, RECORD [VAR w]),
375 :     SVAL(VAR w)))
376 :     end
377 :     in h
378 :     end)
379 :    
380 :     (* val utgd : kenv * tyc -> lexp -> lexp *)
381 :     fun utgd (kenv, tc) =
382 :     (case tcTag(kenv, tc)
383 :     of YES =>
384 :     (fn le => SELECTg(0, UNWRAPg(LT.tcc_tuple [tc], true, le)))
385 :     | NO => (fn le => le)
386 :     | MAYBE ne =>
387 :     let fun h(x as (SVAL(VAR v))) =
388 :     COND(ne, SELECTg(0, UNWRAPg(LT.tcc_tuple [tc], true, x)), x)
389 :     | h x =
390 :     let val w = mkv()
391 :     in LET(w, x,
392 :     COND(ne, SELECTg(0, UNWRAP(LT.tcc_tuple [tc],true,VAR w)),
393 :     SVAL(VAR w)))
394 :     end
395 :     in h
396 :     end)
397 :    
398 :     (* val tgdc : kenv * int * tyc -> lexp -> lexp *)
399 :     fun tgdc (kenv, i, tc) =
400 :     let val nt = LT.tcc_tuple [LT.tcc_int, tc]
401 :     in (fn le => WRAPg(nt, true, RECORDg [SVAL(INT i), le]))
402 :     end
403 :    
404 :     (* val tgdd : kenv * int * tyc -> lexp -> lexp *)
405 :     fun tgdd (kenv, i, tc) =
406 :     let val nt = LT.tcc_tuple [LT.tcc_int, tc]
407 :     in (fn le => SELECTg(1, UNWRAPg(nt, true, le)))
408 :     end
409 :    
410 :    
411 :     (****************************************************************************
412 :     * TYPED INTERPRETATION OF FP RECORD *
413 :     ****************************************************************************)
414 :     (** tc is a ground tyc of kind Omega, only record types and arrow types are
415 :     interesting for the time being. *)
416 :     (** all of these wrappers probably should be lifted to the top of the
417 :     program, otherwise we may run into space blow-up ! *)
418 :     (* val tcCoerce : kenv * tyc * bool * bool -> (lexp -> lexp) option *)
419 :     fun tcCoerce (kenv, tc, wflag, b) =
420 :     (case tc_out tc
421 :     of TC_TUPLE (_, ts) =>
422 :     let fun h([], i, e, el, 0) = NONE
423 :     | h([], i, e, el, res) =
424 :     let val w = mkv()
425 :     val wx = VAR w
426 :     fun g(i, NONE) = SELECT(i, wx)
427 :     | g(i, SOME _) =
428 :     if wflag then
429 :     UNWRAPg(LT.tcc_real, b, SELECT(i, wx))
430 :     else WRAPg(LT.tcc_real, b, SELECT(i, wx))
431 :    
432 :     val ntc = LT.tcc_tuple(map (fn _ => LT.tcc_real) ts)
433 :    
434 :     val ne = RECORDg (map g (rev el))
435 :     val test = APPg(ieq, RECORDg[e, tcode_realN res])
436 :    
437 :     fun hdr0 xe =
438 :     if wflag then
439 :     COND(test, LET(w, xe, WRAPcast(ntc, b, ne)),
440 :     WRAPcast(tc, b, xe))
441 :     else COND(test, LET(w, UNWRAPcast(ntc, b, xe), ne),
442 :     UNWRAPcast(tc, b, xe))
443 :    
444 :     fun hdr (xe as (SVAL(VAR _))) = hdr0 xe
445 :     | hdr xe = let val z = mkv()
446 :     in LET(z, xe, hdr0 (SVAL(VAR z)))
447 :     end
448 :     in SOME hdr
449 :     end
450 :     | h(a::r, i, e, el, res) =
451 :     (case isFloat(kenv, a)
452 :     of NO => NONE
453 :     | YES => h(r, i+1, e, (i,NONE)::el, res)
454 :     | MAYBE z => h(r, i+1, APPg(iadd, RECORDg [e, z]),
455 :     (i, SOME a)::el, res+1))
456 :    
457 :     in h(ts, 0, SVAL(INT 0), [], 0)
458 :     end
459 :     | TC_ARROW _ => (* (tc1, tc2) => *)
460 :     let val (tc1, tc2) = LT.tcd_parrow tc
461 :     in (case isPair(kenv, tc1)
462 :     of (YES | NO) => NONE
463 :     | (MAYBE e) =>
464 :     let val w = mkv()
465 :     val test1 = APPg(ieq, RECORDg[SVAL(VAR w), tcode_pair])
466 :     val test2 = APPg(ieq, RECORDg[SVAL(VAR w), tcode_fpair])
467 :     val m = mkv()
468 :     val n = mkv()
469 :    
470 :     val tc_real = LT.tcc_real
471 :     val tc_breal = LT.tcc_box tc_real
472 :     val tc_void = LT.tcc_void
473 :     val lt_void = LT.ltc_void
474 :     val tc_pair = LT.tcc_tuple [tc_void, tc_void]
475 :     val tc_fpair = LT.tcc_tuple [tc_real, tc_real]
476 :     val tc_bfpair = LT.tcc_tuple [tc_breal, tc_breal]
477 :     val lt_pair = LT.ltc_tyc tc_pair
478 :     val lt_fpair = LT.ltc_tyc tc_fpair
479 :     val lt_bfpair = LT.ltc_tyc tc_bfpair
480 :     val ident = fn le => le
481 :    
482 :     val (argt1, body1, hh1, ih1) =
483 :     if wflag then (* wrapping *)
484 :     (lt_pair, WRAP(tc_pair, true, VAR m),
485 :     fn le => WRAPcast(LT.tcc_parrow(tc_pair,tc2), true, le),
486 :     ident)
487 :     else (* unwrapping *)
488 :     let val q = mkv()
489 :     in (lt_void, UNWRAP(tc_pair, true, VAR m),ident,
490 :     fn le => UNWRAPcast(LT.tcc_parrow(tc_pair, tc2),
491 :     true, le))
492 :     end
493 :    
494 :     val (argt2, body2, hh2, ih2) =
495 :     if wflag then
496 :     (lt_bfpair, WRAPg(tc_fpair, true,
497 :     RECORDg [UNWRAPg(tc_real, true, SELECT(0, VAR n)),
498 :     UNWRAPg(tc_real, true, SELECT(1, VAR n))]),
499 :     fn le => WRAPcast(LT.tcc_parrow(tc_bfpair,tc2), true, le),
500 :     ident)
501 :     else
502 :     let val q = mkv()
503 :     in (lt_void, LET(q, UNWRAP(tc_fpair, true, VAR n),
504 :     RECORDg [WRAPg(tc_real, true, SELECT(0, VAR q)),
505 :     WRAPg(tc_real, true, SELECT(1, VAR q))]),
506 :     ident,
507 :     fn le => UNWRAPcast(LT.tcc_parrow(tc_bfpair, tc2),
508 :     true, le))
509 :     end
510 :    
511 :     val hh3 = if wflag then fn le => WRAPcast(tc, true, le)
512 :     else fn le => UNWRAPcast(tc, true, le)
513 :    
514 :     (*** NEEDS MORE WORK TO DO THE RIGHT COERCIONS ***)
515 :     fun hdr0(sv) =
516 :     LET(w, e,
517 :     COND(test1, hh1(FN(m, argt1,
518 :     APPg(ih1(SVAL sv), body1))),
519 :     COND(test2, hh2(FN(n, argt2,
520 :     APPg(ih2(SVAL sv), body2))),
521 :     hh3(SVAL sv))))
522 :    
523 :     fun hdr (xe as SVAL sv) = hdr0 sv
524 :     | hdr xe = let val z = mkv()
525 :     in LET(z, xe, hdr0(VAR z))
526 :     end
527 :     in SOME hdr
528 :     end)
529 :     end
530 :     | _ => NONE)
531 :    
532 :     (* val mkwrp : kenv * bool * tyc -> lexp -> lexp *)
533 :     fun mkwrp (kenv, b, tc) =
534 :     (case tcCoerce(kenv, tc, true, b)
535 :     of NONE => (fn le => WRAPg(tc, b, le))
536 :     | SOME hdr => hdr)
537 :    
538 :     (* val mkuwp : kenv * bool * tyc -> lexp -> lexp *)
539 :     fun mkuwp (kenv, b, tc) =
540 :     (case tcCoerce(kenv, tc, false, b)
541 :     of NONE => (fn le => UNWRAPg(tc, b, le))
542 :     | SOME hdr => hdr)
543 :    
544 :     val realSub = PO.NUMSUBSCRIPT{kind=PO.FLOAT 64, checked=false, immutable=false}
545 :     val realUpd = PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}
546 :    
547 :     fun arrSub(kenv, lt, tc) =
548 :     let val nt = LT.lt_pinst_st(lt, [tc])
549 :     val rnt = LT.lt_pinst_st(lt, [LT.tcc_real])
550 :     in (case isFloat(kenv, tc)
551 :     of NO => (fn sv => APP(PRIM(PO.SUBSCRIPT, nt, []), sv))
552 :     | YES => (fn sv => WRAPg(LT.tcc_real, true,
553 :     APP(PRIM(realSub, rnt, []), sv)))
554 :     | MAYBE z =>
555 :     (let val test = APPg(ieq, RECORDg[z, tcode_real])
556 :     in (fn sv =>
557 :     COND(test, WRAPg(LT.tcc_real, true,
558 :     APP(PRIM(realSub, rnt, []), sv)),
559 :     APP(PRIM(PO.SUBSCRIPT, nt, []), sv)))
560 :     end))
561 :     end
562 :    
563 :     fun arrUpd(kenv, lt, tc) =
564 :     let val nt = LT.lt_pinst_st(lt, [tc])
565 :     val rnt = LT.lt_pinst_st(lt, [LT.tcc_real])
566 :     in (case isFloat(kenv,tc)
567 :     of NO => (fn sv => APP(PRIM(PO.UPDATE, nt, []), sv))
568 :     | YES => (fn sv => APPg(SVAL(PRIM(realUpd, rnt, [])),
569 :     RECORDg[SELECT(0, sv),
570 :     SELECT(1, sv),
571 :     UNWRAPg(LT.tcc_real, true,
572 :     SELECT(2, sv))]))
573 :     | MAYBE z =>
574 :     (let val test = APPg(ieq, RECORDg[z, tcode_real])
575 :     in (fn sv =>
576 :     COND(test, APPg(SVAL(PRIM(realUpd, rnt, [])),
577 :     RECORDg[SELECT(0, sv),
578 :     SELECT(1, sv),
579 :     UNWRAPg(LT.tcc_real, true,
580 :     SELECT(2, sv))]),
581 :     APP(PRIM(PO.UPDATE, nt, []), sv)))
582 :     end))
583 :     end
584 :    
585 :     fun arrNew(kenv, lt, tc, pv, rv) =
586 :     (case isFloat(kenv,tc)
587 :     of NO => (fn sv => APPg(APPg(SVAL(VAR pv), tsLexp(kenv, [tc])), SVAL sv))
588 :     | YES => (fn sv => APPg(SVAL(VAR rv),
589 :     RECORDg [SELECT(0, sv),
590 :     UNWRAPg(LT.tcc_real, true, SELECT(1, sv))]))
591 :     | MAYBE z =>
592 :     (let val test = APPg(ieq, RECORDg[z, tcode_real])
593 :     in (fn sv =>
594 :     COND(test, APPg(SVAL(VAR rv),
595 :     RECORDg [SELECT(0, sv),
596 :     UNWRAPg(LT.tcc_real, true, SELECT(1, sv))]),
597 :     APPg(APPg(SVAL(VAR pv), tsLexp(kenv, [tc])), SVAL sv)))
598 :     end))
599 :    
600 :     end (* toplevel local *)
601 :     end (* structure TypeOper *)
602 :    
603 :    
604 :     (*
605 :     * $Log: ltyprim.sml,v $
606 :     * Revision 1.5 1998/01/07 15:18:16 dbm
607 :     * Fixing bug 1323. Wrapping and unwrapping primitives were usually ignored
608 :     * in the cpstrans phase before we perform the cps optimization. Unfortunately,
609 :     * they could lead to ill-typed CPS programs. To resolve this, I turn those
610 :     * sensitive wrap and unwrap primitives into "casts"; I leave the casts in the
611 :     * code; the cps generic phase will generate a move for each cast. In the
612 :     * long term, we have to think thoroughly about the meanings of these wrapping
613 :     * primitives and how they interface with compile-time optimizations.
614 :     *
615 :     * Revision 1.4 1997/05/05 20:00:13 george
616 :     * Change the term language into the quasi-A-normal form. Added a new round
617 :     * of lambda contraction before and after type specialization and
618 :     * representation analysis. Type specialization including minimum type
619 :     * derivation is now turned on all the time. Real array is now implemented
620 :     * as realArray. A more sophisticated partial boxing scheme is added and
621 :     * used as the default.
622 :     *
623 :     * Revision 1.3 1997/04/18 15:49:02 george
624 :     * Cosmetic changes on some constructor names. Changed the shape for
625 :     * FIX type to potentially support shared dtsig. -- zsh
626 :     *
627 :     * Revision 1.2 1997/02/26 21:53:57 george
628 :     * Fixing the incorrect wrapper bug, BUG 1158, reported by Ken Cline
629 :     * (zcline.sml). This also fixes the core dump bug, BUG 1153,
630 :     * reported by Nikolaj.
631 :     *
632 :     *)

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