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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

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

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