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/branches/primop-branch-2/src/compiler/FLINT/reps/rttype.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-2/src/compiler/FLINT/reps/rttype.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2014 - (view) (download)

1 : monnier 41 (* Copyright 1998 YALE FLINT PROJECT *)
2 :     (* rttype.sml *)
3 :    
4 :     signature RTTYPE =
5 :     sig
6 :     type tcode
7 :    
8 : monnier 197 type rtype
9 : monnier 41 val tcode_void : tcode
10 :     val tcode_record : tcode
11 :     val tcode_int32 : tcode
12 :     val tcode_pair : tcode
13 :     val tcode_fpair : tcode
14 :     val tcode_real : tcode
15 :     val tcode_realN : int -> tcode
16 :    
17 :     val tovalue : tcode -> FLINT.value
18 : monnier 197 (* val rtLexp : TypeOper.kenv -> TypeOper.tyc -> rtype *)
19 :    
20 : monnier 41 end (* signature RTTYPE *)
21 :    
22 : monnier 197 structure RuntimeType (* :> RTTYPE *) =
23 : monnier 41 struct
24 : monnier 197
25 :     local structure DI = DebIndex
26 :     structure LT = LtyExtern
27 :     structure PO = PrimOp
28 :     structure PT = PrimTyc
29 :     structure LV = LambdaVar
30 : macqueen 2014 open Lty LtyKernel FLINT
31 : monnier 197 in
32 :    
33 : monnier 41 type tcode = int
34 : monnier 197 type rtype = FLINT.lexp
35 :    
36 :     fun bug s = ErrorMsg.impossible ("RuntimeType: " ^ s)
37 :     fun say (s : string) = Control.Print.say s
38 :     fun mkv _ = LV.mkLvar()
39 :     val ident = fn le => le
40 :     val fkfun = {isrec=NONE, known=false, inline=IH_ALWAYS, cconv=CC_FUN LT.ffc_fixed}
41 :     val fkfct = {isrec=NONE, known=false, inline=IH_SAFE, cconv=CC_FCT}
42 :    
43 :     fun mkarw(ts1, ts2) = LT.tcc_arrow(LT.ffc_fixed, ts1, ts2)
44 :    
45 :     val lt_arw = LT.ltc_tyc o LT.tcc_arrow
46 :     fun wty tc =
47 :     (NONE, PO.WRAP, lt_arw(LT.ffc_fixed, [tc], [LT.tcc_void]), [])
48 :     fun uwty tc =
49 :     (NONE, PO.UNWRAP, lt_arw(LT.ffc_fixed, [LT.tcc_void], [tc]), [])
50 :    
51 :     fun FU_WRAP(tc, vs, v, e) = PRIMOP(wty tc, vs, v, e)
52 :     fun FU_UNWRAP(tc, vs, v, e) = PRIMOP(uwty tc, vs, v, e)
53 :     val FU_rk_tuple = FlintUtil.rk_tuple
54 :    
55 :     fun WRAP(t, u) =
56 :     let val v = mkv()
57 :     in FU_WRAP(t, [u], v, RET[VAR v])
58 :     end
59 :    
60 :     fun UNWRAP(t, u) =
61 :     let val v = mkv()
62 :     in FU_UNWRAP(t, [u], v, RET[VAR v])
63 :     end
64 :    
65 :     (****************************************************************************
66 :     * UTILITY FUNCTIONS AND CONSTANTS *
67 :     ****************************************************************************)
68 :     fun split(RET [v]) = (v, ident)
69 :     | split x = let val v = mkv()
70 :     in (VAR v, fn z => LET([v], x, z))
71 :     end
72 :    
73 :     fun SELECTg(i, e) =
74 :     let val (v, hdr) = split e
75 :     val x = mkv()
76 :     in hdr(SELECT(v, i, x, RET [VAR x]))
77 :     end
78 :    
79 :     fun FNg(vts, e) =
80 :     let val f = mkv()
81 :     in FIX([(fkfun, f, vts, e)], RET[VAR f])
82 :     end
83 :    
84 :     fun SELECTv(i, u) =
85 :     let val x = mkv()
86 :     in SELECT(u, i, x, RET [VAR x])
87 :     end
88 :    
89 : monnier 220 fun APPg(e1, e2) =
90 : monnier 197 let val (v1, h1) = split e1
91 : monnier 220 val (v2, h2) = split e2
92 :     in h1(h2(APP(v1, [v2])))
93 : monnier 197 end
94 :    
95 : monnier 220 fun RECORDg es =
96 :     let fun f ([], vs, hdr) =
97 :     let val x = mkv()
98 :     in hdr(RECORD(FU_rk_tuple, rev vs, x, RET[VAR x]))
99 :     end
100 : monnier 197 | f (e::r, vs, hdr) =
101 :     let val (v, h) = split e
102 :     in f(r, v::vs, hdr o h)
103 :     end
104 :     in f(es, [], ident)
105 :     end
106 :    
107 : monnier 220 fun SRECORDg es =
108 :     let fun f ([], vs, hdr) =
109 :     let val x = mkv()
110 :     in hdr(RECORD(RK_STRUCT, rev vs, x, RET[VAR x]))
111 :     end
112 :     | f (e::r, vs, hdr) =
113 :     let val (v, h) = split e
114 :     in f(r, v::vs, hdr o h)
115 :     end
116 :     in f(es, [], ident)
117 :     end
118 :    
119 : monnier 197 fun WRAPg (z, b, e) =
120 :     let val (v, h) = split e
121 :     in h(WRAP(z, v))
122 :     end
123 :    
124 :     fun UNWRAPg (z, b, e) =
125 :     let val (v, h) = split e
126 :     in h(UNWRAP(z, v))
127 :     end
128 :    
129 :     fun WRAPcast (z, b, e) =
130 :     let val (v, h) = split e
131 :     val pt = LT.ltc_arrow(LT.ffc_fixed, [LT.ltc_tyc z], [LT.ltc_void])
132 :     val pv = (NONE,PO.CAST,pt,[])
133 :     val x = mkv()
134 :     in h(PRIMOP(pv, [v], x, RET[VAR x]))
135 :     end
136 :    
137 :     fun UNWRAPcast (z, b, e) =
138 :     let val (v, h) = split e
139 :     val pt = LT.ltc_arrow(LT.ffc_fixed, [LT.ltc_void], [LT.ltc_tyc z])
140 :     val pv = (NONE,PO.CAST,pt,[])
141 :     val x = mkv()
142 :     in h(PRIMOP(pv, [v], x, RET[VAR x]))
143 :     end
144 :    
145 :     fun SWITCHg (e, s, ce, d) =
146 :     let val (v, h) = split e
147 :     in h(SWITCH(v, s, ce, d))
148 :     end
149 :    
150 :     fun COND(u,e1,e2) = u(e1,e2)
151 :    
152 :     fun WRAP(t, u) =
153 :     let val v = mkv()
154 :     in FU_WRAP(t, [u], v, RET[VAR v])
155 :     end
156 :    
157 :     fun UNWRAP(t, u) =
158 :     let val v = mkv()
159 :     in FU_UNWRAP(t, [u], v, RET[VAR v])
160 :     end
161 :    
162 :    
163 :     val intty = LT.ltc_int
164 :     val boolty = (* LT.ltc_bool *) LT.ltc_void
165 :     val inteqty = LT.ltc_arrow(LT.ffc_fixed, [intty, intty], [boolty])
166 :     val intopty = LT.ltc_arrow(LT.ffc_fixed, [intty, intty], [intty])
167 :     val ieqprim = (NONE, PO.IEQL, inteqty, [])
168 :     val iaddprim = (NONE, PO.IADD, intopty, [])
169 :     fun ieqLexp (e1, e2) =
170 :     let val (v1, h1) = split e1
171 :     val (v2, h2) = split e2
172 :     in fn (te, fe) => h1(h2(BRANCH(ieqprim, [v1,v2], te, fe)))
173 :     end
174 :     fun iaddLexp (e1, e2) =
175 :     let val (v1, h1) = split e1
176 :     val (v2, h2) = split e2
177 :     val x = mkv ()
178 :     in h1(h2(PRIMOP(iaddprim, [v1,v2], x, RET[VAR x])))
179 :     end
180 :    
181 :    
182 : monnier 41 val tcode_void = 0
183 :     val tcode_record = 1
184 :     val tcode_int32 = 2
185 :     val tcode_pair = 3
186 :     val tcode_fpair = 4
187 :     val tcode_real = 5
188 :     fun tcode_realN n = n * 5
189 :    
190 : monnier 197
191 : monnier 41 fun tovalue i = FLINT.INT i
192 : monnier 197 val tolexp = fn tcode => RET[tovalue tcode]
193 :     val tcode_void : lexp = tolexp tcode_void
194 :     val tcode_record : lexp = tolexp tcode_record
195 :     val tcode_int32 : lexp = tolexp tcode_int32
196 :     val tcode_pair : lexp = tolexp tcode_pair
197 :     val tcode_fpair : lexp = tolexp tcode_fpair
198 :     val tcode_real : lexp = tolexp tcode_real
199 :     val tcode_realN : int -> lexp = fn i => tolexp (tcode_realN i)
200 :    
201 :     datatype outcome
202 :     = YES
203 :     | NO
204 :     | MAYBE of lexp
205 :    
206 :     (****************************************************************************
207 :     * KIND ENVIRONMENTS *
208 :     ****************************************************************************)
209 :    
210 :     type kenv = (LV.lvar list * tkind list) list
211 :    
212 :     val initKE = []
213 :     fun addKE(kenv, vs, ks) = (vs,ks)::kenv
214 :     fun vlookKE(kenv, i, j) =
215 :     let val (vs,_) = (List.nth(kenv, i-1)
216 :     handle _ => bug "unexpected case1 in vlookKE")
217 :     in ((List.nth(vs, j) handle _ => bug "unexpected case2 in vlookKE"))
218 :     end
219 :    
220 :     fun klookKE(kenv, i, j) =
221 :     let val (_,ks) = (List.nth(kenv, i-1)
222 :     handle _ => bug "unexpected case1 in klookKE")
223 :     in ((List.nth(ks, j) handle _ => bug "unexpected case2 in klookKE"))
224 :     end
225 :    
226 :    
227 :     (* val tkAbsGen : kenv * lvar list * tkind list * lvar * fkind
228 :     -> kenv * ((lexp *lexp) -> lexp) *)
229 :     fun tkAbsGen (kenv, vs, ks, f, fk) =
230 : monnier 220 let val mkArgTy = case fk of {cconv=CC_FUN _,...} => LT.ltc_tuple
231 :     | {cconv=CC_FCT,...} => LT.ltc_str
232 :     val argt = mkArgTy (map LT.tk_lty ks)
233 :    
234 :     val w = mkv()
235 :     fun h([], i, base) = base
236 :     | h(v::r, i, base) = h(r, i+1, SELECT(VAR w, i, v, base))
237 :    
238 :     fun hdr (e1, e2) = FIX([(fk, f, [(w, argt)], h(vs,0,e1))], e2)
239 : monnier 197 in (addKE(kenv, vs, ks), hdr)
240 :     end
241 :    
242 :     (* val tkAbs: kenv * (tvar * tkind) list -> kenv * (lexp * lexp -> lexp) *)
243 :     fun tkAbs (kenv, tvks, f) =
244 :     let val (vs, ks) = ListPair.unzip tvks
245 :     in tkAbsGen(kenv, vs, ks, f, fkfct)
246 :     end
247 :    
248 :     (* val tkTfn: kenv * tkind list -> kenv * (lexp -> lexp) *)
249 :     fun tkTfn (kenv, ks) =
250 :     let val vs = map (fn _ => mkv ()) ks
251 :     val f = mkv()
252 :     val (nkenv, hdr) = tkAbsGen(kenv, vs, ks, f, fkfun)
253 :     in (nkenv, fn e => hdr(e, RET[VAR f]))
254 :     end
255 :    
256 :    
257 :     (* rtLexp maps TC_VAR to proper lvars, TC_PRIM to proper constants *)
258 :     (* val rtLexp : kenv -> tyc -> rtype *)
259 :    
260 :     fun rtLexp (kenv : kenv) (tc : tyc) =
261 :     let fun loop (x : tyc) =
262 :     (case (tc_out x)
263 :     of (TC_FN(ks, tx)) =>
264 :     let val (nenv, hdr) = tkTfn(kenv, ks)
265 :     in hdr(rtLexp nenv tx)
266 :     end
267 :     | (TC_APP(tx, ts)) =>
268 :     (case tc_out tx
269 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>
270 :     APPg(loop tx, tcsLexp(kenv, ts))
271 :     | _ => tcode_void)
272 : monnier 220 | (TC_SEQ ts) => tcsLexp(kenv, ts)
273 : monnier 197 | (TC_PROJ(tx, i)) => SELECTg(i, loop tx)
274 :     | (TC_PRIM pt) =>
275 :     if (pt = PT.ptc_real) then tcode_real
276 :     else if (pt = PT.ptc_int32) then tcode_int32
277 :     else tcode_void
278 :     | (TC_VAR(i, j)) => RET[(VAR(vlookKE(kenv, i, j)))]
279 :     | (TC_TUPLE (_, [t1,t2])) =>
280 :     (case (isFloat(kenv,t1), isFloat(kenv,t2))
281 :     of (YES, YES) => tcode_fpair
282 :     | ((NO, _) | (_, NO)) => tcode_pair
283 :     | ((MAYBE e, YES) | (YES, MAYBE e)) =>
284 :     let val test = ieqLexp(e, tcode_real)
285 :     in COND(test, tcode_fpair, tcode_pair)
286 :     end
287 :     | (MAYBE e1, MAYBE e2) =>
288 :     let val e = iaddLexp(e1, e2)
289 :     val test = ieqLexp(e, tcode_realN 2)
290 :     in COND(test, tcode_fpair, tcode_pair)
291 :     end)
292 :     | (TC_TUPLE (_, [])) => tcode_void
293 :     | (TC_TUPLE (_, ts)) => tcode_record
294 :     | (TC_ARROW (_,tc1,tc2)) => tcode_void
295 :     | (TC_ABS tx) => loop tx
296 :     | (TC_TOKEN(_,tx)) => loop tx
297 :     | (TC_FIX((n,tx,ts), i)) =>
298 :     let val ntx =
299 :     (case ts
300 :     of [] => tx
301 :     | _ =>
302 :     (case tc_out tx
303 :     of TC_FN(_, x) => x
304 :     | _ => bug "unexpected FIX 333 in rtLexp-loop"))
305 :     val tk =
306 :     (case tc_out ntx
307 :     of TC_FN (ks, _) => List.nth(ks, i)
308 :     | _ => bug "unexpected FIX tycs in rtLexp-loop")
309 :     in case tk_out tk
310 :     of TK_FUN(ks, _) =>
311 :     (let val (_, hdr) = tkTfn(kenv, ks)
312 :     in hdr(tcode_void)
313 :     end)
314 :     | _ => tcode_void
315 :     end
316 :     | (TC_SUM _) => bug "unexpected TC_SUM tyc in rtLexp-loop"
317 :     | (TC_ENV _) => bug "unexpected TC_ENV tyc in rtLexp-loop"
318 :     | (TC_CONT _) => bug "unexpected TC_CONT tyc in rtLexp-loop"
319 :     | (TC_IND _) => bug "unexpected TC_IND tyc in rtLexp-loop"
320 :     | (TC_NVAR v) => RET[VAR v]
321 :     | _ => bug "unexpected tyc in rtLexp-loop")
322 :     in loop tc
323 :     end (* function rtLexp *)
324 :    
325 :     and tcsLexp (kenv, ts) =
326 :     let fun h tc = rtLexp kenv tc
327 : monnier 220 in RECORDg(map h ts)
328 : monnier 197 end (* function tcsLexp *)
329 :    
330 :     and tsLexp (kenv, ts) =
331 :     let fun h tc = rtLexp kenv tc
332 : monnier 220 in SRECORDg(map h ts)
333 : monnier 197 end (* function tsLexp *)
334 :    
335 :     and isFloat (kenv, tc) =
336 :     let fun loop x =
337 :     (case (tc_out x)
338 :     of (TC_PRIM pt) =>
339 :     if (pt = PT.ptc_real) then YES else NO
340 :     | (TC_TUPLE (_, ts)) => NO
341 :     | (TC_ARROW (_,tc1,tc2)) => NO
342 :     | (TC_TOKEN(_,tx)) => loop tx
343 :     | (TC_FIX(_, i)) => NO
344 :     | (TC_APP(tx, _)) =>
345 :     (case tc_out tx
346 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>
347 :     MAYBE(rtLexp kenv x)
348 :     | _ => NO)
349 :     (* | (TC_ABS tx) => loop tx *)
350 :     | (TC_VAR(i,j)) =>
351 :     let val k = klookKE(kenv, i, j)
352 :     in case (tk_out k)
353 :     of TK_BOX => NO
354 :     | _ => MAYBE(rtLexp kenv x)
355 :     end
356 :     | _ => MAYBE(rtLexp kenv x))
357 :    
358 :     in loop tc
359 :     end
360 :    
361 :     fun isPair (kenv, tc) =
362 :     let fun loop x =
363 :     (case (tc_out x)
364 :     of (TC_PRIM pt) => NO
365 :     | (TC_TUPLE (_, [_,_])) => YES
366 :     | (TC_TUPLE _) => NO
367 :     | (TC_ARROW _) => NO
368 :     | (TC_TOKEN(_,tx)) => loop tx
369 :     | (TC_FIX(_, i)) => NO
370 :     | (TC_APP(tx, _)) =>
371 :     (case tc_out tx
372 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _ | TC_NVAR _) =>
373 :     MAYBE(rtLexp kenv x)
374 :     | _ => NO)
375 :     (* | (TC_ABS tx) => loop tx *)
376 :     | _ => MAYBE(rtLexp kenv x))
377 :    
378 :     in loop tc
379 :     end
380 :    
381 :    
382 :    
383 :     end (* local *)
384 : monnier 41 end (* structure RuntimeType *)
385 :    

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