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 98, Thu May 14 04:54:52 1998 UTC sml/trunk/compiler/FLINT/main/literals.sml revision 4516, Sat Oct 28 17:51:15 2017 UTC
# Line 1  Line 1 
1  (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *)  (* literals.sml
2  (* literals.sml *)   *
3     * This file implements support for heap-allocated literals.  Our approach
4     * 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 lit2cps : lit -> CPS.function     * literal values from it.  At runtime, these literals will be accessed via
24   end     * 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;
32    
33  structure Literals : LITERALS =  structure Literals : LITERALS =
34  struct  struct
35    
36  local structure LV = LambdaVar      structure W8V = Word8Vector
37        structure LV = LambdaVar
38        structure Intset = struct
39            type intset = IntRedBlackSet.set ref
40            fun new() = ref IntRedBlackSet.empty
41            fun add set i = set := IntRedBlackSet.add(!set, i)
42            fun mem set i =  IntRedBlackSet.member(!set, i)
43            fun rmv set i = set := IntRedBlackSet.delete(!set, i)
44          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  
 val liftLiterals = Control.CG.liftLiterals  
49  fun mkv _ = LV.mkLvar()  fun mkv _ = LV.mkLvar()
50    
51  (****************************************************************************  (****************************************************************************
52   *                         A MINI-LITERAL LANGUAGE                          *   *                         A MINI-LITERAL LANGUAGE                          *
53   ****************************************************************************)   ****************************************************************************)
54  datatype lit_val  datatype lit_val
55    = LI_INT of int        = LI_INT of word
   | LI_INT32 of Word32.word  
   | LI_REAL of string  
56    | LI_STRING of string    | LI_STRING of string
57    | LI_VAR of lvar    | LI_VAR of lvar
58    
59        datatype block_kind
60          = LI_RECORD               (* record of tagged ML values *)
61          | LI_VECTOR               (* vector of tagged ML values *)
62    
63  datatype lit_exp  datatype lit_exp
64    = LI_TOP of lit_val list    = LI_TOP of lit_val list
65    | LI_RECORD of record_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)
67  type lit = lit_exp        | LI_I32BLOCK of (Word32.word list * lvar * lit_exp)
68    
69  fun val2lit (VAR v) = LI_VAR v      fun rk2bk CPS.RK_VECTOR     = LI_VECTOR
70    | val2lit (INT i) = LI_INT i        | rk2bk CPS.RK_RECORD     = LI_RECORD
71    | val2lit (INT32 i) = LI_INT32 i        | rk2bk _         = bug "rk2bk: unexpected block kind"
72    | val2lit (REAL s) = LI_REAL s  
73    | val2lit (STRING s) = LI_STRING s      fun val2lit (CPS.VAR v) = LI_VAR v
74          | val2lit (CPS.INT i) = LI_INT(Word.fromInt i)
75          | val2lit (CPS.STRING s) = LI_STRING s
76    | val2lit _ = bug "unexpected case in val2lit"    | val2lit _ = bug "unexpected case in val2lit"
77    
78  (****************************************************************************  (****************************************************************************
79   *                 TRANSLATING THE LITERAL EXP TO CPS EXP                   *     *                 TRANSLATING THE LITERAL EXP TO BYTES                     *
80   ****************************************************************************)   ****************************************************************************)
 fun lit2cps li =  
   let val k = mkv()  
   
       fun toval (LI_INT i) = INT i  
         | toval (LI_INT32 i) = INT32 i  
         | toval (LI_REAL s) = REAL s  
         | toval (LI_STRING s) = STRING s  
         | toval (LI_VAR v) = VAR v  
   
       fun toexp (LI_TOP []) = APP(VAR k, [INT 0])  
         | toexp (LI_TOP vs) =  
             let val v = mkv()  
                 val nvs = map (fn x => (toval x, OFFp 0)) vs  
              in RECORD(RK_RECORD, nvs, v, APP(VAR k, [VAR v]))  
             end  
         | toexp (LI_RECORD (rk, vs, v, e)) =  
             let val nvs = map (fn x => (toval x, OFFp 0)) vs  
              in RECORD(rk, nvs, v, toexp e)  
             end  
   
       val f = mkv()  
       val x = mkv()  
    in (ESCAPE, f, [k, x], [CNTt, BOGt], toexp li)  
   end  
   
81    
82  (****************************************************************************    (* Literals are encoded as instructions for a "literal machine."  The abstract
83   *                    LIFTING LITERALS ON FLINT                             *     * description of these instructions is as follows:
84   ****************************************************************************)     *
85  (*     *    INT(i)                  -- push the int31 literal i on the stack
86  fun liftlits body = bug "FLINT version currently not implemented yet"     *    RAW32[i1,...,in]        -- form a 32-bit raw data record from the
87       *                               i1..in and push a pointer to it.
88       *    RAW64[r1,...,rn]        -- form a 64-bit raw data record from the
89       *                               r1..rn and push a pointer to it.
90       *    STR[c1,...,cn]          -- form a string from the characters c1..cn
91       *                               and push it on the stack.
92       *    LIT(k)                  -- push the contents of the stack element
93       *                               that is k slots from the top of the stack.
94       *    VECTOR(n)               -- pop n elements from the stack, make a vector
95       *                               from them and push a pointer to the vector.
96       *    RECORD(n)               -- pop n elements from the stack, make a record
97       *                               from them and push a pointer.
98       *    RETURN                  -- return the literal that is on the top of the
99       *                               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 litsplit (FK_FCT, f, [(v, t)], body) =      fun w32ToBytes' (w, l) =
115        if LT.ltp_str t then              Word8.fromLargeWord(Word32.>>(w, 0w24)) ::
116          let val (nbody, lit, llt) =              Word8.fromLargeWord(Word32.>>(w, 0w16)) ::
117                if !liftLiterals then liftlits body              Word8.fromLargeWord(Word32.>>(w, 0w8)) ::
118                else (body, LI_TOP [], LT.ltc_str[])              Word8.fromLargeWord w :: l
119              val nt = LT.ltc_str ((LT.ltd_str t)@[llt])      fun w32ToBytes w = w32ToBytes' (w, [])
120           in ((FK_FCT, f, [(v, nt)], body), lit)      fun w31ToBytes w = w32ToBytes(Word31.toLargeWordX w)
121        fun intToBytes i = w32ToBytes(Word32.fromInt i)
122        fun intToBytes' (i, l) = w32ToBytes'(Word32.fromInt i, l)
123        fun strToBytes s = map Byte.charToByte (explode s)
124    
125        val emit_MAGIC = W8V.fromList[0wx19, 0wx98, 0wx10, 0wx22]
126        fun emit_DEPTH n = W8V.fromList(intToBytes n)
127        fun emit_INT i = W8V.fromList(0wx01 :: w31ToBytes i)
128        fun emit_RAW32 [i] = W8V.fromList(0wx02 :: w32ToBytes i)
129          | emit_RAW32 l =
130              W8V.fromList(0wx03 :: (intToBytes'(length l, List.foldr w32ToBytes' [] l)))
131        fun emit_RAW64 [r] = W8V.fromList(0wx04 :: strToBytes r)
132          | emit_RAW64 l = W8V.concat(
133              W8V.fromList(0wx05 :: intToBytes(length l)) :: map Byte.stringToBytes l)
134        fun emit_STR s = W8V.concat[
135                W8V.fromList(0wx06 :: intToBytes(size s)),
136                Byte.stringToBytes s
137              ]
138        fun emit_LIT k = W8V.fromList(0wx07 :: intToBytes k)
139        fun emit_VECTOR n = W8V.fromList(0wx08 :: intToBytes n)
140        fun emit_RECORD n = W8V.fromList(0wx09 :: intToBytes n)
141        val emit_RETURN = W8V.fromList[0wxff]
142    
143        fun litToBytes (LI_TOP[]) = W8V.fromList[]
144          | litToBytes litExp = let
145              fun depth (LI_TOP ls, d, maxDepth) = Int.max(maxDepth, d+length ls)
146                | depth (LI_BLOCK(_, ls, _, rest), d, maxDepth) =
147                    depth (rest, d+1, Int.max(maxDepth, d+length ls))
148                | depth (LI_F64BLOCK(ls, _, rest), d, maxDepth) =
149                    depth (rest, d+1, Int.max(maxDepth, d+length ls))
150                | depth (LI_I32BLOCK(ls, _, rest), d, maxDepth) =
151                    depth (rest, d+1, Int.max(maxDepth, d+length ls))
152              fun emitLitExp (env, exp, code) = let
153                    fun emitLitVals ([], _, code) = code
154                      | emitLitVals (lit::r, d, code) = let
155                          val instr = (case lit
156                                 of (LI_INT i) => emit_INT i
157                                  | (LI_STRING s) => emit_STR s
158                                  | (LI_VAR v) => let
159                                      fun f ([], _) = bug "unbound lvar"
160                                        | f (v'::r, d) = if (v = v') then d else f(r, d+1)
161                                      in
162                                        emit_LIT(f (env, d))
163                                      end
164                                (* end case *))
165                          in
166                            emitLitVals (r, d+1, instr::code)
167                          end
168                    fun emitBlock (LI_RECORD, ls, code) =
169                          emit_RECORD(length ls) :: emitLitVals(ls, 0, code)
170                      | emitBlock (LI_VECTOR, ls, code) =
171                          emit_VECTOR(length ls) :: emitLitVals(ls, 0, code)
172                    fun emitF64Block (ls, code) =
173                          emit_RAW64(map IEEERealConst.realconst ls) :: code
174                    fun emitI32Block (ls, code) = emit_RAW32 ls :: code
175                    in
176                      case exp
177                       of (LI_TOP ls) => emit_RETURN :: emitBlock(LI_RECORD, ls, code)
178                        | (LI_BLOCK(bk, ls, v, rest)) =>
179                            emitLitExp (v::env, rest, emitBlock(bk, ls, code))
180                        | (LI_F64BLOCK(ls, v, rest)) =>
181                            emitLitExp (v::env, rest, emitF64Block(ls, code))
182                        | (LI_I32BLOCK(ls, v, rest)) =>
183                            emitLitExp (v::env, rest, emitI32Block(ls, code))
184                      (* end case *)
185                    end
186              val maxDepth = depth (litExp, 0, 1)
187              val code = emit_MAGIC
188                    :: emit_DEPTH maxDepth
189                    :: List.rev(emitLitExp([], litExp, []))
190              in
191                W8V.concat code
192          end          end
       else bug "unexpected FLINT header in litsplit (case 1)"  
   | litsplit _ = bug "unexpected FLINT header in litsplit (case 2)"  
 *)  
193    
194  (****************************************************************************  (****************************************************************************
195   *                    LIFTING LITERALS ON CPS                               *   *                    LIFTING LITERALS ON CPS                               *
# Line 100  Line 201 
201    
202  exception LitInfo  exception LitInfo
203    
204  datatype rlit = RLIT of string * int      datatype rlit = RLIT of string * word
205  fun toRlit s = RLIT(s, StrgHash.hashString s)      fun toRlit s = RLIT(s, HashString.hashString s)
206  fun fromRlit (RLIT(s, _)) = s  fun fromRlit (RLIT(s, _)) = s
207  fun rlitcmp (RLIT(s1,i1), RLIT(s2,i2)) =  fun rlitcmp (RLIT(s1,i1), RLIT(s2,i2)) =
208    if i1 < i2 then LESS    if i1 < i2 then LESS
209    else if i1 > i2 then GREATER else String.compare(s1, s2)    else if i1 > i2 then GREATER else String.compare(s1, s2)
210  structure RlitDict = BinaryDict(struct type ord_key = rlit      structure RlitDict = RedBlackMapFn(struct type ord_key = rlit
211                                         val cmpKey = rlitcmp                                              val compare = rlitcmp
212                                  end)                                  end)
213    
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 123  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) = ((IntHashTable.lookup m v; true) handle _ => false)
233                | cstlit (REAL _ | STRING _) = true
234                | cstlit _ = false
235    
236        (* register a string literal *)        (* register a string literal *)
237        local val strs : string list ref = ref []        local val strs : string list ref = ref []
238              val strsN : int ref = ref 0              val strsN : int ref = ref 0
239              val sdict = ref (RlitDict.mkDict())                  val sdict = ref (RlitDict.empty)
240              val srtv = mkv()              val srtv = mkv()
241              val srtval = VAR srtv              val srtval = VAR srtv
242        in        in
# Line 140  Line 245 
245              val sd = !sdict              val sd = !sdict
246              val rlit = toRlit s              val rlit = toRlit s
247              val n =              val n =
248                (case RlitDict.peek(sd, rlit)                    (case RlitDict.find(sd, rlit)
249                  of SOME k => k                  of SOME k => k
250                   | _ => let val _ = (strs := (s :: (!strs)))                   | _ => let val _ = (strs := (s :: (!strs)))
251                              val k = !strsN                              val k = !strsN
# Line 178  Line 283 
283        (** a special treatment of real constants *)        (** a special treatment of real constants *)
284        local val reals : string list ref = ref []        local val reals : string list ref = ref []
285              val realsN : int ref = ref 0              val realsN : int ref = ref 0
286              val rdict = ref (RlitDict.mkDict())                  val rdict = ref (RlitDict.empty)
287              val rrtv = mkv()              val rrtv = mkv()
288              val rrtval = VAR rrtv              val rrtval = VAR rrtv
289        in        in
# Line 187  Line 292 
292              val rd = !rdict              val rd = !rdict
293              val rlit = toRlit s              val rlit = toRlit s
294              val n =              val n =
295                (case RlitDict.peek(rd, rlit)                    (case RlitDict.find(rd, rlit)
296                  of SOME k => k                  of SOME k => k
297                   | _ => let val _ = (reals := (s :: (!reals)))                   | _ => let val _ = (reals := (s :: (!reals)))
298                              val k = !realsN                              val k = !realsN
# Line 195  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 213  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 *)
333        fun field ul =        fun field ul =
334          let fun h ((x, OFFp 0)::r, z) =              let fun h ((x, OFFp 0)::r, z, rsflag) =
335                   if const x then h(r, x::z) else NONE                       if const x then h(r, x::z, rsflag orelse (cstlit x)) else NONE
336                | h ([], z) = SOME(rev z)                    | h ([], z, rsflag) = if rsflag then SOME(rev z) else NONE
337                | h _ = bug "unexpected case in field"                | h _ = bug "unexpected case in field"
338           in h (ul, [])               in h (ul, [], false)
339          end          end
340    
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 264  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_RECORD(RK_FBLOCK, [LI_REAL 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)) =>
392                            LI_F64BLOCK(map unREAL vs, v, lit)
393                         | (ZZ_RCD(CPS.RK_I32BLOCK, vs)) =>
394                           LI_I32BLOCK(map unINT32 vs, v, lit)
395                   | (ZZ_RCD (rk, vs)) =>                   | (ZZ_RCD (rk, vs)) =>
396                       LI_RECORD(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 294  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 307  Line 422 
422                                            val t =                                            val t =
423                                              case rk                                              case rk
424                                               of RK_FBLOCK => PTRt(FPT n)                                               of RK_FBLOCK => PTRt(FPT n)
425                                                      | RK_VECTOR => BOGt
426                                                | _ => PTRt(RPT n)                                                | _ => PTRt(RPT n)
427                                         in fn ce => SELECT(i, rval, v, t, ce)                                         in fn ce => SELECT(i, rval, v, t, ce)
428                                        end)                                        end)
# Line 357  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 365  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) =            val (nbody, lit) = liftlits(body, VAR x, n)
491              if !liftLiterals then liftlits(body, VAR x, n)            in
492              else (body, LI_TOP [])              ((fk, f, vl, [CNTt, nt], nbody), litToBytes lit)
   
        in ((fk, f, vl, [CNTt, nt], nbody), 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.98  
changed lines
  Added in v.4516

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