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

Annotation of /sml/trunk/src/compiler/FLINT/kernel/ltyextern.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 45 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/FLINT/kernel/ltyextern.sml

1 : monnier 16 (* Copyright (c) 1997 YALE FLINT PROJECT *)
2 :     (* ltyextern.sml *)
3 :    
4 :     structure LtyExtern : LTYEXTERN =
5 :     struct
6 :    
7 :     local structure PT = PrimTyc
8 :     structure DI = DebIndex
9 :     structure LK = LtyKernel
10 : monnier 45 structure PO = PrimOp (* really should not refer to this *)
11 :     structure FL = FLINT
12 : monnier 16
13 :     fun bug msg = ErrorMsg.impossible("LtyExtern: "^msg)
14 :     val say = Control.Print.say
15 :    
16 :     (** common utility functions *)
17 :     val tk_inj = LK.tk_inj
18 :     val tk_out = LK.tk_out
19 :    
20 :     val tc_inj = LK.tc_inj
21 :     val tc_out = LK.tc_out
22 :    
23 :     val lt_inj = LK.lt_inj
24 :     val lt_out = LK.lt_out
25 :    
26 :     val tcc_env = LK.tcc_env
27 :     val ltc_env = LK.ltc_env
28 :     val tc_whnm = LK.tc_whnm
29 :     val lt_whnm = LK.lt_whnm
30 :     val tc_norm = LK.tc_norm
31 :     val lt_norm = LK.lt_norm
32 :    
33 :     in
34 :    
35 :     open LtyBasic
36 :    
37 :     (** instantiating a polymorphic type or an higher-order constructor *)
38 :     fun lt_inst (lt : lty, ts : tyc list) =
39 :     let val nt = lt_whnm lt
40 :     in (case ((* lt_outX *) lt_out nt, ts)
41 :     of (LK.LT_POLY(ks, b), ts) =>
42 : monnier 45 let val nenv = LK.tcInsert(LK.initTycEnv, (SOME ts, 0))
43 :     in map (fn x => ltc_env(x, 1, 0, nenv)) b
44 : monnier 16 end
45 :     | (_, []) => [nt] (* this requires further clarifications !!! *)
46 :     | _ => bug "incorrect lty instantiation in lt_inst")
47 : monnier 45 end
48 : monnier 16
49 : monnier 45 fun lt_pinst (lt : lty, ts : tyc list) =
50 :     (case lt_inst (lt, ts) of [y] => y | _ => bug "unexpected lt_pinst")
51 :    
52 : monnier 16 val lt_inst_st = (map lt_norm) o lt_inst (* strict instantiation *)
53 : monnier 45 val lt_pinst_st = lt_norm o lt_pinst (* strict instantiation *)
54 : monnier 16
55 :     exception TkTycChk
56 :     exception LtyAppChk
57 :    
58 :     fun tkSel (tk, i) =
59 :     (case (tk_out tk)
60 :     of (LK.TK_SEQ ks) => (List.nth(ks, i) handle _ => raise TkTycChk)
61 :     | _ => raise TkTycChk)
62 :    
63 : monnier 45 fun tks_eqv (ks1, ks2) = tk_eqv(tkc_seq ks1, tkc_seq ks2)
64 :    
65 :     fun tkApp (tk, tks) =
66 :     (case (tk_out tk)
67 :     of LK.TK_FUN(a, b) => if tks_eqv(a, tks) then b else raise TkTycChk
68 : monnier 16 | _ => raise TkTycChk)
69 :    
70 :     (* Warning: the following tkTyc function has not considered the
71 :     * occurence of .TK_BOX, in other words, if there is TK_BOX present,
72 :     * then the tk_tyc checker will produce wrong results. (ZHONG)
73 :     *)
74 :     fun tk_tyc (t, kenv) =
75 :     let fun g x =
76 :     (case tc_out x
77 :     of (LK.TC_VAR (i, j)) => tkLookup(kenv, i, j)
78 :     | (LK.TC_NVAR _) => bug "TC_NVAR not supported yet in tk_tyc"
79 : monnier 45 | (LK.TC_PRIM pt) => tkc_int (PrimTyc.pt_arity pt)
80 : monnier 16 | (LK.TC_FN(ks, tc)) =>
81 : monnier 45 tkc_fun(ks, tk_tyc(tc, tkInsert(kenv, ks)))
82 :     | (LK.TC_APP (tc, tcs)) => tkApp(g tc, map g tcs)
83 : monnier 16 | (LK.TC_SEQ tcs) => tkc_seq (map g tcs)
84 :     | (LK.TC_PROJ(tc, i)) => tkSel(g tc, i)
85 :     | (LK.TC_SUM tcs) =>
86 :     let val _ = map (fn x => tk_eqv(g x, tkc_mono)) tcs
87 :     in tkc_mono
88 :     end
89 :     | (LK.TC_FIX ((n, tc, ts), i)) =>
90 :     let val k = g tc
91 :     val nk = case ts of [] => k
92 : monnier 45 | _ => tkApp(k, map g ts)
93 : monnier 16 in (case (tk_out nk)
94 :     of LK.TK_FUN(a, b) =>
95 : monnier 45 let val arg = case a of [x] => x
96 :     | _ => tkc_seq a
97 :     in if tk_eqv(arg, b) then
98 :     (if n = 1 then b else tkSel(arg, i))
99 :     else raise TkTycChk
100 :     end
101 : monnier 16 | _ => raise TkTycChk)
102 :     end
103 :     | (LK.TC_ABS tc) => (tk_eqv(g tc, tkc_mono); tkc_mono)
104 :     | (LK.TC_BOX tc) => (tk_eqv(g tc, tkc_mono); tkc_mono)
105 : monnier 45 | (LK.TC_TUPLE (_,tcs)) =>
106 : monnier 16 let val _ = map (fn x => tk_eqv(g x, tkc_mono)) tcs
107 :     in tkc_mono
108 :     end
109 :     | (LK.TC_ARROW (_, ts1, ts2)) =>
110 :     let val _ = map (fn x => tk_eqv(g x, tkc_mono)) ts1
111 :     val _ = map (fn x => tk_eqv(g x, tkc_mono)) ts2
112 :     in tkc_mono
113 :     end
114 :     | _ => bug "unexpected TC_ENV or TC_CONT in tk_tyc")
115 :     in g t
116 :     end
117 :    
118 :     and tk_chk kenv (k, tc) =
119 :     if tk_eqv(k, tk_tyc(tc, kenv)) then () else raise TkTycChk
120 :    
121 :     fun lt_inst_chk (lt : lty, ts : tyc list, kenv : tkindEnv) =
122 :     let val nt = lt_whnm lt
123 :     in (case ((* lt_outX *) lt_out nt, ts)
124 :     of (LK.LT_POLY(ks, b), ts) =>
125 :     let val _ = ListPair.app (tk_chk kenv) (ks, ts)
126 :     fun h x = ltc_env(x, 1, 0, tcInsert(initTycEnv, (SOME ts, 0)))
127 :     in map h b
128 :     end
129 :     | (_, []) => [nt] (* ? problematic *)
130 :     | _ => raise LtyAppChk)
131 :     end
132 :    
133 :     (** a special lty application --- used inside the translate/specialize.sml *)
134 :     fun lt_sp_adj(ks, lt, ts, dist, bnl) =
135 :     let fun h(abslevel, ol, nl, tenv) =
136 :     if abslevel = 0 then ltc_env(lt, ol, nl, tenv)
137 :     else if abslevel > 0 then
138 :     h(abslevel-1, ol+1, nl+1, tcInsert(tenv, (NONE, nl)))
139 :     else bug "unexpected cases in ltAdjSt"
140 :    
141 :     val btenv = tcInsert(initTycEnv, (SOME ts, 0))
142 :     val nt = h(dist, 1, bnl, btenv)
143 : monnier 45 in nt (* was lt_norm nt *)
144 : monnier 16 end
145 :    
146 :     (** a special tyc application --- used inside the translate/specialize.sml *)
147 :     fun tc_sp_adj(ks, tc, ts, dist, bnl) =
148 :     let fun h(abslevel, ol, nl, tenv) =
149 :     if abslevel = 0 then tcc_env(tc, ol, nl, tenv)
150 :     else if abslevel > 0 then
151 :     h(abslevel-1, ol+1, nl+1, tcInsert(tenv, (NONE, nl)))
152 :     else bug "unexpected cases in tcAdjSt"
153 :    
154 :     val btenv = tcInsert(initTycEnv, (SOME ts, 0))
155 :     val nt = h(dist, 1, bnl, btenv)
156 : monnier 45 in nt (* was tc_norm nt *)
157 : monnier 16 end
158 :    
159 :     (** sinking the lty one-level down --- used inside the specialize.sml *)
160 :     fun lt_sp_sink (ks, lt, d, nd) =
161 :     let fun h(abslevel, ol, nl, tenv) =
162 :     if abslevel = 0 then ltc_env(lt, ol, nl, tenv)
163 :     else if abslevel > 0 then
164 :     h(abslevel-1, ol+1, nl+1, tcInsert(tenv, (NONE, nl)))
165 :     else bug "unexpected cases in ltSinkSt"
166 :     val nt = h(nd-d, 0, 1, initTycEnv)
167 : monnier 45 in nt (* was lt_norm nt *)
168 : monnier 16 end
169 :    
170 :     (** sinking the tyc one-level down --- used inside the specialize.sml *)
171 :     fun tc_sp_sink (ks, tc, d, nd) =
172 :     let fun h(abslevel, ol, nl, tenv) =
173 :     if abslevel = 0 then tcc_env(tc, ol, nl, tenv)
174 :     else if abslevel > 0 then
175 :     h(abslevel-1, ol+1, nl+1, tcInsert(tenv, (NONE, nl)))
176 :     else bug "unexpected cases in ltSinkSt"
177 :     val nt = h(nd-d, 0, 1, initTycEnv)
178 : monnier 45 in nt (* was tc_norm nt *)
179 : monnier 16 end
180 :    
181 :     (** utility functions used in CPS *)
182 :     fun lt_iscont lt =
183 :     (case lt_out lt
184 :     of LK.LT_CONT _ => true
185 :     | LK.LT_TYC tc =>
186 :     (case tc_out tc of LK.TC_CONT _ => true | _ => false)
187 :     | _ => false)
188 :    
189 :     fun ltw_iscont (lt, f, g, h) =
190 :     (case lt_out lt
191 :     of LK.LT_CONT t => f t
192 :     | LK.LT_TYC tc =>
193 :     (case tc_out tc of LK.TC_CONT x => g x | _ => h lt)
194 :     | _ => h lt)
195 :    
196 :    
197 :     fun tc_bug tc s = bug (s ^ "\n\n" ^ (tc_print tc) ^ "\n\n")
198 :     fun lt_bug lt s = bug (s ^ "\n\n" ^ (lt_print lt) ^ "\n\n")
199 :    
200 :     (** other misc utility functions *)
201 :     fun tc_select(tc, i) =
202 :     (case tc_out tc
203 : monnier 45 of LK.TC_TUPLE (_,zs) =>
204 : monnier 16 ((List.nth(zs, i)) handle _ => bug "wrong TC_TUPLE in tc_select")
205 :     | _ => tc_bug tc "wrong TCs in tc_select")
206 :    
207 :     fun lt_select(t, i) =
208 :     (case lt_out t
209 :     of LK.LT_STR ts =>
210 :     ((List.nth(ts, i)) handle _ => bug "incorrect LT_STR in lt_select")
211 :     | LK.LT_PST ts =>
212 :     let fun h [] = bug "incorrect LT_PST in lt_select"
213 :     | h ((j,a)::r) = if i=j then a else h r
214 :     in h ts
215 :     end
216 :     | LK.LT_TYC tc => ltc_tyc(tc_select(tc, i))
217 :     | _ => bug "incorrect lambda types in lt_select")
218 :    
219 :     fun tc_swap t =
220 :     (case (tc_out t)
221 : monnier 45 of LK.TC_ARROW (LK.FF_VAR (r1,r2), [s1], [s2]) =>
222 :     tcc_arrow(LK.FF_VAR (r2,r1), [s2], [s1])
223 :     | LK.TC_ARROW (LK.FF_FIXED, [s1], [s2]) =>
224 :     tcc_arrow(LK.FF_FIXED, [s2], [s1])
225 : monnier 16 | _ => bug "unexpected tycs in tc_swap")
226 :    
227 :     fun lt_swap t =
228 :     (case (lt_out t)
229 :     of (LK.LT_POLY (ks, [x])) => ltc_poly(ks, [lt_swap x])
230 :     | (LK.LT_TYC x) => ltc_tyc(tc_swap x)
231 :     | _ => bug "unexpected type in lt_swap")
232 :    
233 : monnier 45 (** functions that manipulate the FLINT function and record types *)
234 :     fun ltc_fkfun (FL.FK_FCT, atys, rtys) =
235 :     ltc_fct (atys, rtys)
236 :     | ltc_fkfun (FL.FK_FUN {fixed, ...}, atys, rtys) =
237 :     ltc_arrow(fixed, atys, rtys)
238 :    
239 :     fun ltd_fkfun lty =
240 :     if ltp_fct lty then ltd_fct lty
241 :     else let val (_, atys, rtys) = ltd_arrow lty
242 :     in (atys, rtys)
243 :     end
244 :    
245 :     fun ltc_rkind (FL.RK_TUPLE _, lts) = ltc_tuple lts
246 :     | ltc_rkind (FL.RK_STRUCT, lts) = ltc_str lts
247 :     | ltc_rkind (FL.RK_VECTOR t, _) = ltc_vector (ltc_tyc t)
248 :    
249 :     fun ltd_rkind (lt, i) = lt_select (lt, i)
250 :    
251 :     (****************************************************************************
252 :     * THE FOLLOWING UTILITY FUNCTIONS WILL SOON BE OBSOLETE *
253 :     ****************************************************************************)
254 :    
255 : monnier 16 (** a version of ltc_arrow with singleton argument and return result *)
256 :     val ltc_arw = ltc_parrow
257 :    
258 :     (** not knowing what FUNCTION this is, to build a fct or an arw *)
259 :     fun ltc_fun (x, y) =
260 :     (case (lt_out x, lt_out y)
261 :     of (LK.LT_TYC _, LK.LT_TYC _) => ltc_parrow(x, y)
262 :     | _ => ltc_pfct(x, y))
263 :    
264 :     (* lt_arrow used by chkflint.sml, checklty.sml, chkplexp.sml, convert.sml
265 :     * and wrapping.sml only
266 :     *)
267 :     fun lt_arrow t =
268 :     (case (lt_out t)
269 :     of (LK.LT_FCT([t1], [t2])) => (t1, t2)
270 :     | (LK.LT_FCT(_, _)) => bug "unexpected case in lt_arrow"
271 :     | (LK.LT_CONT [t]) => (t, ltc_void)
272 :     | _ => (ltd_parrow t) handle _ =>
273 :     bug ("unexpected lt_arrow --- more info: \n\n"
274 :     ^ (lt_print t) ^ "\n\n"))
275 :    
276 :     (* lt_arrowN used by flintnm.sml and ltysingle.sml only, should go away soon *)
277 :     fun lt_arrowN t =
278 :     (case (lt_out t)
279 :     of (LK.LT_FCT(ts1, ts2)) => (ts1, ts2)
280 :     | (LK.LT_CONT ts) => (ts, [])
281 :     | _ => (let val (_, s1, s2) = ltd_arrow t
282 :     in (s1, s2)
283 :     end))
284 :    
285 : monnier 45
286 :    
287 :     (****************************************************************************
288 :     * UTILITY FUNCTIONS USED BY POST-REPRESENTATION ANALYSIS *
289 :     ****************************************************************************)
290 :     (** find out what is the appropriate primop given a tyc *)
291 :     fun tc_upd_prim tc =
292 :     let fun h(LK.TC_PRIM pt) =
293 :     if PT.ubxupd pt then PO.UNBOXEDUPDATE
294 :     else if PT.bxupd pt then PO.BOXEDUPDATE
295 :     else PO.UPDATE
296 :     | h(LK.TC_TUPLE _ | LK.TC_ARROW _) = PO.BOXEDUPDATE
297 :     | h(LK.TC_FIX ((1,tc,ts), 0)) =
298 :     let val ntc = case ts of [] => tc
299 :     | _ => tcc_app(tc, ts)
300 :     in (case (tc_out ntc)
301 :     of LK.TC_FN([k],b) => h (tc_out b)
302 :     | _ => PO.UPDATE)
303 :     end
304 :     | h(LK.TC_SUM tcs) =
305 :     let fun g (a::r) = if tc_eqv(a, tcc_unit) then g r else false
306 :     | g [] = true
307 :     in if (g tcs) then PO.UNBOXEDUPDATE else PO.UPDATE
308 :     end
309 :     | h _ = PO.UPDATE
310 :     in h(tc_out tc)
311 :     end
312 :    
313 :     (** tk_lty : tkind -> lty --- finds out the corresponding type for a tkind *)
314 :     fun tk_lty tk =
315 :     (case tk_out tk
316 :     of LK.TK_MONO => ltc_int
317 :     | LK.TK_BOX => ltc_int
318 :     | LK.TK_SEQ ks => ltc_tuple (map tk_lty ks)
319 :     | LK.TK_FUN (ks, k) => ltc_parrow(ltc_tuple(map tk_lty ks), tk_lty k))
320 :    
321 :    
322 :     (* val tnarrow_gen : unit -> ((tyc -> tyc) * (lty -> lty) * (unit->unit)) *)
323 :     fun tnarrow_gen () =
324 :     let fun tcNarrow tcf t =
325 :     (case (tc_out t)
326 :     of LK.TC_PRIM pt =>
327 :     if PT.isvoid pt then tcc_void else t
328 :     | LK.TC_TUPLE (_, tcs) => tcc_tuple (map tcf tcs)
329 :     | LK.TC_ARROW (r, ts1, ts2) =>
330 :     tcc_arrow(r, map tcf ts1, map tcf ts2)
331 :     | _ => tcc_void)
332 :    
333 :     fun ltNarrow (tcf, ltf) t =
334 :     (case lt_out t
335 :     of LK.LT_TYC tc => ltc_tyc (tcf tc)
336 :     | LK.LT_STR ts => ltc_str (map ltf ts)
337 :     | LK.LT_PST its => ltc_pst (map (fn (i, t) => (i, ltf t)) its)
338 :     | LK.LT_FCT (ts1, ts2) => ltc_fct(map ltf ts1, map ltf ts2)
339 :     | LK.LT_POLY (ks, xs) =>
340 :     ltc_fct([ltc_str (map tk_lty ks)], map ltf xs)
341 :     | LK.LT_CONT _ => bug "unexpected CNTs in ltNarrow"
342 :     | LK.LT_IND _ => bug "unexpected INDs in ltNarrow"
343 :     | LK.LT_ENV _ => bug "unexpected ENVs in ltNarrow")
344 :    
345 :     val {tc_map, lt_map} = LtyDict.tmemo_gen {tcf=tcNarrow, ltf=ltNarrow}
346 :     in (tc_map, lt_map, fn ()=>())
347 :     end (* function tnarrow_gen *)
348 :    
349 : monnier 16 end (* top-level local *)
350 :     end (* structure LtyExtern *)
351 :    

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