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 216 - (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 :     FLINT.lvar IntmapF.intmap ->
26 :     FLINT.lexp -> FLINT.lexp
27 : monnier 216 val copyfdec : FLINT.fundec -> FLINT.fundec
28 : monnier 154
29 : monnier 216 val freevars : FLINT.lexp -> IntSetF.intset
30 :    
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 154 structure M = IntmapF
44 : monnier 197 structure A = Access
45 :     structure O = Option
46 : monnier 216 structure S = IntSetF
47 :     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 216 val tmap_sort = Sort.sort (fn ((v1,_),(v2,_)) => v1 > v2)
107 :    
108 : monnier 197 fun substvar alpha lv = ((M.lookup alpha lv) handle M.IntmapF => lv)
109 :     fun substval alpha (VAR lv) = VAR(substvar alpha lv)
110 :     | substval alpha v = v
111 : monnier 154 fun newv (lv,alpha) =
112 :     let val nlv = cplv lv in (nlv, M.add(alpha,lv,nlv)) end
113 :     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 :     | TFN ((lv,args,body),le) =>
165 :     (* 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 197 in TFN((nlv, ListPair.zip(nargs, map #2 args), copy' ita ialpha body),
172 : monnier 154 copy nalpha le)
173 :     end
174 : monnier 197 | TAPP (f,tycs) => TAPP(substval f, map (tc_subst ta) tycs)
175 : monnier 154 | SWITCH (v,ac,arms,def) =>
176 :     let fun carm (DATAcon(dc,tycs,lv),le) =
177 :     let val (nlv,nalpha) = newv(lv, alpha)
178 : monnier 197 in (DATAcon(cdcon dc, map (tc_subst ta) tycs, nlv),
179 :     copy nalpha le)
180 : monnier 154 end
181 :     | carm (con,le) = (con, copy alpha le)
182 :     in SWITCH(substval v, ac, map carm arms, Option.map (copy alpha) def)
183 :     end
184 :     | CON (dc,tycs,v,lv,le) =>
185 :     let val (nlv,nalpha) = newv(lv, alpha)
186 : monnier 197 in CON(cdcon dc, map (tc_subst ta) tycs, substval v, nlv, copy nalpha le)
187 : monnier 154 end
188 :     | RECORD (rk,vs,lv,le) =>
189 :     let val (nlv,nalpha) = newv(lv, alpha)
190 : monnier 197 in RECORD(crk ta rk, map substval vs, nlv, copy nalpha le)
191 : monnier 154 end
192 :     | SELECT (v,i,lv,le) =>
193 :     let val (nlv,nalpha) = newv(lv, alpha)
194 :     in SELECT(substval v, i, nlv, copy nalpha le)
195 :     end
196 : monnier 197 | RAISE (v,ltys) => RAISE(substval v, map (lt_subst ta) ltys)
197 : monnier 154 | HANDLE (le,v) => HANDLE(copy alpha le, substval v)
198 :     | BRANCH (po,vs,le1,le2) =>
199 :     BRANCH(cpo po, map substval vs, copy alpha le1, copy alpha le2)
200 :     | PRIMOP (po,vs,lv,le) =>
201 :     let val (nlv,nalpha) = newv(lv, alpha)
202 :     in PRIMOP(cpo po, map substval vs, nlv, copy nalpha le)
203 :     end
204 : monnier 197 end
205 : monnier 216 in copy' (tmap_sort ta) alpha le
206 : monnier 154 end
207 : monnier 216 fun copyfdec fdec =
208 :     case copy [] M.empty (F.FIX([fdec], F.RET[]))
209 :     of F.FIX([nfdec], F.RET[]) => nfdec
210 :     | _ => bug "copyfdec"
211 : monnier 16
212 : monnier 216 fun freevars lexp = let
213 :     val loop = freevars
214 : monnier 16
215 : monnier 216 fun addv (s,F.VAR lv) = S.add(lv, s)
216 :     | addv (s,_) = s
217 :     fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
218 :     fun rmvs (s,lvs) = foldl S.rmv s lvs
219 :     fun singleton (F.VAR v) = S.singleton v
220 :     | singleton _ = S.empty
221 :    
222 :     fun fpo (fv,(NONE:F.dict option,po,lty,tycs)) = fv
223 :     | fpo (fv,(SOME{default,table},po,lty,tycs)) =
224 :     addvs(addv(fv, F.VAR default), map (F.VAR o #2) table)
225 :    
226 :     fun fdcon (fv,(s,Access.EXN(Access.LVAR lv),lty)) = addv(fv, F.VAR lv)
227 :     | fdcon (fv,_) = fv
228 :    
229 :     in case lexp
230 :     of F.RET vs => addvs(S.empty, vs)
231 :     | F.LET (lvs,body,le) => S.union(rmvs(loop le, lvs), loop body)
232 :     | F.FIX (fdecs,le) =>
233 :     rmvs((foldl (fn ((_,_,args,body),fv) =>
234 :     S.union(rmvs(loop body, map #1 args), fv))
235 :     (loop le) fdecs),
236 :     map #2 fdecs)
237 :     | F.APP (f,args) => addvs(S.empty, f::args)
238 :     | F.TFN ((f,args,body),le) => S.union(S.rmv(f, loop le), loop body)
239 :     | F.TAPP (f,args) => singleton f
240 :     | F.SWITCH (v,ac,arms,def) =>
241 :     let fun farm ((dc,le),fv) =
242 :     let val fvle = loop le
243 :     in S.union(fv,
244 :     case dc
245 :     of F.DATAcon(dc,_,lv) => fdcon(S.rmv(lv, fvle),dc)
246 :     | _ => fvle)
247 :     end
248 :     in foldl farm (case def of NONE => S.empty | SOME le => loop le) arms
249 :     end
250 :     | F.CON (dc,tycs,v,lv,le) => fdcon(addv(S.rmv(lv, loop le), v),dc)
251 :     | F.RECORD (rk,vs,lv,le) => addvs(S.rmv(lv, loop le), vs)
252 :     | F.SELECT (v,i,lv,le) => addv(S.rmv(lv, loop le), v)
253 :     | F.RAISE (v,ltys) => singleton v
254 :     | F.HANDLE (le,v) => addv(loop le, v)
255 :     | F.BRANCH (po,vs,le1,le2) => fpo(addvs(S.union(loop le1, loop le2), vs), po)
256 :     | F.PRIMOP (po,vs,lv,le) => fpo(addvs(S.rmv(lv, loop le), vs),po)
257 :     end
258 :    
259 : monnier 16 end (* top-level local *)
260 :     end (* structure FlintUtil *)
261 : monnier 93
262 :     (*
263 : monnier 113 * $Log$
264 : monnier 93 *)

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