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 24 - (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 24 val copy : (unit -> LambdaVar.lvar) -> FLINT.fundec -> FLINT.fundec
7 :     end (* signature LEXPUTIL *)
8 : monnier 16
9 :    
10 :     structure FlintUtil : FLINTUTIL =
11 :     struct
12 :    
13 :     local structure EM = ErrorMsg
14 : monnier 24 open Access FLINT
15 :     fun bug msg = EM.impossible("FlintUtil: "^msg)
16 : monnier 16 in
17 :    
18 :     (*
19 :     * general alpha-conversion on lexp free variables remain unchanged
20 :     * val copy: (unit -> lvar) -> fundec -> fundec
21 :     *)
22 :     fun copy mkLvar = let
23 :    
24 :     fun look m v = (IntmapF.lookup m v) handle IntmapF.IntmapF => v
25 :     fun rename (lv, m) =
26 :     let val lv' = mkLvar ()
27 :     val m' = IntmapF.add (m, lv, lv')
28 :     in (lv', m')
29 :     end
30 :    
31 :     fun renamevs (vs, m) =
32 :     let fun h([], nvs, nm) = (rev nvs, nm)
33 :     | h(a::r, nvs, nm) =
34 :     let val (a', nm') = rename(a, nm)
35 :     in h(r, a'::nvs, nm')
36 :     end
37 :     in h(vs, [], m)
38 :     end
39 :    
40 :     fun renamevps (vps, m) =
41 :     let fun h([], nvs, nm) = (rev nvs, nm)
42 :     | h((a,t)::r, nvs, nm) =
43 :     let val (a', nm') = rename(a, nm)
44 :     in h(r, (a',t)::nvs, nm')
45 :     end
46 :     in h(vps, [], m)
47 :     end
48 :    
49 :     (* access *)
50 : monnier 24 fun ca (LVAR v, m) = LVAR (look m v)
51 :     | ca (PATH (a, i), m) = PATH (ca (a, m), i)
52 : monnier 16 | ca (a, _) = a
53 :    
54 :     (* conrep *)
55 : monnier 24 fun ccr (EXN a, m) = EXN (ca (a, m))
56 : monnier 16 | ccr (cr, _) = cr
57 :    
58 :     (* dataconstr *)
59 :     fun cdc ((s, cr, t), m) = (s, ccr (cr, m), t)
60 :    
61 :     (* con *)
62 : monnier 24 fun ccon (DATAcon (dc, ts, vs), m) =
63 :     let val (nvs, m') = renamevs(vs, m)
64 :     in (DATAcon (cdc(dc, m), ts, nvs), m')
65 : monnier 16 end
66 :     | ccon x = x
67 :    
68 :     (* dict *)
69 :     fun dict ({default=v, table=tbls}, m) =
70 :     let val nv = look m v
71 :     val ntbls = map (fn (x, v) => (x, look m v)) tbls
72 :     in {default=nv, table=ntbls}
73 :     end
74 :    
75 :     (* value *)
76 :     fun sv (VAR lv, m) = VAR (look m lv)
77 :     | sv (x as INT _, _) = x
78 :     | sv (x as INT32 _, _) = x
79 :     | sv (x as WORD _, _) = x
80 :     | sv (x as WORD32 _, _) = x
81 :     | sv (x as REAL _, _) = x
82 :     | sv (x as STRING _, _) = x
83 :    
84 :     (* value list *)
85 :     fun svs (vs, m) =
86 :     let fun h([], res, m) = rev res
87 :     | h(v::r, res, m) = h(r, (sv(v, m))::res, m)
88 :     in h(vs, [], m)
89 :     end
90 :    
91 :     (* lexp *)
92 :     fun c (RET vs, m) = RET (svs (vs, m))
93 :     | c (APP (v, vs), m) = APP (sv (v, m), svs (vs, m))
94 :     | c (TAPP (v, ts), m) = TAPP (sv (v, m), ts)
95 :     | c (FIX (fdecs, le), m) =
96 :     let val (fdecs', nm) = cf(fdecs, m)
97 :     in FIX(fdecs', c(le, nm))
98 :     end
99 :     | c (LET (vs, le1, le2), m) =
100 :     let val le1' = c(le1, m)
101 :     val (nvs, m') = renamevs(vs, m)
102 :     in LET(nvs, le1', c(le2, m'))
103 :     end
104 :     | c (TFN (tfdec, le), m) =
105 :     let val (tfdec', nm) = ctf(tfdec, m)
106 :     in TFN(tfdec', c(le, nm))
107 :     end
108 :    
109 :     | c (SWITCH (v, crl, cel, eo), m) =
110 :     let fun cc (con, x) =
111 :     let val (ncon, m') = ccon (con, m)
112 :     in (ncon, c (x, m'))
113 :     end
114 :     fun co NONE = NONE
115 :     | co (SOME x) = SOME (c (x, m))
116 :     in SWITCH (sv (v, m), crl, map cc cel, co eo)
117 :     end
118 : monnier 24 | c (CON (dc, ts, vs, v, le), m) =
119 : monnier 16 let val (nv, nm) = rename(v, m)
120 : monnier 24 in CON (cdc (dc, m), ts, svs (vs, m), nv, c(le, nm))
121 : monnier 16 end
122 :     | c (RECORD (rk, vs, v, le), m) =
123 :     let val (nv, nm) = rename(v, m)
124 :     in RECORD (rk, svs (vs, m), nv, c(le, nm))
125 :     end
126 :     | c (SELECT (u, i, v, le), m) =
127 :     let val (nv, nm) = rename(v, m)
128 :     in SELECT (sv (u,m), i, nv, c(le, nm))
129 :     end
130 :     | c (RAISE (v, ts), m) = RAISE (sv (v, m), ts)
131 :     | c (HANDLE (e, v), m) = HANDLE (c (e, m), sv (v, m))
132 : monnier 24 | c (ETAG (t, u, v, le), m) =
133 : monnier 16 let val (nv, nm) = rename(v, m)
134 : monnier 24 in ETAG (t, sv(u, m), nv, c(le, nm))
135 : monnier 16 end
136 : monnier 24 | c (PRIMOP(p, vs, v, le), m) =
137 :     let val (nv, nm) = rename(v, m)
138 :     in PRIMOP(p, svs(vs, m), nv, c(le, nm))
139 :     end
140 :     | c (GENOP(d, p, vs, v, le), m) =
141 :     let val (nv, nm) = rename(v, m)
142 :     in GENOP(dict(d, m), p, svs(vs, m), nv, c(le, nm))
143 :     end
144 :     | c (WRAP (t, u, v, le), m) =
145 :     let val (nv, nm) = rename(v, m)
146 :     in WRAP (t, sv (u, m), nv, c(le, nm))
147 :     end
148 :     | c (UNWRAP (t, u, v, le), m) =
149 :     let val (nv, nm) = rename(v, m)
150 :     in UNWRAP (t, sv (u, m), nv, c(le, nm))
151 :     end
152 : monnier 16
153 :     and ctf ((v,args,le), m) =
154 :     let val (nv, nm) = rename(v, m)
155 :     (*** ZSH-WARNING: I didn't bother to rename tvars in args ***)
156 :     in ((nv, args, c(le, m)), nm)
157 :     end
158 :    
159 :     and cf (fdecs, m) =
160 :     let fun pass1([], res, m) = (rev res, m)
161 :     | pass1((_, v, _, _)::r, res, m) =
162 :     let val (nv, nm) = rename(v, m)
163 :     in pass1(r, nv::res, nm)
164 :     end
165 :    
166 :     val (nvs, nm) = pass1(fdecs, [], m)
167 :    
168 :     fun pass2([], [], res) = (rev res, nm)
169 :     | pass2((fk, _, args, le)::r, nv::nvs, res) =
170 :     let val (args', nm') = renamevps(args, nm)
171 :     in pass2(r, nvs, (fk, nv, args', c(le, nm'))::res)
172 :     end
173 :     | pass2 _ = bug "unexpected cases in cf - pass2"
174 :     in pass2(fdecs, nvs, [])
175 :     end
176 :     in
177 :     fn fdec =>
178 :     let val init = IntmapF.empty
179 :     val (fdecs', _) = cf([fdec], init)
180 :     in (case fdecs'
181 :     of [x] => x
182 :     | _ => bug "unexpected cases in copy - top")
183 :     end
184 :     end (* function copy *)
185 :    
186 :     end (* top-level local *)
187 :     end (* structure FlintUtil *)

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