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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 651 - (view) (download)

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

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