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

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

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