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 4512, Sun Oct 22 14:23:27 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 164  Line 179 
179          W8V.concat code          W8V.concat code
180        end        end
181    
   
 (****************************************************************************  
  *                    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)"  
 *)  
   
182  (****************************************************************************  (****************************************************************************
183   *                    LIFTING LITERALS ON CPS                               *   *                    LIFTING LITERALS ON CPS                               *
184   ****************************************************************************)   ****************************************************************************)
# Line 290  Line 288 
288                              val _ = (rdict := (RlitDict.insert(rd, rlit, k)))                              val _ = (rdict := (RlitDict.insert(rd, rlit, k)))
289                           in k                           in k
290                          end)                          end)
291           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 *)
292          end          end
293    
294        fun appReal () =        fun appReal () =
# Line 308  Line 306 
306          (case u          (case u
307            of REAL s => entReal s            of REAL s => entReal s
308             | STRING s => entStr s             | STRING s => entStr s
309             | VAR v => (used v; (u, ident))                 | VAR v => (used v; (u, Fn.id))
310             | _ => (u, ident))                 | _ => (u, Fn.id))
311    
312        fun lpvs vs =        fun lpvs vs =
313          let fun g (u, (xs, hh)) =          let fun g (u, (xs, hh)) =
314                let val (nu, nh) = lpsv u                let val (nu, nh) = lpsv u
315                 in (nu::xs, nh o hh)                 in (nu::xs, nh o hh)
316                end                end
317           in foldr g ([], ident) vs               in foldr g ([], Fn.id) vs
318          end          end
319    
320        (* 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 329 
329        (* register a constant record *)        (* register a constant record *)
330        fun record (rk, ul, v) =        fun record (rk, ul, v) =
331          (case field ul          (case field ul
332            of SOME xl => (enter(v, ZZ_RCD(rk, xl)); ident)                of SOME xl => (enter(v, ZZ_RCD(rk, xl)); Fn.id)
333             | NONE =>             | NONE =>
334                 let fun g ((u, p as OFFp 0), (r, hh)) =                 let fun g ((u, p as OFFp 0), (r, hh)) =
335                           let val (nu, nh) = lpsv u                           let val (nu, nh) = lpsv u
336                            in ((nu, p)::r, nh o hh)                            in ((nu, p)::r, nh o hh)
337                           end                           end
338                       | g _ = bug "unexpected non-zero OFFp in record"                       | g _ = bug "unexpected non-zero OFFp in record"
339                     val (nl, hdr) = foldr g ([], ident) ul                         val (nl, hdr) = foldr g ([], Fn.id) ul
340                  in fn ce => hdr(RECORD(rk, nl, v, ce))                  in fn ce => hdr(RECORD(rk, nl, v, ce))
341                 end)                 end)
342    
343        (* register a wrapped float literal *)        (* register a wrapped float literal *)
344        fun wrapfloat (u, v, t) =        fun wrapfloat (u, v, t) =
345          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)
346          else let val (nu, hh) = lpsv u          else let val (nu, hh) = lpsv u
347                in (fn ce => hh(PURE(P.fwrap, [nu], v, t, ce)))                in (fn ce => hh(PURE(P.fwrap, [nu], v, t, ce)))
348               end               end
# Line 391  Line 389 
389    
390              val n = length exports              val n = length exports
391              val hdr =              val hdr =
392                if n = 0 then ident                    if n = 0 then Fn.id
393                else let val rv = mkv()                else let val rv = mkv()
394                         val rval = VAR rv                         val rval = VAR rv
395                         val rhdr =                         val rhdr =
# Line 475  Line 473 
473    end    end
474    
475  (* the main function *)  (* the main function *)
476  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
477        let val nt = PTRt(RPT (n+1))            val nt = PTRt(RPT (n+1))
478            val (nbody, lit) = liftlits(body, VAR x, n)            val (nbody, lit) = liftlits(body, VAR x, n)
479         in ((fk, f, vl, [CNTt, nt], nbody), lit)            in
480                ((fk, f, vl, [CNTt, nt], nbody), litToBytes lit)
481        end        end
482    | litsplit _ = bug "unexpected CPS header in litsplit"        | split _ = bug "unexpected CPS header in split"
483    
 end (* toplevel local *)  
484  end (* Literals *)  end (* Literals *)

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

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