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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4527 - (view) (download)

1 : monnier 251 (* literals.sml
2 :     *
3 : jhr 4512 * 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 : jhr 4454 * COPYRIGHT (c) 2017 The Fellowship of SML/NJ (http://www.smlnj.org)
11 :     * All rights reserved.
12 :     *
13 : jhr 4512 * 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 : monnier 251 *)
18 : monnier 98
19 :     signature LITERALS =
20 : jhr 4512 sig
21 : monnier 98
22 : jhr 4512 (** `litsplit f` takes a CPS function and splits out the heap-allocated
23 :     * 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;
32 :    
33 : jhr 4454 structure Literals : LITERALS =
34 : jhr 4512 struct
35 : monnier 98
36 : jhr 4512 structure W8V = Word8Vector
37 :     structure LV = LambdaVar
38 :     structure Intset = struct
39 : monnier 504 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 : monnier 98
46 : jhr 4512 open CPS
47 : monnier 98
48 : jhr 4512 fun bug msg = ErrorMsg.impossible ("Literals: "^msg)
49 :     fun mkv _ = LV.mkLvar()
50 : monnier 98
51 : jhr 4512 (****************************************************************************
52 :     * A MINI-LITERAL LANGUAGE *
53 :     ****************************************************************************)
54 :     datatype lit_val
55 :     = LI_INT of word
56 :     | LI_STRING of string
57 :     | LI_VAR of lvar
58 : monnier 251
59 : jhr 4512 datatype block_kind
60 :     = LI_RECORD (* record of tagged ML values *)
61 :     | LI_VECTOR (* vector of tagged ML values *)
62 : monnier 98
63 : jhr 4512 datatype lit_exp
64 :     = LI_TOP of lit_val list
65 :     | LI_BLOCK of (block_kind * lit_val list * lvar * lit_exp)
66 : jhr 4527 | LI_F64BLOCK of (RealLit.t list * lvar * lit_exp)
67 : jhr 4512 | LI_I32BLOCK of (Word32.word list * lvar * lit_exp)
68 : monnier 98
69 : jhr 4512 fun rk2bk CPS.RK_VECTOR = LI_VECTOR
70 :     | rk2bk CPS.RK_RECORD = LI_RECORD
71 :     | rk2bk _ = bug "rk2bk: unexpected block kind"
72 : monnier 251
73 : jhr 4512 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"
77 : monnier 98
78 : jhr 4512 (****************************************************************************
79 :     * TRANSLATING THE LITERAL EXP TO BYTES *
80 :     ****************************************************************************)
81 : monnier 98
82 : jhr 4512 (* Literals are encoded as instructions for a "literal machine." The abstract
83 :     * description of these instructions is as follows:
84 :     *
85 :     * INT(i) -- push the int31 literal i on the stack
86 :     * 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 : jhr 4516 *
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 : jhr 4512 *)
113 : monnier 98
114 : jhr 4512 fun w32ToBytes' (w, l) =
115 :     Word8.fromLargeWord(Word32.>>(w, 0w24)) ::
116 :     Word8.fromLargeWord(Word32.>>(w, 0w16)) ::
117 :     Word8.fromLargeWord(Word32.>>(w, 0w8)) ::
118 :     Word8.fromLargeWord w :: l
119 :     fun w32ToBytes w = w32ToBytes' (w, [])
120 :     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 : monnier 98
125 : jhr 4512 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 : jhr 4527 fun emit_RAW64 [r] = W8V.fromList(0wx04 :: Word8Vector.toList r)
132 :     | emit_RAW64 l = W8V.concat(W8V.fromList(0wx05 :: intToBytes(length l)) :: l)
133 : jhr 4512 fun emit_STR s = W8V.concat[
134 :     W8V.fromList(0wx06 :: intToBytes(size s)),
135 :     Byte.stringToBytes s
136 :     ]
137 :     fun emit_LIT k = W8V.fromList(0wx07 :: intToBytes k)
138 :     fun emit_VECTOR n = W8V.fromList(0wx08 :: intToBytes n)
139 :     fun emit_RECORD n = W8V.fromList(0wx09 :: intToBytes n)
140 :     val emit_RETURN = W8V.fromList[0wxff]
141 : monnier 98
142 : jhr 4512 fun litToBytes (LI_TOP[]) = W8V.fromList[]
143 :     | litToBytes litExp = let
144 :     fun depth (LI_TOP ls, d, maxDepth) = Int.max(maxDepth, d+length ls)
145 :     | depth (LI_BLOCK(_, ls, _, rest), d, maxDepth) =
146 :     depth (rest, d+1, Int.max(maxDepth, d+length ls))
147 :     | depth (LI_F64BLOCK(ls, _, rest), d, maxDepth) =
148 :     depth (rest, d+1, Int.max(maxDepth, d+length ls))
149 :     | depth (LI_I32BLOCK(ls, _, rest), d, maxDepth) =
150 :     depth (rest, d+1, Int.max(maxDepth, d+length ls))
151 :     fun emitLitExp (env, exp, code) = let
152 :     fun emitLitVals ([], _, code) = code
153 :     | emitLitVals (lit::r, d, code) = let
154 :     val instr = (case lit
155 :     of (LI_INT i) => emit_INT i
156 :     | (LI_STRING s) => emit_STR s
157 :     | (LI_VAR v) => let
158 :     fun f ([], _) = bug "unbound lvar"
159 :     | f (v'::r, d) = if (v = v') then d else f(r, d+1)
160 :     in
161 :     emit_LIT(f (env, d))
162 :     end
163 :     (* end case *))
164 :     in
165 :     emitLitVals (r, d+1, instr::code)
166 :     end
167 :     fun emitBlock (LI_RECORD, ls, code) =
168 :     emit_RECORD(length ls) :: emitLitVals(ls, 0, code)
169 :     | emitBlock (LI_VECTOR, ls, code) =
170 :     emit_VECTOR(length ls) :: emitLitVals(ls, 0, code)
171 : jhr 4527 fun emitF64Block (ls, code) = let
172 :     val toBits = #1 o Real64ToBits.toBits
173 :     in
174 :     emit_RAW64(map toBits ls) :: code
175 :     end
176 : jhr 4512 fun emitI32Block (ls, code) = emit_RAW32 ls :: code
177 :     in
178 :     case exp
179 :     of (LI_TOP ls) => emit_RETURN :: emitBlock(LI_RECORD, ls, code)
180 :     | (LI_BLOCK(bk, ls, v, rest)) =>
181 :     emitLitExp (v::env, rest, emitBlock(bk, ls, code))
182 :     | (LI_F64BLOCK(ls, v, rest)) =>
183 :     emitLitExp (v::env, rest, emitF64Block(ls, code))
184 :     | (LI_I32BLOCK(ls, v, rest)) =>
185 :     emitLitExp (v::env, rest, emitI32Block(ls, code))
186 :     (* end case *)
187 :     end
188 :     val maxDepth = depth (litExp, 0, 1)
189 :     val code = emit_MAGIC
190 :     :: emit_DEPTH maxDepth
191 :     :: List.rev(emitLitExp([], litExp, []))
192 :     in
193 :     W8V.concat code
194 :     end
195 : monnier 98
196 : jhr 4512 (****************************************************************************
197 :     * LIFTING LITERALS ON CPS *
198 :     ****************************************************************************)
199 :     datatype info
200 :     = ZZ_STR of string
201 :     | ZZ_FLT of string
202 :     | ZZ_RCD of record_kind * value list
203 : monnier 251
204 : jhr 4512 exception LitInfo
205 : monnier 98
206 : jhr 4527 (* FIXME: we should probably either use hash tables or the raw comparison
207 :     * functions to implement the dictionaries.
208 :     *)
209 : monnier 98
210 : jhr 4527 (* 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
219 :     else if i1 > i2 then GREATER
220 :     else String.compare(s1, s2)
221 :     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)
235 :    
236 : jhr 4512 (* lifting all literals from a CPS program *)
237 : jhr 4527 fun liftlits (body, root, offset) = let
238 :     (* the list of record, string, and real constants *)
239 : jhr 4512 val m : info IntHashTable.hash_table = IntHashTable.mkTable(32, LitInfo)
240 :     val freevars : lvar list ref = ref []
241 :     fun addv x = (freevars := (x :: (!freevars)))
242 : jhr 4527 (* check if an lvar is used by the main program *)
243 : jhr 4512 val refset : Intset.intset = Intset.new()
244 :     val used : lvar -> unit = Intset.add refset
245 :     val isUsed : lvar -> bool = Intset.mem refset
246 : jhr 4527 (* memoize the information on which corresponds to what *)
247 : jhr 4512 fun enter (v, i) = (IntHashTable.insert m (v, i); addv v)
248 :     fun const (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)
249 :     | const (INT _ | INT32 _ | REAL _ | STRING _) = true
250 :     | const _ = bug "unexpected case in const"
251 :     fun cstlit (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)
252 :     | cstlit (REAL _ | STRING _) = true
253 :     | cstlit _ = false
254 : jhr 4527 (* register a string literal *)
255 : jhr 4512 local val strs : string list ref = ref []
256 :     val strsN : int ref = ref 0
257 : jhr 4527 val sdict = ref (SlitDict.empty)
258 : jhr 4512 val srtv = mkv()
259 :     val srtval = VAR srtv
260 :     in
261 : jhr 4527 fun entStr s = let
262 :     val v = mkv() (** should hash to remove duplicates **)
263 : jhr 4512 val sd = !sdict
264 : jhr 4527 val rlit = toSlit s
265 :     val n = (case SlitDict.find(sd, rlit)
266 :     of SOME k => k
267 :     | _ => let
268 :     val _ = (strs := (s :: (!strs)))
269 :     val k = !strsN
270 :     val _ = (strsN := (k+1))
271 :     val _ = (sdict := (SlitDict.insert(sd, rlit, k)))
272 :     in
273 :     k
274 : jhr 4512 end)
275 : jhr 4527 in
276 :     (VAR v, fn ce => SELECT(n, srtval, v, BOGt, ce))
277 :     end
278 :     fun appStr () = let
279 :     fun g (a::r, z) = g(r, (STRING a)::z)
280 : jhr 4512 | g ([], z) = z (* reverse to reflecting the correct order *)
281 :     val allStrs = !strs
282 : jhr 4527 in
283 :     case !strs
284 :     of [] => ()
285 :     | xs => (enter(srtv, ZZ_RCD(RK_RECORD, g(xs,[]))); used srtv)
286 :     (* end case *)
287 :     end
288 : jhr 4512 end (* local of processing string literals *)
289 : jhr 4527 (* register a real literal *)
290 :     local val reals : RealLit.t list ref = ref []
291 : jhr 4512 val realsN : int ref = ref 0
292 :     val rdict = ref (RlitDict.empty)
293 :     val rrtv = mkv()
294 :     val rrtval = VAR rrtv
295 :     in
296 : jhr 4527 fun entReal s = let
297 :     val v = mkv() (** should hash to remove duplicates **)
298 : jhr 4512 val rd = !rdict
299 :     val rlit = toRlit s
300 : jhr 4527 val n = (case RlitDict.find(rd, rlit)
301 :     of SOME k => k
302 :     | _ => let
303 :     val _ = (reals := (s :: (!reals)))
304 :     val k = !realsN
305 :     val _ = (realsN := (k+1))
306 :     val _ = (rdict := (RlitDict.insert(rd, rlit, k)))
307 :     in
308 :     k
309 : jhr 4512 end)
310 : jhr 4527 in
311 :     (VAR v, fn ce => SELECT(n, rrtval, v, FLTt 64, ce)) (* REAL32: FIXME *)
312 :     end
313 :     fun appReal () = let
314 :     fun g (a::r, z) = g(r, (REAL a)::z)
315 : jhr 4512 | g ([], z) = z (* reverse to reflecting the correct order *)
316 :     val allReals = !reals
317 : jhr 4527 in
318 :     case !reals
319 :     of [] => ()
320 :     | xs => (enter(rrtv, ZZ_RCD(RK_FBLOCK, g(xs,[]))); used rrtv)
321 :     end
322 :     end (* local of processing real literals *)
323 :     (* translation on the CPS values *)
324 :     fun lpsv u = (case u
325 :     of REAL r => entReal r
326 :     | STRING s => entStr s
327 :     | VAR v => (used v; (u, Fn.id))
328 :     | _ => (u, Fn.id)
329 :     (* end case *))
330 :     fun lpvs vs = let
331 :     fun g (u, (xs, hh)) = let
332 :     val (nu, nh) = lpsv u
333 :     in
334 :     (nu::xs, nh o hh)
335 :     end
336 :     in
337 :     foldr g ([], Fn.id) vs
338 :     end
339 :     (* if all fields of a record are "constant", then we lift it *)
340 :     fun field ul = let
341 :     fun h ((x, OFFp 0)::r, z, rsflag) = if const x
342 :     then h(r, x::z, rsflag orelse (cstlit x))
343 :     else NONE
344 : jhr 4512 | h ([], z, rsflag) = if rsflag then SOME(rev z) else NONE
345 :     | h _ = bug "unexpected case in field"
346 : jhr 4527 in
347 :     h (ul, [], false)
348 :     end
349 :     (* register a constant record *)
350 :     fun record (rk, ul, v) = (case field ul
351 :     of SOME xl => (enter(v, ZZ_RCD(rk, xl)); Fn.id)
352 :     | NONE => let
353 :     fun g ((u, p as OFFp 0), (r, hh)) = let
354 :     val (nu, nh) = lpsv u
355 :     in
356 :     ((nu, p)::r, nh o hh)
357 :     end
358 : jhr 4512 | g _ = bug "unexpected non-zero OFFp in record"
359 : jhr 4527 val (nl, hdr) = foldr g ([], Fn.id) ul
360 :     in
361 :     fn ce => hdr(RECORD(rk, nl, v, ce))
362 :     end)
363 :     (* register a wrapped float literal *)
364 :     fun wrapfloat (u, v, t) = if const u
365 :     then (enter(v, ZZ_RCD(RK_FBLOCK, [u])); Fn.id)
366 :     else let val (nu, hh) = lpsv u
367 :     in (fn ce => hh(PURE(P.fwrap, [nu], v, t, ce)))
368 :     end
369 :     (* fetch out the literal information *)
370 :     fun getInfo () = let
371 :     val _ = appReal() (* register all Reals as a record *)
372 : jhr 4512 val _ = appStr() (* register all Strings as a record *)
373 :     val allvars = !freevars
374 :     val exports = List.filter isUsed allvars
375 : monnier 98
376 : jhr 4512 val toplit =
377 :     let fun g ([], z) = LI_TOP z
378 :     | g (x::r, z) =
379 :     (case IntHashTable.lookup m x
380 :     of ZZ_STR s => g(r, (LI_STRING s)::z)
381 :     | _ => g(r, (LI_VAR x)::z))
382 :     in g(exports, [])
383 :     end
384 : monnier 98
385 : jhr 4512 fun mklit (v, lit) = let
386 : jhr 4527 fun unREAL (CPS.REAL r) = r
387 : jhr 4512 | unREAL _ = bug "unREAL"
388 :     fun unINT32 (CPS.INT32 w) = w
389 :     | unINT32 _ = bug "unINT32"
390 : jhr 4527 in
391 :     case IntHashTable.lookup m v
392 :     of (ZZ_FLT _) => (* float is wrapped *)
393 :     bug "currently we don't expect ZZ_FLT in mklit"
394 :     (* LI_F64BLOCK([s], v, lit) *)
395 :     | (ZZ_STR s) =>
396 :     bug "currently we don't expect ZZ_STR in mklit"
397 :     (* lit --- or we could inline string *)
398 :     | (ZZ_RCD(CPS.RK_FBLOCK, vs)) =>
399 :     LI_F64BLOCK(map unREAL vs, v, lit)
400 :     | (ZZ_RCD(CPS.RK_I32BLOCK, vs)) =>
401 :     LI_I32BLOCK(map unINT32 vs, v, lit)
402 :     | (ZZ_RCD(rk, vs)) =>
403 :     LI_BLOCK(rk2bk rk, map val2lit vs, v, lit)
404 :     end
405 : monnier 98
406 : jhr 4512 (** build up the literal structure *)
407 :     val lit = foldl mklit toplit allvars
408 : monnier 98
409 : jhr 4512 val n = length exports
410 :     val hdr =
411 :     if n = 0 then Fn.id
412 :     else let val rv = mkv()
413 :     val rval = VAR rv
414 :     val rhdr =
415 :     fn ce => SELECT(offset, root, rv, PTRt(RPT n), ce)
416 : monnier 98
417 : jhr 4512 fun mkhdr (v, (i, hh)) =
418 :     let val nh =
419 :     (case IntHashTable.lookup m v
420 :     of (ZZ_FLT _) => bug "ZZ_FLT in mkhdr"
421 :     (* (fn ce =>
422 :     (SELECT(i, rval, w, PTRt(FPT 1),
423 :     SELECT(0, VAR w, v, FLTt, ce)))) *)
424 :     | (ZZ_STR s) => bug "ZZ_STR in mkhdr"
425 :     (* (fn ce =>
426 :     SELECT(i, rval, v, BOGt, ce)) *)
427 :     | (ZZ_RCD (rk, vs)) =>
428 :     let val n = length vs
429 :     val t =
430 :     case rk
431 :     of RK_FBLOCK => PTRt(FPT n)
432 :     | RK_VECTOR => BOGt
433 :     | _ => PTRt(RPT n)
434 :     in fn ce => SELECT(i, rval, v, t, ce)
435 :     end)
436 :     in (i+1, hh o nh)
437 :     end
438 :     in #2 (foldr mkhdr (0, rhdr) exports)
439 :     end
440 :     in (lit, hdr)
441 :     end (* function getInfo *)
442 : monnier 98
443 : jhr 4512 fun lpfn (fk, f, vl, cl, e) = (fk, f, vl, cl, loop e)
444 : monnier 98
445 : jhr 4527 and loop ce = (case ce
446 : jhr 4512 of RECORD (rk, ul, v, e) => record (rk, ul, v) (loop e)
447 :     | SELECT (i, u, v, t, e) =>
448 :     let val (nu, hh) = lpsv u
449 :     in hh(SELECT(i, nu, v, t, loop e))
450 :     end
451 :     | OFFSET _ => bug "unexpected OFFSET in loop"
452 :     | APP (u, ul) =>
453 :     let val (nu, h1) = lpsv u
454 :     val (nl, h2) = lpvs ul
455 :     in h1(h2(APP(nu, nl)))
456 :     end
457 :     | FIX (fns, e) => FIX(map lpfn fns, loop e)
458 :     | SWITCH (u, v, es) =>
459 :     let val (nu, hh) = lpsv u
460 :     in hh(SWITCH(nu, v, map loop es))
461 :     end
462 :     | BRANCH (p, ul, v, e1, e2) =>
463 :     let val (nl, hh) = lpvs ul
464 :     in hh(BRANCH(p, nl, v, loop e1, loop e2))
465 :     end
466 :     | SETTER (p, ul, e) =>
467 :     let val (nl, hh) = lpvs ul
468 :     in hh(SETTER(p, nl, loop e))
469 :     end
470 :     | LOOKER (p, ul, v, t, e) =>
471 :     let val (nl, hh) = lpvs ul
472 :     in hh(LOOKER(p, nl, v, t, loop e))
473 :     end
474 :     | ARITH (p, ul, v, t, e) =>
475 :     let val (nl, hh) = lpvs ul
476 :     in hh(ARITH(p, nl, v, t, loop e))
477 :     end
478 :     | PURE (P.fwrap, [u], v, t, e) => wrapfloat (u, v, t) (loop e)
479 :     | PURE (p, ul, v, t, e) =>
480 :     let val (nl, hh) = lpvs ul
481 :     in hh(PURE(p, nl, v, t, loop e))
482 :     end
483 :     | RCC (k, l, p, ul, vtl, e) =>
484 :     let val (nl, hh) = lpvs ul
485 :     in hh(RCC(k, l, p, nl, vtl, loop e))
486 :     end)
487 : monnier 98
488 : jhr 4512 val newbody = loop body
489 :     val (lit, hdr) = getInfo ()
490 :     in (hdr newbody, lit)
491 :     end
492 : monnier 98
493 : jhr 4512 (* the main function *)
494 :     fun split (fk, f, vl as [_,x], [CNTt, t as PTRt(RPT n)], body) = let
495 :     val nt = PTRt(RPT (n+1))
496 :     val (nbody, lit) = liftlits(body, VAR x, n)
497 :     in
498 :     ((fk, f, vl, [CNTt, nt], nbody), litToBytes lit)
499 :     end
500 :     | split _ = bug "unexpected CPS header in split"
501 : monnier 98
502 : jhr 4512 end (* Literals *)

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