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

Parent Directory | Revision Log

---

Revision 489 - (view) (download)

1 :	monnier	16	(* Copyright 1997 (c) by YALE FLINT PROJECT *)
2 :			(* flintutil.sml *)
3 :
4 :			signature FLINTUTIL =
5 :			sig
6 :	monnier	45	val rk_tuple : FLINT.rkind
7 :	monnier	16
8 :	monnier	45	val mketag : FLINT.tyc -> FLINT.primop
9 :			val wrap : FLINT.tyc -> FLINT.primop
10 :			val unwrap : FLINT.tyc -> FLINT.primop
11 :	monnier	16
12 :	monnier	45	val WRAP : FLINT.tyc * FLINT.value list
13 :			* FLINT.lvar * FLINT.lexp -> FLINT.lexp
14 :			val UNWRAP : FLINT.tyc * FLINT.value list
15 :			* FLINT.lvar * FLINT.lexp -> FLINT.lexp
16 :
17 :			val getEtagTyc : FLINT.primop -> FLINT.tyc
18 :			val getWrapTyc : FLINT.primop -> FLINT.tyc
19 :			val getUnWrapTyc : FLINT.primop -> FLINT.tyc
20 :
21 :	monnier	154	(* copy a lexp with alpha renaming.
22 :			* free variables remain unchanged except for the renaming specified
23 :	monnier	197	* in the first (types) and second (values) argument *)
24 :			val copy : (FLINT.tvar * FLINT.tyc) list ->
25 :	monnier	423	FLINT.lvar IntBinaryMap.map ->
26 :	monnier	197	FLINT.lexp -> FLINT.lexp
27 :	monnier	216	val copyfdec : FLINT.fundec -> FLINT.fundec
28 :	monnier	154
29 :	monnier	423	val freevars : FLINT.lexp -> IntBinarySet.set
30 :	monnier	216
31 :	monnier	154	val dcon_eq : FLINT.dcon * FLINT.dcon -> bool
32 :
33 :	monnier	45	end (* signature FLINTUTIL *)
34 :
35 :
36 :	monnier	16	structure FlintUtil : FLINTUTIL =
37 :			struct
38 :
39 :			local structure EM = ErrorMsg
40 :	monnier	45	structure LT = LtyExtern
41 :			structure PO = PrimOp
42 :			structure DA = Access
43 :	monnier	423	structure M = IntBinaryMap
44 :	monnier	197	structure A = Access
45 :			structure O = Option
46 :	monnier	423	structure S = IntBinarySet
47 :	monnier	216	structure F = FLINT
48 :	monnier	45	open FLINT
49 :	monnier	16	in
50 :
51 :	monnier	45	fun bug msg = EM.impossible("FlintUtil: "^msg)
52 :
53 :			val rk_tuple : rkind = RK_TUPLE (LT.rfc_tmp)
54 :
55 :			(* a set of useful primops used by FLINT *)
56 :			val tv0 = LT.ltc_tv 0
57 :			val btv0 = LT.ltc_tyc(LT.tcc_box (LT.tcc_tv 0))
58 :			val etag_lty =
59 :			LT.ltc_ppoly ([LT.tkc_mono],
60 :			LT.ltc_arrow(LT.ffc_rrflint, [LT.ltc_string],
61 :			[LT.ltc_etag tv0]))
62 :			fun wrap_lty tc =
63 :			LT.ltc_tyc(LT.tcc_arrow(LT.ffc_fixed, [tc], [LT.tcc_wrap tc]))
64 :			fun unwrap_lty tc =
65 :			LT.ltc_tyc(LT.tcc_arrow(LT.ffc_fixed, [LT.tcc_wrap tc], [tc]))
66 :
67 :			fun mketag tc = (NONE, PO.MKETAG, etag_lty, [tc])
68 :			fun wrap tc = (NONE, PO.WRAP, wrap_lty tc, [])
69 :			fun unwrap tc = (NONE, PO.UNWRAP, unwrap_lty tc, [])
70 :
71 :			fun WRAP(tc, vs, v, e) = PRIMOP(wrap tc, vs, v, e)
72 :			fun UNWRAP(tc, vs, v, e) = PRIMOP(unwrap tc, vs, v, e)
73 :
74 :			(* the corresponding utility functions to recover the tyc *)
75 :			fun getEtagTyc (_, _, lt, [tc]) = tc
76 :			| getEtagTyc (_, _, lt, []) =
77 :	monnier	69	let val nt = LT.ltd_tyc (#2(LT.ltd_parrow lt))
78 :			in if LT.tcp_app nt then
79 :			(case #2 (LT.tcd_app nt)
80 :			of [x] => x
81 :			| _ => bug "unexpected case 1 in getEtagTyc")
82 :			else LT.tcc_void
83 :	monnier	45	end
84 :			| getEtagTyc _ = bug "unexpected case 2 in getEtagTyc"
85 :
86 :			fun getWrapTyc (_, _, lt, []) = LT.ltd_tyc(#1(LT.ltd_parrow lt))
87 :			| getWrapTyc _ = bug "unexpected case in getWrapTyc"
88 :
89 :			fun getUnWrapTyc (_, _, lt, []) = LT.ltd_tyc(#2(LT.ltd_parrow lt))
90 :			| getUnWrapTyc _ = bug "unexpected case in getUnWrapTyc"
91 :
92 :	monnier	154	fun dcon_eq ((s1,c1,t1),(s2,c2,t2)) =
93 :			(s1 = s2) andalso (c1 = c2) andalso LtyBasic.lt_eqv(t1, t2)
94 :
95 :			val cplv = LambdaVar.dupLvar
96 :	monnier	16	(*
97 :			* general alpha-conversion on lexp free variables remain unchanged
98 :	monnier	154	* except for the renaming specified in the first argument.
99 :			* val copy: lvar M.intmap -> fundec -> fundec
100 :	monnier	16	*)
101 :	monnier	197	fun copy ta alpha le = let
102 :
103 :			val tc_subst = LT.tc_nvar_subst_gen()
104 :			val lt_subst = LT.lt_nvar_subst_gen()
105 :
106 :	monnier	423	val tmap_sort = ListMergeSort.sort (fn ((v1,_),(v2,_)) => v1 > v2)
107 :	monnier	216
108 :	monnier	423	fun substvar alpha lv = case M.find(alpha,lv) of SOME(lv) => lv | NOE => lv
109 :	monnier	197	fun substval alpha (VAR lv) = VAR(substvar alpha lv)
110 :			| substval alpha v = v
111 :	monnier	154	fun newv (lv,alpha) =
112 :	monnier	423	let val nlv = cplv lv in (nlv, M.insert(alpha,lv,nlv)) end
113 :	monnier	154	fun newvs (lvs,alpha) =
114 :			foldr (fn (lv,(lvs,alpha)) =>
115 :			let val (nlv,nalpha) = newv(lv,alpha) in (nlv::lvs,nalpha) end)
116 :			([],alpha) lvs
117 :	monnier	197	fun cdcon ta alpha (s,ac,lty) =
118 :			(s,
119 :			case ac
120 :			of A.EXN(A.LVAR lv) => A.EXN(A.LVAR(substvar alpha lv))
121 :			| _ => ac,
122 :			lt_subst ta lty)
123 :			fun cpo ta alpha (dict,po,lty,tycs) =
124 :			(O.map (fn {default,table} =>
125 :			{default=substvar alpha default,
126 :			table=map (fn (tycs,lv) =>
127 :			(map (tc_subst ta) tycs, substvar alpha lv))
128 :			table}) dict,
129 :			po, lt_subst ta lty, map (tc_subst ta) tycs)
130 :			fun cfk ta {isrec=SOME(ltys,lk),known,inline,cconv} =
131 :			{isrec=SOME(map (lt_subst ta) ltys,lk),
132 :			known=known, inline=inline, cconv=cconv}
133 :			| cfk _ fk = fk
134 :
135 :			fun crk ta (RK_VECTOR tyc) = RK_VECTOR(tc_subst ta tyc)
136 :			| crk _ rk = rk
137 :
138 :			fun copy' ta alpha le = let
139 :			val cpo = cpo ta alpha
140 :			val cdcon = cdcon ta alpha
141 :			val substvar = substvar alpha
142 :			val substval = substval alpha
143 :			val copy = copy' ta
144 :			in case le
145 :	monnier	154	of RET vs => RET(map substval vs)
146 :			| LET (lvs,le,body) =>
147 :			let val nle = copy alpha le
148 :			val (nlvs,nalpha) = newvs(lvs,alpha)
149 :			in LET(nlvs, nle, copy nalpha body)
150 :			end
151 :			| FIX (fdecs,le) =>
152 :			let fun cfun alpha ((fk,f,args,body):fundec,nf) =
153 :			let val (nargs,nalpha) = newvs(map #1 args, alpha)
154 :	monnier	197	in (cfk ta fk, nf,
155 :			ListPair.zip(nargs, (map (lt_subst ta o #2) args)),
156 :			copy nalpha body)
157 :	monnier	154	end
158 :			val (nfs, nalpha) = newvs(map #2 fdecs, alpha)
159 :			val nfdecs = ListPair.map (cfun nalpha) (fdecs, nfs)
160 :			in
161 :			FIX(nfdecs, copy nalpha le)
162 :			end
163 :			| APP (f,args) => APP(substval f, map substval args)
164 :	monnier	220	| TFN ((tfk,lv,args,body),le) =>
165 :	monnier	154	(* don't forget to rename the tvar also *)
166 :			let val (nlv,nalpha) = newv(lv,alpha)
167 :			val (nargs,ialpha) = newvs(map #1 args, nalpha)
168 :	monnier	216	val ita = tmap_sort ((ListPair.map
169 :			(fn ((t,k),nt) => (t, LT.tcc_nvar nt))
170 :			(args, nargs)) @ ta)
171 :	monnier	220	in TFN((tfk,nlv,
172 :			ListPair.zip(nargs, map #2 args),
173 :			copy' ita ialpha body),
174 :			copy nalpha le)
175 :	monnier	154	end
176 :	monnier	197	| TAPP (f,tycs) => TAPP(substval f, map (tc_subst ta) tycs)
177 :	monnier	154	| SWITCH (v,ac,arms,def) =>
178 :			let fun carm (DATAcon(dc,tycs,lv),le) =
179 :			let val (nlv,nalpha) = newv(lv, alpha)
180 :	monnier	197	in (DATAcon(cdcon dc, map (tc_subst ta) tycs, nlv),
181 :			copy nalpha le)
182 :	monnier	154	end
183 :			| carm (con,le) = (con, copy alpha le)
184 :			in SWITCH(substval v, ac, map carm arms, Option.map (copy alpha) def)
185 :			end
186 :			| CON (dc,tycs,v,lv,le) =>
187 :			let val (nlv,nalpha) = newv(lv, alpha)
188 :	monnier	197	in CON(cdcon dc, map (tc_subst ta) tycs, substval v, nlv, copy nalpha le)
189 :	monnier	154	end
190 :			| RECORD (rk,vs,lv,le) =>
191 :			let val (nlv,nalpha) = newv(lv, alpha)
192 :	monnier	197	in RECORD(crk ta rk, map substval vs, nlv, copy nalpha le)
193 :	monnier	154	end
194 :			| SELECT (v,i,lv,le) =>
195 :			let val (nlv,nalpha) = newv(lv, alpha)
196 :			in SELECT(substval v, i, nlv, copy nalpha le)
197 :			end
198 :	monnier	197	| RAISE (v,ltys) => RAISE(substval v, map (lt_subst ta) ltys)
199 :	monnier	154	| HANDLE (le,v) => HANDLE(copy alpha le, substval v)
200 :			| BRANCH (po,vs,le1,le2) =>
201 :			BRANCH(cpo po, map substval vs, copy alpha le1, copy alpha le2)
202 :			| PRIMOP (po,vs,lv,le) =>
203 :			let val (nlv,nalpha) = newv(lv, alpha)
204 :			in PRIMOP(cpo po, map substval vs, nlv, copy nalpha le)
205 :			end
206 :	monnier	197	end
207 :	monnier	216	in copy' (tmap_sort ta) alpha le
208 :	monnier	154	end
209 :	monnier	216	fun copyfdec fdec =
210 :			case copy [] M.empty (F.FIX([fdec], F.RET[]))
211 :			of F.FIX([nfdec], F.RET[]) => nfdec
212 :			| _ => bug "copyfdec"
213 :	monnier	16
214 :	monnier	216	fun freevars lexp = let
215 :			val loop = freevars
216 :	monnier	16
217 :	monnier	489	fun S_rmv(x, s) = S.delete(s, x) handle NotFound => s
218 :
219 :	monnier	423	fun addv (s,F.VAR lv) = S.add(s, lv)
220 :	monnier	216	| addv (s,_) = s
221 :			fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
222 :	monnier	489	fun rmvs (s,lvs) = foldl (fn (l,s) => S_rmv (l, s)) s lvs
223 :	monnier	216	fun singleton (F.VAR v) = S.singleton v
224 :			| singleton _ = S.empty
225 :
226 :			fun fpo (fv,(NONE:F.dict option,po,lty,tycs)) = fv
227 :			| fpo (fv,(SOME{default,table},po,lty,tycs)) =
228 :			addvs(addv(fv, F.VAR default), map (F.VAR o #2) table)
229 :
230 :			fun fdcon (fv,(s,Access.EXN(Access.LVAR lv),lty)) = addv(fv, F.VAR lv)
231 :			| fdcon (fv,_) = fv
232 :
233 :			in case lexp
234 :			of F.RET vs => addvs(S.empty, vs)
235 :			| F.LET (lvs,body,le) => S.union(rmvs(loop le, lvs), loop body)
236 :			| F.FIX (fdecs,le) =>
237 :			rmvs((foldl (fn ((_,_,args,body),fv) =>
238 :			S.union(rmvs(loop body, map #1 args), fv))
239 :			(loop le) fdecs),
240 :			map #2 fdecs)
241 :			| F.APP (f,args) => addvs(S.empty, f::args)
242 :	monnier	489	| F.TFN ((tfk,f,args,body),le) => S.union(S_rmv(f, loop le), loop body)
243 :	monnier	216	| F.TAPP (f,args) => singleton f
244 :			| F.SWITCH (v,ac,arms,def) =>
245 :			let fun farm ((dc,le),fv) =
246 :			let val fvle = loop le
247 :			in S.union(fv,
248 :			case dc
249 :	monnier	489	of F.DATAcon(dc,_,lv) => fdcon(S_rmv(lv, fvle),dc)
250 :	monnier	216	| _ => fvle)
251 :			end
252 :	monnier	220	val fvs = case def of NONE => singleton v
253 :			| SOME le => addv(loop le, v)
254 :			in foldl farm fvs arms
255 :	monnier	216	end
256 :	monnier	489	| F.CON (dc,tycs,v,lv,le) => fdcon(addv(S_rmv(lv, loop le), v),dc)
257 :			| F.RECORD (rk,vs,lv,le) => addvs(S_rmv(lv, loop le), vs)
258 :			| F.SELECT (v,i,lv,le) => addv(S_rmv(lv, loop le), v)
259 :	monnier	216	| F.RAISE (v,ltys) => singleton v
260 :			| F.HANDLE (le,v) => addv(loop le, v)
261 :			| F.BRANCH (po,vs,le1,le2) => fpo(addvs(S.union(loop le1, loop le2), vs), po)
262 :	monnier	489	| F.PRIMOP (po,vs,lv,le) => fpo(addvs(S_rmv(lv, loop le), vs),po)
263 :	monnier	216	end
264 :
265 :	monnier	16	end (* top-level local *)
266 :			end (* structure FlintUtil *)

---

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