Annotation of /sml/trunk/compiler/FLINT/cps/convert.sml

Parent Directory | Revision Log

---

Revision 93 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/FLINT/cps/convert.sml

1 :	monnier	69	(* COPYRIGHT 1998 BY YALE FLINT PROJECT *)
2 :	monnier	16	(* convert.sml *)
3 :
4 :			(***************************************************************************
5 :			* IMPORTANT NOTES *
6 :			* *
7 :	monnier	69	* The CPS code generated by this phase should not *
8 :			* use OFFSET and RECORD accesspath SELp. *
9 :	monnier	16	* generated by this module. *
10 :			***************************************************************************)
11 :			signature CONVERT = sig
12 :	monnier	69	val convert : FLINT.prog -> CPS.function
13 :	monnier	16	end (* signature CONVERT *)
14 :
15 :			functor Convert(MachSpec : MACH_SPEC) : CONVERT = struct
16 :
17 :	monnier	69	local structure DA = Access
18 :	monnier	16	structure LT = LtyExtern
19 :			structure LV = LambdaVar
20 :			structure AP = PrimOp
21 :	monnier	69	structure DI = DebIndex
22 :			structure F = FLINT
23 :			structure FU = FlintUtil
24 :
25 :			open CPS
26 :	monnier	16	in
27 :
28 :	monnier	69	fun bug s = ErrorMsg.impossible ("ConvertN: " ^ s)
29 :	monnier	16	val say = Control.Print.say
30 :	monnier	69	val mkv = fn _ => LV.mkLvar()
31 :			fun mkfn f = let val v = mkv() in f v end
32 :	monnier	16	val ident = fn le => le
33 :	monnier	69	val OFFp0 = OFFp 0
34 :	monnier	16
35 :	monnier	69	(* testing if two values are equivalent lvar values *)
36 :			fun veq (VAR x, VAR y) = (x = y)
37 :			| veq _ = false
38 :	monnier	16
39 :	monnier	69	(***************************************************************************
40 :			* CONSTANTS AND UTILITY FUNCTIONS *
41 :			***************************************************************************)
42 :	monnier	16
43 :	monnier	69	fun unwrapf64(u,x,ce) = PURE(P.funwrap,[u],x,FLTt,ce)
44 :			fun unwrapi32(u,x,ce) = PURE(P.i32unwrap,[u],x,INT32t,ce)
45 :			fun wrapf64(u,x,ce) = PURE(P.fwrap,[u],x,BOGt,ce)
46 :			fun wrapi32(u,x,ce) = PURE(P.i32wrap,[u],x,BOGt,ce)
47 :	monnier	16
48 :	monnier	69	fun all_float (FLTt::r) = all_float r
49 :			| all_float (_::r) = false
50 :			| all_float [] = true
51 :	monnier	16
52 :	monnier	69	fun selectFL(i,u,x,ct,ce) = SELECT(i,u,x,ct,ce)
53 :	monnier	16
54 :	monnier	69	fun selectNM(i,u,x,ct,ce) =
55 :			(case ct
56 :			of FLTt => mkfn(fn v => SELECT(i,u,v,BOGt,unwrapf64(VAR v,x,ce)))
57 :			| INT32t => mkfn(fn v => SELECT(i,u,v,BOGt,unwrapi32(VAR v,x,ce)))
58 :			| _ => SELECT(i,u,x,ct,ce))
59 :
60 :			fun recordFL(ul,_,w,ce) =
61 :			RECORD(RK_FBLOCK, map (fn u => (u,OFFp 0)) ul, w, ce)
62 :
63 :			fun recordNM(ul,ts,w,ce) =
64 :			let fun g(FLTt::r,u::z,l,h) =
65 :			mkfn(fn v => g(r, z, (VAR v,OFFp 0)::l,
66 :			fn ce => h(wrapf64(u,v,ce))))
67 :			| g(INT32t::r,u::z,l,h) =
68 :			mkfn(fn v => g(r, z, (VAR v,OFFp 0)::l,
69 :			fn ce => h(wrapi32(u,v,ce))))
70 :			| g(_::r,u::z,l,h) = g(r, z, (u,OFFp0)::l, h)
71 :			| g([],[],l,h) = (rev l, h)
72 :			| g _ = bug "unexpected in recordNM in convert"
73 :
74 :			val (nul,header) = g(ts,ul,[],fn x => x)
75 :			in header(RECORD(RK_RECORD,nul,w,ce))
76 :			end
77 :
78 :	monnier	16	(***************************************************************************
79 :	monnier	69	* UTILITY FUNCTIONS FOR PROCESSING THE PRIMOPS *
80 :	monnier	16	***************************************************************************)
81 :
82 :	monnier	69	(* numkind: AP.numkind -> P.numkind *)
83 :	monnier	16	fun numkind (AP.INT bits) = P.INT bits
84 :			| numkind (AP.UINT bits) = P.UINT bits
85 :			| numkind (AP.FLOAT bits) = P.FLOAT bits
86 :
87 :	monnier	69	(* cmpop: AP.stuff -> P.branch *)
88 :			fun cmpop stuff =
89 :			(case stuff
90 :			of {oper=AP.EQL,kind=AP.INT 31} => P.ieql
91 :			| {oper=AP.NEQ,kind=AP.INT 31} => P.ineq
92 :	monnier	16	| {oper,kind=AP.FLOAT size} =>
93 :			let fun c AP.> = P.fGT
94 :			| c AP.>= = P.fGE
95 :			| c AP.< = P.fLT
96 :			| c AP.<= = P.fLE
97 :			| c AP.EQL = P.fEQ
98 :			| c AP.NEQ = P.fLG
99 :			| c _ = bug "cmpop:kind=AP.FLOAT"
100 :			in P.fcmp{oper= c oper, size=size}
101 :			end
102 :			| {oper, kind} =>
103 :			let fun check (_, AP.UINT _) = ()
104 :			| check (oper, _) = bug ("check" ^ oper)
105 :			fun c AP.> = P.>
106 :			| c AP.>= = P.>=
107 :			| c AP.< = P.<
108 :			| c AP.<= = P.<=
109 :			| c AP.LEU = (check ("leu", kind); P.<= )
110 :			| c AP.LTU = (check ("ltu", kind); P.< )
111 :			| c AP.GEU = (check ("geu", kind); P.>= )
112 :			| c AP.GTU = (check ("gtu", kind); P.> )
113 :			| c AP.EQL = P.eql
114 :			| c AP.NEQ = P.neq
115 :			in P.cmp{oper=c oper, kind=numkind kind}
116 :			end)
117 :
118 :	monnier	69	(* map_branch: AP.primop -> P.branch *)
119 :			fun map_branch p =
120 :			(case p
121 :			of AP.BOXED => P.boxed
122 :			| AP.UNBOXED => P.unboxed
123 :			| AP.CMP stuff => cmpop stuff
124 :			| AP.PTREQL => P.peql
125 :			| AP.PTRNEQ => P.pneq
126 :			| _ => bug "unexpected primops in map_branch")
127 :
128 :			(* primwrap: cty -> P.pure *)
129 :			fun primwrap(INTt) = P.iwrap
130 :			| primwrap(INT32t) = P.i32wrap
131 :			| primwrap(FLTt) = P.fwrap
132 :			| primwrap _ = P.wrap
133 :
134 :			(* primunwrap: cty -> P.pure *)
135 :			fun primunwrap(INTt) = P.iunwrap
136 :			| primunwrap(INT32t) = P.i32unwrap
137 :			| primunwrap(FLTt) = P.funwrap
138 :			| primunwrap _ = P.unwrap
139 :
140 :			(* arithop: AP.arithop -> P.arithop *)
141 :	monnier	16	fun arithop AP.~ = P.~
142 :			| arithop AP.ABS = P.abs
143 :			| arithop AP.NOTB = P.notb
144 :			| arithop AP.+ = P.+
145 :			| arithop AP.- = P.-
146 :			| arithop AP.* = P.*
147 :			| arithop AP./ = P./
148 :			| arithop AP.LSHIFT = P.lshift
149 :			| arithop AP.RSHIFT = P.rshift
150 :			| arithop AP.RSHIFTL = P.rshiftl
151 :			| arithop AP.ANDB = P.andb
152 :			| arithop AP.ORB = P.orb
153 :			| arithop AP.XORB = P.xorb
154 :
155 :	monnier	69	(* a temporary classifier of various kinds of CPS primops *)
156 :			datatype pkind
157 :			= PKS of P.setter
158 :			| PKP of P.pure
159 :			| PKL of P.looker
160 :			| PKA of P.arith
161 :	monnier	16
162 :	monnier	69	(* map_primop: AP.primop -> pkind *)
163 :			fun map_primop p =
164 :			(case p
165 :			of AP.TEST(from,to) => PKA (P.test(from, to))
166 :			| AP.TESTU(from,to) => PKA (P.testu(from, to))
167 :			| AP.COPY(from,to) => PKP (P.copy(from,to))
168 :			| AP.EXTEND(from,to) => PKP (P.extend(from, to))
169 :			| AP.TRUNC(from,to) => PKP (P.trunc(from, to))
170 :	monnier	16
171 :	monnier	69	| AP.ARITH{oper,kind,overflow=true} =>
172 :			PKA(P.arith{oper=arithop oper,kind=numkind kind})
173 :			| AP.ARITH{oper,kind,overflow=false} =>
174 :			PKP(P.pure_arith{oper=arithop oper,kind=numkind kind})
175 :			| AP.ROUND{floor,fromkind,tokind} =>
176 :			PKA(P.round{floor=floor, fromkind=numkind fromkind,
177 :			tokind=numkind tokind})
178 :			| AP.REAL{fromkind,tokind} =>
179 :			PKP(P.real{tokind=numkind tokind, fromkind=numkind fromkind})
180 :	monnier	16
181 :	monnier	69	| AP.SUBSCRIPTV => PKP (P.subscriptv)
182 :			| AP.MAKEREF => PKP (P.makeref)
183 :			| AP.LENGTH => PKP (P.length)
184 :			| AP.OBJLENGTH => PKP (P.objlength)
185 :			| AP.GETTAG => PKP (P.gettag)
186 :			| AP.MKSPECIAL => PKP (P.mkspecial)
187 :			| AP.THROW => PKP (P.cast)
188 :			| AP.CAST => PKP (P.cast)
189 :			| AP.MKETAG => PKP (P.makeref)
190 :
191 :			| AP.SUBSCRIPT => PKL (P.subscript)
192 :			| AP.NUMSUBSCRIPT{kind,immutable=false,checked=false} =>
193 :			PKL(P.numsubscript{kind=numkind kind})
194 :			| AP.NUMSUBSCRIPT{kind,immutable=true,checked=false} =>
195 :			PKP(P.pure_numsubscript{kind=numkind kind})
196 :			| AP.DEREF => PKL(P.!)
197 :			| AP.GETRUNVEC => PKL(P.getrunvec)
198 :			| AP.GETHDLR => PKL(P.gethdlr)
199 :			| AP.GETVAR => PKL(P.getvar)
200 :			| AP.GETPSEUDO => PKL(P.getpseudo)
201 :			| AP.GETSPECIAL =>PKL(P.getspecial)
202 :			| AP.DEFLVAR => PKL(P.deflvar)
203 :
204 :			| AP.SETHDLR => PKS(P.sethdlr)
205 :			| AP.NUMUPDATE{kind,checked=false} =>
206 :			PKS(P.numupdate{kind=numkind kind})
207 :			| AP.UNBOXEDUPDATE => PKS(P.unboxedupdate)
208 :			| AP.BOXEDUPDATE => PKS(P.boxedupdate)
209 :			| AP.UPDATE => PKS(P.update)
210 :			| AP.SETVAR => PKS(P.setvar)
211 :			| AP.SETPSEUDO => PKS(P.setpseudo)
212 :			| AP.SETMARK => PKS(P.setmark)
213 :			| AP.DISPOSE => PKS(P.free)
214 :			| AP.SETSPECIAL => PKS(P.setspecial)
215 :			| AP.USELVAR => PKS(P.uselvar)
216 :
217 :			| _ => bug ("bad primop in map_primop: " ^ (AP.prPrimop p) ^ "\n"))
218 :	monnier	16
219 :	monnier	69	(***************************************************************************
220 :			* SWITCH OPTIMIZATIONS AND COMPILATIONS *
221 :			***************************************************************************)
222 :			(*
223 :			* BUG: The defintion of E_word is clearly incorrect since it can raise
224 :			* an overflow at code generation time. A clean solution would be
225 :			* to add a WORD constructor into the CPS language -- daunting! The
226 :			* revolting hack solution would be to put the right int constant
227 :			* that gets converted to the right set of bits for the word constant.
228 :	monnier	16	*)
229 :	monnier	69	fun do_switch_gen ren = Switch.switch {
230 :			E_int = fn i => if i < ~0x20000000 orelse i >= 0x20000000
231 :			then raise Switch.TooBig else INT i,
232 :			E_word = fn w => (* if w >= 0wx20000000
233 :			then raise Switch.TooBig else *) INT (Word.toIntX w),
234 :			E_real = (fn s => REAL s),
235 :	monnier	16	E_switchlimit = 4,
236 :	monnier	69	E_neq = P.ineq,
237 :	monnier	16	E_w32neq = P.cmp{oper=P.neq,kind=P.UINT 32},
238 :			E_i32neq = P.cmp{oper=P.neq,kind=P.INT 32},
239 :			E_word32 = INT32,
240 :	monnier	69	E_int32 = INT32,
241 :			E_wneq = P.cmp{oper=P.neq, kind=P.UINT 31},
242 :			E_pneq = P.pneq,
243 :			E_fneq = P.fneq,
244 :			E_less = P.ilt,
245 :			E_branch = (fn (cmp,x,y,a,b) => BRANCH(cmp,[x,y],mkv(),a,b)),
246 :			E_strneq = (fn (w,str,a,b) => BRANCH(P.strneq, [INT(size str), w,
247 :			STRING str], mkv(), a, b)),
248 :			E_switch = (fn (v,l) => SWITCH(v, mkv(), l)),
249 :			E_add = (fn (x,y,c) =>
250 :			mkfn(fn v => ARITH(P.iadd,[x,y],v,INTt,c(VAR v)))),
251 :			E_gettag = (fn (x,c) => mkfn(fn v => PURE(P.getcon,[x],v,INTt,c(VAR v)))),
252 :			E_unwrap = (fn (x,c) => mkfn(fn v => PURE(P.unwrap,[x],v,INTt,c(VAR v)))),
253 :			E_getexn = (fn (x,c) => mkfn(fn v => PURE(P.getexn,[x],v,BOGt,c(VAR v)))),
254 :			E_length = (fn (x,c) => mkfn(fn v => PURE(P.length,[x],v,INTt,c(VAR v)))),
255 :			E_boxed = (fn (x,a,b) => BRANCH(P.boxed,[x],mkv(),a,b)),
256 :			E_path = (fn (DA.LVAR v, k) => k(ren v)
257 :			| _ => bug "unexpected path in convpath")}
258 :	monnier	16
259 :			(***************************************************************************
260 :	monnier	69	* UTILITY FUNCTIONS FOR DEALING WITH META-LEVEL CONTINUATIONS *
261 :	monnier	16	***************************************************************************)
262 :	monnier	69	(* an abstract representation of the meta-level continuation *)
263 :			datatype mcont = MCONT of {cnt: value list -> cexp, ts: cty list}
264 :	monnier	16
265 :	monnier	69	(* appmc : mcont * value list -> cexp *)
266 :			fun appmc (MCONT{cnt, ...}, vs) = cnt(vs)
267 :	monnier	16
268 :	monnier	69	(* makmc : (value list -> cexp) * cty list -> cexp *)
269 :			fun makmc (cnt, ts) = MCONT{cnt=cnt, ts=ts}
270 :	monnier	16
271 :	monnier	69	(* rttys : mcont -> cty list *)
272 :			fun rttys (MCONT{ts, ...}) = ts
273 :	monnier	16
274 :	monnier	69	(* isEta : cexp * value list -> value option *)
275 :			fun isEta (APP(w, vl), ul) =
276 :			let fun h (x::xs, y::ys) =
277 :			if (veq(x, y)) andalso (not (veq(w, y)))
278 :			then h(xs, ys) else NONE
279 :			| h ([], []) = SOME w
280 :			| h _ = NONE
281 :			in h(ul, vl)
282 :			end
283 :			| isEta _ = NONE
284 :	monnier	16
285 :	monnier	69	(* preventEta : mcont -> (cexp -> cexp) * value *)
286 :			fun preventEta (MCONT{cnt=c, ts=ts}) =
287 :			let val vl = map mkv ts
288 :			val ul = map VAR vl
289 :			val b = c ul
290 :			in case isEta(b, ul)
291 :			of SOME w => (ident, w)
292 :			| NONE => let val f = mkv()
293 :			in (fn x => FIX([(CONT,f,vl,ts,b)],x), VAR f)
294 :			end
295 :			end (* function preventEta *)
296 :	monnier	16
297 :			(***************************************************************************
298 :	monnier	69	* THE MAIN FUNCTION *
299 :			* convert : F.prog -> CPS.function *
300 :	monnier	16	***************************************************************************)
301 :	monnier	69	fun convert fdec =
302 :			let val {getLty=getLtyGen, cleanUp} = Recover.recover (fdec, true)
303 :			val getlty = getLtyGen DI.top
304 :			val ctypes = map ctype
305 :			fun res_ctys f =
306 :			let val lt = getlty (F.VAR f)
307 :			in if LT.ltp_fct lt then ctypes (#2(LT.ltd_fct lt))
308 :			else if LT.ltp_arrow lt then ctypes (#3(LT.ltd_arrow lt))
309 :			else [BOGt]
310 :	monnier	16	end
311 :	monnier	69	fun get_cty v = ctype (getlty v)
312 :			fun is_float_record u =
313 :			LT.ltw_tyc (getlty u,
314 :			fn tc => LT.tcw_tuple (tc, fn l => all_float (map ctyc l),
315 :			fn _ => false),
316 :			fn _ => false)
317 :	monnier	16
318 :	monnier	69	val bogus_cont = mkv()
319 :			fun bogus_header ce =
320 :			let val bogus_knownf = mkv()
321 :			in FIX([(KNOWN, bogus_knownf, [mkv()], [BOGt],
322 :			APP(VAR bogus_knownf, [STRING "bogus"]))],
323 :			FIX([(CONT, bogus_cont, [mkv()], [BOGt],
324 :			APP(VAR bogus_knownf, [STRING "bogus"]))], ce))
325 :			end
326 :	monnier	16
327 :	monnier	69	local exception Rename
328 :			val m : value Intmap.intmap = Intmap.new(32, Rename)
329 :			in
330 :			(* F.lvar -> CPS.value *)
331 :			fun rename v = Intmap.map m v handle Rename => VAR v
332 :	monnier	16
333 :	monnier	69	(* F.lvar * CPS.value -> unit *)
334 :			fun newname (v, w) =
335 :			(case w of VAR w' => LV.sameName (v, w') | _ => ();
336 :			Intmap.add m (v, w))
337 :	monnier	16
338 :	monnier	69	(* F.lvar list * CPS.value list -> unit *)
339 :			fun newnames (v::vs, w::ws) = (newname(v,w); newnames(vs, ws))
340 :			| newnames ([], []) = ()
341 :			| newnames _ = bug "unexpected case in newnames"
342 :			end (* local of Rename *)
343 :	monnier	16
344 :	monnier	69	(* switch optimization *)
345 :			val do_switch = do_switch_gen rename
346 :	monnier	16
347 :	monnier	69	(* lpvar : F.value -> value *)
348 :			fun lpvar (F.VAR v) = rename v
349 :			| lpvar (F.INT32 i) =
350 :			let val int32ToWord32 = Word32.fromLargeInt o Int32.toLarge
351 :			in INT32 (int32ToWord32 i)
352 :			end
353 :			| lpvar (F.WORD32 w) = INT32 w
354 :			| lpvar (F.INT i) = INT i
355 :			| lpvar (F.WORD w) = INT(Word.toIntX w)
356 :			| lpvar (F.REAL r) = REAL r
357 :			| lpvar (F.STRING s) = STRING s
358 :
359 :
360 :			(* lpvars : F.value list -> value list *)
361 :			fun lpvars vl =
362 :			let fun h([], z) = rev z
363 :			| h(a::r, z) = h(r, (lpvar a)::z)
364 :			in h(vl, [])
365 :	monnier	16	end
366 :	monnier	69
367 :			(* lpfd : F.fundec -> function *)
368 :			fun lpfd ((fk, f, vts, e) : F.fundec) =
369 :			let val k = mkv()
370 :			val vl = k::(map #1 vts)
371 :			val cl = CNTt::(map (ctype o #2) vts)
372 :			val kont = makmc (fn vs => APP(VAR k, vs), res_ctys f)
373 :			in (ESCAPE, f, vl, cl, loop(e, kont))
374 :	monnier	16	end
375 :	monnier	69
376 :			(* loop : F.lexp * (value list -> cexp) -> cexp *)
377 :			and loop (le, c) =
378 :			(case le
379 :			of F.RET vs => appmc(c, lpvars vs)
380 :			| F.LET(vs, e1, e2) =>
381 :			let val kont =
382 :			makmc (fn ws => (newnames(vs, ws); loop(e2, c)),
383 :			map (get_cty o F.VAR) vs)
384 :			in loop(e1, kont)
385 :			end
386 :
387 :			| F.FIX(fds, e) => FIX(map lpfd fds, loop(e, c))
388 :			| F.APP(f, vs) =>
389 :			let val (hdr, F) = preventEta c
390 :			val vf = lpvar f
391 :			val ul = lpvars vs
392 :			in hdr(APP(vf, F::ul))
393 :			end
394 :
395 :			| (F.TFN _ | F.TAPP _) =>
396 :			bug "unexpected TFN and TAPP in convert"
397 :
398 :			| F.RECORD(F.RK_VECTOR _, [], v, e) =>
399 :			bug "zero length vectors in convert"
400 :			| F.RECORD(rk, [], v, e) =>
401 :			let val _ = newname(v, INT 0)
402 :			in loop(e, c)
403 :			end
404 :			| F.RECORD(rk, vl, v, e) =>
405 :			let val ts = map get_cty vl
406 :			val nvl = lpvars vl
407 :			val ce = loop(e, c)
408 :			in case rk
409 :			of F.RK_TUPLE _ =>
410 :			if (all_float ts) then recordFL(nvl, ts, v, ce)
411 :			else recordNM(nvl, ts, v, ce)
412 :			| F.RK_VECTOR _ =>
413 :			RECORD(RK_VECTOR, map (fn x => (x, OFFp0)) nvl, v, ce)
414 :			| _ => recordNM(nvl, ts, v, ce)
415 :			end
416 :			| F.SELECT(u, i, v, e) =>
417 :			let val ct = get_cty (F.VAR v)
418 :			val nu = lpvar u
419 :			val ce = loop(e, c)
420 :			in if is_float_record u then selectFL(i, nu, v, ct, ce)
421 :			else selectNM(i, nu, v, ct, ce)
422 :			end
423 :
424 :			| F.SWITCH(e,l,[a as (F.DATAcon((_,DA.CONSTANT 0,_),_,_),_),
425 :			b as (F.DATAcon((_,DA.CONSTANT 1,_),_,_),_)],
426 :			NONE) =>
427 :			loop(F.SWITCH(e,l,[b,a],NONE),c)
428 :			| F.SWITCH (u, sign, l, d) =>
429 :			let val (header,F) = preventEta c
430 :			val kont = makmc(fn vl => APP(F, vl), rttys c)
431 :			val body =
432 :			let val df = mkv()
433 :			fun proc (cn as (F.DATAcon(dc, _, v)), e) =
434 :			(cn, loop (F.LET([v], F.RET [u], e), kont))
435 :			| proc (cn, e) = (cn, loop(e, kont))
436 :			val b = do_switch{sign=sign, exp=lpvar u,
437 :			cases=map proc l,
438 :			default=APP(VAR df, [INT 0])}
439 :			in case d
440 :			of NONE => b
441 :			| SOME de => FIX([(CONT, df, [mkv()], [INTt],
442 :			loop(de, kont))], b)
443 :			end
444 :			in header(body)
445 :			end
446 :			| F.CON(dc, ts, u, v, e) =>
447 :			bug "unexpected case CON in cps convert"
448 :
449 :			| F.RAISE(u, lts) =>
450 :			let (* execute the continuation for side effects *)
451 :			val _ = appmc(c, (map (fn _ => VAR(mkv())) lts))
452 :			val h = mkv()
453 :			in LOOKER(P.gethdlr, [], h, FUNt,
454 :			APP(VAR h,[VAR bogus_cont,lpvar u]))
455 :			end
456 :			| F.HANDLE(e,u) => (* recover type from u *)
457 :			let val (hdr, F) = preventEta c
458 :			val h = mkv()
459 :			val kont =
460 :			makmc (fn vl =>
461 :			SETTER(P.sethdlr, [VAR h], APP(F, vl)),
462 :			rttys c)
463 :			val body =
464 :			let val k = mkv() and v = mkv()
465 :			in FIX([(ESCAPE, k, [mkv(), v], [CNTt, BOGt],
466 :			SETTER(P.sethdlr, [VAR h],
467 :			APP(lpvar u, [F, VAR v])))],
468 :			SETTER(P.sethdlr, [VAR k], loop(e, kont)))
469 :			end
470 :			in LOOKER(P.gethdlr, [], h, FUNt, hdr(body))
471 :			end
472 :
473 :			| F.PRIMOP((_,p as (AP.CALLCC | AP.CAPTURE),_,_), [f], v, e) =>
474 :			let val (kont_decs, F) =
475 :			let val k = mkv()
476 :			val ct = get_cty f
477 :			in ([(CONT, k, [v], [ct], loop(e, c))], VAR k)
478 :			end
479 :
480 :			val (hdr1,hdr2) =
481 :			(case p
482 :			of AP.CALLCC =>
483 :			mkfn(fn h =>
484 :			(fn e => SETTER(P.sethdlr, [VAR h], e),
485 :			fn e => LOOKER(P.gethdlr, [], h, BOGt, e)))
486 :			| _ => (ident, ident))
487 :
488 :			val (ccont_decs, ccont_var) =
489 :			let val k = mkv() (* captured continuation *)
490 :			val x = mkv()
491 :			in ([(ESCAPE, k, [mkv(), x], [CNTt, BOGt],
492 :			hdr1(APP(F, [VAR x])))], k)
493 :			end
494 :			in FIX(kont_decs,
495 :			hdr2(FIX(ccont_decs,
496 :			APP(lpvar f, [F, VAR ccont_var]))))
497 :			end
498 :
499 :			| F.PRIMOP((_,AP.ISOLATE,lt,ts), [f], v, e) =>
500 :			let val (exndecs, exnvar) =
501 :			let val h = mkv() and z = mkv() and x = mkv()
502 :			in ([(ESCAPE, h, [z, x], [CNTt, BOGt],
503 :			APP(VAR bogus_cont, [VAR x]))], h)
504 :			end
505 :			val newfdecs =
506 :			let val nf = v and z = mkv() and x = mkv()
507 :			in [(ESCAPE, v, [z, x], [CNTt, BOGt],
508 :			SETTER(P.sethdlr, [VAR exnvar],
509 :			APP(lpvar f, [VAR bogus_cont, VAR x])))]
510 :			end
511 :			in FIX(exndecs, FIX(newfdecs, loop(e, c)))
512 :			end
513 :	monnier	16
514 :	monnier	69	| F.PRIMOP(po as (_,AP.WCAST,_,_), [u], v, e) =>
515 :			(newname(v, lpvar u); loop(e, c))
516 :
517 :			| F.PRIMOP(po as (_,AP.WRAP,_,_), [u], v, e) =>
518 :			let val ct = ctyc(FU.getWrapTyc po)
519 :			in PURE(primwrap ct, [lpvar u], v, BOGt, loop(e, c))
520 :			end
521 :			| F.PRIMOP(po as (_,AP.UNWRAP,_,_), [u], v, e) =>
522 :			let val ct = ctyc(FU.getUnWrapTyc po)
523 :			in PURE(primunwrap ct, [lpvar u], v, ct, loop(e, c))
524 :			end
525 :
526 :			| F.PRIMOP(po as (_,AP.MARKEXN,_,_), [x,m], v, e) =>
527 :			let val bty = LT.ltc_void
528 :			val ety = LT.ltc_tuple[bty,bty,bty]
529 :			val (xx,x0,x1,x2) = (mkv(),mkv(),mkv(),mkv())
530 :			val (y,z,z') = (mkv(),mkv(),mkv())
531 :			in PURE(P.unwrap,[lpvar x],xx,ctype(ety),
532 :			SELECT(0,VAR xx,x0,BOGt,
533 :			SELECT(1,VAR xx,x1,BOGt,
534 :			SELECT(2,VAR xx,x2,BOGt,
535 :			RECORD(RK_RECORD,[(lpvar m, OFFp0),
536 :			(VAR x2, OFFp0)], z,
537 :			PURE(P.wrap,[VAR z],z',BOGt,
538 :			RECORD(RK_RECORD,[(VAR x0,OFFp0),
539 :			(VAR x1,OFFp0),
540 :			(VAR z', OFFp0)],
541 :			y,
542 :			PURE(P.wrap,[VAR y],v,BOGt,
543 :			loop(e,c)))))))))
544 :			end
545 :
546 :			| F.PRIMOP(po as (_,p,lt,ts), ul, v, e) =>
547 :			let val ct =
548 :			case (#3(LT.ltd_arrow(LT.lt_pinst (lt, ts))))
549 :			of [x] => ctype x
550 :			| _ => bug "unexpected case in F.PRIMOP"
551 :			val vl = lpvars ul
552 :			in case map_primop p
553 :			of PKS i => let val _ = newname(v, INT 0)
554 :			in SETTER(i, vl, loop(e,c))
555 :			end
556 :			| PKA i => ARITH(i, vl, v, ct, loop(e,c))
557 :			| PKL i => LOOKER(i, vl, v, ct, loop(e,c))
558 :			| PKP i => PURE(i, vl, v, ct, loop(e,c))
559 :			end
560 :
561 :			| F.BRANCH(po as (_,p,_,_), ul, e1, e2) =>
562 :			let val (hdr, F) = preventEta c
563 :			val kont = makmc(fn vl => APP(F, vl), rttys c)
564 :			in hdr(BRANCH(map_branch p, lpvars ul, mkv(),
565 :			loop(e1, kont), loop(e2, kont)))
566 :			end)
567 :
568 :			(* processing the top-level fundec *)
569 :			val (fk, f, vts, be) = fdec
570 :			val k = mkv() (* top-level return continuation *)
571 :			val kont = makmc (fn vs => APP(VAR k, vs), res_ctys f)
572 :			val body = loop(be, kont)
573 :	monnier	16
574 :	monnier	69	val vl = k::(map #1 vts)
575 :			val cl = CNTt::(map (ctype o #2) vts)
576 :			in (ESCAPE, f, vl, cl, bogus_header body) before cleanUp()
577 :			end (* function convert *)
578 :	monnier	16
579 :			end (* toplevel local *)
580 :			end (* functor Convert *)
581 :
582 :	monnier	93
583 :			(*
584 :			* $Log: convert.sml,v $
585 :			* Revision 1.1.1.1 1998/04/08 18:39:47 george
586 :			* Version 110.5
587 :			*
588 :			*)

---

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