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 46 - (view) (download)

1 : monnier 16 (* Copyright (c) 1997 YALE FLINT PROJECT *)
2 :     (* ltyutil.sml *)
3 :    
4 : monnier 45 (*** this file will go away soon *)
5 :    
6 : monnier 16 signature LTYUTIL = sig
7 :    
8 :     type tkind = LtyDef.tkind
9 :     type tyc = LtyDef.tyc
10 :     type lty = LtyDef.lty
11 :    
12 : monnier 45 (** used by the coercion and wrapping *)
13 : monnier 16 val tcWrap : tyc -> tyc option
14 : monnier 24 val genWrap : bool -> ((tyc -> tyc option) * (lty -> lty option)
15 :     * (tyc list -> tyc list option))
16 : monnier 16
17 : monnier 45 val genWrapNEW : bool -> ((tyc -> tyc) * (lty -> lty) *
18 :     (tyc -> tyc) * (lty -> lty) * (unit -> unit))
19 :     end (* signature LTYUTIL *)
20 : monnier 16
21 :     structure LtyUtil : LTYUTIL =
22 :     struct
23 :    
24 :     local structure DA = Access
25 :     structure DI = DebIndex
26 :     structure LT = LtyExtern
27 :     structure PO = PrimOp
28 :     structure PT = PrimTyc
29 :     open LtyKernel
30 :     in
31 :    
32 :     fun bug s = ErrorMsg.impossible ("LtyUtil: " ^ s)
33 :     val say = Control.Print.say
34 :     fun fromto(i,j) = if i < j then (i::fromto(i+1,j)) else []
35 :    
36 :     fun option(NONE) = false
37 :     | option(SOME _) = true
38 :    
39 :     fun exists(p, a::r) = if p a then true else exists(p, r)
40 :     | exists(p, []) = false
41 :    
42 :     fun opList l = exists(option, l)
43 :    
44 :    
45 :     type tkind = LtyDef.tkind
46 :     type tyc = LtyDef.tyc
47 :     type lty = LtyDef.lty
48 :     type tkindEnv = LT.tkindEnv
49 :    
50 :     structure TcDict = BinaryDict(struct type ord_key = tyc
51 :     val cmpKey = tc_cmp
52 :     end)
53 :    
54 :     structure LtDict = BinaryDict(struct type ord_key = lty
55 :     val cmpKey = lt_cmp
56 :     end)
57 :    
58 :     (** wrapping over a lambdatyc; assumption: arg is in normal form already *)
59 :     (** warning: this does not handle tycons of non-zero arity *)
60 :     datatype ucvinfo = SOMEB of tyc
61 :     | SOMEU of tyc
62 :     | NOTHING
63 :    
64 :     fun uinfoList l = exists(fn NOTHING => false | _ => true, l)
65 :    
66 :     val tcBox = LT.tcc_box
67 :    
68 :     fun genWrap save =
69 :     let
70 :     val m1 = ref (TcDict.mkDict())
71 :     fun lookTc t =
72 :     if save then
73 :     let val u = !m1
74 :     in (case TcDict.peek(u, t)
75 :     of SOME t' => t'
76 :     | NONE =>
77 :     let val x = tcWrap t
78 :     val _ = (m1 := TcDict.insert(u, t, x))
79 :     in x
80 :     end)
81 :     end
82 :     else tcWrap t
83 :    
84 : monnier 45
85 : monnier 16 and tcWrap x =
86 :     (case (tc_out x)
87 :     of (TC_PRIM pt) =>
88 : monnier 45 if PT.unboxed pt then SOME (tcBox x) else NONE
89 :     (* if (PT.isvoid pt) then NONE else SOME (tcBox x) *)
90 : monnier 16 (* warning: this does not handle tycons of non-zero arity *)
91 :     | TC_TUPLE _ => SOME(ucvInfo x)
92 :     | TC_ARROW _ => SOME(ucvInfo x)
93 :     | (TC_FN(ks, tc)) =>
94 :     (case (tc_out tc, lookTc tc)
95 :     of (TC_SEQ _, NONE) => NONE
96 :     | (TC_PRIM _, NONE) => NONE
97 :     | (TC_FN _, _) => bug "unexpected case in tcWrap"
98 :     | (_, NONE) => SOME(LT.tcc_fn(ks, tcBox tc))
99 :     (** invariants: any TC_FN whose body is not TC_SEQ
100 :     must have a body of kind Omega; a temporary hack **)
101 :     | (_, SOME z) => SOME(LT.tcc_fn(ks, z)))
102 :     | (TC_APP(tc, ts)) =>
103 :     (case lookTc tc of NONE => NONE
104 :     | SOME z => SOME(LT.tcc_app(z, ts)))
105 :     | (TC_SEQ ts) =>
106 :     (case tcsWrap ts of NONE => NONE
107 :     | SOME z => SOME(LT.tcc_seq z))
108 :     | _ => NONE)
109 :    
110 :     and ucvInfo x =
111 :     (case tcUncover x
112 :     of NOTHING => tcBox x
113 :     | SOMEB y => y
114 :     | SOMEU z => tcBox z)
115 :    
116 :     and tcsWrap xs =
117 :     let fun p([], flag, bs) = if flag then SOME(rev bs) else NONE
118 :     | p(a::r, flag, bs) =
119 :     (case (lookTc a) of NONE => p(r, flag, a::bs)
120 :     | SOME z => p(r, true, z::bs))
121 :     in p(xs, false, [])
122 :     end
123 :    
124 :     and ltWrap x =
125 :     (case lt_out x
126 :     of LT_TYC t => (case lookTc t
127 :     of NONE => NONE
128 :     | SOME z => SOME(LT.ltc_tyc z))
129 :     | _ => bug "unexpected case in ltWrap")
130 :    
131 :     (*** wrapping for partially-boxed representations ***)
132 :     and tcUncover x =
133 :     (case (tc_out x)
134 :     of (TC_PRIM pt) => NOTHING
135 :     | (TC_VAR _ | TC_PROJ _ | TC_ABS _ | TC_NVAR _) => SOMEU x
136 : monnier 45 | (TC_TUPLE (_,ts)) =>
137 : monnier 16 let val nts = map tcUncover ts
138 :     in if (uinfoList nts) then
139 :     (let fun h(z, NOTHING) = z
140 :     | h(_, SOMEB z) = z
141 :     | h(_, SOMEU z) = z
142 :     val nt = LT.tcc_tuple (ListPair.map h (ts, nts))
143 :     in SOMEB(tcBox nt)
144 :     end)
145 :     else NOTHING
146 :     end
147 :     | (TC_ARROW _) =>
148 : monnier 45 let val (tc1, tc2) = LT.tcd_parrow x
149 : monnier 16 val ntc1 =
150 :     (case tc_out tc1
151 : monnier 45 of TC_TUPLE (_, ts as [_, _]) =>
152 : monnier 16 let val nts = map lookTc ts
153 :     in if (opList nts) then
154 : monnier 45 let fun h(z, NONE) = z
155 :     | h(_, SOME z) = z
156 :     val nt = LT.tcc_tuple(ListPair.map h (ts, nts))
157 :     in SOMEU nt
158 :     end
159 : monnier 16 else NOTHING
160 :     end
161 :     | (TC_VAR _ | TC_PROJ _ | TC_APP _ | TC_NVAR _) => SOMEB tc1
162 :     | _ => (case (lookTc tc1)
163 :     of SOME x => SOMEU x
164 :     | _ => NOTHING))
165 :    
166 :     val ntc2 = lookTc tc2
167 :     in (case (ntc1, ntc2)
168 :     of (NOTHING, NONE) => NOTHING
169 : monnier 45 | (SOMEU z1, NONE) => SOMEU (LT.tcc_parrow(z1, tc2))
170 :     | (SOMEB z1, NONE) => SOMEB (tcBox(LT.tcc_parrow(z1, tc2)))
171 :     | (NOTHING, SOME z2) => SOMEU (LT.tcc_parrow(tc1, z2))
172 :     | (SOMEU z1, SOME z2) => SOMEU (LT.tcc_parrow(z1, z2))
173 :     | (SOMEB z1, SOME z2) => SOMEB (tcBox(LT.tcc_parrow(z1, z2))))
174 : monnier 16 end
175 :     | (TC_APP(tc, ts)) =>
176 :     (case tcUncover tc of NOTHING => NOTHING
177 :     | _ => SOMEU x)
178 :     | _ => NOTHING)
179 :    
180 :     in (lookTc, ltWrap, tcsWrap)
181 :     end
182 :    
183 : monnier 24 val (tcWrap, ltWrap, tcsWrap) = genWrap false
184 : monnier 16
185 : monnier 45 fun genWrapNEW bbb =
186 :     let fun tc_wmap (w, u) t =
187 :     (case (tc_out t)
188 :     of (TC_VAR _ | TC_NVAR _) => t
189 :     | TC_PRIM pt => if PT.unboxed pt then LT.tcc_wrap t else t
190 :     | TC_FN (ks, tc) => LT.tcc_fn(ks, w tc) (* impossible case *)
191 :     | TC_APP (tc, tcs) => LT.tcc_app(w tc, map w tcs)
192 :     | TC_SEQ tcs => LT.tcc_seq(map w tcs)
193 :     | TC_PROJ (tc, i) => LT.tcc_proj(w tc, i)
194 :     | TC_SUM tcs => LT.tcc_sum (map w tcs)
195 :     | TC_FIX ((n,tc,ts), i) =>
196 :     LT.tcc_fix((n, tc_norm (u tc), map w ts), i)
197 : monnier 16
198 : monnier 45 | TC_TUPLE (_, ts) => LT.tcc_wrap(LT.tcc_tuple (map w ts)) (* ? *)
199 :     | TC_ARROW (FF_VAR(b1,b2), ts1, ts2) =>
200 :     let val nts1 = (* too specific ! *)
201 :     (case ts1 of [t11,t12] => [w t11, w t12]
202 :     | _ => [w (tc_autotuple ts1)])
203 :     val nts2 = [w (tc_autotuple ts2)]
204 :     val nt = LT.tcc_arrow(LT.ffc_fixed, nts1, nts2)
205 :     in if b1 then nt else LT.tcc_wrap nt
206 :     end
207 :     | TC_ARROW (FF_FIXED, _, _) =>
208 :     bug "unexpected TC_FIXED_ARROW in tc_umap"
209 :     | TC_TOKEN (k, t) => bug "unexpected token tyc in tc_wmap"
210 :     | TC_BOX _ => bug "unexpected TC_BOX in tc_wmap"
211 :     | TC_ABS _ => bug "unexpected TC_ABS in tc_wmap"
212 :     | _ => bug "unexpected other tycs in tc_wmap")
213 : monnier 16
214 : monnier 45 fun tc_umap (u, w) t =
215 :     (case (tc_out t)
216 :     of (TC_VAR _ | TC_NVAR _ | TC_PRIM _) => t
217 :     | TC_FN (ks, tc) => LT.tcc_fn(ks, u tc) (* impossible case *)
218 :     | TC_APP (tc, tcs) => LT.tcc_app(u tc, map w tcs)
219 :     | TC_SEQ tcs => LT.tcc_seq(map u tcs)
220 :     | TC_PROJ (tc, i) => LT.tcc_proj(u tc, i)
221 :     | TC_SUM tcs => LT.tcc_sum (map u tcs)
222 :     | TC_FIX ((n,tc,ts), i) =>
223 :     LT.tcc_fix((n, tc_norm (u tc), map w ts), i)
224 : monnier 16
225 : monnier 45 | TC_TUPLE (rk, tcs) => LT.tcc_tuple(map u tcs)
226 :     | TC_ARROW (FF_VAR(b1,b2), ts1, ts2) =>
227 :     LT.tcc_arrow(LT.ffc_fixed, map u ts1, map u ts2)
228 :     | TC_ARROW (FF_FIXED, _, _) =>
229 :     bug "unexpected TC_FIXED_ARROW in tc_umap"
230 :     | TC_PARROW _ => bug "unexpected TC_PARROW in tc_umap"
231 : monnier 16
232 : monnier 45 | TC_BOX _ => bug "unexpected TC_BOX in tc_umap"
233 :     | TC_ABS _ => bug "unexpected TC_ABS in tc_umap"
234 :     | TC_TOKEN (k, t) =>
235 :     if token_eq(k, wrap_token) then
236 :     bug "unexpected TC_WRAP in tc_umap"
237 :     else tc_inj (TC_TOKEN (k, u t))
238 : monnier 16
239 : monnier 45 | _ => bug "unexpected other tycs in tc_umap")
240 : monnier 16
241 : monnier 45 fun lt_umap (tcf, ltf) t =
242 :     (case (lt_out t)
243 :     of LT_TYC tc => LT.ltc_tyc (tcf tc)
244 :     | LT_STR ts => LT.ltc_str (map ltf ts)
245 :     | LT_FCT (ts1, ts2) => LT.ltc_fct(map ltf ts1, map ltf ts2)
246 :     | LT_POLY (ks, xs) => LT.ltc_poly(ks, map ltf xs)
247 :     | LT_PST its => LT.ltc_pst (map (fn (i, t) => (i, ltf t)) its)
248 :     | LT_CONT _ => bug "unexpected CNTs in lt_umap"
249 :     | LT_IND _ => bug "unexpected INDs in lt_umap"
250 :     | LT_ENV _ => bug "unexpected ENVs in lt_umap")
251 : monnier 24
252 : monnier 45 val {tc_wmap=tcWrap, tc_umap=tcMap, lt_umap=ltMap, cleanup} =
253 :     LtyDict.wmemo_gen{tc_wmap=tc_wmap, tc_umap=tc_umap, lt_umap=lt_umap}
254 : monnier 24
255 : monnier 45 fun ltWrap x =
256 :     LT.ltw_tyc (x, (fn tc => LT.ltc_tyc (tcWrap tc)),
257 :     fn _ => bug "unexpected case in ltWrap")
258 : monnier 16
259 : monnier 45 in (tcWrap o tc_norm, ltWrap o lt_norm,
260 :     tcMap o tc_norm, ltMap o lt_norm, cleanup)
261 :     end
262 : monnier 16
263 :     end (* toplevel local *)
264 :     end (* structure LtyUtil *)
265 :    

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