CVS: sml-dist/src/compiler/FLINT/plambda flintnm.sml, 1.17.10.7, 1.17.10.8
George Kuan <[email protected]> Fri, 28 Jul 2006 15:26:11 -0700
| Newsgroups | gmane.comp.lang.sml.smlnj.commits |
|---|---|
| Message-ID | <[email protected]> |
Update of /cvsroot/smlnj/sml-dist/src/compiler/FLINT/plambda
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv32569/FLINT/plambda
Modified Files:
Tag: primop-branch-2
flintnm.sml
Log Message:
started LTy pretty printer using SMLNJ-lib
Index: flintnm.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/plambda/flintnm.sml,v
retrieving revision 1.17.10.7
retrieving revision 1.17.10.8
diff -C2 -d -r1.17.10.7 -r1.17.10.8
*** flintnm.sml 26 Jul 2006 22:34:58 -0000 1.17.10.7
--- flintnm.sml 28 Jul 2006 22:26:08 -0000 1.17.10.8
***************
*** 277,281 ****
| L.INT i =>
((i+i+2; cont(F.INT i, LT.ltc_int)) handle Overflow =>
! (let val z = i div 2
val ne = L.APP(iadd_prim, L.RECORD [L.INT z, L.INT (i-z)])
in tovalue(venv, d, ne, cont)
--- 277,282 ----
| L.INT i =>
((i+i+2; cont(F.INT i, LT.ltc_int)) handle Overflow =>
! (let val _ = debugmsg "toValue INT Overflow"
! val z = i div 2
val ne = L.APP(iadd_prim, L.RECORD [L.INT z, L.INT (i-z)])
in tovalue(venv, d, ne, cont)
***************
*** 299,303 ****
| _ =>
let val lv = mkv()
! in tolvar(venv, d, lv, lexp, fn lty => cont(F.VAR lv, lty))
end
val _ = debugmsg "<<tovalue"
--- 300,307 ----
| _ =>
let val lv = mkv()
! in tolvar(venv, d, lv, lexp,
! fn lty => (debugmsg ">>tovalue tolvar cont";
! if !debugging then PPLexp.printLexp lexp else ();
! cont(F.VAR lv, lty)))
end
val _ = debugmsg "<<tovalue"
***************
*** 323,331 ****
lexps2values(venv,d,lexps,
fn (vals,ltys) =>
! let val lty = LT.ltc_tuple ltys
val (_, ltys, _) = FL.t_pflatten lty
in
(* detect the case where flattening is trivial *)
! if LT.lt_eqv(lty, LT.ltc_tuple ltys) then
cont(vals,lty)
else
--- 327,369 ----
lexps2values(venv,d,lexps,
fn (vals,ltys) =>
! let val _ = debugmsg ">>tovalues continuation"
! val _ =
! if length ltys = 0 then
! debugmsg ("tovalues cont ltys null")
! else if length ltys = 1
! then debugmsg ("tovalues cont ltys singleton"^
! LtyBasic.lt_print (hd ltys))
! else debugmsg ("tovalues cont ltys > 1 "^
! "starting with "^
! LtyBasic.lt_print (hd ltys) ^
! "\nlength is "
! ^ Int.toString (length ltys))
! fun scan [] = debugmsg "tovalues end of ltys"
! | scan (lts) =
! let fun scan' ([], [], n) = ()
! | scan' (x::xs, l::ls, n) =
! (debugmsg ("tovalues cont ltys ["^
! Int.toString n ^"]:");
! PPLexp.printLexp l;
! debugmsg (LtyBasic.lt_print x); scan' (xs, ls, n + 1))
! in scan'(lts, lexps, 0)
! end
! val _ = scan ltys
! val lty = LT.ltc_tuple ltys
! val _ = debugmsg ("<<tovalues cont tupled "^
! LtyBasic.lt_print lty)
val (_, ltys, _) = FL.t_pflatten lty
+ val _ = debugmsg "<<tovalues cont flatten"
+ val _ = debugmsg (">>tovalues cont LT.lt_eqv " ^
+ LtyBasic.lt_print lty ^ " eqv? ")
+ val _ = debugmsg ">>tovalues cont LT.ltc_tuple"
+ val ltyst = (LT.ltc_tuple ltys)
+ val _ = debugmsg ("<<tovalues cont LT.ltc_tuple "
+ ^ LtyBasic.lt_print ltyst)
+ val eqvLty = LT.lt_eqv(lty, LT.ltc_tuple ltys)
+ val _ = debugmsg "<<tovalues cont lt_eqv"
in
(* detect the case where flattening is trivial *)
! if eqvLty then
cont(vals,lty)
else
***************
*** 334,337 ****
--- 372,376 ----
val (vs,wrap) = pflatten (F.VAR lv)
val (c_lexp,c_lty) = cont(vs, lty)
+ val _ = debugmsg "<<tovalues continuation"
in
(F.RECORD(FU.rk_tuple,
***************
*** 360,366 ****
fun f [] (vals,ltys) = cont (rev vals, rev ltys)
| f (lexp::lexps) (vals,ltys) =
tovalue(venv,d,lexp,
! fn (v, lty) =>
! f lexps (v::vals, lty::ltys))
val v = f lexps ([], [])
val _ = debugmsg "<<lexp2values"
--- 399,408 ----
fun f [] (vals,ltys) = cont (rev vals, rev ltys)
| f (lexp::lexps) (vals,ltys) =
+ (debugmsg ("lexps2values ltys "^concat (map (fn x => ("\n"^LtyBasic.lt_print x)) ltys));
tovalue(venv,d,lexp,
! fn (v, lty) => (debugmsg ">>lexps2values tovalue";
! if !debugging then PPLexp.printLexp lexp else ();
! if !debugging then debugmsg ("lty: "^ LtyBasic.lt_print lty) else ();
! f lexps (v::vals, lty::ltys))))
val v = f lexps ([], [])
val _ = debugmsg "<<lexp2values"
***************
*** 374,378 ****
*)
and tolvar (venv,d,lvar,lexp,cont) =
! let fun eta_expand (f, f_lty) =
let val lv = mkv()
val (arg_lty, ret_lty) = (LT.ltd_parrow f_lty)
--- 416,422 ----
*)
and tolvar (venv,d,lvar,lexp,cont) =
! let val _ = debugmsg ">>tolvar"
! val _ = if !debugging then PPLexp.printLexp lexp else ()
! fun eta_expand (f, f_lty) =
let val lv = mkv()
val (arg_lty, ret_lty) = (LT.ltd_parrow f_lty)
***************
*** 401,404 ****
--- 445,449 ----
or not. The results of primops are never flattened.
*)
+ val _ = debugmsg ">>tolvar PO_helper"
val (pty, r_lty, flat) =
(case (LT.ltp_ppoly f_lty, tycs)
***************
*** 431,435 ****
end
| _ => bug "unexpected case in PO_helper")
! in if flat then
(* ZHONG asks: is the following definitely safe ?
what would happen if ltc_raw is not an identity function ?
--- 476,480 ----
end
| _ => bug "unexpected case in PO_helper")
! val r = if flat then
(* ZHONG asks: is the following definitely safe ?
what would happen if ltc_raw is not an identity function ?
***************
*** 437,443 ****
tovalues(venv, d, arg,
fn (arg_vals, arg_lty) =>
! let val (c_lexp, c_lty) = cont(r_lty)
(* put the filling inbetween *)
! in (filler(arg_vals, pty, c_lexp), c_lty)
end)
else
--- 482,491 ----
tovalues(venv, d, arg,
fn (arg_vals, arg_lty) =>
! let val _ = debugmsg ">>tolvar PO_helper cont"
! val (c_lexp, c_lty) = cont(r_lty)
(* put the filling inbetween *)
! val r' = (filler(arg_vals, pty, c_lexp), c_lty)
! val _ = debugmsg "<<tolvar PO_helper cont"
! in r'
end)
else
***************
*** 447,451 ****
(* put the filling inbetween *)
in (filler([arg_val], pty, c_lexp), c_lty)
! end)
end (* function PO_helper *)
--- 495,501 ----
(* put the filling inbetween *)
in (filler([arg_val], pty, c_lexp), c_lty)
! end)
! val _ = debugmsg "<<tolvar PO_helper"
! in r
end (* function PO_helper *)
***************
*** 465,469 ****
(* end) *)
! in case lexp of
(* primops have to be eta-expanded since they're not valid
* function values anymore in Flint *)
--- 515,519 ----
(* end) *)
! val r = case lexp of
(* primops have to be eta-expanded since they're not valid
* function values anymore in Flint *)
***************
*** 481,488 ****
--- 531,545 ----
(* this is were we really deal with primops *)
| L.APP (L.PRIM ((po,f_lty,tycs)),arg) =>
+ let val _ = debugmsg ">>tolvar L.APP"
+ val (lexp', lty') =
PO_helper(arg, f_lty, tycs,
fn (arg_vals,pty, c_lexp) =>
flint_prim((NONE, po, pty, map FL.tcc_raw tycs),
arg_vals, lvar, c_lexp))
+ val _ = debugmsg "<<tolvar L.APP"
+
+ val _ = if !debugging then debugmsg (LtyBasic.lt_print lty') else ()
+ in (lexp', lty')
+ end
| L.APP (L.GENOP({default,table},po,f_lty,tycs),arg) =>
***************
*** 552,556 ****
lexps2values(venv,d,lexps,
fn (vals, ltys) =>
! let val lty = LT.ltc_tyc(LT.tcc_vector tyc)
val (c_lexp, c_lty) = cont(lty)
in (F.RECORD(F.RK_VECTOR (FL.tcc_raw tyc),
--- 609,614 ----
lexps2values(venv,d,lexps,
fn (vals, ltys) =>
! let val _ = debugmsg ">>tolvar VECTOR cont"
! val lty = LT.ltc_tyc(LT.tcc_vector tyc)
val (c_lexp, c_lty) = cont(lty)
in (F.RECORD(F.RK_VECTOR (FL.tcc_raw tyc),
***************
*** 561,565 ****
lexps2values(venv,d,lexps,
fn (vals, ltys) =>
! let val lty = LT.ltc_tuple ltys
val (c_lexp, c_lty) = cont(lty)
in (F.RECORD(FU.rk_tuple,
--- 619,624 ----
lexps2values(venv,d,lexps,
fn (vals, ltys) =>
! let val _ = debugmsg ">>tolvar RECORD cont"
! val lty = LT.ltc_tuple ltys
val (c_lexp, c_lty) = cont(lty)
in (F.RECORD(FU.rk_tuple,
***************
*** 569,573 ****
lexps2values(venv,d,lexps,
fn (vals, ltys) =>
! let val lty = LT.ltc_str(ltys)
val (c_lexp, c_lty) = cont(lty)
in (F.RECORD(F.RK_STRUCT, vals, lvar, c_lexp), c_lty)
--- 628,633 ----
lexps2values(venv,d,lexps,
fn (vals, ltys) =>
! let val _ = debugmsg ">>tolvar SRECORD cont"
! val lty = LT.ltc_str(ltys)
val (c_lexp, c_lty) = cont(lty)
in (F.RECORD(F.RK_STRUCT, vals, lvar, c_lexp), c_lty)
***************
*** 602,605 ****
--- 662,666 ----
| _ => default_tolexp ()
+ in (debugmsg "<<tolvar"; r)
end
-------------------------------------------------------------------------
Take Surveys. Earn Cash. Influence the Future of IT
Join SourceForge.net's Techsay panel and you'll get the chance to share your
opinions on IT & business topics through brief surveys -- and earn cash
http://www.techsay.com/default.php?page=join.php&p=sourceforge&CID=DEVDEV