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/branches/arith64/compiler/FLINT/cps/convert.sml
ViewVC logotype

Annotation of /sml/branches/arith64/compiler/FLINT/cps/convert.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4874 - (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 4560 (* integer types/values *)
44 :     local
45 :     val tt = {sz = Target.defaultIntSz, tag = true}
46 :     fun bt sz = {sz = sz, tag = false}
47 :     in
48 :     val tagIntTy = NUMt tt
49 :     fun tagInt n = NUM{ival = n, ty = tt}
50 :     fun tagInt' n = tagInt(IntInf.fromInt n)
51 :     fun boxIntTy sz = NUMt(bt sz)
52 :     fun boxInt (sz, i) = NUM{ival = i, ty = bt sz}
53 :     end
54 :    
55 : jhr 4535 (* testing if two values are equivalent lvar values *)
56 :     fun veq (VAR x, VAR y) = (x = y)
57 :     | veq _ = false
58 : monnier 16
59 : jhr 4535 local
60 :     structure PCT = PrimCTypes
61 :     structure CT = CTypes
62 :     in
63 :     (* convert PrimCTypes.c_proto to MLRISC's CTypes.c_proto *)
64 :     fun cvtCProto {conv, retTy, paramTys} : CTypes.c_proto = let
65 :     fun cvtIntTy PCT.I_char = CT.I_char
66 :     | cvtIntTy PCT.I_short = CT.I_short
67 :     | cvtIntTy PCT.I_int = CT.I_int
68 :     | cvtIntTy PCT.I_long = CT.I_long
69 :     | cvtIntTy PCT.I_long_long = CT.I_long_long
70 :     fun cvtTy PCT.C_void = CT.C_void
71 :     | cvtTy PCT.C_float = CT.C_float
72 :     | cvtTy PCT.C_double = CT.C_double
73 :     | cvtTy PCT.C_long_double = CT.C_long_double
74 :     | cvtTy (PCT.C_unsigned ity) = CT.C_unsigned(cvtIntTy ity)
75 :     | cvtTy (PCT.C_signed ity) = CT.C_signed(cvtIntTy ity)
76 :     | cvtTy PCT.C_PTR = CT.C_PTR
77 :     | cvtTy (PCT.C_ARRAY(ty, n)) = CT.C_ARRAY(cvtTy ty, n)
78 :     | cvtTy (PCT.C_STRUCT tys) = CT.C_STRUCT(List.map cvtTy tys)
79 :     | cvtTy (PCT.C_UNION tys) = CT.C_UNION(List.map cvtTy tys)
80 :     in
81 :     {conv = conv, retTy = cvtTy retTy, paramTys = List.map cvtTy paramTys}
82 :     end
83 :     end (* local *)
84 : monnier 16
85 : jhr 4535 (***************************************************************************
86 :     * CONSTANTS AND UTILITY FUNCTIONS *
87 :     ***************************************************************************)
88 : monnier 16
89 : jhr 4874 fun unwrapFlt (sz, u, x, ce) = PURE(P.unwrap(P.FLOAT sz), [u], x, FLTt sz, ce)
90 :     fun unwrapInt (sz, u, x, ce) = PURE(P.unwrap(P.INT sz), [u], x, boxIntTy sz, ce)
91 :     fun wrapFlt (sz, u, x, ce) = PURE(P.wrap(P.FLOAT sz), [u], x, BOGt, ce)
92 :     fun wrapInt (sz, u, x, ce) = PURE(P.wrap(P.INT sz), [u], x, BOGt, ce)
93 : monnier 16
94 : jhr 4535 fun all_float (FLTt _::r) = all_float r
95 :     | all_float (_::r) = false
96 :     | all_float [] = true
97 : monnier 69
98 : jhr 4535 fun selectFL(i,u,x,ct,ce) = SELECT(i,u,x,ct,ce)
99 : monnier 69
100 : jhr 4535 fun selectNM(i,u,x,ct,ce) = (case ct
101 : jhr 4874 of FLTt sz => mkfn(fn v => SELECT(i, u, v, BOGt, unwrapFlt(sz, VAR v, x, ce)))
102 :     | NUMt{sz, tag=false} =>
103 :     mkfn(fn v => SELECT(i, u, v, BOGt, unwrapInt(sz, VAR v, x, ce)))
104 :     | _ => SELECT(i, u, x, ct, ce)
105 : jhr 4535 (* end case *))
106 : monnier 69
107 : jhr 4535 fun recordFL(ul,_,w,ce) =
108 :     RECORD(RK_FBLOCK, map (fn u => (u,OFFp 0)) ul, w, ce)
109 : monnier 69
110 : jhr 4535 fun recordNM(ul,ts,w,ce) =
111 : jhr 4874 let fun g (FLTt sz::r,u::z,l,h) =
112 :     mkfn(fn v => g(r, z, (VAR v,OFFp 0)::l, fn ce => h(wrapFlt(sz, u, v, ce))))
113 :     | g (NUMt{sz, tag=false}::r,u::z,l,h) =
114 :     mkfn(fn v => g(r, z, (VAR v,OFFp 0)::l, fn ce => h(wrapInt(sz, u, v, ce))))
115 : jhr 4669 | g (NUMt{tag=false, sz} ::_, _, _, _) =
116 :     raise Fail("unsupported NUMt size = " ^ Int.toString sz) (* 64BIT: FIXME *)
117 : jhr 4535 | g (_::r,u::z,l,h) = g(r, z, (u,OFFp0)::l, h)
118 :     | g ([],[],l,h) = (rev l, h)
119 :     | g _ = bug "unexpected in recordNM in convert"
120 : monnier 16
121 : jhr 4535 val (nul,header) = g(ts,ul,[],fn x => x)
122 :     in header(RECORD(RK_RECORD,nul,w,ce))
123 :     end
124 : monnier 16
125 : jhr 4535 (***************************************************************************
126 :     * UTILITY FUNCTIONS FOR PROCESSING THE PRIMOPS *
127 :     ***************************************************************************)
128 : monnier 16
129 : jhr 4535 (* numkind: AP.numkind -> P.numkind *)
130 :     fun numkind (AP.INT bits) = P.INT bits
131 :     | numkind (AP.UINT bits) = P.UINT bits
132 :     | numkind (AP.FLOAT bits) = P.FLOAT bits
133 : monnier 69
134 : jhr 4535 (* cmpop: {oper: AP.cmpop, kind: AP.numkind} -> P.branch *)
135 : jhr 4561 fun cmpop stuff = (case stuff
136 :     of {oper=AP.EQL,kind=AP.INT 31} => P.ieql
137 :     | {oper=AP.NEQ,kind=AP.INT 31} => P.ineq
138 :     | {oper,kind=AP.FLOAT size} => let
139 :     val rator = (case oper
140 :     of AP.GT => P.fGT
141 :     | AP.GTE => P.fGE
142 :     | AP.LT => P.fLT
143 :     | AP.LTE => P.fLE
144 :     | AP.EQL => P.fEQ
145 :     | AP.NEQ => P.fULG
146 :     | AP.FSGN => P.fsgn
147 :     | _ => bug "cmpop:kind=AP.FLOAT"
148 :     (* end case *))
149 :     in
150 :     P.fcmp{oper= rator, size=size}
151 :     end
152 :     | {oper, kind} => let
153 :     fun check (_, AP.UINT _) = ()
154 :     | check (oper, _) = bug ("check" ^ oper)
155 :     fun c AP.GT = P.>
156 :     | c AP.GTE = P.>=
157 :     | c AP.LT = P.<
158 :     | c AP.LTE = P.<=
159 :     | c AP.LEU = (check ("leu", kind); P.<= )
160 :     | c AP.LTU = (check ("ltu", kind); P.< )
161 :     | c AP.GEU = (check ("geu", kind); P.>= )
162 :     | c AP.GTU = (check ("gtu", kind); P.> )
163 :     | c AP.EQL = P.eql
164 :     | c AP.NEQ = P.neq
165 :     | c AP.FSGN = bug "cmpop:kind=AP.UINT"
166 :     in
167 :     P.cmp{oper=c oper, kind=numkind kind}
168 :     end
169 :     (* end case *))
170 : jhr 4535
171 :     (* map_branch: AP.primop -> P.branch *)
172 :     fun map_branch p = (case p
173 :     of AP.BOXED => P.boxed
174 :     | AP.UNBOXED => P.unboxed
175 :     | AP.CMP stuff => cmpop stuff
176 :     | AP.PTREQL => P.peql
177 :     | AP.PTRNEQ => P.pneq
178 :     | _ => bug "unexpected primops in map_branch"
179 :     (* end case *))
180 :    
181 :     (* primwrap: cty -> P.pure *)
182 : jhr 4874 fun primwrap (NUMt{sz, ...}) = P.wrap(P.INT sz)
183 :     | primwrap (FLTt sz) = P.wrap(P.FLOAT sz)
184 :     | primwrap _ = P.box
185 : jhr 4454
186 : jhr 4535 (* primunwrap: cty -> P.pure *)
187 : jhr 4874 fun primunwrap (NUMt{sz, ...}) = P.unwrap(P.INT sz)
188 :     | primunwrap (FLTt sz) = P.unwrap(P.FLOAT sz)
189 :     | primunwrap _ = P.unbox
190 : monnier 69
191 : jhr 4535 (* arithop: AP.arithop -> P.arithop *)
192 :     fun arithop AP.NEG = P.~
193 :     | arithop AP.ABS = P.abs
194 :     | arithop AP.FSQRT = P.fsqrt
195 :     | arithop AP.FSIN = P.fsin
196 :     | arithop AP.FCOS = P.fcos
197 :     | arithop AP.FTAN = P.ftan
198 :     | arithop AP.NOTB = P.notb
199 :     | arithop AP.QUOT = P./
200 :     | arithop AP.REM = P.rem
201 :     | arithop AP.DIV = P.div
202 :     | arithop AP.MOD = P.mod
203 :     | arithop AP.ADD = P.+
204 :     | arithop AP.SUB = P.-
205 :     | arithop AP.MUL = P.*
206 :     | arithop AP.FDIV = P./
207 :     | arithop AP.LSHIFT = P.lshift
208 :     | arithop AP.RSHIFT = P.rshift
209 :     | arithop AP.RSHIFTL = P.rshiftl
210 :     | arithop AP.ANDB = P.andb
211 :     | arithop AP.ORB = P.orb
212 :     | arithop AP.XORB = P.xorb
213 : monnier 16
214 : jhr 4535 (* a temporary classifier of various kinds of CPS primops *)
215 :     datatype pkind
216 :     = PKS of P.setter
217 :     | PKP of P.pure
218 :     | PKL of P.looker
219 :     | PKA of P.arith
220 : monnier 16
221 : jhr 4535 (* map_primop: AP.primop -> pkind *)
222 : jhr 4561 fun map_primop p = (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 4561 | 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 4561 | 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 4561 | 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 4561 | 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 4561 | 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 4561 | 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 4561 | _ => bug ("bad primop in map_primop: " ^ (AP.prPrimop p) ^ "\n")
288 :     (* end case *))
289 : monnier 16
290 : jhr 4535 (***************************************************************************
291 :     * SWITCH OPTIMIZATIONS AND COMPILATIONS *
292 :     ***************************************************************************)
293 : monnier 16
294 : jhr 4795 fun switchGen rename = Switch.switch { rename = rename }
295 : monnier 16
296 : jhr 4535 (***************************************************************************
297 :     * UTILITY FUNCTIONS FOR DEALING WITH META-LEVEL CONTINUATIONS *
298 :     ***************************************************************************)
299 :     (* an abstract representation of the meta-level continuation *)
300 :     datatype mcont = MCONT of {cnt: value list -> cexp, ts: cty list}
301 : monnier 16
302 : jhr 4535 (* appmc : mcont * value list -> cexp *)
303 :     fun appmc (MCONT{cnt, ...}, vs) = cnt(vs)
304 : monnier 16
305 : jhr 4535 (* makmc : (value list -> cexp) * cty list -> cexp *)
306 :     fun makmc (cnt, ts) = MCONT{cnt=cnt, ts=ts}
307 : monnier 16
308 : jhr 4535 (* rttys : mcont -> cty list *)
309 :     fun rttys (MCONT{ts, ...}) = ts
310 : monnier 16
311 : jhr 4535 (***************************************************************************
312 :     * THE MAIN FUNCTION *
313 :     * convert : F.prog -> CPS.function *
314 :     ***************************************************************************)
315 :     fun convert fdec =
316 :     let val {getLty=getlty, cleanUp, ...} = Recover.recover (fdec, true)
317 :     val ctypes = map ctype
318 :     fun res_ctys f =
319 :     let val lt = getlty (F.VAR f)
320 :     in if LT.ltp_fct lt then ctypes (#2(LT.ltd_fct lt))
321 :     else if LT.ltp_arrow lt then ctypes (#3(LT.ltd_arrow lt))
322 :     else [BOGt]
323 :     end
324 :     fun get_cty v = ctype (getlty v)
325 :     fun is_float_record u =
326 :     LT.ltw_tyc (getlty u,
327 :     fn tc => LT.tcw_tuple (tc, fn l => all_float (map ctyc l),
328 :     fn _ => false),
329 :     fn _ => false)
330 : monnier 16
331 : jhr 4535 val bogus_cont = mkv()
332 :     fun bogus_header ce =
333 :     let val bogus_knownf = mkv()
334 :     in FIX([(KNOWN, bogus_knownf, [mkv()], [BOGt],
335 :     APP(VAR bogus_knownf, [STRING "bogus"]))],
336 :     FIX([(CONT, bogus_cont, [mkv()], [BOGt],
337 :     APP(VAR bogus_knownf, [STRING "bogus"]))], ce))
338 :     end
339 : monnier 16
340 : jhr 4535 local exception Rename
341 :     val m : value IntHashTable.hash_table =
342 :     IntHashTable.mkTable(32, Rename)
343 :     in
344 :     (* F.lvar -> CPS.value *)
345 :     fun rename v = IntHashTable.lookup m v handle Rename => VAR v
346 : monnier 16
347 : jhr 4535 (* F.lvar * CPS.value -> unit *)
348 :     fun newname (v, w) =
349 :     (case w of VAR w' => LV.sameName (v, w') | _ => ();
350 :     IntHashTable.insert m (v, w))
351 : monnier 191
352 : jhr 4535 (* F.lvar list * CPS.value list -> unit *)
353 :     fun newnames (v::vs, w::ws) = (newname(v,w); newnames(vs, ws))
354 :     | newnames ([], []) = ()
355 :     | newnames _ = bug "unexpected case in newnames"
356 : monnier 191
357 : jhr 4535 (* isEta : cexp * value list -> value option *)
358 :     fun isEta (APP(w as VAR lv, vl), ul) =
359 :     (* If the function is in the global renaming table and it's
360 :     * renamed to itself, then it's most likely a while loop and
361 :     * should *not* be eta-reduced *)
362 :     if ((case IntHashTable.lookup m lv of
363 :     VAR lv' => lv = lv'
364 :     | _ => false)
365 :     handle Rename => false) then NONE else
366 :     let fun h (x::xs, y::ys) =
367 :     if (veq(x, y)) andalso (not (veq(w, y)))
368 :     then h(xs, ys) else NONE
369 :     | h ([], []) = SOME w
370 :     | h _ = NONE
371 :     in h(ul, vl)
372 :     end
373 :     | isEta _ = NONE
374 : monnier 16
375 : jhr 4535 end (* local of Rename *)
376 : monnier 191
377 : jhr 4535 (* preventEta : mcont -> (cexp -> cexp) * value *)
378 :     fun preventEta (MCONT{cnt=c, ts=ts}) =
379 :     let val vl = map mkv ts
380 :     val ul = map VAR vl
381 :     val b = c ul
382 :     in case isEta(b, ul)
383 :     of SOME w => (ident, w)
384 :     | NONE => let val f = mkv()
385 :     in (fn x => FIX([(CONT,f,vl,ts,b)],x), VAR f)
386 :     end
387 :     end (* function preventEta *)
388 : monnier 16
389 : jhr 4535 (* switch optimization *)
390 : jhr 4795 val switch = switchGen rename
391 : jhr 4446
392 : jhr 4535 (* lpvar : F.value -> value *)
393 :     fun lpvar (F.VAR v) = rename v
394 : jhr 4560 | lpvar (F.INT{ival, ty=32}) = boxInt(32, ival)
395 :     | lpvar (F.WORD{ival, ty=32}) = boxInt(32, ival)
396 :     | lpvar (F.INT{ival, ty=31}) = tagInt ival
397 :     | lpvar (F.WORD{ival, ty=31}) = tagInt ival
398 : jhr 4535 | lpvar (F.REAL r) = REAL r
399 :     | lpvar (F.STRING s) = STRING s
400 : jhr 4561 | lpvar v = bug(concat["lpvar (", PPFlint.toStringValue v, ")"])
401 : jhr 4446
402 : jhr 4535 (* lpvars : F.value list -> value list *)
403 :     fun lpvars vl =
404 :     let fun h([], z) = rev z
405 :     | h(a::r, z) = h(r, (lpvar a)::z)
406 :     in h(vl, [])
407 :     end
408 : jhr 4446
409 : jhr 4535 (* loop : F.lexp * (value list -> cexp) -> cexp *)
410 :     fun loop' m (le, c) = let val loop = loop' m
411 :     in case le
412 :     of F.RET vs => appmc(c, lpvars vs)
413 :     | F.LET(vs, e1, e2) =>
414 :     let val kont =
415 :     makmc (fn ws => (newnames(vs, ws); loop(e2, c)),
416 :     map (get_cty o F.VAR) vs)
417 :     in loop(e1, kont)
418 :     end
419 : jhr 4446
420 : jhr 4535 | F.FIX(fds, e) =>
421 :     (* lpfd : F.fundec -> function *)
422 :     let fun lpfd ((fk, f, vts, e) : F.fundec) =
423 :     let val k = mkv()
424 :     val cl = CNTt::(map (ctype o #2) vts)
425 :     val kont = makmc (fn vs => APP(VAR k, vs), res_ctys f)
426 :     val (vl,body) =
427 :     case fk
428 :     of {isrec=SOME(_,F.LK_TAIL),...} => let
429 :     (* for tail recursive loops, we create a
430 :     * local function that takes its continuation
431 :     * from the environment *)
432 :     val f' = cplv f
433 :     (* here we add a dumb entry for f' in the
434 :     * global renaming table just so that isEta
435 :     * can avoid eta-reducing it *)
436 :     val _ = newname(f', VAR f')
437 :     val vl = k::(map (cplv o #1) vts)
438 :     val vl' = map #1 vts
439 :     val cl' = map (ctype o #2) vts
440 :     in
441 :     (vl,
442 :     FIX([(KNOWN_TAIL, f', vl', cl',
443 :     (* add the function to the tail map *)
444 :     loop' (M.insert(m,f,f')) (e, kont))],
445 :     APP(VAR f', map VAR (tl vl))))
446 :     end
447 :     | _ => (k::(map #1 vts), loop(e, kont))
448 :     in (ESCAPE, f, vl, cl, body)
449 :     end
450 :     in FIX(map lpfd fds, loop(e, c))
451 :     end
452 :     | F.APP(f as F.VAR lv, vs) =>
453 :     (* first check if it's a recursive call to a tail loop *)
454 :     (case M.find(m, lv)
455 :     of SOME f' => APP(VAR f', lpvars vs)
456 :     | NONE =>
457 :     (* code for the non-tail case.
458 :     * Sadly this is *not* exceptional *)
459 :     let val (hdr, F) = preventEta c
460 :     val vf = lpvar f
461 :     val ul = lpvars vs
462 :     in hdr(APP(vf, F::ul))
463 :     end)
464 :     | F.APP _ => bug "unexpected APP in convert"
465 : jhr 4446
466 : jhr 4535 | (F.TFN _ | F.TAPP _) =>
467 :     bug "unexpected TFN and TAPP in convert"
468 : jhr 4446
469 : jhr 4535 | F.RECORD(F.RK_VECTOR _, [], v, e) =>
470 :     bug "zero length vectors in convert"
471 : jhr 4540 | F.RECORD(rk, [], v, e) => let
472 : jhr 4560 val _ = newname(v, tagInt 0)
473 : jhr 4540 in
474 :     loop(e, c)
475 : jhr 4535 end
476 :     | F.RECORD(rk, vl, v, e) =>
477 :     let val ts = map get_cty vl
478 :     val nvl = lpvars vl
479 :     val ce = loop(e, c)
480 :     in case rk
481 :     of F.RK_TUPLE _ =>
482 :     if (all_float ts) then recordFL(nvl, ts, v, ce)
483 :     else recordNM(nvl, ts, v, ce)
484 :     | F.RK_VECTOR _ =>
485 :     RECORD(RK_VECTOR, map (fn x => (x, OFFp0)) nvl, v, ce)
486 :     | _ => recordNM(nvl, ts, v, ce)
487 :     end
488 :     | F.SELECT(u, i, v, e) =>
489 :     let val ct = get_cty (F.VAR v)
490 :     val nu = lpvar u
491 :     val ce = loop(e, c)
492 :     in if is_float_record u then selectFL(i, nu, v, ct, ce)
493 :     else selectNM(i, nu, v, ct, ce)
494 :     end
495 : jhr 4446
496 : jhr 4535 | F.SWITCH(e,l,[a as (F.DATAcon((_,DA.CONSTANT 0,_),_,_),_),
497 :     b as (F.DATAcon((_,DA.CONSTANT 1,_),_,_),_)],
498 :     NONE) =>
499 :     loop(F.SWITCH(e,l,[b,a],NONE),c)
500 :     | F.SWITCH (u, sign, l, d) =>
501 :     let val (header,F) = preventEta c
502 :     val kont = makmc(fn vl => APP(F, vl), rttys c)
503 : jhr 4795 val body = let
504 :     val df = mkv()
505 : jhr 4535 fun proc (cn as (F.DATAcon(dc, _, v)), e) =
506 :     (cn, loop (F.LET([v], F.RET [u], e), kont))
507 :     | proc (cn, e) = (cn, loop(e, kont))
508 : jhr 4795 val b = switch {
509 :     arg = lpvar u, sign = sign,
510 :     cases = map proc l,
511 :     default = APP(VAR df, [tagInt 0])
512 :     }
513 :     in case d
514 :     of NONE => b
515 :     | SOME de => FIX([(CONT, df, [mkv()], [tagIntTy],
516 :     loop(de, kont))], b)
517 :     end
518 : jhr 4535 in header(body)
519 :     end
520 :     | F.CON(dc, ts, u, v, e) =>
521 :     bug "unexpected case CON in cps convert"
522 : jhr 4446
523 : jhr 4535 | F.RAISE(u, lts) =>
524 :     let (* execute the continuation for side effects *)
525 :     val _ = appmc(c, (map (fn _ => VAR(mkv())) lts))
526 :     val h = mkv()
527 :     in LOOKER(P.gethdlr, [], h, FUNt,
528 :     APP(VAR h,[VAR bogus_cont,lpvar u]))
529 :     end
530 :     | F.HANDLE(e,u) => (* recover type from u *)
531 :     let val (hdr, F) = preventEta c
532 :     val h = mkv()
533 :     val kont =
534 :     makmc (fn vl =>
535 :     SETTER(P.sethdlr, [VAR h], APP(F, vl)),
536 :     rttys c)
537 :     val body =
538 :     let val k = mkv() and v = mkv()
539 :     in FIX([(ESCAPE, k, [mkv(), v], [CNTt, BOGt],
540 :     SETTER(P.sethdlr, [VAR h],
541 :     APP(lpvar u, [F, VAR v])))],
542 :     SETTER(P.sethdlr, [VAR k], loop(e, kont)))
543 :     end
544 :     in LOOKER(P.gethdlr, [], h, FUNt, hdr(body))
545 :     end
546 : jhr 4446
547 : jhr 4535 | F.PRIMOP((_,p as (AP.CALLCC | AP.CAPTURE),_,_), [f], v, e) =>
548 :     let val (kont_decs, F) =
549 :     let val k = mkv()
550 :     val ct = get_cty f
551 :     in ([(CONT, k, [v], [ct], loop(e, c))], VAR k)
552 :     end
553 : jhr 4446
554 : jhr 4535 val (hdr1,hdr2) =
555 :     (case p
556 :     of AP.CALLCC =>
557 :     mkfn(fn h =>
558 :     (fn e => SETTER(P.sethdlr, [VAR h], e),
559 :     fn e => LOOKER(P.gethdlr, [], h, BOGt, e)))
560 :     | _ => (ident, ident))
561 : jhr 4446
562 : jhr 4535 val (ccont_decs, ccont_var) =
563 :     let val k = mkv() (* captured continuation *)
564 :     val x = mkv()
565 :     in ([(ESCAPE, k, [mkv(), x], [CNTt, BOGt],
566 :     hdr1(APP(F, [VAR x])))], k)
567 :     end
568 :     in FIX(kont_decs,
569 :     hdr2(FIX(ccont_decs,
570 :     APP(lpvar f, [F, VAR ccont_var]))))
571 :     end
572 : monnier 16
573 : jhr 4535 | F.PRIMOP((_,AP.ISOLATE,lt,ts), [f], v, e) =>
574 :     let val (exndecs, exnvar) =
575 :     let val h = mkv() and z = mkv() and x = mkv()
576 :     in ([(ESCAPE, h, [z, x], [CNTt, BOGt],
577 :     APP(VAR bogus_cont, [VAR x]))], h)
578 :     end
579 :     val newfdecs =
580 :     let val nf = v and z = mkv() and x = mkv()
581 :     in [(ESCAPE, v, [z, x], [CNTt, BOGt],
582 :     SETTER(P.sethdlr, [VAR exnvar],
583 :     APP(lpvar f, [VAR bogus_cont, VAR x])))]
584 :     end
585 :     in FIX(exndecs, FIX(newfdecs, loop(e, c)))
586 :     end
587 : monnier 100
588 : jhr 4535 | F.PRIMOP(po as (_,AP.THROW,_,_), [u], v, e) =>
589 :     (newname(v, lpvar u); loop(e, c))
590 :     (* PURE(P.wrap, [lpvar u], v, FUNt, c(VAR v)) *)
591 : jhr 4446
592 : jhr 4535 | F.PRIMOP(po as (_,AP.WCAST,_,_), [u], v, e) =>
593 :     (newname(v, lpvar u); loop(e, c))
594 : jhr 4446
595 : jhr 4535 | F.PRIMOP(po as (_,AP.WRAP,_,_), [u], v, e) =>
596 :     let val ct = ctyc(FU.getWrapTyc po)
597 :     in PURE(primwrap ct, [lpvar u], v, BOGt, loop(e, c))
598 :     end
599 :     | F.PRIMOP(po as (_,AP.UNWRAP,_,_), [u], v, e) =>
600 :     let val ct = ctyc(FU.getUnWrapTyc po)
601 :     in PURE(primunwrap ct, [lpvar u], v, ct, loop(e, c))
602 :     end
603 : blume 773
604 : jhr 4535 | F.PRIMOP(po as (_,AP.MARKEXN,_,_), [x,m], v, e) =>
605 :     let val bty = LT.ltc_void
606 :     val ety = LT.ltc_tuple[bty,bty,bty]
607 :     val (xx,x0,x1,x2) = (mkv(),mkv(),mkv(),mkv())
608 :     val (y,z,z') = (mkv(),mkv(),mkv())
609 : jhr 4874 in PURE(P.unbox,[lpvar x],xx,ctype(ety),
610 : jhr 4535 SELECT(0,VAR xx,x0,BOGt,
611 :     SELECT(1,VAR xx,x1,BOGt,
612 :     SELECT(2,VAR xx,x2,BOGt,
613 :     RECORD(RK_RECORD,[(lpvar m, OFFp0),
614 :     (VAR x2, OFFp0)], z,
615 : jhr 4874 PURE(P.box,[VAR z],z',BOGt,
616 : jhr 4535 RECORD(RK_RECORD,[(VAR x0,OFFp0),
617 :     (VAR x1,OFFp0),
618 :     (VAR z', OFFp0)],
619 :     y,
620 : jhr 4874 PURE(P.box,[VAR y],v,BOGt,
621 : jhr 4535 loop(e,c)))))))))
622 :     end
623 : blume 773
624 : jhr 4535 | F.PRIMOP ((_,AP.RAW_CCALL NONE,_,_), _::_::a::_,v,e) =>
625 :     (* code generated here should never be executed anyway,
626 :     * so we just fake it... *)
627 :     (print "*** pro-forma raw-ccall\n";
628 :     newname (v, lpvar a); loop(e,c))
629 :    
630 :     | F.PRIMOP ((_,AP.RAW_CCALL (SOME i),lt,ts),f::a::_::_,v,e) => let
631 :     val { c_proto, ml_args, ml_res_opt, reentrant } = i
632 :     val c_proto = cvtCProto c_proto
633 : jhr 4550 fun cty AP.CCR64 = FLTt 64 (* REAL32: FIXME *)
634 : jhr 4560 | cty AP.CCI32 = boxIntTy 32 (* 64BIT: FIXME *)
635 : jhr 4535 | cty AP.CCML = BOGt
636 : jhr 4803 | cty AP.CCI64 = BOGt (* 64BIT: FIXME *)
637 : jhr 4535 val a' = lpvar a
638 :     val rcckind = if reentrant then REENTRANT_RCC else FAST_RCC
639 :     fun rcc args = let
640 :     val al = map VAR args
641 :     val (al,linkage) =
642 :     case f of
643 :     F.STRING linkage => (al, linkage)
644 :     | _ => (lpvar f :: al, "")
645 : jhr 4558 in case ml_res_opt
646 :     of NONE =>
647 : jhr 4560 RCC (rcckind, linkage, c_proto, al, [(v, tagIntTy)], loop (e, c))
648 : jhr 4454 (* 64BIT: this code implements the fake 64-bit integers that are used on 32-bit targets *)
649 : jhr 4535 | SOME AP.CCI64 =>
650 :     let val (v1, v2) = (mkv (), mkv ())
651 :     in
652 : jhr 4558 RCC (rcckind, linkage, c_proto, al,
653 : jhr 4560 [(v1, boxIntTy 32), (v2, boxIntTy 32)],
654 :     recordNM([VAR v1, VAR v2],[boxIntTy 32, boxIntTy 32],
655 : jhr 4558 v, loop (e, c)))
656 : jhr 4535 end
657 :     | SOME rt => let
658 :     val v' = mkv ()
659 :     val res_cty = cty rt
660 :     in
661 :     RCC (rcckind, linkage, c_proto, al, [(v', res_cty)],
662 :     PURE(primwrap res_cty, [VAR v'], v, BOGt,
663 :     loop (e, c)))
664 :     end
665 :     end
666 :     val sel = if is_float_record a then selectFL else selectNM
667 :     fun build ([], rvl, _) = rcc (rev rvl)
668 :     | build (ft :: ftl, rvl, i) = let
669 :     val t = cty ft
670 :     val v = mkv ()
671 : mblume 1755 in
672 : jhr 4535 sel (i, a', v, t, build (ftl, v :: rvl, i + 1))
673 : mblume 1755 end
674 : jhr 4535 in
675 :     case ml_args of
676 :     [ft] => let
677 :     (* if there is precisely one arg, then it will not
678 :     * come packaged into a record *)
679 :     val t = cty ft
680 :     val v = mkv ()
681 : blume 774 in
682 : jhr 4535 PURE (primunwrap t, [a'], v, t, rcc [v])
683 : blume 774 end
684 : jhr 4535 | _ => build (ml_args, [], 0)
685 : blume 774 end
686 : blume 773
687 : jhr 4535 | F.PRIMOP ((_,AP.RAW_CCALL _,_,_),_,_,_) => bug "bad raw_ccall"
688 : blume 773
689 : jhr 4535 | F.PRIMOP ((_,AP.RAW_RECORD _,_,_),[x as F.VAR _],v,e) =>
690 :     (* code generated here should never be executed anyway,
691 :     * so we just fake it... *)
692 :     (print "*** pro-forma raw-record\n";
693 :     newname (v, lpvar x); loop(e,c))
694 : leunga 1174
695 : jhr 4535 | F.PRIMOP(po as (_,p,lt,ts), ul, v, e) =>
696 :     let val ct =
697 :     case (#3(LT.ltd_arrow(LT.lt_pinst (lt, ts))))
698 :     of [x] => ctype x
699 :     | _ => bug "unexpected case in F.PRIMOP"
700 :     val vl = lpvars ul
701 :     in case map_primop p
702 : jhr 4560 of PKS i => let val _ = newname(v, tagInt 0)
703 : jhr 4535 in SETTER(i, vl, loop(e,c))
704 :     end
705 :     | PKA i => ARITH(i, vl, v, ct, loop(e,c))
706 :     | PKL i => LOOKER(i, vl, v, ct, loop(e,c))
707 :     | PKP i => PURE(i, vl, v, ct, loop(e,c))
708 :     end
709 : jhr 4446
710 : jhr 4535 | F.BRANCH(po as (_,p,_,_), ul, e1, e2) =>
711 :     let val (hdr, F) = preventEta c
712 :     val kont = makmc(fn vl => APP(F, vl), rttys c)
713 :     in hdr(BRANCH(map_branch p, lpvars ul, mkv(),
714 :     loop(e1, kont), loop(e2, kont)))
715 :     end
716 :     end
717 : jhr 4446
718 : jhr 4535 (* processing the top-level fundec *)
719 :     val (fk, f, vts, be) = fdec
720 :     val k = mkv() (* top-level return continuation *)
721 :     val kont = makmc (fn vs => APP(VAR k, vs), res_ctys f)
722 :     val body = loop' M.empty (be, kont)
723 : monnier 16
724 : jhr 4535 val vl = k::(map #1 vts)
725 :     val cl = CNTt::(map (ctype o #2) vts)
726 :     in (ESCAPE, f, vl, cl, bogus_header body) before cleanUp()
727 :     end (* function convert *)
728 : monnier 16
729 : jhr 4535 end (* functor Convert *)

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