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 477 - (view) (download)

1 : monnier 251 (* literals.sml
2 :     *
3 :     * COPYRIGHT (c) 1998 Bell Labs, Lucent Technologies.
4 :     * COPYRIGHT (c) 1998 YALE FLINT PROJECT.
5 :     *)
6 : monnier 98
7 :     signature LITERALS =
8 :     sig
9 :     type lit
10 :     val litsplit : CPS.function -> CPS.function * lit
11 : monnier 251 val litToBytes : lit -> Word8Vector.vector
12 :     end;
13 : monnier 98
14 :     structure Literals : LITERALS =
15 :     struct
16 :    
17 : monnier 251 structure W8V = Word8Vector
18 :    
19 : monnier 98 local structure LV = LambdaVar
20 :     open CPS
21 :     in
22 :    
23 :     fun bug msg = ErrorMsg.impossible ("Literals: "^msg)
24 :     val ident = fn x => x
25 :     fun mkv _ = LV.mkLvar()
26 :    
27 :     (****************************************************************************
28 :     * A MINI-LITERAL LANGUAGE *
29 :     ****************************************************************************)
30 :     datatype lit_val
31 : monnier 251 = LI_INT of word
32 : monnier 98 | LI_STRING of string
33 :     | LI_VAR of lvar
34 :    
35 : monnier 251 datatype block_kind
36 :     = LI_RECORD (* record of tagged ML values *)
37 :     | LI_VECTOR (* vector of tagged ML values *)
38 :    
39 : monnier 98 datatype lit_exp
40 :     = LI_TOP of lit_val list
41 : monnier 251 | LI_BLOCK of (block_kind * lit_val list * lvar * lit_exp)
42 :     | LI_F64BLOCK of (string list * lvar * lit_exp)
43 :     | LI_I32BLOCK of (Word32.word list * lvar * lit_exp)
44 : monnier 98
45 :     type lit = lit_exp
46 :    
47 : monnier 251 fun rk2bk CPS.RK_VECTOR = LI_VECTOR
48 :     | rk2bk CPS.RK_RECORD = LI_RECORD
49 :     | rk2bk _ = bug "rk2bk: unexpected block kind"
50 :    
51 :     fun val2lit (CPS.VAR v) = LI_VAR v
52 :     | val2lit (CPS.INT i) = LI_INT(Word.fromInt i)
53 :     | val2lit (CPS.STRING s) = LI_STRING s
54 : monnier 98 | val2lit _ = bug "unexpected case in val2lit"
55 :    
56 :     (****************************************************************************
57 : monnier 251 * TRANSLATING THE LITERAL EXP TO BYTES *
58 : monnier 98 ****************************************************************************)
59 :    
60 : monnier 251 (* Literals are encoded as instructions for a "literal machine." The abstract
61 :     * description of these instructions is as follows:
62 :     *
63 :     * INT(i) -- push the int31 literal i on the stack
64 :     * RAW32[i1,...,in] -- form a 32-bit raw data record from the
65 :     * i1..in and push a pointer to it.
66 :     * RAW64[r1,...,rn] -- form a 64-bit raw data record from the
67 :     * r1..rn and push a pointer to it.
68 :     * STR[c1,...,cn] -- form a string from the characters c1..cn
69 :     * and push it on the stack.
70 :     * LIT(k) -- push the contents of the stack element
71 :     * that is k slots from the top of the stack.
72 :     * VECTOR(n) -- pop n elements from the stack, make a vector
73 :     * from them and push a pointer to the vector.
74 :     * RECORD(n) -- pop n elements from the stack, make a record
75 :     * from them and push a pointer.
76 :     * RETURN -- return the literal that is on the top of the
77 :     * stack.
78 :     *)
79 : monnier 98
80 : monnier 251 fun w32ToBytes' (w, l) =
81 :     Word8.fromLargeWord(Word32.>>(w, 0w24)) ::
82 :     Word8.fromLargeWord(Word32.>>(w, 0w16)) ::
83 :     Word8.fromLargeWord(Word32.>>(w, 0w8)) ::
84 :     Word8.fromLargeWord w :: l
85 :     fun w32ToBytes w = w32ToBytes' (w, [])
86 :     fun w31ToBytes w = w32ToBytes(Word31.toLargeWordX w)
87 :     fun intToBytes i = w32ToBytes(Word32.fromInt i)
88 :     fun intToBytes' (i, l) = w32ToBytes'(Word32.fromInt i, l)
89 :     fun strToBytes s = map Byte.charToByte (explode s)
90 : monnier 98
91 : monnier 251 val emit_MAGIC = W8V.fromList[0wx19, 0wx98, 0wx10, 0wx22]
92 :     fun emit_DEPTH n = W8V.fromList(intToBytes n)
93 :     fun emit_INT i = W8V.fromList(0wx01 :: w31ToBytes i)
94 :     fun emit_RAW32 [i] = W8V.fromList(0wx02 :: w32ToBytes i)
95 :     | emit_RAW32 l =
96 :     W8V.fromList(0wx03 :: (intToBytes'(length l, List.foldr w32ToBytes' [] l)))
97 :     fun emit_RAW64 [r] = W8V.fromList(0wx04 :: strToBytes r)
98 :     | emit_RAW64 l = W8V.concat(
99 :     W8V.fromList(0wx05 :: intToBytes(length l)) :: map Byte.stringToBytes l)
100 :     fun emit_STR s = W8V.concat[
101 :     W8V.fromList(0wx06 :: intToBytes(size s)),
102 :     Byte.stringToBytes s
103 :     ]
104 :     fun emit_LIT k = W8V.fromList(0wx07 :: intToBytes k)
105 :     fun emit_VECTOR n = W8V.fromList(0wx08 :: intToBytes n)
106 :     fun emit_RECORD n = W8V.fromList(0wx09 :: intToBytes n)
107 :     val emit_RETURN = W8V.fromList[0wxff]
108 : monnier 98
109 : monnier 251 fun litToBytes (LI_TOP[]) = W8V.fromList[]
110 :     | litToBytes litExp = let
111 :     fun depth (LI_TOP ls, d, maxDepth) = Int.max(maxDepth, d+length ls)
112 :     | depth (LI_BLOCK(_, ls, _, rest), d, maxDepth) =
113 :     depth (rest, d+1, Int.max(maxDepth, d+length ls))
114 :     | depth (LI_F64BLOCK(ls, _, rest), d, maxDepth) =
115 :     depth (rest, d+1, Int.max(maxDepth, d+length ls))
116 :     | depth (LI_I32BLOCK(ls, _, rest), d, maxDepth) =
117 :     depth (rest, d+1, Int.max(maxDepth, d+length ls))
118 :     fun emitLitExp (env, exp, code) = let
119 :     fun emitLitVals ([], _, code) = code
120 :     | emitLitVals (lit::r, d, code) = let
121 :     val instr = (case lit
122 :     of (LI_INT i) => emit_INT i
123 :     | (LI_STRING s) => emit_STR s
124 :     | (LI_VAR v) => let
125 :     fun f ([], _) = bug "unbound lvar"
126 :     | f (v'::r, d) = if (v = v') then d else f(r, d+1)
127 :     in
128 :     emit_LIT(f (env, d))
129 :     end
130 :     (* end case *))
131 :     in
132 :     emitLitVals (r, d+1, instr::code)
133 :     end
134 :     fun emitBlock (LI_RECORD, ls, code) =
135 :     emit_RECORD(length ls) :: emitLitVals(ls, 0, code)
136 :     | emitBlock (LI_VECTOR, ls, code) =
137 :     emit_VECTOR(length ls) :: emitLitVals(ls, 0, code)
138 :     fun emitF64Block (ls, code) =
139 :     emit_RAW64(map IEEERealConst.realconst ls) :: code
140 :     fun emitI32Block (ls, code) = emit_RAW32 ls :: code
141 :     in
142 :     case exp
143 :     of (LI_TOP ls) => emit_RETURN :: emitBlock(LI_RECORD, ls, code)
144 :     | (LI_BLOCK(bk, ls, v, rest)) =>
145 :     emitLitExp (v::env, rest, emitBlock(bk, ls, code))
146 :     | (LI_F64BLOCK(ls, v, rest)) =>
147 :     emitLitExp (v::env, rest, emitF64Block(ls, code))
148 :     | (LI_I32BLOCK(ls, v, rest)) =>
149 :     emitLitExp (v::env, rest, emitI32Block(ls, code))
150 :     (* end case *)
151 :     end
152 :     val maxDepth = depth (litExp, 0, 1)
153 :     val code = emit_MAGIC
154 :     :: emit_DEPTH maxDepth
155 :     :: List.rev(emitLitExp([], litExp, []))
156 :     in
157 :     W8V.concat code
158 :     end
159 : monnier 98
160 : monnier 251
161 : monnier 98 (****************************************************************************
162 :     * LIFTING LITERALS ON FLINT *
163 :     ****************************************************************************)
164 :     (*
165 :     fun liftlits body = bug "FLINT version currently not implemented yet"
166 :    
167 :     fun litsplit (FK_FCT, f, [(v, t)], body) =
168 :     if LT.ltp_str t then
169 : monnier 251 let val (nbody, lit, llt) = liftlits body
170 : monnier 98 val nt = LT.ltc_str ((LT.ltd_str t)@[llt])
171 :     in ((FK_FCT, f, [(v, nt)], body), lit)
172 :     end
173 :     else bug "unexpected FLINT header in litsplit (case 1)"
174 :     | litsplit _ = bug "unexpected FLINT header in litsplit (case 2)"
175 :     *)
176 :    
177 :     (****************************************************************************
178 :     * LIFTING LITERALS ON CPS *
179 :     ****************************************************************************)
180 :     datatype info
181 :     = ZZ_STR of string
182 :     | ZZ_FLT of string
183 :     | ZZ_RCD of record_kind * value list
184 :    
185 :     exception LitInfo
186 :    
187 : monnier 422 datatype rlit = RLIT of string * word
188 :     fun toRlit s = RLIT(s, HashString.hashString s)
189 : monnier 98 fun fromRlit (RLIT(s, _)) = s
190 :     fun rlitcmp (RLIT(s1,i1), RLIT(s2,i2)) =
191 :     if i1 < i2 then LESS
192 :     else if i1 > i2 then GREATER else String.compare(s1, s2)
193 : monnier 422 structure RlitDict = BinaryMapFn(struct type ord_key = rlit
194 : monnier 477 val compare = rlitcmp
195 :     end)
196 : monnier 98
197 :     (* lifting all literals from a CPS program *)
198 :     fun liftlits (body, root, offset) =
199 :     let (* the list of record, string, or real constants *)
200 :     val m : info Intmap.intmap = Intmap.new(32, LitInfo)
201 :     val freevars : lvar list ref = ref []
202 :     fun addv x = (freevars := (x :: (!freevars)))
203 :    
204 :     (* check if an lvar is used by the main program *)
205 :     val refset : Intset.intset = Intset.new()
206 : monnier 477 val used : lvar -> unit = Intset.add refset
207 : monnier 98 val isUsed : lvar -> bool = Intset.mem refset
208 :    
209 :     (* memoize the information on which corresponds to what *)
210 :     fun enter (v, i) = (Intmap.add m (v, i); addv v)
211 :     fun const (VAR v) = ((Intmap.map m v; true) handle _ => false)
212 :     | const (INT _ | INT32 _ | REAL _ | STRING _) = true
213 :     | const _ = bug "unexpected case in const"
214 :    
215 : monnier 251 fun cstlit (VAR v) = ((Intmap.map m v; true) handle _ => false)
216 :     | cstlit (REAL _ | STRING _) = true
217 :     | cstlit _ = false
218 :    
219 : monnier 98 (* register a string literal *)
220 :     local val strs : string list ref = ref []
221 :     val strsN : int ref = ref 0
222 : monnier 422 val sdict = ref (RlitDict.empty)
223 : monnier 98 val srtv = mkv()
224 :     val srtval = VAR srtv
225 :     in
226 :     fun entStr s =
227 :     let val v = mkv() (** should hash to remove duplicates **)
228 :     val sd = !sdict
229 :     val rlit = toRlit s
230 :     val n =
231 : monnier 422 (case RlitDict.find(sd, rlit)
232 : monnier 98 of SOME k => k
233 :     | _ => let val _ = (strs := (s :: (!strs)))
234 :     val k = !strsN
235 :     val _ = (strsN := (k+1))
236 :     val _ = (sdict := (RlitDict.insert(sd, rlit, k)))
237 :     in k
238 :     end)
239 :     in (VAR v, fn ce => SELECT(n, srtval, v, BOGt, ce))
240 :     end
241 :    
242 :     (* old definition of entStr
243 :    
244 :     let val sd = !sdict
245 :     val rlit = toRlit s
246 :     in (case RlitDict.peek(sd, rlit)
247 :     of SOME v => (VAR v, ident)
248 :     | _ => let val v = mkv()
249 :     val _ = (enter(v, ZZ_STR s); used v)
250 :     val _ = (sdict := RlitDict.insert(sd, rlit, v))
251 :     in (VAR v, ident)
252 :     end)
253 :     end
254 :     *)
255 :    
256 :     fun appStr () =
257 :     let fun g (a::r, z) = g(r, (STRING a)::z)
258 :     | g ([], z) = z (* reverse to reflecting the correct order *)
259 :     val allStrs = !strs
260 :     in case !strs
261 :     of [] => ()
262 :     | xs => (enter(srtv, ZZ_RCD(RK_RECORD, g(xs,[]))); used srtv)
263 :     end
264 :     end (* local of processing string literals *)
265 :    
266 :     (** a special treatment of real constants *)
267 :     local val reals : string list ref = ref []
268 :     val realsN : int ref = ref 0
269 : monnier 422 val rdict = ref (RlitDict.empty)
270 : monnier 98 val rrtv = mkv()
271 :     val rrtval = VAR rrtv
272 :     in
273 :     fun entReal s =
274 :     let val v = mkv() (** should hash to remove duplicates **)
275 :     val rd = !rdict
276 :     val rlit = toRlit s
277 :     val n =
278 : monnier 422 (case RlitDict.find(rd, rlit)
279 : monnier 98 of SOME k => k
280 :     | _ => let val _ = (reals := (s :: (!reals)))
281 :     val k = !realsN
282 :     val _ = (realsN := (k+1))
283 :     val _ = (rdict := (RlitDict.insert(rd, rlit, k)))
284 :     in k
285 :     end)
286 :     in (VAR v, fn ce => SELECT(n, rrtval, v, FLTt, ce))
287 :     end
288 :    
289 :     fun appReal () =
290 :     let fun g (a::r, z) = g(r, (REAL a)::z)
291 :     | g ([], z) = z (* reverse to reflecting the correct order *)
292 :     val allReals = !reals
293 :     in case !reals
294 :     of [] => ()
295 :     | xs => (enter(rrtv, ZZ_RCD(RK_FBLOCK, g(xs,[]))); used rrtv)
296 :     end
297 :     end (* local of special treatment of real constants *)
298 :    
299 :     (* translation on the CPS values *)
300 :     fun lpsv u =
301 :     (case u
302 :     of REAL s => entReal s
303 :     | STRING s => entStr s
304 :     | VAR v => (used v; (u, ident))
305 :     | _ => (u, ident))
306 :    
307 :     fun lpvs vs =
308 :     let fun g (u, (xs, hh)) =
309 :     let val (nu, nh) = lpsv u
310 :     in (nu::xs, nh o hh)
311 :     end
312 :     in foldr g ([], ident) vs
313 :     end
314 :    
315 :     (* if all fields of a record are "constant", then we lift it *)
316 :     fun field ul =
317 : monnier 251 let fun h ((x, OFFp 0)::r, z, rsflag) =
318 :     if const x then h(r, x::z, rsflag orelse (cstlit x)) else NONE
319 :     | h ([], z, rsflag) = if rsflag then SOME(rev z) else NONE
320 : monnier 98 | h _ = bug "unexpected case in field"
321 : monnier 251 in h (ul, [], false)
322 : monnier 98 end
323 :    
324 :     (* register a constant record *)
325 :     fun record (rk, ul, v) =
326 :     (case field ul
327 :     of SOME xl => (enter(v, ZZ_RCD(rk, xl)); ident)
328 :     | NONE =>
329 :     let fun g ((u, p as OFFp 0), (r, hh)) =
330 :     let val (nu, nh) = lpsv u
331 :     in ((nu, p)::r, nh o hh)
332 :     end
333 :     | g _ = bug "unexpected non-zero OFFp in record"
334 :     val (nl, hdr) = foldr g ([], ident) ul
335 :     in fn ce => hdr(RECORD(rk, nl, v, ce))
336 :     end)
337 :    
338 :     (* register a wrapped float literal *)
339 :     fun wrapfloat (u, v, t) =
340 :     if const u then (enter(v, ZZ_RCD(RK_FBLOCK, [u])); ident)
341 :     else let val (nu, hh) = lpsv u
342 :     in (fn ce => hh(PURE(P.fwrap, [nu], v, t, ce)))
343 :     end
344 :    
345 :     (* fetch out the literal information *)
346 :     fun getInfo () =
347 :     let val _ = appReal() (* register all Reals as a record *)
348 :     val _ = appStr() (* register all Strings as a record *)
349 :     val allvars = !freevars
350 :     val exports = List.filter isUsed allvars
351 :    
352 :     val toplit =
353 :     let fun g ([], z) = LI_TOP z
354 :     | g (x::r, z) =
355 :     (case Intmap.map m x
356 :     of ZZ_STR s => g(r, (LI_STRING s)::z)
357 :     | _ => g(r, (LI_VAR x)::z))
358 :     in g(exports, [])
359 :     end
360 :    
361 :     fun mklit (v, lit) =
362 :     (case Intmap.map m v
363 :     of (ZZ_FLT _) => (* float is wrapped *)
364 :     bug "currently we don't expect ZZ_FLT in mklit"
365 : monnier 251 (* LI_F64BLOCK([s], v, lit) *)
366 : monnier 98 | (ZZ_STR s) =>
367 :     bug "currently we don't expect ZZ_STR in mklit"
368 :     (* lit --- or we could inline string *)
369 : monnier 251 | (ZZ_RCD(CPS.RK_FBLOCK, vs)) =>
370 :     LI_F64BLOCK(map (fn (CPS.REAL s) => s) vs, v, lit)
371 :     | (ZZ_RCD(CPS.RK_I32BLOCK, vs)) =>
372 :     LI_I32BLOCK(map (fn (CPS.INT32 w) => w) vs, v, lit)
373 :     | (ZZ_RCD(rk, vs)) =>
374 :     LI_BLOCK(rk2bk rk, map val2lit vs, v, lit))
375 : monnier 98
376 :     (** build up the literal structure *)
377 :     val lit = foldl mklit toplit allvars
378 :    
379 :     val n = length exports
380 :     val hdr =
381 :     if n = 0 then ident
382 :     else let val rv = mkv()
383 :     val rval = VAR rv
384 :     val rhdr =
385 :     fn ce => SELECT(offset, root, rv, PTRt(RPT n), ce)
386 :    
387 :     fun mkhdr (v, (i, hh)) =
388 :     let val nh =
389 :     (case Intmap.map m v
390 :     of (ZZ_FLT _) => bug "ZZ_FLT in mkhdr"
391 :     (* (fn ce =>
392 :     (SELECT(i, rval, w, PTRt(FPT 1),
393 :     SELECT(0, VAR w, v, FLTt, ce)))) *)
394 :     | (ZZ_STR s) => bug "ZZ_STR in mkhdr"
395 :     (* (fn ce =>
396 :     SELECT(i, rval, v, BOGt, ce)) *)
397 :     | (ZZ_RCD (rk, vs)) =>
398 :     let val n = length vs
399 :     val t =
400 :     case rk
401 :     of RK_FBLOCK => PTRt(FPT n)
402 : monnier 477 | RK_VECTOR => BOGt
403 : monnier 98 | _ => PTRt(RPT n)
404 :     in fn ce => SELECT(i, rval, v, t, ce)
405 :     end)
406 :     in (i+1, hh o nh)
407 :     end
408 :     in #2 (foldr mkhdr (0, rhdr) exports)
409 :     end
410 :     in (lit, hdr)
411 :     end (* function getInfo *)
412 :    
413 :     fun lpfn (fk, f, vl, cl, e) = (fk, f, vl, cl, loop e)
414 :    
415 :     and loop ce =
416 :     (case ce
417 :     of RECORD (rk, ul, v, e) => record (rk, ul, v) (loop e)
418 :     | SELECT (i, u, v, t, e) =>
419 :     let val (nu, hh) = lpsv u
420 :     in hh(SELECT(i, nu, v, t, loop e))
421 :     end
422 :     | OFFSET _ => bug "unexpected OFFSET in loop"
423 :     | APP (u, ul) =>
424 :     let val (nu, h1) = lpsv u
425 :     val (nl, h2) = lpvs ul
426 :     in h1(h2(APP(nu, nl)))
427 :     end
428 :     | FIX (fns, e) => FIX(map lpfn fns, loop e)
429 :     | SWITCH (u, v, es) =>
430 :     let val (nu, hh) = lpsv u
431 :     in hh(SWITCH(nu, v, map loop es))
432 :     end
433 :     | BRANCH (p, ul, v, e1, e2) =>
434 :     let val (nl, hh) = lpvs ul
435 :     in hh(BRANCH(p, nl, v, loop e1, loop e2))
436 :     end
437 :     | SETTER (p, ul, e) =>
438 :     let val (nl, hh) = lpvs ul
439 :     in hh(SETTER(p, nl, loop e))
440 :     end
441 :     | LOOKER (p, ul, v, t, e) =>
442 :     let val (nl, hh) = lpvs ul
443 :     in hh(LOOKER(p, nl, v, t, loop e))
444 :     end
445 :     | ARITH (p, ul, v, t, e) =>
446 :     let val (nl, hh) = lpvs ul
447 :     in hh(ARITH(p, nl, v, t, loop e))
448 :     end
449 :     | PURE (P.fwrap, [u], v, t, e) => wrapfloat (u, v, t) (loop e)
450 :     | PURE (p, ul, v, t, e) =>
451 :     let val (nl, hh) = lpvs ul
452 :     in hh(PURE(p, nl, v, t, loop e))
453 :     end)
454 :    
455 :     val newbody = loop body
456 :     val (lit, hdr) = getInfo ()
457 :     in (hdr newbody, lit)
458 :     end
459 :    
460 :     (* the main function *)
461 :     fun litsplit (fk, f, vl as [_,x], [CNTt, t as PTRt(RPT n)], body) =
462 :     let val nt = PTRt(RPT (n+1))
463 : monnier 251 val (nbody, lit) = liftlits(body, VAR x, n)
464 : monnier 98 in ((fk, f, vl, [CNTt, nt], nbody), lit)
465 :     end
466 :     | litsplit _ = bug "unexpected CPS header in litsplit"
467 :    
468 :     end (* toplevel local *)
469 :     end (* Literals *)
470 :    
471 : monnier 477 (*
472 :     * $Log$
473 :     *)
474 :    

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