Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/FLINT/reps/rttype.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/reps/rttype.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 196, Fri Nov 20 18:16:19 1998 UTC revision 197, Sun Nov 22 01:25:23 1998 UTC
# Line 5  Line 5 
5  sig  sig
6    type tcode    type tcode
7    
8      type rtype
9    val tcode_void   : tcode    val tcode_void   : tcode
10    val tcode_record : tcode    val tcode_record : tcode
11    val tcode_int32  : tcode    val tcode_int32  : tcode
# Line 14  Line 15 
15    val tcode_realN  : int -> tcode    val tcode_realN  : int -> tcode
16    
17    val tovalue      : tcode -> FLINT.value    val tovalue      : tcode -> FLINT.value
18    (*  val rtLexp       : TypeOper.kenv -> TypeOper.tyc -> rtype *)
19    
20  end (* signature RTTYPE *)  end (* signature RTTYPE *)
21    
22  structure RuntimeType :> RTTYPE =  structure RuntimeType (* :> RTTYPE *) =
23  struct  struct
24    
25    local structure DI = DebIndex
26          structure LT = LtyExtern
27          structure PO = PrimOp
28          structure PT = PrimTyc
29          structure LV = LambdaVar
30          open LtyKernel FLINT
31    in
32    
33    type tcode = int    type tcode = int
34      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    fun APPg(e1, e2) =
90      let val (v1, h1) = split e1
91          val (v2, h2) = split e2
92       in h1(h2(APP(v1, [v2])))
93      end
94    
95    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            | 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    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    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    val tcode_void = 0    val tcode_void = 0
183    val tcode_record = 1    val tcode_record = 1
184    val tcode_int32 = 2    val tcode_int32 = 2
# Line 27  Line 187 
187    val tcode_real = 5    val tcode_real = 5
188    fun tcode_realN n = n * 5    fun tcode_realN n = n * 5
189    
190    
191    fun tovalue i = FLINT.INT i    fun tovalue i = FLINT.INT i
192  end (* structure RuntimeType *)    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      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       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               | (TC_SEQ ts) => tcsLexp(kenv, ts)
273               | (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       in RECORDg(map h ts)
328      end (* function tcsLexp *)
329    
330    and tsLexp (kenv, ts) =
331      let fun h tc = rtLexp kenv tc
332       in SRECORDg(map h ts)
333      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    end (* structure RuntimeType *)
385    
386    
 (*  
  * $Log$  
  *)  

Legend:
Removed from v.196  
changed lines
  Added in v.197

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