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

Annotation of /sml/trunk/src/compiler/FLINT/main/literals.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 122 - (view) (download)

1 : monnier 98 (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *)
2 :     (* literals.sml *)
3 :    
4 :     signature LITERALS =
5 :     sig
6 :     type lit
7 :     val litsplit : CPS.function -> CPS.function * lit
8 :     val lit2cps : lit -> CPS.function
9 :     end
10 :    
11 :     structure Literals : LITERALS =
12 :     struct
13 :    
14 :     local structure LV = LambdaVar
15 :     open CPS
16 :     in
17 :    
18 :     fun bug msg = ErrorMsg.impossible ("Literals: "^msg)
19 :     val ident = fn x => x
20 : monnier 122 val liftLiterals = Control.FLINT.liftLiterals
21 : monnier 98 fun mkv _ = LV.mkLvar()
22 :    
23 :     (****************************************************************************
24 :     * A MINI-LITERAL LANGUAGE *
25 :     ****************************************************************************)
26 :     datatype lit_val
27 :     = LI_INT of int
28 :     | LI_INT32 of Word32.word
29 :     | LI_REAL of string
30 :     | LI_STRING of string
31 :     | LI_VAR of lvar
32 :    
33 :     datatype lit_exp
34 :     = LI_TOP of lit_val list
35 :     | LI_RECORD of record_kind * lit_val list * lvar * lit_exp
36 :    
37 :     type lit = lit_exp
38 :    
39 :     fun val2lit (VAR v) = LI_VAR v
40 :     | val2lit (INT i) = LI_INT i
41 :     | val2lit (INT32 i) = LI_INT32 i
42 :     | val2lit (REAL s) = LI_REAL s
43 :     | val2lit (STRING s) = LI_STRING s
44 :     | val2lit _ = bug "unexpected case in val2lit"
45 :    
46 :     (****************************************************************************
47 :     * TRANSLATING THE LITERAL EXP TO CPS EXP *
48 :     ****************************************************************************)
49 :     fun lit2cps li =
50 :     let val k = mkv()
51 :    
52 :     fun toval (LI_INT i) = INT i
53 :     | toval (LI_INT32 i) = INT32 i
54 :     | toval (LI_REAL s) = REAL s
55 :     | toval (LI_STRING s) = STRING s
56 :     | toval (LI_VAR v) = VAR v
57 :    
58 :     fun toexp (LI_TOP []) = APP(VAR k, [INT 0])
59 :     | toexp (LI_TOP vs) =
60 :     let val v = mkv()
61 :     val nvs = map (fn x => (toval x, OFFp 0)) vs
62 :     in RECORD(RK_RECORD, nvs, v, APP(VAR k, [VAR v]))
63 :     end
64 :     | toexp (LI_RECORD (rk, vs, v, e)) =
65 :     let val nvs = map (fn x => (toval x, OFFp 0)) vs
66 :     in RECORD(rk, nvs, v, toexp e)
67 :     end
68 :    
69 :     val f = mkv()
70 :     val x = mkv()
71 :     in (ESCAPE, f, [k, x], [CNTt, BOGt], toexp li)
72 :     end
73 :    
74 :    
75 :     (****************************************************************************
76 :     * LIFTING LITERALS ON FLINT *
77 :     ****************************************************************************)
78 :     (*
79 :     fun liftlits body = bug "FLINT version currently not implemented yet"
80 :    
81 :     fun litsplit (FK_FCT, f, [(v, t)], body) =
82 :     if LT.ltp_str t then
83 :     let val (nbody, lit, llt) =
84 :     if !liftLiterals then liftlits body
85 :     else (body, LI_TOP [], LT.ltc_str[])
86 :     val nt = LT.ltc_str ((LT.ltd_str t)@[llt])
87 :     in ((FK_FCT, f, [(v, nt)], body), lit)
88 :     end
89 :     else bug "unexpected FLINT header in litsplit (case 1)"
90 :     | litsplit _ = bug "unexpected FLINT header in litsplit (case 2)"
91 :     *)
92 :    
93 :     (****************************************************************************
94 :     * LIFTING LITERALS ON CPS *
95 :     ****************************************************************************)
96 :     datatype info
97 :     = ZZ_STR of string
98 :     | ZZ_FLT of string
99 :     | ZZ_RCD of record_kind * value list
100 :    
101 :     exception LitInfo
102 :    
103 :     datatype rlit = RLIT of string * int
104 :     fun toRlit s = RLIT(s, StrgHash.hashString s)
105 :     fun fromRlit (RLIT(s, _)) = s
106 :     fun rlitcmp (RLIT(s1,i1), RLIT(s2,i2)) =
107 :     if i1 < i2 then LESS
108 :     else if i1 > i2 then GREATER else String.compare(s1, s2)
109 :     structure RlitDict = BinaryDict(struct type ord_key = rlit
110 :     val cmpKey = rlitcmp
111 :     end)
112 :    
113 :     (* lifting all literals from a CPS program *)
114 :     fun liftlits (body, root, offset) =
115 :     let (* the list of record, string, or real constants *)
116 :     val m : info Intmap.intmap = Intmap.new(32, LitInfo)
117 :     val freevars : lvar list ref = ref []
118 :     fun addv x = (freevars := (x :: (!freevars)))
119 :    
120 :     (* check if an lvar is used by the main program *)
121 :     val refset : Intset.intset = Intset.new()
122 :     val used : lvar -> unit = Intset.add refset
123 :     val isUsed : lvar -> bool = Intset.mem refset
124 :    
125 :     (* memoize the information on which corresponds to what *)
126 :     fun enter (v, i) = (Intmap.add m (v, i); addv v)
127 :     fun const (VAR v) = ((Intmap.map m v; true) handle _ => false)
128 :     | const (INT _ | INT32 _ | REAL _ | STRING _) = true
129 :     | const _ = bug "unexpected case in const"
130 :    
131 :     (* register a string literal *)
132 :     local val strs : string list ref = ref []
133 :     val strsN : int ref = ref 0
134 :     val sdict = ref (RlitDict.mkDict())
135 :     val srtv = mkv()
136 :     val srtval = VAR srtv
137 :     in
138 :     fun entStr s =
139 :     let val v = mkv() (** should hash to remove duplicates **)
140 :     val sd = !sdict
141 :     val rlit = toRlit s
142 :     val n =
143 :     (case RlitDict.peek(sd, rlit)
144 :     of SOME k => k
145 :     | _ => let val _ = (strs := (s :: (!strs)))
146 :     val k = !strsN
147 :     val _ = (strsN := (k+1))
148 :     val _ = (sdict := (RlitDict.insert(sd, rlit, k)))
149 :     in k
150 :     end)
151 :     in (VAR v, fn ce => SELECT(n, srtval, v, BOGt, ce))
152 :     end
153 :    
154 :     (* old definition of entStr
155 :    
156 :     let val sd = !sdict
157 :     val rlit = toRlit s
158 :     in (case RlitDict.peek(sd, rlit)
159 :     of SOME v => (VAR v, ident)
160 :     | _ => let val v = mkv()
161 :     val _ = (enter(v, ZZ_STR s); used v)
162 :     val _ = (sdict := RlitDict.insert(sd, rlit, v))
163 :     in (VAR v, ident)
164 :     end)
165 :     end
166 :     *)
167 :    
168 :     fun appStr () =
169 :     let fun g (a::r, z) = g(r, (STRING a)::z)
170 :     | g ([], z) = z (* reverse to reflecting the correct order *)
171 :     val allStrs = !strs
172 :     in case !strs
173 :     of [] => ()
174 :     | xs => (enter(srtv, ZZ_RCD(RK_RECORD, g(xs,[]))); used srtv)
175 :     end
176 :     end (* local of processing string literals *)
177 :    
178 :     (** a special treatment of real constants *)
179 :     local val reals : string list ref = ref []
180 :     val realsN : int ref = ref 0
181 :     val rdict = ref (RlitDict.mkDict())
182 :     val rrtv = mkv()
183 :     val rrtval = VAR rrtv
184 :     in
185 :     fun entReal s =
186 :     let val v = mkv() (** should hash to remove duplicates **)
187 :     val rd = !rdict
188 :     val rlit = toRlit s
189 :     val n =
190 :     (case RlitDict.peek(rd, rlit)
191 :     of SOME k => k
192 :     | _ => let val _ = (reals := (s :: (!reals)))
193 :     val k = !realsN
194 :     val _ = (realsN := (k+1))
195 :     val _ = (rdict := (RlitDict.insert(rd, rlit, k)))
196 :     in k
197 :     end)
198 :     in (VAR v, fn ce => SELECT(n, rrtval, v, FLTt, ce))
199 :     end
200 :    
201 :     fun appReal () =
202 :     let fun g (a::r, z) = g(r, (REAL a)::z)
203 :     | g ([], z) = z (* reverse to reflecting the correct order *)
204 :     val allReals = !reals
205 :     in case !reals
206 :     of [] => ()
207 :     | xs => (enter(rrtv, ZZ_RCD(RK_FBLOCK, g(xs,[]))); used rrtv)
208 :     end
209 :     end (* local of special treatment of real constants *)
210 :    
211 :     (* translation on the CPS values *)
212 :     fun lpsv u =
213 :     (case u
214 :     of REAL s => entReal s
215 :     | STRING s => entStr s
216 :     | VAR v => (used v; (u, ident))
217 :     | _ => (u, ident))
218 :    
219 :     fun lpvs vs =
220 :     let fun g (u, (xs, hh)) =
221 :     let val (nu, nh) = lpsv u
222 :     in (nu::xs, nh o hh)
223 :     end
224 :     in foldr g ([], ident) vs
225 :     end
226 :    
227 :     (* if all fields of a record are "constant", then we lift it *)
228 :     fun field ul =
229 :     let fun h ((x, OFFp 0)::r, z) =
230 :     if const x then h(r, x::z) else NONE
231 :     | h ([], z) = SOME(rev z)
232 :     | h _ = bug "unexpected case in field"
233 :     in h (ul, [])
234 :     end
235 :    
236 :     (* register a constant record *)
237 :     fun record (rk, ul, v) =
238 :     (case field ul
239 :     of SOME xl => (enter(v, ZZ_RCD(rk, xl)); ident)
240 :     | NONE =>
241 :     let fun g ((u, p as OFFp 0), (r, hh)) =
242 :     let val (nu, nh) = lpsv u
243 :     in ((nu, p)::r, nh o hh)
244 :     end
245 :     | g _ = bug "unexpected non-zero OFFp in record"
246 :     val (nl, hdr) = foldr g ([], ident) ul
247 :     in fn ce => hdr(RECORD(rk, nl, v, ce))
248 :     end)
249 :    
250 :     (* register a wrapped float literal *)
251 :     fun wrapfloat (u, v, t) =
252 :     if const u then (enter(v, ZZ_RCD(RK_FBLOCK, [u])); ident)
253 :     else let val (nu, hh) = lpsv u
254 :     in (fn ce => hh(PURE(P.fwrap, [nu], v, t, ce)))
255 :     end
256 :    
257 :     (* fetch out the literal information *)
258 :     fun getInfo () =
259 :     let val _ = appReal() (* register all Reals as a record *)
260 :     val _ = appStr() (* register all Strings as a record *)
261 :     val allvars = !freevars
262 :     val exports = List.filter isUsed allvars
263 :    
264 :     val toplit =
265 :     let fun g ([], z) = LI_TOP z
266 :     | g (x::r, z) =
267 :     (case Intmap.map m x
268 :     of ZZ_STR s => g(r, (LI_STRING s)::z)
269 :     | _ => g(r, (LI_VAR x)::z))
270 :     in g(exports, [])
271 :     end
272 :    
273 :     fun mklit (v, lit) =
274 :     (case Intmap.map m v
275 :     of (ZZ_FLT _) => (* float is wrapped *)
276 :     bug "currently we don't expect ZZ_FLT in mklit"
277 :     (* LI_RECORD(RK_FBLOCK, [LI_REAL s], v, lit) *)
278 :     | (ZZ_STR s) =>
279 :     bug "currently we don't expect ZZ_STR in mklit"
280 :     (* lit --- or we could inline string *)
281 :     | (ZZ_RCD (rk, vs)) =>
282 :     LI_RECORD(rk, map val2lit vs, v, lit))
283 :    
284 :     (** build up the literal structure *)
285 :     val lit = foldl mklit toplit allvars
286 :    
287 :     val n = length exports
288 :     val hdr =
289 :     if n = 0 then ident
290 :     else let val rv = mkv()
291 :     val rval = VAR rv
292 :     val rhdr =
293 :     fn ce => SELECT(offset, root, rv, PTRt(RPT n), ce)
294 :    
295 :     fun mkhdr (v, (i, hh)) =
296 :     let val nh =
297 :     (case Intmap.map m v
298 :     of (ZZ_FLT _) => bug "ZZ_FLT in mkhdr"
299 :     (* (fn ce =>
300 :     (SELECT(i, rval, w, PTRt(FPT 1),
301 :     SELECT(0, VAR w, v, FLTt, ce)))) *)
302 :     | (ZZ_STR s) => bug "ZZ_STR in mkhdr"
303 :     (* (fn ce =>
304 :     SELECT(i, rval, v, BOGt, ce)) *)
305 :     | (ZZ_RCD (rk, vs)) =>
306 :     let val n = length vs
307 :     val t =
308 :     case rk
309 :     of RK_FBLOCK => PTRt(FPT n)
310 :     | _ => PTRt(RPT n)
311 :     in fn ce => SELECT(i, rval, v, t, ce)
312 :     end)
313 :     in (i+1, hh o nh)
314 :     end
315 :     in #2 (foldr mkhdr (0, rhdr) exports)
316 :     end
317 :     in (lit, hdr)
318 :     end (* function getInfo *)
319 :    
320 :     fun lpfn (fk, f, vl, cl, e) = (fk, f, vl, cl, loop e)
321 :    
322 :     and loop ce =
323 :     (case ce
324 :     of RECORD (rk, ul, v, e) => record (rk, ul, v) (loop e)
325 :     | SELECT (i, u, v, t, e) =>
326 :     let val (nu, hh) = lpsv u
327 :     in hh(SELECT(i, nu, v, t, loop e))
328 :     end
329 :     | OFFSET _ => bug "unexpected OFFSET in loop"
330 :     | APP (u, ul) =>
331 :     let val (nu, h1) = lpsv u
332 :     val (nl, h2) = lpvs ul
333 :     in h1(h2(APP(nu, nl)))
334 :     end
335 :     | FIX (fns, e) => FIX(map lpfn fns, loop e)
336 :     | SWITCH (u, v, es) =>
337 :     let val (nu, hh) = lpsv u
338 :     in hh(SWITCH(nu, v, map loop es))
339 :     end
340 :     | BRANCH (p, ul, v, e1, e2) =>
341 :     let val (nl, hh) = lpvs ul
342 :     in hh(BRANCH(p, nl, v, loop e1, loop e2))
343 :     end
344 :     | SETTER (p, ul, e) =>
345 :     let val (nl, hh) = lpvs ul
346 :     in hh(SETTER(p, nl, loop e))
347 :     end
348 :     | LOOKER (p, ul, v, t, e) =>
349 :     let val (nl, hh) = lpvs ul
350 :     in hh(LOOKER(p, nl, v, t, loop e))
351 :     end
352 :     | ARITH (p, ul, v, t, e) =>
353 :     let val (nl, hh) = lpvs ul
354 :     in hh(ARITH(p, nl, v, t, loop e))
355 :     end
356 :     | PURE (P.fwrap, [u], v, t, e) => wrapfloat (u, v, t) (loop e)
357 :     | PURE (p, ul, v, t, e) =>
358 :     let val (nl, hh) = lpvs ul
359 :     in hh(PURE(p, nl, v, t, loop e))
360 :     end)
361 :    
362 :     val newbody = loop body
363 :     val (lit, hdr) = getInfo ()
364 :     in (hdr newbody, lit)
365 :     end
366 :    
367 :     (* the main function *)
368 :     fun litsplit (fk, f, vl as [_,x], [CNTt, t as PTRt(RPT n)], body) =
369 :     let val nt = PTRt(RPT (n+1))
370 :     val (nbody, lit) =
371 :     if !liftLiterals then liftlits(body, VAR x, n)
372 :     else (body, LI_TOP [])
373 :    
374 :     in ((fk, f, vl, [CNTt, nt], nbody), lit)
375 :     end
376 :     | litsplit _ = bug "unexpected CPS header in litsplit"
377 :    
378 :     end (* toplevel local *)
379 :     end (* Literals *)
380 :    

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