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/cps/convert.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1347 - (view) (download)
Original Path: sml/trunk/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 : monnier 423 structure M = IntBinaryMap
25 : monnier 69
26 :     open CPS
27 : monnier 16 in
28 :    
29 : monnier 100 fun bug s = ErrorMsg.impossible ("Convert: " ^ s)
30 : monnier 16 val say = Control.Print.say
31 : monnier 69 val mkv = fn _ => LV.mkLvar()
32 : monnier 191 val cplv = LV.dupLvar
33 : monnier 69 fun mkfn f = let val v = mkv() in f v end
34 : monnier 16 val ident = fn le => le
35 : monnier 69 val OFFp0 = OFFp 0
36 : monnier 16
37 : monnier 69 (* testing if two values are equivalent lvar values *)
38 :     fun veq (VAR x, VAR y) = (x = y)
39 :     | veq _ = false
40 : monnier 16
41 : monnier 69 (***************************************************************************
42 :     * CONSTANTS AND UTILITY FUNCTIONS *
43 :     ***************************************************************************)
44 : monnier 16
45 : monnier 69 fun unwrapf64(u,x,ce) = PURE(P.funwrap,[u],x,FLTt,ce)
46 :     fun unwrapi32(u,x,ce) = PURE(P.i32unwrap,[u],x,INT32t,ce)
47 :     fun wrapf64(u,x,ce) = PURE(P.fwrap,[u],x,BOGt,ce)
48 :     fun wrapi32(u,x,ce) = PURE(P.i32wrap,[u],x,BOGt,ce)
49 : monnier 16
50 : monnier 69 fun all_float (FLTt::r) = all_float r
51 :     | all_float (_::r) = false
52 :     | all_float [] = true
53 : monnier 16
54 : monnier 69 fun selectFL(i,u,x,ct,ce) = SELECT(i,u,x,ct,ce)
55 : monnier 16
56 : monnier 69 fun selectNM(i,u,x,ct,ce) =
57 :     (case ct
58 :     of FLTt => mkfn(fn v => SELECT(i,u,v,BOGt,unwrapf64(VAR v,x,ce)))
59 :     | INT32t => mkfn(fn v => SELECT(i,u,v,BOGt,unwrapi32(VAR v,x,ce)))
60 :     | _ => SELECT(i,u,x,ct,ce))
61 :    
62 :     fun recordFL(ul,_,w,ce) =
63 :     RECORD(RK_FBLOCK, map (fn u => (u,OFFp 0)) ul, w, ce)
64 :    
65 :     fun recordNM(ul,ts,w,ce) =
66 :     let fun g(FLTt::r,u::z,l,h) =
67 :     mkfn(fn v => g(r, z, (VAR v,OFFp 0)::l,
68 :     fn ce => h(wrapf64(u,v,ce))))
69 :     | g(INT32t::r,u::z,l,h) =
70 :     mkfn(fn v => g(r, z, (VAR v,OFFp 0)::l,
71 :     fn ce => h(wrapi32(u,v,ce))))
72 :     | g(_::r,u::z,l,h) = g(r, z, (u,OFFp0)::l, h)
73 :     | g([],[],l,h) = (rev l, h)
74 :     | g _ = bug "unexpected in recordNM in convert"
75 :    
76 :     val (nul,header) = g(ts,ul,[],fn x => x)
77 :     in header(RECORD(RK_RECORD,nul,w,ce))
78 :     end
79 :    
80 : monnier 16 (***************************************************************************
81 : monnier 69 * UTILITY FUNCTIONS FOR PROCESSING THE PRIMOPS *
82 : monnier 16 ***************************************************************************)
83 :    
84 : monnier 69 (* numkind: AP.numkind -> P.numkind *)
85 : monnier 16 fun numkind (AP.INT bits) = P.INT bits
86 :     | numkind (AP.UINT bits) = P.UINT bits
87 :     | numkind (AP.FLOAT bits) = P.FLOAT bits
88 :    
89 : monnier 69 (* cmpop: AP.stuff -> P.branch *)
90 :     fun cmpop stuff =
91 :     (case stuff
92 :     of {oper=AP.EQL,kind=AP.INT 31} => P.ieql
93 :     | {oper=AP.NEQ,kind=AP.INT 31} => P.ineq
94 : monnier 16 | {oper,kind=AP.FLOAT size} =>
95 :     let fun c AP.> = P.fGT
96 :     | c AP.>= = P.fGE
97 :     | c AP.< = P.fLT
98 :     | c AP.<= = P.fLE
99 :     | c AP.EQL = P.fEQ
100 : george 754 | c AP.NEQ = P.fULG
101 : monnier 16 | c _ = bug "cmpop:kind=AP.FLOAT"
102 :     in P.fcmp{oper= c oper, size=size}
103 :     end
104 :     | {oper, kind} =>
105 :     let fun check (_, AP.UINT _) = ()
106 :     | check (oper, _) = bug ("check" ^ oper)
107 :     fun c AP.> = P.>
108 :     | c AP.>= = P.>=
109 :     | c AP.< = P.<
110 :     | c AP.<= = P.<=
111 :     | c AP.LEU = (check ("leu", kind); P.<= )
112 :     | c AP.LTU = (check ("ltu", kind); P.< )
113 :     | c AP.GEU = (check ("geu", kind); P.>= )
114 :     | c AP.GTU = (check ("gtu", kind); P.> )
115 :     | c AP.EQL = P.eql
116 :     | c AP.NEQ = P.neq
117 :     in P.cmp{oper=c oper, kind=numkind kind}
118 :     end)
119 :    
120 : monnier 69 (* map_branch: AP.primop -> P.branch *)
121 :     fun map_branch p =
122 :     (case p
123 :     of AP.BOXED => P.boxed
124 :     | AP.UNBOXED => P.unboxed
125 :     | AP.CMP stuff => cmpop stuff
126 :     | AP.PTREQL => P.peql
127 :     | AP.PTRNEQ => P.pneq
128 :     | _ => bug "unexpected primops in map_branch")
129 :    
130 :     (* primwrap: cty -> P.pure *)
131 :     fun primwrap(INTt) = P.iwrap
132 :     | primwrap(INT32t) = P.i32wrap
133 :     | primwrap(FLTt) = P.fwrap
134 :     | primwrap _ = P.wrap
135 :    
136 :     (* primunwrap: cty -> P.pure *)
137 :     fun primunwrap(INTt) = P.iunwrap
138 :     | primunwrap(INT32t) = P.i32unwrap
139 :     | primunwrap(FLTt) = P.funwrap
140 :     | primunwrap _ = P.unwrap
141 :    
142 :     (* arithop: AP.arithop -> P.arithop *)
143 : monnier 16 fun arithop AP.~ = P.~
144 :     | arithop AP.ABS = P.abs
145 : george 717 | arithop AP.FSQRT = P.fsqrt
146 :     | arithop AP.FSIN = P.fsin
147 :     | arithop AP.FCOS = P.fcos
148 :     | arithop AP.FTAN = P.ftan
149 : monnier 16 | arithop AP.NOTB = P.notb
150 : blume 1183 | arithop AP.REM = P.rem
151 :     | arithop AP.DIV = P.div
152 :     | arithop AP.MOD = P.mod
153 : monnier 16 | arithop AP.+ = P.+
154 :     | arithop AP.- = P.-
155 :     | arithop AP.* = P.*
156 :     | arithop AP./ = P./
157 :     | arithop AP.LSHIFT = P.lshift
158 :     | arithop AP.RSHIFT = P.rshift
159 :     | arithop AP.RSHIFTL = P.rshiftl
160 :     | arithop AP.ANDB = P.andb
161 :     | arithop AP.ORB = P.orb
162 :     | arithop AP.XORB = P.xorb
163 :    
164 : monnier 69 (* a temporary classifier of various kinds of CPS primops *)
165 :     datatype pkind
166 :     = PKS of P.setter
167 :     | PKP of P.pure
168 :     | PKL of P.looker
169 :     | PKA of P.arith
170 : monnier 16
171 : monnier 69 (* map_primop: AP.primop -> pkind *)
172 :     fun map_primop p =
173 :     (case p
174 :     of AP.TEST(from,to) => PKA (P.test(from, to))
175 :     | AP.TESTU(from,to) => PKA (P.testu(from, to))
176 :     | AP.COPY(from,to) => PKP (P.copy(from,to))
177 :     | AP.EXTEND(from,to) => PKP (P.extend(from, to))
178 :     | AP.TRUNC(from,to) => PKP (P.trunc(from, to))
179 : monnier 16
180 : mblume 1347 | AP.TEST_INF to => PKA (P.test_inf to)
181 :     | AP.TRUNC_INF to => PKP (P.trunc_inf to)
182 :     | AP.COPY_INF from => PKP (P.copy_inf from)
183 :     | AP.EXTEND_INF from => PKP (P.extend_inf from)
184 :    
185 : monnier 69 | AP.ARITH{oper,kind,overflow=true} =>
186 :     PKA(P.arith{oper=arithop oper,kind=numkind kind})
187 :     | AP.ARITH{oper,kind,overflow=false} =>
188 :     PKP(P.pure_arith{oper=arithop oper,kind=numkind kind})
189 :     | AP.ROUND{floor,fromkind,tokind} =>
190 :     PKA(P.round{floor=floor, fromkind=numkind fromkind,
191 :     tokind=numkind tokind})
192 :     | AP.REAL{fromkind,tokind} =>
193 :     PKP(P.real{tokind=numkind tokind, fromkind=numkind fromkind})
194 : monnier 16
195 : monnier 69 | AP.SUBSCRIPTV => PKP (P.subscriptv)
196 :     | AP.MAKEREF => PKP (P.makeref)
197 :     | AP.LENGTH => PKP (P.length)
198 :     | AP.OBJLENGTH => PKP (P.objlength)
199 :     | AP.GETTAG => PKP (P.gettag)
200 :     | AP.MKSPECIAL => PKP (P.mkspecial)
201 : monnier 100 (* | AP.THROW => PKP (P.cast) *)
202 : monnier 69 | AP.CAST => PKP (P.cast)
203 :     | AP.MKETAG => PKP (P.makeref)
204 : monnier 251 | AP.NEW_ARRAY0 => PKP (P.newarray0)
205 :     | AP.GET_SEQ_DATA => PKP (P.getseqdata)
206 :     | AP.SUBSCRIPT_REC => PKP (P.recsubscript)
207 :     | AP.SUBSCRIPT_RAW64 => PKP (P.raw64subscript)
208 : monnier 69
209 :     | AP.SUBSCRIPT => PKL (P.subscript)
210 :     | AP.NUMSUBSCRIPT{kind,immutable=false,checked=false} =>
211 :     PKL(P.numsubscript{kind=numkind kind})
212 :     | AP.NUMSUBSCRIPT{kind,immutable=true,checked=false} =>
213 :     PKP(P.pure_numsubscript{kind=numkind kind})
214 :     | AP.DEREF => PKL(P.!)
215 :     | AP.GETRUNVEC => PKL(P.getrunvec)
216 :     | AP.GETHDLR => PKL(P.gethdlr)
217 :     | AP.GETVAR => PKL(P.getvar)
218 :     | AP.GETPSEUDO => PKL(P.getpseudo)
219 :     | AP.GETSPECIAL =>PKL(P.getspecial)
220 :     | AP.DEFLVAR => PKL(P.deflvar)
221 :    
222 :     | AP.SETHDLR => PKS(P.sethdlr)
223 :     | AP.NUMUPDATE{kind,checked=false} =>
224 :     PKS(P.numupdate{kind=numkind kind})
225 :     | AP.UNBOXEDUPDATE => PKS(P.unboxedupdate)
226 :     | AP.BOXEDUPDATE => PKS(P.boxedupdate)
227 :     | AP.UPDATE => PKS(P.update)
228 : monnier 251 | AP.ASSIGN => PKS(P.assign)
229 :     | AP.UNBOXEDASSIGN => PKS(P.unboxedassign)
230 : monnier 69 | AP.SETVAR => PKS(P.setvar)
231 :     | AP.SETPSEUDO => PKS(P.setpseudo)
232 :     | AP.SETMARK => PKS(P.setmark)
233 :     | AP.DISPOSE => PKS(P.free)
234 :     | AP.SETSPECIAL => PKS(P.setspecial)
235 :     | AP.USELVAR => PKS(P.uselvar)
236 : blume 772
237 :     | AP.RAW_LOAD nk => PKL (P.rawload { kind = numkind nk })
238 :     | AP.RAW_STORE nk => PKS (P.rawstore { kind = numkind nk })
239 : blume 1178 | AP.RAW_RECORD{ fblock = false } => PKP (P.rawrecord (SOME RK_I32BLOCK))
240 :     | AP.RAW_RECORD{ fblock = true } => PKP (P.rawrecord (SOME RK_FBLOCK))
241 : monnier 69
242 :     | _ => bug ("bad primop in map_primop: " ^ (AP.prPrimop p) ^ "\n"))
243 : monnier 16
244 : monnier 69 (***************************************************************************
245 :     * SWITCH OPTIMIZATIONS AND COMPILATIONS *
246 :     ***************************************************************************)
247 :     (*
248 :     * BUG: The defintion of E_word is clearly incorrect since it can raise
249 :     * an overflow at code generation time. A clean solution would be
250 :     * to add a WORD constructor into the CPS language -- daunting! The
251 :     * revolting hack solution would be to put the right int constant
252 :     * that gets converted to the right set of bits for the word constant.
253 : monnier 16 *)
254 : monnier 69 fun do_switch_gen ren = Switch.switch {
255 :     E_int = fn i => if i < ~0x20000000 orelse i >= 0x20000000
256 :     then raise Switch.TooBig else INT i,
257 :     E_word = fn w => (* if w >= 0wx20000000
258 :     then raise Switch.TooBig else *) INT (Word.toIntX w),
259 :     E_real = (fn s => REAL s),
260 : monnier 16 E_switchlimit = 4,
261 : monnier 69 E_neq = P.ineq,
262 : monnier 16 E_w32neq = P.cmp{oper=P.neq,kind=P.UINT 32},
263 :     E_i32neq = P.cmp{oper=P.neq,kind=P.INT 32},
264 :     E_word32 = INT32,
265 : monnier 69 E_int32 = INT32,
266 :     E_wneq = P.cmp{oper=P.neq, kind=P.UINT 31},
267 :     E_pneq = P.pneq,
268 :     E_fneq = P.fneq,
269 :     E_less = P.ilt,
270 :     E_branch = (fn (cmp,x,y,a,b) => BRANCH(cmp,[x,y],mkv(),a,b)),
271 :     E_strneq = (fn (w,str,a,b) => BRANCH(P.strneq, [INT(size str), w,
272 :     STRING str], mkv(), a, b)),
273 :     E_switch = (fn (v,l) => SWITCH(v, mkv(), l)),
274 :     E_add = (fn (x,y,c) =>
275 :     mkfn(fn v => ARITH(P.iadd,[x,y],v,INTt,c(VAR v)))),
276 :     E_gettag = (fn (x,c) => mkfn(fn v => PURE(P.getcon,[x],v,INTt,c(VAR v)))),
277 :     E_unwrap = (fn (x,c) => mkfn(fn v => PURE(P.unwrap,[x],v,INTt,c(VAR v)))),
278 :     E_getexn = (fn (x,c) => mkfn(fn v => PURE(P.getexn,[x],v,BOGt,c(VAR v)))),
279 :     E_length = (fn (x,c) => mkfn(fn v => PURE(P.length,[x],v,INTt,c(VAR v)))),
280 :     E_boxed = (fn (x,a,b) => BRANCH(P.boxed,[x],mkv(),a,b)),
281 :     E_path = (fn (DA.LVAR v, k) => k(ren v)
282 :     | _ => bug "unexpected path in convpath")}
283 : monnier 16
284 :     (***************************************************************************
285 : monnier 69 * UTILITY FUNCTIONS FOR DEALING WITH META-LEVEL CONTINUATIONS *
286 : monnier 16 ***************************************************************************)
287 : monnier 69 (* an abstract representation of the meta-level continuation *)
288 :     datatype mcont = MCONT of {cnt: value list -> cexp, ts: cty list}
289 : monnier 16
290 : monnier 69 (* appmc : mcont * value list -> cexp *)
291 :     fun appmc (MCONT{cnt, ...}, vs) = cnt(vs)
292 : monnier 16
293 : monnier 69 (* makmc : (value list -> cexp) * cty list -> cexp *)
294 :     fun makmc (cnt, ts) = MCONT{cnt=cnt, ts=ts}
295 : monnier 16
296 : monnier 69 (* rttys : mcont -> cty list *)
297 :     fun rttys (MCONT{ts, ...}) = ts
298 : monnier 16
299 :     (***************************************************************************
300 : monnier 69 * THE MAIN FUNCTION *
301 :     * convert : F.prog -> CPS.function *
302 : monnier 16 ***************************************************************************)
303 : monnier 69 fun convert fdec =
304 : monnier 216 let val {getLty=getlty, cleanUp, ...} = Recover.recover (fdec, true)
305 : monnier 69 val ctypes = map ctype
306 :     fun res_ctys f =
307 :     let val lt = getlty (F.VAR f)
308 :     in if LT.ltp_fct lt then ctypes (#2(LT.ltd_fct lt))
309 :     else if LT.ltp_arrow lt then ctypes (#3(LT.ltd_arrow lt))
310 :     else [BOGt]
311 : monnier 16 end
312 : monnier 69 fun get_cty v = ctype (getlty v)
313 :     fun is_float_record u =
314 :     LT.ltw_tyc (getlty u,
315 :     fn tc => LT.tcw_tuple (tc, fn l => all_float (map ctyc l),
316 :     fn _ => false),
317 :     fn _ => false)
318 : monnier 16
319 : monnier 69 val bogus_cont = mkv()
320 :     fun bogus_header ce =
321 :     let val bogus_knownf = mkv()
322 :     in FIX([(KNOWN, bogus_knownf, [mkv()], [BOGt],
323 :     APP(VAR bogus_knownf, [STRING "bogus"]))],
324 :     FIX([(CONT, bogus_cont, [mkv()], [BOGt],
325 :     APP(VAR bogus_knownf, [STRING "bogus"]))], ce))
326 :     end
327 : monnier 16
328 : monnier 69 local exception Rename
329 : blume 733 val m : value IntHashTable.hash_table =
330 :     IntHashTable.mkTable(32, Rename)
331 : monnier 69 in
332 :     (* F.lvar -> CPS.value *)
333 : blume 733 fun rename v = IntHashTable.lookup m v handle Rename => VAR v
334 : monnier 16
335 : monnier 69 (* F.lvar * CPS.value -> unit *)
336 :     fun newname (v, w) =
337 :     (case w of VAR w' => LV.sameName (v, w') | _ => ();
338 : blume 733 IntHashTable.insert m (v, w))
339 : monnier 16
340 : monnier 69 (* F.lvar list * CPS.value list -> unit *)
341 :     fun newnames (v::vs, w::ws) = (newname(v,w); newnames(vs, ws))
342 :     | newnames ([], []) = ()
343 :     | newnames _ = bug "unexpected case in newnames"
344 : monnier 191
345 :     (* isEta : cexp * value list -> value option *)
346 :     fun isEta (APP(w as VAR lv, vl), ul) =
347 :     (* If the function is in the global renaming table and it's
348 :     * renamed to itself, then it's most likely a while loop and
349 :     * should *not* be eta-reduced *)
350 : blume 733 if ((case IntHashTable.lookup m lv of
351 :     VAR lv' => lv = lv'
352 :     | _ => false)
353 :     handle Rename => false) then NONE else
354 : monnier 191 let fun h (x::xs, y::ys) =
355 :     if (veq(x, y)) andalso (not (veq(w, y)))
356 :     then h(xs, ys) else NONE
357 :     | h ([], []) = SOME w
358 :     | h _ = NONE
359 :     in h(ul, vl)
360 :     end
361 :     | isEta _ = NONE
362 :    
363 : monnier 69 end (* local of Rename *)
364 : monnier 16
365 : monnier 191 (* preventEta : mcont -> (cexp -> cexp) * value *)
366 :     fun preventEta (MCONT{cnt=c, ts=ts}) =
367 :     let val vl = map mkv ts
368 :     val ul = map VAR vl
369 :     val b = c ul
370 :     in case isEta(b, ul)
371 :     of SOME w => (ident, w)
372 :     | NONE => let val f = mkv()
373 :     in (fn x => FIX([(CONT,f,vl,ts,b)],x), VAR f)
374 :     end
375 :     end (* function preventEta *)
376 :    
377 : monnier 69 (* switch optimization *)
378 :     val do_switch = do_switch_gen rename
379 : monnier 16
380 : monnier 69 (* lpvar : F.value -> value *)
381 :     fun lpvar (F.VAR v) = rename v
382 :     | lpvar (F.INT32 i) =
383 :     let val int32ToWord32 = Word32.fromLargeInt o Int32.toLarge
384 :     in INT32 (int32ToWord32 i)
385 :     end
386 :     | lpvar (F.WORD32 w) = INT32 w
387 :     | lpvar (F.INT i) = INT i
388 :     | lpvar (F.WORD w) = INT(Word.toIntX w)
389 :     | lpvar (F.REAL r) = REAL r
390 :     | lpvar (F.STRING s) = STRING s
391 :    
392 :    
393 :     (* lpvars : F.value list -> value list *)
394 :     fun lpvars vl =
395 :     let fun h([], z) = rev z
396 :     | h(a::r, z) = h(r, (lpvar a)::z)
397 :     in h(vl, [])
398 : monnier 16 end
399 : monnier 69
400 :     (* loop : F.lexp * (value list -> cexp) -> cexp *)
401 : monnier 191 fun loop' m (le, c) = let val loop = loop' m
402 :     in case le
403 : monnier 69 of F.RET vs => appmc(c, lpvars vs)
404 :     | F.LET(vs, e1, e2) =>
405 :     let val kont =
406 :     makmc (fn ws => (newnames(vs, ws); loop(e2, c)),
407 :     map (get_cty o F.VAR) vs)
408 :     in loop(e1, kont)
409 :     end
410 :    
411 : monnier 191 | F.FIX(fds, e) =>
412 :     (* lpfd : F.fundec -> function *)
413 :     let fun lpfd ((fk, f, vts, e) : F.fundec) =
414 :     let val k = mkv()
415 :     val cl = CNTt::(map (ctype o #2) vts)
416 :     val kont = makmc (fn vs => APP(VAR k, vs), res_ctys f)
417 :     val (vl,body) =
418 :     case fk
419 : monnier 199 of {isrec=SOME(_,F.LK_TAIL),...} => let
420 : monnier 191 (* for tail recursive loops, we create a
421 :     * local function that takes its continuation
422 :     * from the environment *)
423 :     val f' = cplv f
424 :     (* here we add a dumb entry for f' in the
425 :     * global renaming table just so that isEta
426 :     * can avoid eta-reducing it *)
427 :     val _ = newname(f', VAR f')
428 :     val vl = k::(map (cplv o #1) vts)
429 :     val vl' = map #1 vts
430 :     val cl' = map (ctype o #2) vts
431 :     in
432 :     (vl,
433 :     FIX([(KNOWN_TAIL, f', vl', cl',
434 :     (* add the function to the tail map *)
435 : monnier 423 loop' (M.insert(m,f,f')) (e, kont))],
436 : monnier 191 APP(VAR f', map VAR (tl vl))))
437 :     end
438 :     | _ => (k::(map #1 vts), loop(e, kont))
439 :     in (ESCAPE, f, vl, cl, body)
440 :     end
441 :     in FIX(map lpfd fds, loop(e, c))
442 :     end
443 :     | F.APP(f as F.VAR lv, vs) =>
444 :     (* first check if it's a recursive call to a tail loop *)
445 : monnier 423 (case M.find(m, lv)
446 :     of SOME f' => APP(VAR f', lpvars vs)
447 :     | NONE =>
448 :     (* code for the non-tail case.
449 :     * Sadly this is *not* exceptional *)
450 :     let val (hdr, F) = preventEta c
451 :     val vf = lpvar f
452 :     val ul = lpvars vs
453 :     in hdr(APP(vf, F::ul))
454 :     end)
455 : monnier 191 | F.APP _ => bug "unexpected APP in convert"
456 : monnier 69
457 :     | (F.TFN _ | F.TAPP _) =>
458 :     bug "unexpected TFN and TAPP in convert"
459 :    
460 :     | F.RECORD(F.RK_VECTOR _, [], v, e) =>
461 :     bug "zero length vectors in convert"
462 :     | F.RECORD(rk, [], v, e) =>
463 :     let val _ = newname(v, INT 0)
464 :     in loop(e, c)
465 :     end
466 :     | F.RECORD(rk, vl, v, e) =>
467 :     let val ts = map get_cty vl
468 :     val nvl = lpvars vl
469 :     val ce = loop(e, c)
470 :     in case rk
471 :     of F.RK_TUPLE _ =>
472 :     if (all_float ts) then recordFL(nvl, ts, v, ce)
473 :     else recordNM(nvl, ts, v, ce)
474 :     | F.RK_VECTOR _ =>
475 :     RECORD(RK_VECTOR, map (fn x => (x, OFFp0)) nvl, v, ce)
476 :     | _ => recordNM(nvl, ts, v, ce)
477 :     end
478 :     | F.SELECT(u, i, v, e) =>
479 :     let val ct = get_cty (F.VAR v)
480 :     val nu = lpvar u
481 :     val ce = loop(e, c)
482 :     in if is_float_record u then selectFL(i, nu, v, ct, ce)
483 :     else selectNM(i, nu, v, ct, ce)
484 :     end
485 :    
486 :     | F.SWITCH(e,l,[a as (F.DATAcon((_,DA.CONSTANT 0,_),_,_),_),
487 :     b as (F.DATAcon((_,DA.CONSTANT 1,_),_,_),_)],
488 :     NONE) =>
489 :     loop(F.SWITCH(e,l,[b,a],NONE),c)
490 :     | F.SWITCH (u, sign, l, d) =>
491 :     let val (header,F) = preventEta c
492 :     val kont = makmc(fn vl => APP(F, vl), rttys c)
493 :     val body =
494 :     let val df = mkv()
495 :     fun proc (cn as (F.DATAcon(dc, _, v)), e) =
496 :     (cn, loop (F.LET([v], F.RET [u], e), kont))
497 :     | proc (cn, e) = (cn, loop(e, kont))
498 :     val b = do_switch{sign=sign, exp=lpvar u,
499 :     cases=map proc l,
500 :     default=APP(VAR df, [INT 0])}
501 :     in case d
502 :     of NONE => b
503 :     | SOME de => FIX([(CONT, df, [mkv()], [INTt],
504 :     loop(de, kont))], b)
505 :     end
506 :     in header(body)
507 :     end
508 :     | F.CON(dc, ts, u, v, e) =>
509 :     bug "unexpected case CON in cps convert"
510 :    
511 :     | F.RAISE(u, lts) =>
512 :     let (* execute the continuation for side effects *)
513 :     val _ = appmc(c, (map (fn _ => VAR(mkv())) lts))
514 :     val h = mkv()
515 :     in LOOKER(P.gethdlr, [], h, FUNt,
516 :     APP(VAR h,[VAR bogus_cont,lpvar u]))
517 :     end
518 :     | F.HANDLE(e,u) => (* recover type from u *)
519 :     let val (hdr, F) = preventEta c
520 :     val h = mkv()
521 :     val kont =
522 :     makmc (fn vl =>
523 :     SETTER(P.sethdlr, [VAR h], APP(F, vl)),
524 :     rttys c)
525 :     val body =
526 :     let val k = mkv() and v = mkv()
527 :     in FIX([(ESCAPE, k, [mkv(), v], [CNTt, BOGt],
528 :     SETTER(P.sethdlr, [VAR h],
529 :     APP(lpvar u, [F, VAR v])))],
530 :     SETTER(P.sethdlr, [VAR k], loop(e, kont)))
531 :     end
532 :     in LOOKER(P.gethdlr, [], h, FUNt, hdr(body))
533 :     end
534 :    
535 :     | F.PRIMOP((_,p as (AP.CALLCC | AP.CAPTURE),_,_), [f], v, e) =>
536 :     let val (kont_decs, F) =
537 :     let val k = mkv()
538 :     val ct = get_cty f
539 :     in ([(CONT, k, [v], [ct], loop(e, c))], VAR k)
540 :     end
541 :    
542 :     val (hdr1,hdr2) =
543 :     (case p
544 :     of AP.CALLCC =>
545 :     mkfn(fn h =>
546 :     (fn e => SETTER(P.sethdlr, [VAR h], e),
547 :     fn e => LOOKER(P.gethdlr, [], h, BOGt, e)))
548 :     | _ => (ident, ident))
549 :    
550 :     val (ccont_decs, ccont_var) =
551 :     let val k = mkv() (* captured continuation *)
552 :     val x = mkv()
553 :     in ([(ESCAPE, k, [mkv(), x], [CNTt, BOGt],
554 :     hdr1(APP(F, [VAR x])))], k)
555 :     end
556 :     in FIX(kont_decs,
557 :     hdr2(FIX(ccont_decs,
558 :     APP(lpvar f, [F, VAR ccont_var]))))
559 :     end
560 :    
561 :     | F.PRIMOP((_,AP.ISOLATE,lt,ts), [f], v, e) =>
562 :     let val (exndecs, exnvar) =
563 :     let val h = mkv() and z = mkv() and x = mkv()
564 :     in ([(ESCAPE, h, [z, x], [CNTt, BOGt],
565 :     APP(VAR bogus_cont, [VAR x]))], h)
566 :     end
567 :     val newfdecs =
568 :     let val nf = v and z = mkv() and x = mkv()
569 :     in [(ESCAPE, v, [z, x], [CNTt, BOGt],
570 :     SETTER(P.sethdlr, [VAR exnvar],
571 :     APP(lpvar f, [VAR bogus_cont, VAR x])))]
572 :     end
573 :     in FIX(exndecs, FIX(newfdecs, loop(e, c)))
574 :     end
575 : monnier 16
576 : monnier 100 | F.PRIMOP(po as (_,AP.THROW,_,_), [u], v, e) =>
577 :     (newname(v, lpvar u); loop(e, c))
578 :     (* PURE(P.wrap, [lpvar u], v, FUNt, c(VAR v)) *)
579 :    
580 : monnier 69 | F.PRIMOP(po as (_,AP.WCAST,_,_), [u], v, e) =>
581 :     (newname(v, lpvar u); loop(e, c))
582 :    
583 :     | F.PRIMOP(po as (_,AP.WRAP,_,_), [u], v, e) =>
584 :     let val ct = ctyc(FU.getWrapTyc po)
585 :     in PURE(primwrap ct, [lpvar u], v, BOGt, loop(e, c))
586 :     end
587 :     | F.PRIMOP(po as (_,AP.UNWRAP,_,_), [u], v, e) =>
588 :     let val ct = ctyc(FU.getUnWrapTyc po)
589 :     in PURE(primunwrap ct, [lpvar u], v, ct, loop(e, c))
590 :     end
591 :    
592 :     | F.PRIMOP(po as (_,AP.MARKEXN,_,_), [x,m], v, e) =>
593 :     let val bty = LT.ltc_void
594 :     val ety = LT.ltc_tuple[bty,bty,bty]
595 :     val (xx,x0,x1,x2) = (mkv(),mkv(),mkv(),mkv())
596 :     val (y,z,z') = (mkv(),mkv(),mkv())
597 :     in PURE(P.unwrap,[lpvar x],xx,ctype(ety),
598 :     SELECT(0,VAR xx,x0,BOGt,
599 :     SELECT(1,VAR xx,x1,BOGt,
600 :     SELECT(2,VAR xx,x2,BOGt,
601 :     RECORD(RK_RECORD,[(lpvar m, OFFp0),
602 :     (VAR x2, OFFp0)], z,
603 :     PURE(P.wrap,[VAR z],z',BOGt,
604 :     RECORD(RK_RECORD,[(VAR x0,OFFp0),
605 :     (VAR x1,OFFp0),
606 :     (VAR z', OFFp0)],
607 :     y,
608 :     PURE(P.wrap,[VAR y],v,BOGt,
609 :     loop(e,c)))))))))
610 :     end
611 : blume 773
612 : leunga 1174 | F.PRIMOP ((_,AP.RAW_CCALL NONE,_,_), _::_::a::_,v,e) =>
613 : blume 773 (* code generated here should never be executed anyway,
614 :     * so we just fake it... *)
615 :     (print "*** pro-forma raw-ccall\n";
616 :     newname (v, lpvar a); loop(e,c))
617 :    
618 : leunga 1174 | F.PRIMOP ((_,AP.RAW_CCALL (SOME i),lt,ts),f::a::_::_,v,e) => let
619 :     val { c_proto = p, ml_args, ml_res_opt, reentrant } = i
620 : blume 1178 fun cty AP.CCR64 = FLTt
621 :     | cty AP.CCI32 = INT32t
622 :     | cty AP.CCML = BOGt
623 :     | cty AP.CCI64 = bug "CCI64 calling convention unimplemented"
624 : blume 773 val a' = lpvar a
625 : leunga 1174 val rcckind = if reentrant then REENTRANT_RCC else FAST_RCC
626 : blume 774 fun rcc args = let
627 : leunga 1174 val al = map VAR args
628 :     val (al,linkage) =
629 :     case f of
630 :     F.STRING linkage => (al, linkage)
631 :     | _ => (lpvar f :: al, "")
632 :     in case ml_res_opt of
633 :     NONE => RCC (rcckind, linkage,
634 :     p, al, v, INTt, loop (e, c))
635 : blume 774 | SOME rt => let
636 :     val v' = mkv ()
637 :     val res_cty = cty rt
638 :     in
639 : leunga 1174 RCC (rcckind, linkage, p, al, v', res_cty,
640 : blume 774 PURE(primwrap res_cty, [VAR v'], v, BOGt,
641 :     loop (e, c)))
642 :     end
643 :     end
644 : blume 777 val sel = if is_float_record a then selectFL else selectNM
645 : blume 773 fun build ([], rvl, _) = rcc (rev rvl)
646 :     | build (ft :: ftl, rvl, i) = let
647 :     val t = cty ft
648 :     val v = mkv ()
649 :     in
650 : blume 777 sel (i, a', v, t, build (ftl, v :: rvl, i + 1))
651 : blume 773 end
652 :     in
653 : leunga 1174 case ml_args of
654 : blume 773 [ft] => let
655 :     (* if there is precisely one arg, then it will not
656 :     * come packaged into a record *)
657 :     val t = cty ft
658 :     val v = mkv ()
659 :     in
660 :     PURE (primunwrap t, [a'], v, t, rcc [v])
661 :     end
662 : leunga 1174 | _ => build (ml_args, [], 0)
663 : blume 773 end
664 :    
665 :     | F.PRIMOP ((_,AP.RAW_CCALL _,_,_),_,_,_) => bug "bad raw_ccall"
666 :    
667 : leunga 1174 | F.PRIMOP ((_,AP.RAW_RECORD _,_,_),[x as F.VAR _],v,e) =>
668 :     (* code generated here should never be executed anyway,
669 :     * so we just fake it... *)
670 :     (print "*** pro-forma raw-record\n";
671 :     newname (v, lpvar x); loop(e,c))
672 :    
673 : monnier 69 | F.PRIMOP(po as (_,p,lt,ts), ul, v, e) =>
674 :     let val ct =
675 :     case (#3(LT.ltd_arrow(LT.lt_pinst (lt, ts))))
676 :     of [x] => ctype x
677 :     | _ => bug "unexpected case in F.PRIMOP"
678 :     val vl = lpvars ul
679 :     in case map_primop p
680 :     of PKS i => let val _ = newname(v, INT 0)
681 :     in SETTER(i, vl, loop(e,c))
682 :     end
683 :     | PKA i => ARITH(i, vl, v, ct, loop(e,c))
684 :     | PKL i => LOOKER(i, vl, v, ct, loop(e,c))
685 :     | PKP i => PURE(i, vl, v, ct, loop(e,c))
686 :     end
687 :    
688 :     | F.BRANCH(po as (_,p,_,_), ul, e1, e2) =>
689 :     let val (hdr, F) = preventEta c
690 :     val kont = makmc(fn vl => APP(F, vl), rttys c)
691 :     in hdr(BRANCH(map_branch p, lpvars ul, mkv(),
692 :     loop(e1, kont), loop(e2, kont)))
693 : monnier 191 end
694 :     end
695 : monnier 69
696 :     (* processing the top-level fundec *)
697 :     val (fk, f, vts, be) = fdec
698 :     val k = mkv() (* top-level return continuation *)
699 :     val kont = makmc (fn vs => APP(VAR k, vs), res_ctys f)
700 : monnier 191 val body = loop' M.empty (be, kont)
701 : monnier 16
702 : monnier 69 val vl = k::(map #1 vts)
703 :     val cl = CNTt::(map (ctype o #2) vts)
704 :     in (ESCAPE, f, vl, cl, bogus_header body) before cleanUp()
705 :     end (* function convert *)
706 : monnier 16
707 :     end (* toplevel local *)
708 :     end (* functor Convert *)
709 :    

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