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

Annotation of /sml/trunk/src/compiler/FLINT/flint/tvarcvt.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 422 - (view) (download)

1 : monnier 197 (* tvarcvt.sml --
2 :     * converting between different representations of
3 :     * type variables in a FLINT program.
4 :     *)
5 :    
6 :     signature TVARCVT =
7 :     sig
8 :     val debIndex2names : FLINT.prog -> FLINT.prog
9 :     val names2debIndex : FLINT.prog -> FLINT.prog
10 :     end (* TVARCVT *)
11 :    
12 :    
13 :     structure TvarCvt :> TVARCVT =
14 :     struct
15 :     (* local abbreviations *)
16 :     structure F = FLINT
17 :     structure DI = DebIndex
18 :     structure LT = LtyExtern
19 :     structure LK = LtyKernel
20 :    
21 :     (* `debIndex2names' converts all variables bound by the
22 :     * term-language TFN (capital lambda) construct into named
23 :     * variables. This is primarily to experiment with the cost of
24 :     * named variables, should we introduce them during translate or
25 :     * other phases.
26 :     *)
27 :     val debIndex2names = let
28 :    
29 :     fun extendEnv env d _ tvtks = let
30 :     fun tvtk2tyc (tvar, _) = LT.tcc_nvar tvar
31 :     in
32 :     LK.tcInsert (env, (SOME (map tvtk2tyc tvtks), 0))
33 :     end
34 :    
35 :     fun cvtExp env d = let
36 :     fun tcSubst tyc = LK.tcc_env (tyc, d, d, env)
37 :     fun ltSubst lty = LK.ltc_env (lty, d, d, env)
38 :    
39 :     fun cvtCon (F.DATAcon ((sym,cr,lty),ts,lv)) =
40 :     F.DATAcon ((sym, cr, ltSubst lty),
41 :     map tcSubst ts, lv)
42 :     | cvtCon c = c
43 :    
44 :     fun cvtDict {default, table} = let
45 :     fun f (ts,lv) = ((map tcSubst ts), lv)
46 :     in
47 :     {default = default,
48 :     table = map f table
49 :     } : F.dict
50 :     end (* cvtDict *)
51 :    
52 :     fun cvtPrimop (dictOpt, po, lty, tycs) =
53 :     (Option.map cvtDict dictOpt,
54 :     po,
55 :     ltSubst lty,
56 :     map tcSubst tycs
57 :     ) : F.primop
58 :    
59 :     fun r exp =
60 :     case exp of
61 :     F.RET _ => exp (* no processing required *)
62 :    
63 :     | F.LET (lvs, e1, e2) => (* recursion only *)
64 :     F.LET (lvs, r e1, r e2)
65 :    
66 :     | F.FIX (fundecs, e) => (* recursion only *)
67 :     F.FIX (map (cvtFundec env d) fundecs,
68 :     r e)
69 :    
70 :     | F.APP _ => exp (* no processing required *)
71 :    
72 : monnier 220 | F.TFN ((tfk,v,tvtks,e1),e2) =>
73 :     F.TFN ((tfk, v, tvtks,
74 : monnier 197 cvtExp (extendEnv env d 0 tvtks) (DI.next d) e1),
75 :     r e2)
76 :    
77 :     | F.TAPP (v, ts) => (* subst ts *)
78 :     F.TAPP (v, map tcSubst ts)
79 :    
80 :     | F.SWITCH (v, cs, conlexps, lexpO) =>
81 :     F.SWITCH (v, cs,
82 :     (map (fn (con,lexp) => (cvtCon con, r lexp))
83 :     conlexps),
84 :     Option.map r lexpO)
85 :    
86 :     | F.CON ((sym,cr,lty), ts, v, lv, e) =>
87 :     F.CON ((sym, cr, ltSubst lty),
88 :     map tcSubst ts,
89 :     v, lv, r e)
90 :    
91 :     | F.RECORD (rk, vs, lv, e) =>
92 :     F.RECORD ((case rk of
93 :     F.RK_VECTOR t =>
94 :     F.RK_VECTOR (tcSubst t)
95 :     | _ => rk),
96 :     vs, lv, r e)
97 :    
98 :     | F.SELECT (v, i, lv, e) =>
99 :     F.SELECT (v, i, lv, r e)
100 :    
101 :     | F.RAISE (v, ltys) =>
102 :     F.RAISE (v, map ltSubst ltys)
103 :    
104 :     | F.HANDLE (e, v) =>
105 :     F.HANDLE (r e, v)
106 :    
107 :     | F.BRANCH (po, vs, e1, e2) =>
108 :     F.BRANCH (cvtPrimop po,
109 :     vs, r e1, r e2)
110 :    
111 :     | F.PRIMOP (po, vs, lv, e) =>
112 :     F.PRIMOP (cvtPrimop po,
113 :     vs, lv, r e)
114 :     in
115 :     r
116 :     end (* cvtExp *)
117 :    
118 :     and cvtFundec env d (fkind, lvar, lvlts, e) = let
119 :     fun tcSubst tyc = LK.tcc_env (tyc, d, d, env)
120 :     fun ltSubst lty = LK.ltc_env (lty, d, d, env)
121 :    
122 :     fun cvtFkind {isrec = SOME(ltys,lk),
123 :     cconv, known, inline} =
124 :     {isrec = SOME (map ltSubst ltys, lk),
125 :     cconv = cconv,
126 :     known = known,
127 :     inline = inline}
128 :     | cvtFkind fk = fk
129 :    
130 :     fun cvtLvLt (lvar, lty) = (lvar, ltSubst lty)
131 :     in
132 :     (cvtFkind fkind,
133 :     lvar,
134 :     map cvtLvLt lvlts,
135 :     cvtExp env d e
136 :     ) : F.fundec
137 :     end (* cvtFundec *)
138 :     in
139 :     cvtFundec LK.initTycEnv DI.top
140 :     end
141 :    
142 :     (* `names2debIndex' removes all named variables (`TC_NVAR')
143 :     * from a FLINT program, replacing them with deBruijn-indexed
144 :     * variables. It expects, of course, that named variables are
145 :     * only bound by the term-language TFN (capital lambda), and not
146 :     * by the LT_POLY (forall) or TC_FN (lowercase lambda) in the
147 :     * type language.
148 :     *)
149 :     fun names2debIndex_gen() = let
150 :    
151 :     fun extendEnv env d i [] = env
152 :     | extendEnv env d i ((tv,_)::tvtks) =
153 : monnier 422 extendEnv (IntBinaryMap.insert (env, tv, (d,i)))
154 : monnier 197 d (i+1) tvtks
155 :    
156 : monnier 422 fun queryEnv env (tvar, currDepth) =
157 :     (case IntBinaryMap.find(env, tvar)
158 :     of NONE => NONE
159 :     | SOME(defnDepth, i) =>
160 :     SOME (LT.tcc_var (DI.calc (currDepth, defnDepth), i))
161 :     (*esac*))
162 : monnier 197
163 :     val tc_nvar_elim = LT.tc_nvar_elim_gen()
164 :     val lt_nvar_elim = LT.lt_nvar_elim_gen()
165 :    
166 :     fun cvtExp env d = let
167 :     val q = queryEnv env
168 :     (* instantiate a new subst dictionary on each invocation..
169 :     * clean this up later.
170 :     *)
171 :     val tcSubst = tc_nvar_elim q d
172 :     val ltSubst = lt_nvar_elim q d
173 :    
174 :     fun cvtCon (F.DATAcon ((sym,cr,lty),ts,lv)) =
175 :     F.DATAcon ((sym, cr, ltSubst lty),
176 :     map tcSubst ts, lv)
177 :     | cvtCon c = c
178 :    
179 :     fun cvtDict {default, table} = let
180 :     fun f (ts,lv) = ((map tcSubst ts), lv)
181 :     in
182 :     {default = default,
183 :     table = map f table
184 :     } : F.dict
185 :     end (* cvtDict *)
186 :    
187 :     fun cvtPrimop (dictOpt, po, lty, tycs) =
188 :     (Option.map cvtDict dictOpt,
189 :     po,
190 :     ltSubst lty,
191 :     map tcSubst tycs
192 :     ) : F.primop
193 :    
194 :     fun r exp = (* default recursive invocation *)
195 :     case exp of
196 :     F.RET _ => exp (* no processing required *)
197 :    
198 :     | F.LET (lvs, e1, e2) => (* recursion only *)
199 :     F.LET (lvs, r e1, r e2)
200 :    
201 :     | F.FIX (fundecs, e) => (* recursion only *)
202 :     F.FIX (map (cvtFundec env d) fundecs,
203 :     r e)
204 :    
205 :     | F.APP _ => exp (* no processing required *)
206 :    
207 : monnier 220 | F.TFN ((tfk,v,tvtks,e1),e2) =>
208 :     F.TFN ((tfk, v, tvtks,
209 : monnier 197 cvtExp (extendEnv env d 0 tvtks) (DI.next d) e1),
210 :     r e2)
211 :    
212 :     | F.TAPP (v, ts) => (* subst ts *)
213 :     F.TAPP (v, map tcSubst ts)
214 :    
215 :     | F.SWITCH (v, cs, conlexps, lexpO) =>
216 :     F.SWITCH (v, cs,
217 :     (map (fn (con,lexp) => (cvtCon con, r lexp))
218 :     conlexps),
219 :     Option.map r lexpO)
220 :    
221 :     | F.CON ((sym,cr,lty), ts, v, lv, e) =>
222 :     F.CON ((sym, cr, ltSubst lty),
223 :     map tcSubst ts,
224 :     v, lv, r e)
225 :    
226 :     | F.RECORD (rk, vs, lv, e) =>
227 :     F.RECORD ((case rk of
228 :     F.RK_VECTOR t =>
229 :     F.RK_VECTOR (tcSubst t)
230 :     | _ => rk),
231 :     vs, lv, r e)
232 :    
233 :     | F.SELECT (v, i, lv, e) =>
234 :     F.SELECT (v, i, lv, r e)
235 :    
236 :     | F.RAISE (v, ltys) =>
237 :     F.RAISE (v, map ltSubst ltys)
238 :    
239 :     | F.HANDLE (e, v) =>
240 :     F.HANDLE (r e, v)
241 :    
242 :     | F.BRANCH (po, vs, e1, e2) =>
243 :     F.BRANCH (cvtPrimop po,
244 :     vs, r e1, r e2)
245 :    
246 :     | F.PRIMOP (po, vs, lv, e) =>
247 :     F.PRIMOP (cvtPrimop po,
248 :     vs, lv, r e)
249 :     in
250 :     r
251 :     end (* cvtExp *)
252 :    
253 :     and cvtFundec env d (fkind, lvar, lvlts, e) = let
254 :     val q = queryEnv env
255 :     (* instantiate a new subst dictionary on each invocation..
256 :     * clean this up later.
257 :     *)
258 :     val tcSubst = tc_nvar_elim q d
259 :     val ltSubst = lt_nvar_elim q d
260 :    
261 :     fun cvtFkind ({isrec = SOME (ltys,lk),
262 :     cconv, known, inline}) =
263 :     {isrec = SOME (map ltSubst ltys, lk),
264 :     cconv = cconv,
265 :     known = known,
266 :     inline = inline}
267 :     | cvtFkind fk = fk
268 :    
269 :     fun cvtLvLt (lvar, lty) = (lvar, ltSubst lty)
270 :     in
271 :     (cvtFkind fkind,
272 :     lvar,
273 :     map cvtLvLt lvlts,
274 :     cvtExp env d e
275 :     ) : F.fundec
276 :     end (* cvtFundec *)
277 :     in
278 : monnier 422 cvtFundec IntBinaryMap.empty DI.top
279 : monnier 197 end (* names2debIndex_gen *)
280 :    
281 :     (* generate tables once per invocation
282 :     * ie, once per compilation unit.
283 :     *)
284 :     fun names2debIndex prog = names2debIndex_gen() prog
285 :    
286 :     end (* TvarCvt *)
287 :    
288 : monnier 422

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