Mercurial > urweb
changeset 316:04ebfe929a98
Unpolyed a polymorphic function of two arguments
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 11 Sep 2008 10:14:59 -0400 |
| parents | e21d0dddda09 |
| children | 6a4e365db60c |
| files | src/cjr.sml src/cjr_print.sml src/cjrize.sml src/mono_reduce.sml src/prepare.sml src/unpoly.sml src/urweb.lex tests/specialize.ur |
| diffstat | 8 files changed, 126 insertions(+), 73 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr.sml Thu Sep 11 09:36:47 2008 -0400 +++ b/src/cjr.sml Thu Sep 11 10:14:59 2008 -0400 @@ -64,7 +64,7 @@ | ESome of typ * exp | EFfi of string * string | EFfiApp of string * string * exp list - | EApp of exp * exp + | EApp of exp * exp list | ERecord of int * (string * exp) list | EField of exp * string
--- a/src/cjr_print.sml Thu Sep 11 09:36:47 2008 -0400 +++ b/src/cjr_print.sml Thu Sep 11 10:14:59 2008 -0400 @@ -57,6 +57,11 @@ val dummyTyp = (TDatatype (Enum, 0, ref []), ErrorMsg.dummySpan) +val ident = String.translate (fn #"'" => "PRIME" + | ch => str ch) + +val p_ident = string o ident + fun p_typ' par env (t, loc) = case t of TFun (t1, t2) => parenIf par (box [p_typ' true env t2, @@ -89,7 +94,7 @@ space, string ("__uwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")] handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n)) - | TFfi (m, x) => box [string "uw_", string m, string "_", string x] + | TFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x] | TOption t => (case #1 t of TDatatype _ => p_typ' par env t @@ -99,15 +104,15 @@ and p_typ env = p_typ' false env -fun p_rel env n = string ("__uwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1)) +fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1)) handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1)) fun p_enamed env n = - string ("__uwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n) + string ("__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n) handle CjrEnv.UnboundNamed _ => string ("__uwn_UNBOUND_" ^ Int.toString n) fun p_con_named env n = - string ("__uwc_" ^ #1 (E.lookupConstructor env n) ^ "_" ^ Int.toString n) + string ("__uwc_" ^ ident (#1 (E.lookupConstructor env n)) ^ "_" ^ Int.toString n) handle CjrEnv.UnboundNamed _ => string ("__uwc_UNBOUND_" ^ Int.toString n) fun p_pat_preamble env (p, _) = @@ -117,7 +122,7 @@ | PVar (x, t) => (box [p_typ env t, space, string "__uwr_", - string x, + p_ident x, string "_", string (Int.toString (E.countERels env)), string ";", @@ -139,7 +144,7 @@ fun p_patCon env pc = case pc of PConVar n => p_con_named env n - | PConFfi {mod = m, con, ...} => string ("uw_" ^ m ^ "_" ^ con) + | PConFfi {mod = m, con, ...} => string ("uw_" ^ ident m ^ "_" ^ ident con) fun p_pat (env, exit, depth) (p, _) = case p of @@ -147,7 +152,7 @@ (box [], env) | PVar (x, t) => (box [string "__uwr_", - string x, + p_ident x, string "_", string (Int.toString (E.countERels env)), space, @@ -198,10 +203,10 @@ let val (x, to, _) = E.lookupConstructor env n in - ("uw_" ^ x, to) + ("uw_" ^ ident x, to) end | PConFfi {mod = m, con, arg, ...} => - ("uw_" ^ m ^ "_" ^ con, arg) + ("uw_" ^ ident m ^ "_" ^ ident con, arg) val t = case to of NONE => raise Fail "CjrPrint: Constructor mismatch" @@ -287,7 +292,7 @@ string "disc", string (Int.toString depth), string ".__uwf_", - string x, + p_ident x, string ";", newline, p, @@ -379,14 +384,14 @@ val (x, _, dn) = E.lookupConstructor env n val (dx, _) = E.lookupDatatype env dn in - ("__uwd_" ^ dx ^ "_" ^ Int.toString dn, - "__uwc_" ^ x ^ "_" ^ Int.toString n, - "uw_" ^ x) + ("__uwd_" ^ ident dx ^ "_" ^ Int.toString dn, + "__uwc_" ^ ident x ^ "_" ^ Int.toString n, + "uw_" ^ ident x) end | PConFfi {mod = m, datatyp, con, ...} => - ("uw_" ^ m ^ "_" ^ datatyp, - "uw_" ^ m ^ "_" ^ con, - "uw_" ^ con) + ("uw_" ^ ident m ^ "_" ^ ident datatyp, + "uw_" ^ ident m ^ "_" ^ ident con, + "uw_" ^ ident con) fun p_unsql env (tAll as (t, loc)) e = case t of @@ -545,7 +550,7 @@ newline, string "})"]) - | EFfi (m, x) => box [string "uw_", string m, string "_", string x] + | EFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x] | EError (e, t) => box [string "({", newline, @@ -563,27 +568,18 @@ newline, string "})"] | EFfiApp (m, x, es) => box [string "uw_", - string m, + p_ident m, string "_", - string x, + p_ident x, string "(ctx, ", p_list (p_exp env) es, string ")"] - | EApp (e1, e2) => - let - fun unravel (f, acc) = - case #1 f of - EApp (f', arg) => unravel (f', arg :: acc) - | _ => (f, acc) - - val (f, args) = unravel (e1, [e2]) - in - parenIf par (box [p_exp' true env e1, - string "(ctx,", - space, - p_list_sep (box [string ",", space]) (p_exp env) args, - string ")"]) - end + | EApp (f, args) => + parenIf par (box [p_exp' true env f, + string "(ctx,", + space, + p_list_sep (box [string ",", space]) (p_exp env) args, + string ")"]) | ERecord (i, xes) => box [string "({", space, @@ -606,7 +602,7 @@ | EField (e, x) => box [p_exp' true env e, string ".__uwf_", - string x] + p_ident x] | ECase (e, pes, {disc, result}) => let @@ -692,7 +688,7 @@ p_typ env t, space, string "__uwr_", - string x, + p_ident x, string "_", string (Int.toString (E.countERels env)), space, @@ -708,9 +704,9 @@ | EQuery {exps, tables, rnum, state, query, body, initial, prepared} => let - val exps = map (fn (x, t) => ("__uwf_" ^ x, t)) exps + val exps = map (fn (x, t) => ("__uwf_" ^ ident x, t)) exps val tables = ListUtil.mapConcat (fn (x, xts) => - map (fn (x', t) => ("__uwf_" ^ x ^ ".__uwf_" ^ x', t)) xts) + map (fn (x', t) => ("__uwf_" ^ ident x ^ ".__uwf_" ^ ident x', t)) xts) tables val outputs = exps @ tables @@ -945,7 +941,7 @@ space, p_typ env ran, space, - string ("__uwn_" ^ fx ^ "_" ^ Int.toString n), + string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n), string "(", p_list_sep (box [string ",", space]) (fn x => x) (string "uw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) => @@ -978,7 +974,7 @@ p_list_sep (box []) (fn (x, t) => box [p_typ env t, space, string "__uwf_", - string x, + p_ident x, string ";", newline]) xts, string "};"] @@ -986,11 +982,12 @@ | DDatatype (Enum, x, n, xncs) => box [string "enum", space, - string ("__uwe_" ^ x ^ "_" ^ Int.toString n), + string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n), space, string "{", space, - p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__uwc_" ^ x ^ "_" ^ Int.toString n)) xncs, + p_list_sep (box [string ",", space]) (fn (x, n, _) => + string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) xncs, space, string "};"] | DDatatype (Option, _, _, _) => box [] @@ -1001,24 +998,25 @@ in box [string "enum", space, - string ("__uwe_" ^ x ^ "_" ^ Int.toString n), + string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n), space, string "{", space, - p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__uwc_" ^ x ^ "_" ^ Int.toString n)) xncs, + p_list_sep (box [string ",", space]) (fn (x, n, _) => + string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) xncs, space, string "};", newline, newline, string "struct", space, - string ("__uwd_" ^ x ^ "_" ^ Int.toString n), + string ("__uwd_" ^ ident x ^ "_" ^ Int.toString n), space, string "{", newline, string "enum", space, - string ("__uwe_" ^ x ^ "_" ^ Int.toString n), + string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n), space, string "tag;", newline, @@ -1030,7 +1028,7 @@ newline, p_list_sep newline (fn (x, n, t) => box [p_typ env t, space, - string ("uw_" ^ x), + string ("uw_" ^ ident x), string ";"]) xncsArgs, newline, string "}", @@ -1045,7 +1043,7 @@ | DVal (x, n, t, e) => box [p_typ env t, space, - string ("__uwn_" ^ x ^ "_" ^ Int.toString n), + string ("__uwn_" ^ ident x ^ "_" ^ Int.toString n), space, string "=", space, @@ -1061,7 +1059,7 @@ space, p_typ env ran, space, - string ("__uwn_" ^ fx ^ "_" ^ Int.toString n), + string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n), string "(uw_context,", space, p_list_sep (box [string ",", space]) @@ -1314,7 +1312,7 @@ fun unurlify (t, loc) = case t of - TFfi (m, t) => string ("uw_" ^ m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") + TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") | TRecord 0 => string "uw_unit_v" | TRecord i => @@ -1370,7 +1368,7 @@ string (Int.toString (size x')), string "] == 0 || request[", string (Int.toString (size x')), - string ("] == '/')) ? __uwc_" ^ x' ^ "_" ^ Int.toString n), + string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n), space, string ":", space, @@ -1475,7 +1473,7 @@ newline, string "struct", space, - string ("__uwd_" ^ x ^ "_" ^ Int.toString i), + string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i), space, string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_", string x, @@ -1487,7 +1485,7 @@ space, string "=", space, - string ("__uwc_" ^ x' ^ "_" ^ Int.toString n), + string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n), string ";", newline, string "request", @@ -1502,7 +1500,7 @@ case to of NONE => box [] | SOME t => box [string "tmp->data.uw_", - string x', + p_ident x', space, string "=", space, @@ -1540,7 +1538,7 @@ box [box (map (fn (x, t) => box [p_typ env t, space, string "uw_input_", - string x, + p_ident x, string ";", newline]) xts), newline, @@ -1571,7 +1569,7 @@ string "}", newline, string "uw_input_", - string x, + p_ident x, space, string "=", space, @@ -1587,7 +1585,7 @@ string "= {", newline, box (map (fn (x, _) => box [string "uw_input_", - string x, + p_ident x, string ",", newline]) xts), string "};", @@ -1671,7 +1669,7 @@ (map (fn (x, t) => String.concat ["(attname = 'uw_", CharVector.map - Char.toLower x, + Char.toLower (ident x), "' AND atttypid = (SELECT oid FROM pg_type", " WHERE typname = '", p_sqltype' env t,
--- a/src/cjrize.sml Thu Sep 11 09:36:47 2008 -0400 +++ b/src/cjrize.sml Thu Sep 11 10:14:59 2008 -0400 @@ -233,10 +233,17 @@ end | L.EApp (e1, e2) => let - val (e1, sm) = cifyExp (e1, sm) - val (e2, sm) = cifyExp (e2, sm) + fun unravel (e, args) = + case e of + (L.EApp (e1, e2), _) => unravel (e1, e2 :: args) + | _ => (e, args) + + val (f, es) = unravel (e1, [e2]) + + val (f, sm) = cifyExp (f, sm) + val (es, sm) = ListUtil.foldlMap cifyExp sm es in - ((L'.EApp (e1, e2), loc), sm) + ((L'.EApp (f, es), loc), sm) end | L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation"; Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)];
--- a/src/mono_reduce.sml Thu Sep 11 09:36:47 2008 -0400 +++ b/src/mono_reduce.sml Thu Sep 11 10:14:59 2008 -0400 @@ -95,6 +95,21 @@ fun typ c = c +val swapExpVars = + U.Exp.mapB {typ = fn t => t, + exp = fn lower => fn e => + case e of + ERel xn => + if xn = lower then + ERel (lower + 1) + else if xn = lower + 1 then + ERel lower + else + e + | _ => e, + bind = fn (lower, U.Exp.RelE _) => lower+1 + | (lower, _) => lower} + datatype result = Yes of E.env | No | Maybe fun match (env, p : pat, e : exp) = @@ -208,6 +223,10 @@ | EApp ((ELet (x, t, e, b), loc), e') => #1 (reduceExp env (ELet (x, t, e, (EApp (b, liftExpInExp 0 e'), loc)), loc)) + + | ELet (x, t, e, (EAbs (x', t' as (TRecord [], _), ran, e'), loc)) => + EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e, swapExpVars 0 e'), loc)) + | ELet (x, t, e', b) => if impure e' then e
--- a/src/prepare.sml Thu Sep 11 09:36:47 2008 -0400 +++ b/src/prepare.sml Thu Sep 11 10:14:59 2008 -0400 @@ -74,12 +74,12 @@ in ((EFfiApp (m, x, es), loc), sns) end - | EApp (e1, e2) => + | EApp (e1, es) => let val (e1, sns) = prepExp (e1, sns) - val (e2, sns) = prepExp (e2, sns) + val (es, sns) = ListUtil.foldlMap prepExp sns es in - ((EApp (e1, e2), loc), sns) + ((EApp (e1, es), loc), sns) end | ERecord (rn, xes) =>
--- a/src/unpoly.sml Thu Sep 11 09:36:47 2008 -0400 +++ b/src/unpoly.sml Thu Sep 11 10:14:59 2008 -0400 @@ -46,6 +46,19 @@ val liftConInExp = E.liftConInExp val subConInExp = E.subConInExp +fun unpolyNamed (xn, rep) = + U.Exp.map {kind = fn k => k, + con = fn c => c, + exp = fn e => + case e of + ENamed xn' => + if xn' = xn then + rep + else + e + | ECApp (e, _) => #1 e + | _ => e} + type state = { funcs : (kind list * (string * int * con * exp * string) list) IM.map, decls : decl list, @@ -93,7 +106,14 @@ in trim (t, e, cargs) end - | (_, _, []) => SOME (t, e) + | (_, _, []) => + let + val e = foldl (fn ((_, n, n_old, _, _, _), e) => + unpolyNamed (n_old, ENamed n) e) + e vis + in + SOME (t, e) + end | _ => NONE in (*Print.prefaces "specialize" @@ -106,19 +126,25 @@ val vis = List.map specialize vis in - if List.exists (not o Option.isSome) vis then + if List.exists (not o Option.isSome) vis orelse length cargs > length ks then (e, st) else let val vis = List.mapPartial (fn x => x) vis + val vis = map (fn (x, n, n_old, t, e, s) => + (x ^ "_unpoly", n, n_old, t, e, s)) vis val vis' = map (fn (x, n, _, t, e, s) => - (x ^ "_unpoly", n, t, e, s)) vis + (x, n, t, e, s)) vis + + val ks' = List.drop (ks, length cargs) in case List.find (fn (_, _, n_old, _, _, _) => n_old = n) vis of NONE => raise Fail "Unpoly: Inconsistent 'val rec' record" | SOME (_, n, _, _, _, _) => (ENamed n, - {funcs = #funcs st, + {funcs = foldl (fn (vi, funcs) => + IM.insert (funcs, #2 vi, (ks', vis'))) + (#funcs st) vis', decls = (DValRec vis', ErrorMsg.dummySpan) :: #decls st, nextName = nextName}) end
--- a/src/urweb.lex Thu Sep 11 09:36:47 2008 -0400 +++ b/src/urweb.lex Thu Sep 11 10:14:59 2008 -0400 @@ -112,7 +112,7 @@ %s COMMENT STRING XML XMLTAG; id = [a-z_][A-Za-z0-9_']*; -cid = [A-Z][A-Za-z0-9_']*; +cid = [A-Z][A-Za-z0-9_]*; ws = [\ \t\012]; intconst = [0-9]+; realconst = [0-9]+\.[0-9]*;
--- a/tests/specialize.ur Thu Sep 11 09:36:47 2008 -0400 +++ b/tests/specialize.ur Thu Sep 11 10:14:59 2008 -0400 @@ -5,7 +5,7 @@ Nil => True | Cons _ => False -(*fun append (t ::: Type) (ls1 : list t) (ls2 : list t) : list t = +fun append (t ::: Type) (ls1 : list t) (ls2 : list t) : list t = case ls1 of Nil => ls2 | Cons (x, ls1') => Cons (x, append ls1' ls2) @@ -13,14 +13,17 @@ fun delist (ls : list string) : xml body [] [] = case ls of Nil => <body>Nil</body> - | Cons (h, t) => <body>{cdata h} :: {delist t}</body>*) + | Cons (h, t) => <body>{cdata h} :: {delist t}</body> val ls = Cons ("X", Cons ("Y", Cons ("Z", Nil))) +val ls' = Cons ("A", Cons ("B", Nil)) fun main () : transaction page = return <html><body> {if isNil ls then <body>It's Nil.</body> else <body>It's not Nil.</body>} + + <p>{delist (append ls' ls)}</p> </body></html> -(* <p>{delist ls}</p>*) +