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

sml/trunk/src/compiler/FLINT/main/literals.sml revision 651, Thu Jun 1 18:34:03 2000 UTC sml/trunk/compiler/FLINT/main/literals.sml revision 4516, Sat Oct 28 17:51:15 2017 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 49  Line 66 
66    | LI_F64BLOCK of (string list * lvar * lit_exp)    | LI_F64BLOCK of (string 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 164  Line 191 
191          W8V.concat code          W8V.concat code
192        end        end
193    
   
 (****************************************************************************  
  *                    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)"  
 *)  
   
194  (****************************************************************************  (****************************************************************************
195   *                    LIFTING LITERALS ON CPS                               *   *                    LIFTING LITERALS ON CPS                               *
196   ****************************************************************************)   ****************************************************************************)
# Line 204  Line 214 
214  (* lifting all literals from a CPS program *)  (* lifting all literals from a CPS program *)
215  fun liftlits (body, root, offset) =  fun liftlits (body, root, offset) =
216    let (* the list of record, string, or real constants *)    let (* the list of record, string, or real constants *)
217        val m : info Intmap.intmap = Intmap.new(32, LitInfo)            val m : info IntHashTable.hash_table = IntHashTable.mkTable(32, LitInfo)
218        val freevars : lvar list ref = ref []        val freevars : lvar list ref = ref []
219        fun addv x = (freevars := (x :: (!freevars)))        fun addv x = (freevars := (x :: (!freevars)))
220    
# Line 214  Line 224 
224        val isUsed : lvar -> bool = Intset.mem refset        val isUsed : lvar -> bool = Intset.mem refset
225    
226        (* memoize the information on which corresponds to what *)        (* memoize the information on which corresponds to what *)
227        fun enter (v, i) = (Intmap.add m (v, i); addv v)            fun enter (v, i) = (IntHashTable.insert m (v, i); addv v)
228        fun const (VAR v) = ((Intmap.map m v; true) handle _ => false)            fun const (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)
229          | const (INT _ | INT32 _ | REAL _ | STRING _) = true          | const (INT _ | INT32 _ | REAL _ | STRING _) = true
230          | const _ = bug "unexpected case in const"          | const _ = bug "unexpected case in const"
231    
232        fun cstlit (VAR v) = ((Intmap.map m v; true) handle _ => false)            fun cstlit (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)
233          | cstlit (REAL _ | STRING _) = true          | cstlit (REAL _ | STRING _) = true
234          | cstlit _ = false          | cstlit _ = false
235    
# Line 290  Line 300 
300                              val _ = (rdict := (RlitDict.insert(rd, rlit, k)))                              val _ = (rdict := (RlitDict.insert(rd, rlit, k)))
301                           in k                           in k
302                          end)                          end)
303           in (VAR v, fn ce => SELECT(n, rrtval, v, FLTt, ce))               in (VAR v, fn ce => SELECT(n, rrtval, v, FLTt 64, ce))     (* REAL32: FIXME *)
304          end          end
305    
306        fun appReal () =        fun appReal () =
# Line 308  Line 318 
318          (case u          (case u
319            of REAL s => entReal s            of REAL s => entReal s
320             | STRING s => entStr s             | STRING s => entStr s
321             | VAR v => (used v; (u, ident))                 | VAR v => (used v; (u, Fn.id))
322             | _ => (u, ident))                 | _ => (u, Fn.id))
323    
324        fun lpvs vs =        fun lpvs vs =
325          let fun g (u, (xs, hh)) =          let fun g (u, (xs, hh)) =
326                let val (nu, nh) = lpsv u                let val (nu, nh) = lpsv u
327                 in (nu::xs, nh o hh)                 in (nu::xs, nh o hh)
328                end                end
329           in foldr g ([], ident) vs               in foldr g ([], Fn.id) vs
330          end          end
331    
332        (* if all fields of a record are "constant", then we lift it *)        (* if all fields of a record are "constant", then we lift it *)
# Line 331  Line 341 
341        (* register a constant record *)        (* register a constant record *)
342        fun record (rk, ul, v) =        fun record (rk, ul, v) =
343          (case field ul          (case field ul
344            of SOME xl => (enter(v, ZZ_RCD(rk, xl)); ident)                of SOME xl => (enter(v, ZZ_RCD(rk, xl)); Fn.id)
345             | NONE =>             | NONE =>
346                 let fun g ((u, p as OFFp 0), (r, hh)) =                 let fun g ((u, p as OFFp 0), (r, hh)) =
347                           let val (nu, nh) = lpsv u                           let val (nu, nh) = lpsv u
348                            in ((nu, p)::r, nh o hh)                            in ((nu, p)::r, nh o hh)
349                           end                           end
350                       | g _ = bug "unexpected non-zero OFFp in record"                       | g _ = bug "unexpected non-zero OFFp in record"
351                     val (nl, hdr) = foldr g ([], ident) ul                         val (nl, hdr) = foldr g ([], Fn.id) ul
352                  in fn ce => hdr(RECORD(rk, nl, v, ce))                  in fn ce => hdr(RECORD(rk, nl, v, ce))
353                 end)                 end)
354    
355        (* register a wrapped float literal *)        (* register a wrapped float literal *)
356        fun wrapfloat (u, v, t) =        fun wrapfloat (u, v, t) =
357          if const u then (enter(v, ZZ_RCD(RK_FBLOCK, [u])); ident)              if const u then (enter(v, ZZ_RCD(RK_FBLOCK, [u])); Fn.id)
358          else let val (nu, hh) = lpsv u          else let val (nu, hh) = lpsv u
359                in (fn ce => hh(PURE(P.fwrap, [nu], v, t, ce)))                in (fn ce => hh(PURE(P.fwrap, [nu], v, t, ce)))
360               end               end
# Line 359  Line 369 
369              val toplit =              val toplit =
370                let fun g ([], z) = LI_TOP z                let fun g ([], z) = LI_TOP z
371                      | g (x::r, z) =                      | g (x::r, z) =
372                           (case Intmap.map m x                               (case IntHashTable.lookup m x
373                             of ZZ_STR s => g(r, (LI_STRING s)::z)                             of ZZ_STR s => g(r, (LI_STRING s)::z)
374                              | _ => g(r, (LI_VAR x)::z))                              | _ => g(r, (LI_VAR x)::z))
375                 in g(exports, [])                 in g(exports, [])
376                end                end
377    
378              fun mklit (v, lit) =                  fun mklit (v, lit) = let
379                (case Intmap.map m v                      fun unREAL (CPS.REAL s) = s
380                  of (ZZ_FLT _) => (* float is wrapped *)                        | unREAL _ = bug "unREAL"
381                        fun unINT32 (CPS.INT32 w) = w
382                          | unINT32 _ = bug "unINT32"
383                    in
384                        case IntHashTable.lookup m v of
385                            (ZZ_FLT _) => (* float is wrapped *)
386                       bug "currently we don't expect ZZ_FLT in mklit"                       bug "currently we don't expect ZZ_FLT in mklit"
387                       (* LI_F64BLOCK([s], v, lit) *)                       (* LI_F64BLOCK([s], v, lit) *)
388                   | (ZZ_STR s) =>                   | (ZZ_STR s) =>
389                       bug "currently we don't expect ZZ_STR in mklit"                       bug "currently we don't expect ZZ_STR in mklit"
390                       (* lit   --- or we could inline string *)                       (* lit   --- or we could inline string *)
391                   | (ZZ_RCD(CPS.RK_FBLOCK, vs)) =>                   | (ZZ_RCD(CPS.RK_FBLOCK, vs)) =>
392                       LI_F64BLOCK(map (fn (CPS.REAL s) => s) vs, v, lit)                          LI_F64BLOCK(map unREAL vs, v, lit)
393                   | (ZZ_RCD(CPS.RK_I32BLOCK, vs)) =>                   | (ZZ_RCD(CPS.RK_I32BLOCK, vs)) =>
394                       LI_I32BLOCK(map (fn (CPS.INT32 w) => w) vs, v, lit)                         LI_I32BLOCK(map unINT32 vs, v, lit)
395                   | (ZZ_RCD(rk, vs)) =>                   | (ZZ_RCD(rk, vs)) =>
396                       LI_BLOCK(rk2bk rk, map val2lit vs, v, lit))                           LI_BLOCK(rk2bk rk, map val2lit vs, v, lit)
397                    end
398    
399              (** build up the literal structure *)              (** build up the literal structure *)
400              val lit = foldl mklit toplit allvars              val lit = foldl mklit toplit allvars
401    
402              val n = length exports              val n = length exports
403              val hdr =              val hdr =
404                if n = 0 then ident                    if n = 0 then Fn.id
405                else let val rv = mkv()                else let val rv = mkv()
406                         val rval = VAR rv                         val rval = VAR rv
407                         val rhdr =                         val rhdr =
# Line 393  Line 409 
409    
410                         fun mkhdr (v, (i, hh)) =                         fun mkhdr (v, (i, hh)) =
411                           let val nh =                           let val nh =
412                                 (case Intmap.map m v                                     (case IntHashTable.lookup m v
413                                   of (ZZ_FLT _) => bug "ZZ_FLT in mkhdr"                                   of (ZZ_FLT _) => bug "ZZ_FLT in mkhdr"
414                                        (* (fn ce =>                                        (* (fn ce =>
415                                             (SELECT(i, rval, w, PTRt(FPT 1),                                             (SELECT(i, rval, w, PTRt(FPT 1),
# Line 457  Line 473 
473             | PURE (p, ul, v, t, e) =>             | PURE (p, ul, v, t, e) =>
474                 let val (nl, hh) = lpvs ul                 let val (nl, hh) = lpvs ul
475                  in hh(PURE(p, nl, v, t, loop e))                  in hh(PURE(p, nl, v, t, loop e))
476                       end
477                   | RCC (k, l, p, ul, vtl, e) =>
478                       let val (nl, hh) = lpvs ul
479                        in hh(RCC(k, l, p, nl, vtl, loop e))
480                 end)                 end)
481    
482        val newbody = loop body        val newbody = loop body
# Line 465  Line 485 
485    end    end
486    
487  (* the main function *)  (* the main function *)
488  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
489        let val nt = PTRt(RPT (n+1))            val nt = PTRt(RPT (n+1))
490            val (nbody, lit) = liftlits(body, VAR x, n)            val (nbody, lit) = liftlits(body, VAR x, n)
491         in ((fk, f, vl, [CNTt, nt], nbody), lit)            in
492                ((fk, f, vl, [CNTt, nt], nbody), litToBytes lit)
493        end        end
494    | litsplit _ = bug "unexpected CPS header in litsplit"        | split _ = bug "unexpected CPS header in split"
495    
 end (* toplevel local *)  
496  end (* Literals *)  end (* Literals *)

Legend:
Removed from v.651  
changed lines
  Added in v.4516

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