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 1755, Thu Feb 10 23:54:06 2005 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 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 391  Line 401 
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 475  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.1755  
changed lines
  Added in v.4516

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