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 4454 - (view) (download)

1 : monnier 251 (* literals.sml
2 :     *
3 : jhr 4454 * COPYRIGHT (c) 2017 The Fellowship of SML/NJ (http://www.smlnj.org)
4 :     * All rights reserved.
5 :     *
6 :     * 64BIT: need support for 64-bit integers
7 :     * REAL32: need support for 32-bit floats
8 : monnier 251 *)
9 : monnier 98
10 :     signature LITERALS =
11 :     sig
12 :     type lit
13 :     val litsplit : CPS.function -> CPS.function * lit
14 : monnier 251 val litToBytes : lit -> Word8Vector.vector
15 :     end;
16 : monnier 98
17 : jhr 4454 structure Literals : LITERALS =
18 : monnier 98 struct
19 :    
20 : monnier 251 structure W8V = Word8Vector
21 :    
22 : monnier 98 local structure LV = LambdaVar
23 : monnier 504 structure Intset = struct
24 :     type intset = IntRedBlackSet.set ref
25 :     fun new() = ref IntRedBlackSet.empty
26 :     fun add set i = set := IntRedBlackSet.add(!set, i)
27 :     fun mem set i = IntRedBlackSet.member(!set, i)
28 :     fun rmv set i = set := IntRedBlackSet.delete(!set, i)
29 :     end
30 : monnier 98 open CPS
31 :     in
32 :    
33 : jhr 4454 fun bug msg = ErrorMsg.impossible ("Literals: "^msg)
34 : monnier 98 val ident = fn x => x
35 :     fun mkv _ = LV.mkLvar()
36 :    
37 :     (****************************************************************************
38 :     * A MINI-LITERAL LANGUAGE *
39 :     ****************************************************************************)
40 :     datatype lit_val
41 : monnier 251 = LI_INT of word
42 : monnier 98 | LI_STRING of string
43 :     | LI_VAR of lvar
44 :    
45 : monnier 251 datatype block_kind
46 :     = LI_RECORD (* record of tagged ML values *)
47 :     | LI_VECTOR (* vector of tagged ML values *)
48 :    
49 : monnier 98 datatype lit_exp
50 :     = LI_TOP of lit_val list
51 : monnier 251 | LI_BLOCK of (block_kind * lit_val list * lvar * lit_exp)
52 :     | LI_F64BLOCK of (string list * lvar * lit_exp)
53 :     | LI_I32BLOCK of (Word32.word list * lvar * lit_exp)
54 : monnier 98
55 :     type lit = lit_exp
56 :    
57 : monnier 251 fun rk2bk CPS.RK_VECTOR = LI_VECTOR
58 :     | rk2bk CPS.RK_RECORD = LI_RECORD
59 :     | rk2bk _ = bug "rk2bk: unexpected block kind"
60 :    
61 :     fun val2lit (CPS.VAR v) = LI_VAR v
62 :     | val2lit (CPS.INT i) = LI_INT(Word.fromInt i)
63 :     | val2lit (CPS.STRING s) = LI_STRING s
64 : monnier 98 | val2lit _ = bug "unexpected case in val2lit"
65 :    
66 :     (****************************************************************************
67 : monnier 251 * TRANSLATING THE LITERAL EXP TO BYTES *
68 : monnier 98 ****************************************************************************)
69 :    
70 : monnier 251 (* Literals are encoded as instructions for a "literal machine." The abstract
71 :     * description of these instructions is as follows:
72 :     *
73 :     * INT(i) -- push the int31 literal i on the stack
74 :     * RAW32[i1,...,in] -- form a 32-bit raw data record from the
75 :     * i1..in and push a pointer to it.
76 :     * RAW64[r1,...,rn] -- form a 64-bit raw data record from the
77 :     * r1..rn and push a pointer to it.
78 :     * STR[c1,...,cn] -- form a string from the characters c1..cn
79 :     * and push it on the stack.
80 :     * LIT(k) -- push the contents of the stack element
81 :     * that is k slots from the top of the stack.
82 :     * VECTOR(n) -- pop n elements from the stack, make a vector
83 :     * from them and push a pointer to the vector.
84 :     * RECORD(n) -- pop n elements from the stack, make a record
85 :     * from them and push a pointer.
86 :     * RETURN -- return the literal that is on the top of the
87 :     * stack.
88 :     *)
89 : monnier 98
90 : monnier 251 fun w32ToBytes' (w, l) =
91 :     Word8.fromLargeWord(Word32.>>(w, 0w24)) ::
92 :     Word8.fromLargeWord(Word32.>>(w, 0w16)) ::
93 :     Word8.fromLargeWord(Word32.>>(w, 0w8)) ::
94 :     Word8.fromLargeWord w :: l
95 :     fun w32ToBytes w = w32ToBytes' (w, [])
96 :     fun w31ToBytes w = w32ToBytes(Word31.toLargeWordX w)
97 :     fun intToBytes i = w32ToBytes(Word32.fromInt i)
98 :     fun intToBytes' (i, l) = w32ToBytes'(Word32.fromInt i, l)
99 :     fun strToBytes s = map Byte.charToByte (explode s)
100 : monnier 98
101 : monnier 251 val emit_MAGIC = W8V.fromList[0wx19, 0wx98, 0wx10, 0wx22]
102 :     fun emit_DEPTH n = W8V.fromList(intToBytes n)
103 :     fun emit_INT i = W8V.fromList(0wx01 :: w31ToBytes i)
104 :     fun emit_RAW32 [i] = W8V.fromList(0wx02 :: w32ToBytes i)
105 :     | emit_RAW32 l =
106 :     W8V.fromList(0wx03 :: (intToBytes'(length l, List.foldr w32ToBytes' [] l)))
107 :     fun emit_RAW64 [r] = W8V.fromList(0wx04 :: strToBytes r)
108 :     | emit_RAW64 l = W8V.concat(
109 :     W8V.fromList(0wx05 :: intToBytes(length l)) :: map Byte.stringToBytes l)
110 :     fun emit_STR s = W8V.concat[
111 :     W8V.fromList(0wx06 :: intToBytes(size s)),
112 :     Byte.stringToBytes s
113 :     ]
114 :     fun emit_LIT k = W8V.fromList(0wx07 :: intToBytes k)
115 :     fun emit_VECTOR n = W8V.fromList(0wx08 :: intToBytes n)
116 :     fun emit_RECORD n = W8V.fromList(0wx09 :: intToBytes n)
117 :     val emit_RETURN = W8V.fromList[0wxff]
118 : monnier 98
119 : monnier 251 fun litToBytes (LI_TOP[]) = W8V.fromList[]
120 :     | litToBytes litExp = let
121 :     fun depth (LI_TOP ls, d, maxDepth) = Int.max(maxDepth, d+length ls)
122 :     | depth (LI_BLOCK(_, ls, _, rest), d, maxDepth) =
123 :     depth (rest, d+1, Int.max(maxDepth, d+length ls))
124 :     | depth (LI_F64BLOCK(ls, _, rest), d, maxDepth) =
125 :     depth (rest, d+1, Int.max(maxDepth, d+length ls))
126 :     | depth (LI_I32BLOCK(ls, _, rest), d, maxDepth) =
127 :     depth (rest, d+1, Int.max(maxDepth, d+length ls))
128 :     fun emitLitExp (env, exp, code) = let
129 :     fun emitLitVals ([], _, code) = code
130 :     | emitLitVals (lit::r, d, code) = let
131 :     val instr = (case lit
132 :     of (LI_INT i) => emit_INT i
133 :     | (LI_STRING s) => emit_STR s
134 :     | (LI_VAR v) => let
135 :     fun f ([], _) = bug "unbound lvar"
136 :     | f (v'::r, d) = if (v = v') then d else f(r, d+1)
137 :     in
138 :     emit_LIT(f (env, d))
139 :     end
140 :     (* end case *))
141 :     in
142 :     emitLitVals (r, d+1, instr::code)
143 :     end
144 :     fun emitBlock (LI_RECORD, ls, code) =
145 :     emit_RECORD(length ls) :: emitLitVals(ls, 0, code)
146 :     | emitBlock (LI_VECTOR, ls, code) =
147 :     emit_VECTOR(length ls) :: emitLitVals(ls, 0, code)
148 :     fun emitF64Block (ls, code) =
149 :     emit_RAW64(map IEEERealConst.realconst ls) :: code
150 :     fun emitI32Block (ls, code) = emit_RAW32 ls :: code
151 :     in
152 :     case exp
153 :     of (LI_TOP ls) => emit_RETURN :: emitBlock(LI_RECORD, ls, code)
154 :     | (LI_BLOCK(bk, ls, v, rest)) =>
155 :     emitLitExp (v::env, rest, emitBlock(bk, ls, code))
156 :     | (LI_F64BLOCK(ls, v, rest)) =>
157 :     emitLitExp (v::env, rest, emitF64Block(ls, code))
158 :     | (LI_I32BLOCK(ls, v, rest)) =>
159 :     emitLitExp (v::env, rest, emitI32Block(ls, code))
160 :     (* end case *)
161 :     end
162 :     val maxDepth = depth (litExp, 0, 1)
163 :     val code = emit_MAGIC
164 :     :: emit_DEPTH maxDepth
165 :     :: List.rev(emitLitExp([], litExp, []))
166 :     in
167 :     W8V.concat code
168 :     end
169 : monnier 98
170 : monnier 251
171 : monnier 98 (****************************************************************************
172 :     * LIFTING LITERALS ON FLINT *
173 :     ****************************************************************************)
174 :     (*
175 :     fun liftlits body = bug "FLINT version currently not implemented yet"
176 :    
177 : jhr 4454 fun litsplit (FK_FCT, f, [(v, t)], body) =
178 : monnier 98 if LT.ltp_str t then
179 : monnier 251 let val (nbody, lit, llt) = liftlits body
180 : monnier 98 val nt = LT.ltc_str ((LT.ltd_str t)@[llt])
181 :     in ((FK_FCT, f, [(v, nt)], body), lit)
182 :     end
183 :     else bug "unexpected FLINT header in litsplit (case 1)"
184 :     | litsplit _ = bug "unexpected FLINT header in litsplit (case 2)"
185 :     *)
186 :    
187 :     (****************************************************************************
188 :     * LIFTING LITERALS ON CPS *
189 :     ****************************************************************************)
190 : jhr 4454 datatype info
191 : monnier 98 = ZZ_STR of string
192 :     | ZZ_FLT of string
193 :     | ZZ_RCD of record_kind * value list
194 :    
195 :     exception LitInfo
196 :    
197 : monnier 422 datatype rlit = RLIT of string * word
198 :     fun toRlit s = RLIT(s, HashString.hashString s)
199 : monnier 98 fun fromRlit (RLIT(s, _)) = s
200 : jhr 4454 fun rlitcmp (RLIT(s1,i1), RLIT(s2,i2)) =
201 : monnier 98 if i1 < i2 then LESS
202 :     else if i1 > i2 then GREATER else String.compare(s1, s2)
203 : monnier 504 structure RlitDict = RedBlackMapFn(struct type ord_key = rlit
204 : monnier 477 val compare = rlitcmp
205 :     end)
206 : monnier 98
207 :     (* lifting all literals from a CPS program *)
208 : jhr 4454 fun liftlits (body, root, offset) =
209 : monnier 98 let (* the list of record, string, or real constants *)
210 : blume 733 val m : info IntHashTable.hash_table = IntHashTable.mkTable(32, LitInfo)
211 : monnier 98 val freevars : lvar list ref = ref []
212 :     fun addv x = (freevars := (x :: (!freevars)))
213 :    
214 :     (* check if an lvar is used by the main program *)
215 :     val refset : Intset.intset = Intset.new()
216 : jhr 4454 val used : lvar -> unit = Intset.add refset
217 : monnier 98 val isUsed : lvar -> bool = Intset.mem refset
218 :    
219 :     (* memoize the information on which corresponds to what *)
220 : blume 733 fun enter (v, i) = (IntHashTable.insert m (v, i); addv v)
221 :     fun const (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)
222 : monnier 98 | const (INT _ | INT32 _ | REAL _ | STRING _) = true
223 :     | const _ = bug "unexpected case in const"
224 :    
225 : blume 733 fun cstlit (VAR v) = ((IntHashTable.lookup m v; true) handle _ => false)
226 : monnier 251 | cstlit (REAL _ | STRING _) = true
227 :     | cstlit _ = false
228 :    
229 : monnier 98 (* register a string literal *)
230 :     local val strs : string list ref = ref []
231 :     val strsN : int ref = ref 0
232 : monnier 422 val sdict = ref (RlitDict.empty)
233 : monnier 98 val srtv = mkv()
234 :     val srtval = VAR srtv
235 :     in
236 : jhr 4454 fun entStr s =
237 : monnier 98 let val v = mkv() (** should hash to remove duplicates **)
238 :     val sd = !sdict
239 :     val rlit = toRlit s
240 : jhr 4454 val n =
241 : monnier 422 (case RlitDict.find(sd, rlit)
242 : monnier 98 of SOME k => k
243 :     | _ => let val _ = (strs := (s :: (!strs)))
244 :     val k = !strsN
245 : jhr 4454 val _ = (strsN := (k+1))
246 : monnier 98 val _ = (sdict := (RlitDict.insert(sd, rlit, k)))
247 :     in k
248 :     end)
249 :     in (VAR v, fn ce => SELECT(n, srtval, v, BOGt, ce))
250 :     end
251 :    
252 :     (* old definition of entStr
253 : jhr 4454
254 : monnier 98 let val sd = !sdict
255 :     val rlit = toRlit s
256 :     in (case RlitDict.peek(sd, rlit)
257 :     of SOME v => (VAR v, ident)
258 :     | _ => let val v = mkv()
259 :     val _ = (enter(v, ZZ_STR s); used v)
260 :     val _ = (sdict := RlitDict.insert(sd, rlit, v))
261 :     in (VAR v, ident)
262 :     end)
263 :     end
264 :     *)
265 :    
266 : jhr 4454 fun appStr () =
267 :     let fun g (a::r, z) = g(r, (STRING a)::z)
268 : monnier 98 | g ([], z) = z (* reverse to reflecting the correct order *)
269 :     val allStrs = !strs
270 :     in case !strs
271 :     of [] => ()
272 :     | xs => (enter(srtv, ZZ_RCD(RK_RECORD, g(xs,[]))); used srtv)
273 :     end
274 :     end (* local of processing string literals *)
275 : jhr 4454
276 : monnier 98 (** a special treatment of real constants *)
277 :     local val reals : string list ref = ref []
278 :     val realsN : int ref = ref 0
279 : monnier 422 val rdict = ref (RlitDict.empty)
280 : monnier 98 val rrtv = mkv()
281 :     val rrtval = VAR rrtv
282 : jhr 4454 in
283 :     fun entReal s =
284 : monnier 98 let val v = mkv() (** should hash to remove duplicates **)
285 :     val rd = !rdict
286 :     val rlit = toRlit s
287 : jhr 4454 val n =
288 : monnier 422 (case RlitDict.find(rd, rlit)
289 : monnier 98 of SOME k => k
290 :     | _ => let val _ = (reals := (s :: (!reals)))
291 :     val k = !realsN
292 : jhr 4454 val _ = (realsN := (k+1))
293 : monnier 98 val _ = (rdict := (RlitDict.insert(rd, rlit, k)))
294 :     in k
295 :     end)
296 : jhr 4454 in (VAR v, fn ce => SELECT(n, rrtval, v, FLTt 64, ce)) (* REAL32: FIXME *)
297 : monnier 98 end
298 :    
299 : jhr 4454 fun appReal () =
300 :     let fun g (a::r, z) = g(r, (REAL a)::z)
301 : monnier 98 | g ([], z) = z (* reverse to reflecting the correct order *)
302 :     val allReals = !reals
303 : jhr 4454 in case !reals
304 : monnier 98 of [] => ()
305 :     | xs => (enter(rrtv, ZZ_RCD(RK_FBLOCK, g(xs,[]))); used rrtv)
306 :     end
307 :     end (* local of special treatment of real constants *)
308 :    
309 :     (* translation on the CPS values *)
310 : jhr 4454 fun lpsv u =
311 : monnier 98 (case u
312 :     of REAL s => entReal s
313 :     | STRING s => entStr s
314 :     | VAR v => (used v; (u, ident))
315 :     | _ => (u, ident))
316 :    
317 : jhr 4454 fun lpvs vs =
318 :     let fun g (u, (xs, hh)) =
319 :     let val (nu, nh) = lpsv u
320 :     in (nu::xs, nh o hh)
321 : monnier 98 end
322 :     in foldr g ([], ident) vs
323 :     end
324 :    
325 :     (* if all fields of a record are "constant", then we lift it *)
326 : jhr 4454 fun field ul =
327 :     let fun h ((x, OFFp 0)::r, z, rsflag) =
328 : monnier 251 if const x then h(r, x::z, rsflag orelse (cstlit x)) else NONE
329 :     | h ([], z, rsflag) = if rsflag then SOME(rev z) else NONE
330 : monnier 98 | h _ = bug "unexpected case in field"
331 : monnier 251 in h (ul, [], false)
332 : monnier 98 end
333 :    
334 :     (* register a constant record *)
335 :     fun record (rk, ul, v) =
336 :     (case field ul
337 :     of SOME xl => (enter(v, ZZ_RCD(rk, xl)); ident)
338 :     | NONE =>
339 : jhr 4454 let fun g ((u, p as OFFp 0), (r, hh)) =
340 : monnier 98 let val (nu, nh) = lpsv u
341 :     in ((nu, p)::r, nh o hh)
342 :     end
343 :     | g _ = bug "unexpected non-zero OFFp in record"
344 :     val (nl, hdr) = foldr g ([], ident) ul
345 :     in fn ce => hdr(RECORD(rk, nl, v, ce))
346 :     end)
347 :    
348 :     (* register a wrapped float literal *)
349 : jhr 4454 fun wrapfloat (u, v, t) =
350 : monnier 98 if const u then (enter(v, ZZ_RCD(RK_FBLOCK, [u])); ident)
351 :     else let val (nu, hh) = lpsv u
352 :     in (fn ce => hh(PURE(P.fwrap, [nu], v, t, ce)))
353 :     end
354 :    
355 :     (* fetch out the literal information *)
356 : jhr 4454 fun getInfo () =
357 : monnier 98 let val _ = appReal() (* register all Reals as a record *)
358 :     val _ = appStr() (* register all Strings as a record *)
359 :     val allvars = !freevars
360 :     val exports = List.filter isUsed allvars
361 :    
362 : jhr 4454 val toplit =
363 : monnier 98 let fun g ([], z) = LI_TOP z
364 : jhr 4454 | g (x::r, z) =
365 : blume 733 (case IntHashTable.lookup m x
366 : monnier 98 of ZZ_STR s => g(r, (LI_STRING s)::z)
367 :     | _ => g(r, (LI_VAR x)::z))
368 :     in g(exports, [])
369 :     end
370 :    
371 : blume 773 fun mklit (v, lit) = let
372 :     fun unREAL (CPS.REAL s) = s
373 :     | unREAL _ = bug "unREAL"
374 :     fun unINT32 (CPS.INT32 w) = w
375 :     | unINT32 _ = bug "unINT32"
376 :     in
377 :     case IntHashTable.lookup m v of
378 :     (ZZ_FLT _) => (* float is wrapped *)
379 :     bug "currently we don't expect ZZ_FLT in mklit"
380 :     (* LI_F64BLOCK([s], v, lit) *)
381 : jhr 4454 | (ZZ_STR s) =>
382 : blume 773 bug "currently we don't expect ZZ_STR in mklit"
383 :     (* lit --- or we could inline string *)
384 :     | (ZZ_RCD(CPS.RK_FBLOCK, vs)) =>
385 :     LI_F64BLOCK(map unREAL vs, v, lit)
386 :     | (ZZ_RCD(CPS.RK_I32BLOCK, vs)) =>
387 :     LI_I32BLOCK(map unINT32 vs, v, lit)
388 : jhr 4454 | (ZZ_RCD(rk, vs)) =>
389 : blume 773 LI_BLOCK(rk2bk rk, map val2lit vs, v, lit)
390 :     end
391 : monnier 98
392 :     (** build up the literal structure *)
393 :     val lit = foldl mklit toplit allvars
394 :    
395 :     val n = length exports
396 : jhr 4454 val hdr =
397 : monnier 98 if n = 0 then ident
398 :     else let val rv = mkv()
399 :     val rval = VAR rv
400 : jhr 4454 val rhdr =
401 : monnier 98 fn ce => SELECT(offset, root, rv, PTRt(RPT n), ce)
402 :    
403 : jhr 4454 fun mkhdr (v, (i, hh)) =
404 :     let val nh =
405 : blume 733 (case IntHashTable.lookup m v
406 : monnier 98 of (ZZ_FLT _) => bug "ZZ_FLT in mkhdr"
407 : jhr 4454 (* (fn ce =>
408 : monnier 98 (SELECT(i, rval, w, PTRt(FPT 1),
409 :     SELECT(0, VAR w, v, FLTt, ce)))) *)
410 :     | (ZZ_STR s) => bug "ZZ_STR in mkhdr"
411 : jhr 4454 (* (fn ce =>
412 : monnier 98 SELECT(i, rval, v, BOGt, ce)) *)
413 :     | (ZZ_RCD (rk, vs)) =>
414 :     let val n = length vs
415 : jhr 4454 val t =
416 :     case rk
417 : monnier 98 of RK_FBLOCK => PTRt(FPT n)
418 : monnier 477 | RK_VECTOR => BOGt
419 : monnier 98 | _ => PTRt(RPT n)
420 :     in fn ce => SELECT(i, rval, v, t, ce)
421 :     end)
422 :     in (i+1, hh o nh)
423 :     end
424 :     in #2 (foldr mkhdr (0, rhdr) exports)
425 :     end
426 :     in (lit, hdr)
427 :     end (* function getInfo *)
428 :    
429 :     fun lpfn (fk, f, vl, cl, e) = (fk, f, vl, cl, loop e)
430 :    
431 :     and loop ce =
432 :     (case ce
433 :     of RECORD (rk, ul, v, e) => record (rk, ul, v) (loop e)
434 : jhr 4454 | SELECT (i, u, v, t, e) =>
435 : monnier 98 let val (nu, hh) = lpsv u
436 :     in hh(SELECT(i, nu, v, t, loop e))
437 :     end
438 :     | OFFSET _ => bug "unexpected OFFSET in loop"
439 : jhr 4454 | APP (u, ul) =>
440 : monnier 98 let val (nu, h1) = lpsv u
441 :     val (nl, h2) = lpvs ul
442 :     in h1(h2(APP(nu, nl)))
443 :     end
444 :     | FIX (fns, e) => FIX(map lpfn fns, loop e)
445 : jhr 4454 | SWITCH (u, v, es) =>
446 : monnier 98 let val (nu, hh) = lpsv u
447 :     in hh(SWITCH(nu, v, map loop es))
448 :     end
449 : jhr 4454 | BRANCH (p, ul, v, e1, e2) =>
450 : monnier 98 let val (nl, hh) = lpvs ul
451 :     in hh(BRANCH(p, nl, v, loop e1, loop e2))
452 :     end
453 : jhr 4454 | SETTER (p, ul, e) =>
454 : monnier 98 let val (nl, hh) = lpvs ul
455 :     in hh(SETTER(p, nl, loop e))
456 :     end
457 :     | LOOKER (p, ul, v, t, e) =>
458 :     let val (nl, hh) = lpvs ul
459 :     in hh(LOOKER(p, nl, v, t, loop e))
460 :     end
461 :     | ARITH (p, ul, v, t, e) =>
462 :     let val (nl, hh) = lpvs ul
463 :     in hh(ARITH(p, nl, v, t, loop e))
464 :     end
465 :     | PURE (P.fwrap, [u], v, t, e) => wrapfloat (u, v, t) (loop e)
466 : jhr 4454 | PURE (p, ul, v, t, e) =>
467 : monnier 98 let val (nl, hh) = lpvs ul
468 :     in hh(PURE(p, nl, v, t, loop e))
469 : blume 773 end
470 : mblume 1755 | RCC (k, l, p, ul, vtl, e) =>
471 : blume 773 let val (nl, hh) = lpvs ul
472 : mblume 1755 in hh(RCC(k, l, p, nl, vtl, loop e))
473 : blume 773 end)
474 : monnier 98
475 :     val newbody = loop body
476 :     val (lit, hdr) = getInfo ()
477 :     in (hdr newbody, lit)
478 :     end
479 :    
480 :     (* the main function *)
481 : jhr 4454 fun litsplit (fk, f, vl as [_,x], [CNTt, t as PTRt(RPT n)], body) =
482 : monnier 98 let val nt = PTRt(RPT (n+1))
483 : monnier 251 val (nbody, lit) = liftlits(body, VAR x, n)
484 : monnier 98 in ((fk, f, vl, [CNTt, nt], nbody), lit)
485 :     end
486 :     | litsplit _ = bug "unexpected CPS header in litsplit"
487 :    
488 :     end (* toplevel local *)
489 :     end (* Literals *)

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