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

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