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 45 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/FLINT/flint/flintutil.sml

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 :     val copy : (unit -> FLINT.lvar) -> FLINT.prog -> FLINT.prog
22 :     end (* signature FLINTUTIL *)
23 :    
24 :    
25 : monnier 16 structure FlintUtil : FLINTUTIL =
26 :     struct
27 :    
28 :     local structure EM = ErrorMsg
29 : monnier 45 structure LT = LtyExtern
30 :     structure PO = PrimOp
31 :     structure DA = Access
32 :     open FLINT
33 : monnier 16 in
34 :    
35 : monnier 45 fun bug msg = EM.impossible("FlintUtil: "^msg)
36 :    
37 :     val rk_tuple : rkind = RK_TUPLE (LT.rfc_tmp)
38 :    
39 :     (* a set of useful primops used by FLINT *)
40 :     val tv0 = LT.ltc_tv 0
41 :     val btv0 = LT.ltc_tyc(LT.tcc_box (LT.tcc_tv 0))
42 :     val etag_lty =
43 :     LT.ltc_ppoly ([LT.tkc_mono],
44 :     LT.ltc_arrow(LT.ffc_rrflint, [LT.ltc_string],
45 :     [LT.ltc_etag tv0]))
46 :     fun wrap_lty tc =
47 :     LT.ltc_tyc(LT.tcc_arrow(LT.ffc_fixed, [tc], [LT.tcc_wrap tc]))
48 :     fun unwrap_lty tc =
49 :     LT.ltc_tyc(LT.tcc_arrow(LT.ffc_fixed, [LT.tcc_wrap tc], [tc]))
50 :    
51 :     fun mketag tc = (NONE, PO.MKETAG, etag_lty, [tc])
52 :     fun wrap tc = (NONE, PO.WRAP, wrap_lty tc, [])
53 :     fun unwrap tc = (NONE, PO.UNWRAP, unwrap_lty tc, [])
54 :    
55 :     fun WRAP(tc, vs, v, e) = PRIMOP(wrap tc, vs, v, e)
56 :     fun UNWRAP(tc, vs, v, e) = PRIMOP(unwrap tc, vs, v, e)
57 :    
58 :     (* the corresponding utility functions to recover the tyc *)
59 :     fun getEtagTyc (_, _, lt, [tc]) = tc
60 :     | getEtagTyc (_, _, lt, []) =
61 :     let val (t, xs) = LT.tcd_app(LT.ltd_tyc (#2(LT.ltd_parrow lt)))
62 :     in (case xs of [x] => x
63 :     | _ => bug "unexpected case 1 in getEtagTyc")
64 :     end
65 :     | getEtagTyc _ = bug "unexpected case 2 in getEtagTyc"
66 :    
67 :     fun getWrapTyc (_, _, lt, []) = LT.ltd_tyc(#1(LT.ltd_parrow lt))
68 :     | getWrapTyc _ = bug "unexpected case in getWrapTyc"
69 :    
70 :     fun getUnWrapTyc (_, _, lt, []) = LT.ltd_tyc(#2(LT.ltd_parrow lt))
71 :     | getUnWrapTyc _ = bug "unexpected case in getUnWrapTyc"
72 :    
73 : monnier 16 (*
74 :     * general alpha-conversion on lexp free variables remain unchanged
75 :     * val copy: (unit -> lvar) -> fundec -> fundec
76 :     *)
77 :     fun copy mkLvar = let
78 :    
79 :     fun look m v = (IntmapF.lookup m v) handle IntmapF.IntmapF => v
80 :     fun rename (lv, m) =
81 :     let val lv' = mkLvar ()
82 :     val m' = IntmapF.add (m, lv, lv')
83 :     in (lv', m')
84 :     end
85 :    
86 :     fun renamevs (vs, m) =
87 :     let fun h([], nvs, nm) = (rev nvs, nm)
88 :     | h(a::r, nvs, nm) =
89 :     let val (a', nm') = rename(a, nm)
90 :     in h(r, a'::nvs, nm')
91 :     end
92 :     in h(vs, [], m)
93 :     end
94 :    
95 :     fun renamevps (vps, m) =
96 :     let fun h([], nvs, nm) = (rev nvs, nm)
97 :     | h((a,t)::r, nvs, nm) =
98 :     let val (a', nm') = rename(a, nm)
99 :     in h(r, (a',t)::nvs, nm')
100 :     end
101 :     in h(vps, [], m)
102 :     end
103 :    
104 :     (* access *)
105 : monnier 45 fun ca (DA.LVAR v, m) = DA.LVAR (look m v)
106 :     | ca (DA.PATH (a, i), m) = DA.PATH (ca (a, m), i)
107 : monnier 16 | ca (a, _) = a
108 :    
109 :     (* conrep *)
110 : monnier 45 fun ccr (DA.EXN a, m) = DA.EXN (ca (a, m))
111 : monnier 16 | ccr (cr, _) = cr
112 :    
113 :     (* dataconstr *)
114 :     fun cdc ((s, cr, t), m) = (s, ccr (cr, m), t)
115 :    
116 :     (* con *)
117 : monnier 45 fun ccon (DATAcon (dc, ts, v), m) =
118 :     let val (nv, m') = rename(v, m)
119 :     in (DATAcon (cdc(dc, m), ts, nv), m')
120 : monnier 16 end
121 :     | ccon x = x
122 :    
123 :     (* dict *)
124 :     fun dict ({default=v, table=tbls}, m) =
125 :     let val nv = look m v
126 :     val ntbls = map (fn (x, v) => (x, look m v)) tbls
127 :     in {default=nv, table=ntbls}
128 :     end
129 :    
130 : monnier 45 (* primop *)
131 :     fun cprim (p as (NONE, _, _, _), m) = p
132 :     | cprim ((SOME d, p, lt, ts), m) = (SOME (dict(d, m)), p, lt, ts)
133 :    
134 : monnier 16 (* value *)
135 :     fun sv (VAR lv, m) = VAR (look m lv)
136 :     | sv (x as INT _, _) = x
137 :     | sv (x as INT32 _, _) = x
138 :     | sv (x as WORD _, _) = x
139 :     | sv (x as WORD32 _, _) = x
140 :     | sv (x as REAL _, _) = x
141 :     | sv (x as STRING _, _) = x
142 :    
143 :     (* value list *)
144 :     fun svs (vs, m) =
145 :     let fun h([], res, m) = rev res
146 :     | h(v::r, res, m) = h(r, (sv(v, m))::res, m)
147 :     in h(vs, [], m)
148 :     end
149 :    
150 :     (* lexp *)
151 :     fun c (RET vs, m) = RET (svs (vs, m))
152 :     | c (APP (v, vs), m) = APP (sv (v, m), svs (vs, m))
153 :     | c (TAPP (v, ts), m) = TAPP (sv (v, m), ts)
154 :     | c (FIX (fdecs, le), m) =
155 :     let val (fdecs', nm) = cf(fdecs, m)
156 :     in FIX(fdecs', c(le, nm))
157 :     end
158 :     | c (LET (vs, le1, le2), m) =
159 :     let val le1' = c(le1, m)
160 :     val (nvs, m') = renamevs(vs, m)
161 :     in LET(nvs, le1', c(le2, m'))
162 :     end
163 :     | c (TFN (tfdec, le), m) =
164 :     let val (tfdec', nm) = ctf(tfdec, m)
165 :     in TFN(tfdec', c(le, nm))
166 :     end
167 :    
168 :     | c (SWITCH (v, crl, cel, eo), m) =
169 :     let fun cc (con, x) =
170 :     let val (ncon, m') = ccon (con, m)
171 :     in (ncon, c (x, m'))
172 :     end
173 :     fun co NONE = NONE
174 :     | co (SOME x) = SOME (c (x, m))
175 :     in SWITCH (sv (v, m), crl, map cc cel, co eo)
176 :     end
177 : monnier 45 | c (CON (dc, ts, u, v, le), m) =
178 : monnier 16 let val (nv, nm) = rename(v, m)
179 : monnier 45 in CON (cdc (dc, m), ts, sv (u, m), nv, c(le, nm))
180 : monnier 16 end
181 :     | c (RECORD (rk, vs, v, le), m) =
182 :     let val (nv, nm) = rename(v, m)
183 :     in RECORD (rk, svs (vs, m), nv, c(le, nm))
184 :     end
185 :     | c (SELECT (u, i, v, le), m) =
186 :     let val (nv, nm) = rename(v, m)
187 :     in SELECT (sv (u,m), i, nv, c(le, nm))
188 :     end
189 :     | c (RAISE (v, ts), m) = RAISE (sv (v, m), ts)
190 :     | c (HANDLE (e, v), m) = HANDLE (c (e, m), sv (v, m))
191 : monnier 45 | c (BRANCH (p, vs, e1, e2), m) =
192 :     BRANCH (cprim(p, m), svs(vs, m), c(e1, m), c(e2, m))
193 :     | c (PRIMOP (p, vs, v, le), m) =
194 : monnier 16 let val (nv, nm) = rename(v, m)
195 : monnier 45 in PRIMOP(cprim(p,m), svs(vs, m), nv, c(le, nm))
196 : monnier 16 end
197 :    
198 :     and ctf ((v,args,le), m) =
199 :     let val (nv, nm) = rename(v, m)
200 :     (*** ZSH-WARNING: I didn't bother to rename tvars in args ***)
201 :     in ((nv, args, c(le, m)), nm)
202 :     end
203 :    
204 :     and cf (fdecs, m) =
205 :     let fun pass1([], res, m) = (rev res, m)
206 :     | pass1((_, v, _, _)::r, res, m) =
207 :     let val (nv, nm) = rename(v, m)
208 :     in pass1(r, nv::res, nm)
209 :     end
210 :    
211 :     val (nvs, nm) = pass1(fdecs, [], m)
212 :    
213 :     fun pass2([], [], res) = (rev res, nm)
214 :     | pass2((fk, _, args, le)::r, nv::nvs, res) =
215 :     let val (args', nm') = renamevps(args, nm)
216 :     in pass2(r, nvs, (fk, nv, args', c(le, nm'))::res)
217 :     end
218 :     | pass2 _ = bug "unexpected cases in cf - pass2"
219 :     in pass2(fdecs, nvs, [])
220 :     end
221 :     in
222 :     fn fdec =>
223 :     let val init = IntmapF.empty
224 :     val (fdecs', _) = cf([fdec], init)
225 :     in (case fdecs'
226 :     of [x] => x
227 :     | _ => bug "unexpected cases in copy - top")
228 :     end
229 :     end (* function copy *)
230 :    
231 :     end (* top-level local *)
232 :     end (* structure FlintUtil *)

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