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/FLINT/src/compiler/FLINT/reps/ltyutil.sml
ViewVC logotype

Annotation of /sml/branches/FLINT/src/compiler/FLINT/reps/ltyutil.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)
Original Path: sml/trunk/src/compiler/FLINT/reps/ltyutil.sml

1 : monnier 16 (* Copyright (c) 1997 YALE FLINT PROJECT *)
2 :     (* ltyutil.sml *)
3 :    
4 :     (*** this file will go away soon *)
5 :    
6 :     signature LTYUTIL = sig
7 :    
8 :     type tkind = LtyDef.tkind
9 :     type tyc = LtyDef.tyc
10 :     type lty = LtyDef.lty
11 :    
12 :     (** used by the coercion and wrapping *)
13 :     val tcWrap : tyc -> tyc option
14 :     val genWrap : bool -> ((tyc -> tyc option) * (lty -> lty option)
15 :     * (tyc list -> tyc list option))
16 :    
17 :     (** type convertion; used by the reify phase *)
18 :     val tkLty : tkind -> lty
19 :    
20 :     (** used by the ltNarrow phase *)
21 :     val narrowGen : unit -> ((tyc -> tyc) * (lty -> lty) * (unit -> unit))
22 :    
23 :     end
24 :    
25 :     structure LtyUtil : LTYUTIL =
26 :     struct
27 :    
28 :     local structure DA = Access
29 :     structure DI = DebIndex
30 :     structure LT = LtyExtern
31 :     structure PO = PrimOp
32 :     structure PT = PrimTyc
33 :     open LtyKernel
34 :     in
35 :    
36 :     fun bug s = ErrorMsg.impossible ("LtyUtil: " ^ s)
37 :     val say = Control.Print.say
38 :     fun fromto(i,j) = if i < j then (i::fromto(i+1,j)) else []
39 :    
40 :     fun option(NONE) = false
41 :     | option(SOME _) = true
42 :    
43 :     fun exists(p, a::r) = if p a then true else exists(p, r)
44 :     | exists(p, []) = false
45 :    
46 :     fun opList l = exists(option, l)
47 :    
48 :    
49 :     type tkind = LtyDef.tkind
50 :     type tyc = LtyDef.tyc
51 :     type lty = LtyDef.lty
52 :     type tkindEnv = LT.tkindEnv
53 :    
54 :     structure TcDict = BinaryDict(struct type ord_key = tyc
55 :     val cmpKey = tc_cmp
56 :     end)
57 :    
58 :     structure LtDict = BinaryDict(struct type ord_key = lty
59 :     val cmpKey = lt_cmp
60 :     end)
61 :    
62 :     (*
63 :     (** wrapping over a lambdatyc; assumption: arg is in normal form already *)
64 :     (** warning: this does not handle tycons of non-zero arity *)
65 :     datatype ucvinfo = SOMEB of tyc
66 :     | SOMEU of tyc
67 :     | NOTHING
68 :    
69 :     fun uinfoList l = exists(fn NOTHING => false | _ => true, l)
70 :    
71 :     val tcBox = LT.tcc_box
72 :    
73 :     fun genWrap save =
74 :     let
75 :     val m1 = ref (TcDict.mkDict())
76 :     fun lookTc t =
77 :     if save then
78 :     let val u = !m1
79 :     in (case TcDict.peek(u, t)
80 :     of SOME t' => t'
81 :     | NONE =>
82 :     let val x = tcWrap t
83 :     val _ = (m1 := TcDict.insert(u, t, x))
84 :     in x
85 :     end)
86 :     end
87 :     else tcWrap t
88 :    
89 :    
90 :     and tcWrap x =
91 :     (case (tc_out x)
92 :     of (TC_PRIM pt) =>
93 :     if PT.unboxed pt then SOME (tcBox x) else NONE
94 :     (* if (PT.isvoid pt) then NONE else SOME (tcBox x) *)
95 :     (* warning: this does not handle tycons of non-zero arity *)
96 :     | TC_TUPLE _ => SOME(ucvInfo x)
97 :     | TC_ARROW _ => SOME(ucvInfo x)
98 :     | (TC_FN(ks, tc)) =>
99 :     (case (tc_out tc, lookTc tc)
100 :     of (TC_SEQ _, NONE) => NONE
101 :     | (TC_PRIM _, NONE) => NONE
102 :     | (TC_FN _, _) => bug "unexpected case in tcWrap"
103 :     | (_, NONE) => SOME(LT.tcc_fn(ks, tcBox tc))
104 :     (** invariants: any TC_FN whose body is not TC_SEQ
105 :     must have a body of kind Omega; a temporary hack **)
106 :     | (_, SOME z) => SOME(LT.tcc_fn(ks, z)))
107 :     | (TC_APP(tc, ts)) =>
108 :     (case lookTc tc of NONE => NONE
109 :     | SOME z => SOME(LT.tcc_app(z, ts)))
110 :     | (TC_SEQ ts) =>
111 :     (case tcsWrap ts of NONE => NONE
112 :     | SOME z => SOME(LT.tcc_seq z))
113 :     | _ => NONE)
114 :    
115 :     and ucvInfo x =
116 :     (case tcUncover x
117 :     of NOTHING => tcBox x
118 :     | SOMEB y => y
119 :     | SOMEU z => tcBox z)
120 :    
121 :     and tcsWrap xs =
122 :     let fun p([], flag, bs) = if flag then SOME(rev bs) else NONE
123 :     | p(a::r, flag, bs) =
124 :     (case (lookTc a) of NONE => p(r, flag, a::bs)
125 :     | SOME z => p(r, true, z::bs))
126 :     in p(xs, false, [])
127 :     end
128 :    
129 :     and ltWrap x =
130 :     (case lt_out x
131 :     of LT_TYC t => (case lookTc t
132 :     of NONE => NONE
133 :     | SOME z => SOME(LT.ltc_tyc z))
134 :     | _ => bug "unexpected case in ltWrap")
135 :    
136 :     (*** wrapping for partially-boxed representations ***)
137 :     and tcUncover x =
138 :     (case (tc_out x)
139 :     of (TC_PRIM pt) => NOTHING
140 :     | (TC_VAR _ | TC_PROJ _ | TC_ABS _ | TC_NVAR _) => SOMEU x
141 :     | (TC_TUPLE (_,ts)) =>
142 :     let val nts = map tcUncover ts
143 :     in if (uinfoList nts) then
144 :     (let fun h(z, NOTHING) = z
145 :     | h(_, SOMEB z) = z
146 :     | h(_, SOMEU z) = z
147 :     val nt = LT.tcc_tuple (ListPair.map h (ts, nts))
148 :     in SOMEB(tcBox nt)
149 :     end)
150 :     else NOTHING
151 :     end
152 :     | (TC_ARROW _) =>
153 :     let val (tc1, tc2) = LT.tcd_parrow x
154 :     val ntc1 =
155 :     (case tc_out tc1
156 :     of TC_TUPLE (_, ts as [_, _]) =>
157 :     let val nts = map lookTc ts
158 :     in if (opList nts) then
159 :     (let fun h(z, NONE) = z
160 :     | h(_, SOME z) = z
161 :     val nt = LT.tcc_tuple(ListPair.map h (ts, nts))
162 :     in SOMEU nt
163 :     end)
164 :     else NOTHING
165 :     end
166 :     | (TC_VAR _ | TC_PROJ _ | TC_APP _ | TC_NVAR _) => SOMEB tc1
167 :     | _ => (case (lookTc tc1)
168 :     of SOME x => SOMEU x
169 :     | _ => NOTHING))
170 :    
171 :     val ntc2 = lookTc tc2
172 :     in (case (ntc1, ntc2)
173 :     of (NOTHING, NONE) => NOTHING
174 :     | (SOMEU z1, NONE) => SOMEU (LT.tcc_parrow(z1, tc2))
175 :     | (SOMEB z1, NONE) => SOMEB (tcBox(LT.tcc_parrow(z1, tc2)))
176 :     | (NOTHING, SOME z2) => SOMEU (LT.tcc_parrow(tc1, z2))
177 :     | (SOMEU z1, SOME z2) => SOMEU (LT.tcc_parrow(z1, z2))
178 :     | (SOMEB z1, SOME z2) => SOMEB (tcBox(LT.tcc_parrow(z1, z2))))
179 :     end
180 :     | (TC_APP(tc, ts)) =>
181 :     (case tcUncover tc of NOTHING => NOTHING
182 :     | _ => SOMEU x)
183 :     | _ => NOTHING)
184 :    
185 :     in (lookTc, ltWrap, tcsWrap)
186 :     end
187 :     *)
188 :    
189 :     fun genWrap bbb =
190 :     let fun tcWrap t =
191 :     let val nt = LtyKernel.tcc_wrap t
192 :     in if LT.tc_eqv(nt,t) then NONE
193 :     else SOME nt
194 :     end
195 :    
196 :     and tcsWrap xs =
197 :     let fun p([], flag, bs) = if flag then SOME(rev bs) else NONE
198 :     | p(a::r, flag, bs) =
199 :     (case (tcWrap a) of NONE => p(r, flag, a::bs)
200 :     | SOME z => p(r, true, z::bs))
201 :     in p(xs, false, [])
202 :     end
203 :    
204 :     and ltWrap x =
205 :     (case lt_out x
206 :     of LT_TYC t => (case tcWrap t
207 :     of NONE => NONE
208 :     | SOME z => SOME(LT.ltc_tyc z))
209 :     | _ => bug "unexpected case in ltWrap")
210 :     in (tcWrap, ltWrap, tcsWrap)
211 :     end
212 :    
213 :     val (tcWrap, ltWrap, tcsWrap) = genWrap false
214 :    
215 :     (** val tkLty : tkind -> lty *)
216 :     fun tkLty tk =
217 :     (case tk_out tk
218 :     of TK_MONO => LT.ltc_int
219 :     | TK_BOX => LT.ltc_int
220 :     | TK_SEQ ks => LT.ltc_tuple (map tkLty ks)
221 :     | TK_FUN (ks, k) => LT.ltc_parrow(LT.ltc_tuple(map tkLty ks), tkLty k))
222 :    
223 :     fun tcNarrow t =
224 :     (case (tc_out t)
225 :     of TC_PRIM pt =>
226 :     if PT.isvoid pt then LT.tcc_void else t
227 :     | TC_TUPLE (_, tcs) => LT.tcc_tuple (map tcNarrow tcs)
228 :     | TC_ARROW (r, ts1, ts2) =>
229 :     LT.tcc_arrow(r, map tcNarrow ts1, map tcNarrow ts2)
230 :     | _ => LT.tcc_void)
231 :    
232 :     fun ltNarrow t =
233 :     (case lt_out t
234 :     of LT_TYC tc => LT.ltc_tyc (tcNarrow tc)
235 :     | LT_STR ts => LT.ltc_str (map ltNarrow ts)
236 :     | LT_PST its => LT.ltc_pst (map (fn (i, t) => (i, ltNarrow t)) its)
237 :     | LT_FCT (ts1, ts2) => LT.ltc_fct(map ltNarrow ts1, map ltNarrow ts2)
238 :     | LT_POLY (ks, [x]) => LT.ltc_fct([LT.ltc_str (map tkLty ks)],
239 :     [ltNarrow x])
240 :     | LT_POLY (ks, _) => bug "unexpectd POLYs in ltNarrow"
241 :     | LT_CONT _ => bug "unexpected CNTs in ltNarrow"
242 :     | LT_IND _ => bug "unexpected INDs in ltNarrow"
243 :     | LT_ENV _ => bug "unexpected ENVs in ltNarrow")
244 :    
245 :     fun tcNarrowSt t =
246 :     let val nt = tc_whnm t
247 :     in (case tc_out nt
248 :     of TC_PRIM pt =>
249 :     if PT.isvoid pt then LT.tcc_void else nt
250 :     | TC_TUPLE (_, tcs) => LT.tcc_tuple (map tcNarrowSt tcs)
251 :     | TC_ARROW (r, ts1, ts2) =>
252 :     LT.tcc_arrow(r, map tcNarrowSt ts1, map tcNarrowSt ts2)
253 :     | _ => LT.tcc_void)
254 :     end
255 :    
256 :     fun ltNarrowSt t =
257 :     (case lt_out (lt_whnm t)
258 :     of LT_TYC tc => LT.ltc_tyc (tcNarrowSt tc)
259 :     | LT_STR ts => LT.ltc_str (map ltNarrowSt ts)
260 :     | LT_PST its => LT.ltc_pst (map (fn (i, t) => (i, ltNarrowSt t)) its)
261 :     | LT_FCT (ts1, ts2) => LT.ltc_fct(map ltNarrowSt ts1, map ltNarrowSt ts2)
262 :     | LT_POLY (ks, [x]) => LT.ltc_fct([LT.ltc_str (map tkLty ks)],
263 :     [ltNarrowSt x])
264 :     | LT_POLY (ks, _) => bug "unexpectd POLYs in ltNarrowSt"
265 :     | LT_CONT _ => bug "unexpected CNTs in ltNarrowSt"
266 :     | LT_IND _ => bug "unexpected INDs in ltNarrowSt"
267 :     | LT_ENV _ => bug "unexpected ENVs in ltNarrowSt")
268 :    
269 :     (* val narrowGen : unit -> ((tyc -> tyc) * (lty -> lty) * (unit -> unit)) *)
270 :     fun narrowGen ()
271 :     = let val m1 = ref (TcDict.mkDict())
272 :     val m2 = ref (LtDict.mkDict())
273 :     fun lookTc t =
274 :     let val u = !m1
275 :     in (case TcDict.peek(u, t)
276 :     of SOME t' => t'
277 :     | NONE =>
278 :     let val x = tcN t
279 :     val _ = (m1 := TcDict.insert(u, t, x))
280 :     in x
281 :     end)
282 :     end
283 :    
284 :     and lookLt t =
285 :     let val u = !m2
286 :     in (case LtDict.peek(u, t)
287 :     of SOME t' => t'
288 :     | NONE =>
289 :     let val x = ltN t
290 :     val _ = (m2 := LtDict.insert(u, t, x))
291 :     in x
292 :     end)
293 :     end
294 :    
295 :     and tcN t =
296 :     (case (tc_out t)
297 :     of TC_PRIM pt =>
298 :     if PT.isvoid pt then LT.tcc_void else t
299 :     | TC_TUPLE (_, tcs) => LT.tcc_tuple (map lookTc tcs)
300 :     | TC_ARROW (r, ts1, ts2) =>
301 :     LT.tcc_arrow(r, map lookTc ts1, map lookTc ts2)
302 :     | _ => LT.tcc_void)
303 :    
304 :     and ltN t =
305 :     (case (lt_out t)
306 :     of LT_TYC tc => LT.ltc_tyc (tcN tc)
307 :     | LT_STR ts => LT.ltc_str (map lookLt ts)
308 :     | LT_PST its => LT.ltc_pst (map (fn (i, t) => (i, lookLt t)) its)
309 :     | LT_FCT (ts1, ts2) => LT.ltc_fct(map lookLt ts1, map lookLt ts2)
310 :     | LT_POLY (ks, [x]) => LT.ltc_fct([LT.ltc_str (map tkLty ks)],
311 :     [lookLt x])
312 :     | _ => bug "unexpected ltys in ltNarrow")
313 :    
314 :     in (lookTc, lookLt, fn () => ())
315 :     end
316 :    
317 :     end (* toplevel local *)
318 :     end (* structure LtyUtil *)
319 :    

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