Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/compiler/FLINT/main/literals.sml
ViewVC logotype

Diff of /sml/trunk/compiler/FLINT/main/literals.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 2162, Thu Nov 2 21:20:47 2006 UTC revision 4527, Sat Apr 14 14:41:11 2018 UTC
# Line 1  Line 1 
1  (* literals.sml  (* literals.sml
2   *   *
3   * COPYRIGHT (c) 1998 Bell Labs, Lucent Technologies.   * This file implements support for heap-allocated literals.  Our approach
4   * COPYRIGHT (c) 1998 YALE FLINT PROJECT.   * is to split out the literals from the CPS representation and create a
5     * bytecode program that for allocating the literals.
6     *
7     * The implementation of the bytecode interpreter for the literal language
8     * is in base/runtime/gc/build-literals.c.
9     *
10     * COPYRIGHT (c) 2017 The Fellowship of SML/NJ (http://www.smlnj.org)
11     * All rights reserved.
12     *
13     * TODO:
14     *   64BIT: need support for 64-bit integers
15     *   REAL32: need support for 32-bit floats
16     *   add support for IntInf.int as type
17   *)   *)
18    
19  signature LITERALS =  signature LITERALS =
20   sig   sig
21     type lit  
22     val litsplit : CPS.function -> CPS.function * lit    (** `litsplit f` takes a CPS function and splits out the heap-allocated
23     val litToBytes : lit -> Word8Vector.vector     * literal values from it.  At runtime, these literals will be accessed via
24       * a record of literals that is allocated by the runtime system.  This
25       * function returns a rewriten version of its argument that accesses
26       * literals from the record and a byte-vector that encodes the program
27       * for generating the literals.
28       *)
29        val split : CPS.function -> CPS.function * Word8Vector.vector
30    
31   end;   end;
32    
33  structure Literals : LITERALS =  structure Literals : LITERALS =
34  struct  struct
35    
36  structure W8V = Word8Vector  structure W8V = Word8Vector
37        structure LV = LambdaVar
 local structure LV = LambdaVar  
38        structure Intset = struct        structure Intset = struct
39          type intset = IntRedBlackSet.set ref          type intset = IntRedBlackSet.set ref
40          fun new() = ref IntRedBlackSet.empty          fun new() = ref IntRedBlackSet.empty
# Line 24  Line 42 
42          fun mem set i =  IntRedBlackSet.member(!set, i)          fun mem set i =  IntRedBlackSet.member(!set, i)
43          fun rmv set i = set := IntRedBlackSet.delete(!set, i)          fun rmv set i = set := IntRedBlackSet.delete(!set, i)
44        end        end
45    
46        open CPS        open CPS
 in  
47    
48  fun bug msg = ErrorMsg.impossible ("Literals: "^msg)  fun bug msg = ErrorMsg.impossible ("Literals: "^msg)
 val ident = fn x => x  
49  fun mkv _ = LV.mkLvar()  fun mkv _ = LV.mkLvar()
50    
51  (****************************************************************************  (****************************************************************************
# Line 46  Line 63 
63  datatype lit_exp  datatype lit_exp
64    = LI_TOP of lit_val list    = LI_TOP of lit_val list
65    | LI_BLOCK of (block_kind * lit_val list * lvar * lit_exp)    | LI_BLOCK of (block_kind * lit_val list * lvar * lit_exp)
66    | LI_F64BLOCK of (string list * lvar * lit_exp)        | LI_F64BLOCK of (RealLit.t list * lvar * lit_exp)
67    | LI_I32BLOCK of (Word32.word list * lvar * lit_exp)    | LI_I32BLOCK of (Word32.word list * lvar * lit_exp)
68    
 type lit = lit_exp  
   
69  fun rk2bk CPS.RK_VECTOR = LI_VECTOR  fun rk2bk CPS.RK_VECTOR = LI_VECTOR
70    | rk2bk CPS.RK_RECORD = LI_RECORD    | rk2bk CPS.RK_RECORD = LI_RECORD
71    | rk2bk _             = bug "rk2bk: unexpected block kind"    | rk2bk _             = bug "rk2bk: unexpected block kind"
# Line 82  Line 97 
97   *                                 from them and push a pointer.   *                                 from them and push a pointer.
98   *      RETURN                  -- return the literal that is on the top of the   *      RETURN                  -- return the literal that is on the top of the
99   *                                 stack.   *                                 stack.
100       *
101       * Encoding:
102       *   INT(i)           0x01 <i>
103       *   RAW32[i]         0x02 <i>
104       *   RAW32[i1,..,in]  0x03 <n> <i1> ... <in>
105       *   RAW64[r]         0x04 <r>
106       *   RAW64[r1,..,rn]  0x05 <n> <r1> ... <rn>
107       *   STR[c1,..,cn]    0x06 <n> <c1> ... <cn>
108       *   LIT(k)           0x07 <k>
109       *   VECTOR(n)        0x08 <n>
110       *   RECORD(n)        0x09 <n>
111       *   RETURN           0xff
112   *)   *)
113    
114  fun w32ToBytes' (w, l) =  fun w32ToBytes' (w, l) =
# Line 101  Line 128 
128  fun emit_RAW32 [i] = W8V.fromList(0wx02 :: w32ToBytes i)  fun emit_RAW32 [i] = W8V.fromList(0wx02 :: w32ToBytes i)
129    | emit_RAW32 l =    | emit_RAW32 l =
130        W8V.fromList(0wx03 :: (intToBytes'(length l, List.foldr w32ToBytes' [] l)))        W8V.fromList(0wx03 :: (intToBytes'(length l, List.foldr w32ToBytes' [] l)))
131  fun emit_RAW64 [r] = W8V.fromList(0wx04 :: strToBytes r)      fun emit_RAW64 [r] = W8V.fromList(0wx04 :: Word8Vector.toList r)
132    | emit_RAW64 l = W8V.concat(        | emit_RAW64 l = W8V.concat(W8V.fromList(0wx05 :: intToBytes(length l)) :: l)
       W8V.fromList(0wx05 :: intToBytes(length l)) :: map Byte.stringToBytes l)  
133  fun emit_STR s = W8V.concat[  fun emit_STR s = W8V.concat[
134          W8V.fromList(0wx06 :: intToBytes(size s)),          W8V.fromList(0wx06 :: intToBytes(size s)),
135          Byte.stringToBytes s          Byte.stringToBytes s
# Line 142  Line 168 
168                    emit_RECORD(length ls) :: emitLitVals(ls, 0, code)                    emit_RECORD(length ls) :: emitLitVals(ls, 0, code)
169                | emitBlock (LI_VECTOR, ls, code) =                | emitBlock (LI_VECTOR, ls, code) =
170                    emit_VECTOR(length ls) :: emitLitVals(ls, 0, code)                    emit_VECTOR(length ls) :: emitLitVals(ls, 0, code)
171              fun emitF64Block (ls, code) =                  fun emitF64Block (ls, code) = let
172                    emit_RAW64(map IEEERealConst.realconst ls) :: code                        val toBits = #1 o Real64ToBits.toBits
173                          in
174                            emit_RAW64(map toBits ls) :: code
175                          end
176              fun emitI32Block (ls, code) = emit_RAW32 ls :: code              fun emitI32Block (ls, code) = emit_RAW32 ls :: code
177              in              in
178                case exp                case exp
# Line 164  Line 193 
193          W8V.concat code          W8V.concat code
194        end        end
195    
   
 (****************************************************************************  
  *                    LIFTING LITERALS ON FLINT                             *  
  ****************************************************************************)  
 (*  
 fun liftlits body = bug "FLINT version currently not implemented yet"  
   
 fun litsplit (FK_FCT, f, [(v, t)], body) =  
       if LT.ltp_str t then  
         let val (nbody, lit, llt) = liftlits body  
             val nt = LT.ltc_str ((LT.ltd_str t)@[llt])  
          in ((FK_FCT, f, [(v, nt)], body), lit)  
         end  
       else bug "unexpected FLINT header in litsplit (case 1)"  
   | litsplit _ = bug "unexpected FLINT header in litsplit (case 2)"  
 *)  
   
196  (****************************************************************************  (****************************************************************************
197   *                    LIFTING LITERALS ON CPS                               *   *                    LIFTING LITERALS ON CPS                               *
198   ****************************************************************************)   ****************************************************************************)
# Line 191  Line 203 
203    
204  exception LitInfo  exception LitInfo
205    
206  datatype rlit = RLIT of string * word  (* FIXME: we should probably either use hash tables or the raw comparison
207  fun toRlit s = RLIT(s, HashString.hashString s)   * functions to implement the dictionaries.
208  fun fromRlit (RLIT(s, _)) = s   *)
209  fun rlitcmp (RLIT(s1,i1), RLIT(s2,i2)) =  
210      (* string literal dictionary *)
211        datatype slit = SLIT of string * word
212        fun toSlit s = SLIT(s, HashString.hashString s)
213        fun fromSlit (SLIT(s, _)) = s
214        structure SlitDict = RedBlackMapFn(
215          struct
216            type ord_key = slit
217            fun compare (SLIT(s1,i1), SLIT(s2,i2)) =
218    if i1 < i2 then LESS    if i1 < i2 then LESS
219    else if i1 > i2 then GREATER else String.compare(s1, s2)                else if i1 > i2 then GREATER
220  structure RlitDict = RedBlackMapFn(struct type ord_key = rlit                else String.compare(s1, s2)
221                                          val compare = rlitcmp        end)
222    
223      (* real literal dictionary *)
224        datatype rlit = RLIT of RealLit.t * word
225        fun toRlit r = RLIT(r, RealLit.hash r)
226        fun fromRlit (RLIT(r, _)) = r
227        structure RlitDict = RedBlackMapFn(
228          struct
229            type ord_key = rlit
230            fun compare (RLIT(r1,i1), RLIT(r2,i2)) =
231              if i1 < i2 then LESS
232              else if i1 > i2 then GREATER
233              else RealLit.compare(r1, r2)
234                                   end)                                   end)
235    
236  (* lifting all literals from a CPS program *)  (* lifting all literals from a CPS program *)
237  fun liftlits (body, root, offset) =      fun liftlits (body, root, offset) = let
238    let (* the list of record, string, or real constants *)          (* the list of record, string, and real constants *)
239        val m : info IntHashTable.hash_table = IntHashTable.mkTable(32, LitInfo)        val m : info IntHashTable.hash_table = IntHashTable.mkTable(32, LitInfo)
240        val freevars : lvar list ref = ref []        val freevars : lvar list ref = ref []
241        fun addv x = (freevars := (x :: (!freevars)))        fun addv x = (freevars := (x :: (!freevars)))
   
242        (* check if an lvar is used by the main program *)        (* check if an lvar is used by the main program *)
243        val refset : Intset.intset = Intset.new()        val refset : Intset.intset = Intset.new()
244        val used : lvar -> unit = Intset.add refset        val used : lvar -> unit = Intset.add refset
245        val isUsed : lvar -> bool = Intset.mem refset        val isUsed : lvar -> bool = Intset.mem refset
   
246        (* memoize the information on which corresponds to what *)        (* memoize the information on which corresponds to what *)
247        fun enter (v, i) = (IntHashTable.insert m (v, i); addv v)        fun enter (v, i) = (IntHashTable.insert m (v, i); addv v)
248        fun const (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)        fun const (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)
249          | const (INT _ | INT32 _ | REAL _ | STRING _) = true          | const (INT _ | INT32 _ | REAL _ | STRING _) = true
250          | const _ = bug "unexpected case in const"          | const _ = bug "unexpected case in const"
   
251        fun cstlit (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)        fun cstlit (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)
252          | cstlit (REAL _ | STRING _) = true          | cstlit (REAL _ | STRING _) = true
253          | cstlit _ = false          | cstlit _ = false
   
254        (* register a string literal *)        (* register a string literal *)
255        local val strs : string list ref = ref []        local val strs : string list ref = ref []
256              val strsN : int ref = ref 0              val strsN : int ref = ref 0
257              val sdict = ref (RlitDict.empty)                  val sdict = ref (SlitDict.empty)
258              val srtv = mkv()              val srtv = mkv()
259              val srtval = VAR srtv              val srtval = VAR srtv
260        in        in
261        fun entStr s =            fun entStr s = let
262          let val v = mkv()  (** should hash to remove duplicates **)                  val v = mkv()  (** should hash to remove duplicates **)
263              val sd = !sdict              val sd = !sdict
264              val rlit = toRlit s                  val rlit = toSlit s
265              val n =                  val n = (case SlitDict.find(sd, rlit)
               (case RlitDict.find(sd, rlit)  
266                  of SOME k => k                  of SOME k => k
267                   | _ => let val _ = (strs := (s :: (!strs)))                          | _ => let
268                                val _ = (strs := (s :: (!strs)))
269                              val k = !strsN                              val k = !strsN
270                              val _ = (strsN := (k+1))                              val _ = (strsN := (k+1))
271                              val _ = (sdict := (RlitDict.insert(sd, rlit, k)))                              val _ = (sdict := (SlitDict.insert(sd, rlit, k)))
272                           in k                              in
273                          end)                                k
          in (VAR v, fn ce => SELECT(n, srtval, v, BOGt, ce))  
         end  
   
 (* old definition of entStr  
   
         let val sd = !sdict  
             val rlit = toRlit s  
          in (case RlitDict.peek(sd, rlit)  
               of SOME v => (VAR v, ident)  
                | _ => let val v = mkv()  
                           val _ = (enter(v, ZZ_STR s); used v)  
                           val _ = (sdict := RlitDict.insert(sd, rlit, v))  
                        in (VAR v, ident)  
274                        end)                        end)
275                    in
276                      (VAR v, fn ce => SELECT(n, srtval, v, BOGt, ce))
277          end          end
278  *)            fun appStr () = let
279                    fun g (a::r, z) = g(r, (STRING a)::z)
       fun appStr () =  
         let fun g (a::r, z) = g(r, (STRING a)::z)  
280                | g ([], z) = z (* reverse to reflecting the correct order *)                | g ([], z) = z (* reverse to reflecting the correct order *)
281              val allStrs = !strs              val allStrs = !strs
282           in case !strs                  in
283                      case !strs
284               of [] => ()               of [] => ()
285                | xs => (enter(srtv, ZZ_RCD(RK_RECORD, g(xs,[]))); used srtv)                | xs => (enter(srtv, ZZ_RCD(RK_RECORD, g(xs,[]))); used srtv)
286                      (* end case *)
287          end          end
288        end (* local of processing string literals *)        end (* local of processing string literals *)
289            (* register a real literal *)
290        (** a special treatment of real constants *)            local val reals : RealLit.t list ref = ref []
       local val reals : string list ref = ref []  
291              val realsN : int ref = ref 0              val realsN : int ref = ref 0
292              val rdict = ref (RlitDict.empty)              val rdict = ref (RlitDict.empty)
293              val rrtv = mkv()              val rrtv = mkv()
294              val rrtval = VAR rrtv              val rrtval = VAR rrtv
295        in        in
296        fun entReal s =            fun entReal s = let
297          let val v = mkv()  (** should hash to remove duplicates **)                  val v = mkv()  (** should hash to remove duplicates **)
298              val rd = !rdict              val rd = !rdict
299              val rlit = toRlit s              val rlit = toRlit s
300              val n =                  val n = (case RlitDict.find(rd, rlit)
               (case RlitDict.find(rd, rlit)  
301                  of SOME k => k                  of SOME k => k
302                   | _ => let val _ = (reals := (s :: (!reals)))                          | _ => let
303                                val _ = (reals := (s :: (!reals)))
304                              val k = !realsN                              val k = !realsN
305                              val _ = (realsN := (k+1))                              val _ = (realsN := (k+1))
306                              val _ = (rdict := (RlitDict.insert(rd, rlit, k)))                              val _ = (rdict := (RlitDict.insert(rd, rlit, k)))
307                           in k                              in
308                                  k
309                          end)                          end)
310           in (VAR v, fn ce => SELECT(n, rrtval, v, FLTt, ce))                  in
311                      (VAR v, fn ce => SELECT(n, rrtval, v, FLTt 64, ce))   (* REAL32: FIXME *)
312          end          end
313              fun appReal () = let
314        fun appReal () =                  fun g (a::r, z) = g(r, (REAL a)::z)
         let fun g (a::r, z) = g(r, (REAL a)::z)  
315                | g ([], z) = z (* reverse to reflecting the correct order *)                | g ([], z) = z (* reverse to reflecting the correct order *)
316              val allReals = !reals              val allReals = !reals
317           in case !reals                  in
318                      case !reals
319               of [] => ()               of [] => ()
320                | xs => (enter(rrtv, ZZ_RCD(RK_FBLOCK, g(xs,[]))); used rrtv)                | xs => (enter(rrtv, ZZ_RCD(RK_FBLOCK, g(xs,[]))); used rrtv)
321          end          end
322        end (* local of special treatment of real constants *)            end (* local of processing real literals *)
   
323        (* translation on the CPS values *)        (* translation on the CPS values *)
324        fun lpsv u =            fun lpsv u = (case u
325          (case u                   of REAL r => entReal r
           of REAL s => entReal s  
326             | STRING s => entStr s             | STRING s => entStr s
327             | VAR v => (used v; (u, ident))                    | VAR v => (used v; (u, Fn.id))
328             | _ => (u, ident))                    | _ => (u, Fn.id)
329                    (* end case *))
330        fun lpvs vs =            fun lpvs vs = let
331          let fun g (u, (xs, hh)) =                  fun g (u, (xs, hh)) = let
332                let val (nu, nh) = lpsv u                        val (nu, nh) = lpsv u
333                 in (nu::xs, nh o hh)                        in
334                            (nu::xs, nh o hh)
335                end                end
336           in foldr g ([], ident) vs                  in
337                      foldr g ([], Fn.id) vs
338          end          end
   
339        (* if all fields of a record are "constant", then we lift it *)        (* if all fields of a record are "constant", then we lift it *)
340        fun field ul =            fun field ul = let
341          let fun h ((x, OFFp 0)::r, z, rsflag) =                 fun h ((x, OFFp 0)::r, z, rsflag) = if const x
342                   if const x then h(r, x::z, rsflag orelse (cstlit x)) else NONE                          then h(r, x::z, rsflag orelse (cstlit x))
343                            else NONE
344                | h ([], z, rsflag) = if rsflag then SOME(rev z) else NONE                | h ([], z, rsflag) = if rsflag then SOME(rev z) else NONE
345                | h _ = bug "unexpected case in field"                | h _ = bug "unexpected case in field"
346           in h (ul, [], false)                  in
347                      h (ul, [], false)
348          end          end
   
349        (* register a constant record *)        (* register a constant record *)
350        fun record (rk, ul, v) =            fun record (rk, ul, v) = (case field ul
351          (case field ul                   of SOME xl => (enter(v, ZZ_RCD(rk, xl)); Fn.id)
352            of SOME xl => (enter(v, ZZ_RCD(rk, xl)); ident)                    | NONE => let
353             | NONE =>                        fun g ((u, p as OFFp 0), (r, hh)) = let
354                 let fun g ((u, p as OFFp 0), (r, hh)) =                                val (nu, nh) = lpsv u
355                           let val (nu, nh) = lpsv u                                in
356                            in ((nu, p)::r, nh o hh)                                  ((nu, p)::r, nh o hh)
357                           end                           end
358                       | g _ = bug "unexpected non-zero OFFp in record"                       | g _ = bug "unexpected non-zero OFFp in record"
359                     val (nl, hdr) = foldr g ([], ident) ul                        val (nl, hdr) = foldr g ([], Fn.id) ul
360                  in fn ce => hdr(RECORD(rk, nl, v, ce))                        in
361                            fn ce => hdr(RECORD(rk, nl, v, ce))
362                 end)                 end)
   
363        (* register a wrapped float literal *)        (* register a wrapped float literal *)
364        fun wrapfloat (u, v, t) =            fun wrapfloat (u, v, t) = if const u
365          if const u then (enter(v, ZZ_RCD(RK_FBLOCK, [u])); ident)                  then (enter(v, ZZ_RCD(RK_FBLOCK, [u])); Fn.id)
366          else let val (nu, hh) = lpsv u          else let val (nu, hh) = lpsv u
367                in (fn ce => hh(PURE(P.fwrap, [nu], v, t, ce)))                in (fn ce => hh(PURE(P.fwrap, [nu], v, t, ce)))
368               end               end
   
369        (* fetch out the literal information *)        (* fetch out the literal information *)
370        fun getInfo () =            fun getInfo () = let
371          let val _ = appReal()   (* register all Reals as a record *)                  val _ = appReal()   (* register all Reals as a record *)
372              val _ = appStr()   (* register all Strings as a record *)              val _ = appStr()   (* register all Strings as a record *)
373              val allvars = !freevars              val allvars = !freevars
374              val exports = List.filter isUsed allvars              val exports = List.filter isUsed allvars
# Line 366  Line 383 
383                end                end
384    
385              fun mklit (v, lit) = let              fun mklit (v, lit) = let
386                  fun unREAL (CPS.REAL s) = s                      fun unREAL (CPS.REAL r) = r
387                    | unREAL _ = bug "unREAL"                    | unREAL _ = bug "unREAL"
388                  fun unINT32 (CPS.INT32 w) = w                  fun unINT32 (CPS.INT32 w) = w
389                    | unINT32 _ = bug "unINT32"                    | unINT32 _ = bug "unINT32"
390              in              in
391                  case IntHashTable.lookup m v of                        case IntHashTable.lookup m v
392                      (ZZ_FLT _) => (* float is wrapped *)                         of (ZZ_FLT _) => (* float is wrapped *)
393                      bug "currently we don't expect ZZ_FLT in mklit"                      bug "currently we don't expect ZZ_FLT in mklit"
394                    (* LI_F64BLOCK([s], v, lit) *)                    (* LI_F64BLOCK([s], v, lit) *)
395                    | (ZZ_STR s) =>                    | (ZZ_STR s) =>
# Line 391  Line 408 
408    
409              val n = length exports              val n = length exports
410              val hdr =              val hdr =
411                if n = 0 then ident                    if n = 0 then Fn.id
412                else let val rv = mkv()                else let val rv = mkv()
413                         val rval = VAR rv                         val rval = VAR rv
414                         val rhdr =                         val rhdr =
# Line 425  Line 442 
442    
443        fun lpfn (fk, f, vl, cl, e) = (fk, f, vl, cl, loop e)        fun lpfn (fk, f, vl, cl, e) = (fk, f, vl, cl, loop e)
444    
445        and loop ce =            and loop ce = (case ce
         (case ce  
446            of RECORD (rk, ul, v, e) => record (rk, ul, v) (loop e)            of RECORD (rk, ul, v, e) => record (rk, ul, v) (loop e)
447             | SELECT (i, u, v, t, e) =>             | SELECT (i, u, v, t, e) =>
448                 let val (nu, hh) = lpsv u                 let val (nu, hh) = lpsv u
# Line 475  Line 491 
491    end    end
492    
493  (* the main function *)  (* the main function *)
494  fun litsplit (fk, f, vl as [_,x], [CNTt, t as PTRt(RPT n)], body) =      fun split (fk, f, vl as [_,x], [CNTt, t as PTRt(RPT n)], body) = let
495        let val nt = PTRt(RPT (n+1))            val nt = PTRt(RPT (n+1))
496            val (nbody, lit) = liftlits(body, VAR x, n)            val (nbody, lit) = liftlits(body, VAR x, n)
497         in ((fk, f, vl, [CNTt, nt], nbody), lit)            in
498                ((fk, f, vl, [CNTt, nt], nbody), litToBytes lit)
499        end        end
500    | litsplit _ = bug "unexpected CPS header in litsplit"        | split _ = bug "unexpected CPS header in split"
501    
 end (* toplevel local *)  
502  end (* Literals *)  end (* Literals *)

Legend:
Removed from v.2162  
changed lines
  Added in v.4527

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