diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/cjr.sml | 2 | ||||
| -rw-r--r-- | src/cjr_print.sml | 114 | ||||
| -rw-r--r-- | src/cjrize.sml | 13 | ||||
| -rw-r--r-- | src/mono_reduce.sml | 19 | ||||
| -rw-r--r-- | src/prepare.sml | 6 | ||||
| -rw-r--r-- | src/unpoly.sml | 34 | ||||
| -rw-r--r-- | src/urweb.lex | 2 |
7 files changed, 120 insertions, 70 deletions
diff --git a/src/cjr.sml b/src/cjr.sml index f9155980..9b6765dc 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -64,7 +64,7 @@ datatype exp' = | 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 diff --git a/src/cjr_print.sml b/src/cjr_print.sml index e2bc37fa..a6eb0ffe 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -57,6 +57,11 @@ val debug = ref false 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 @@ fun p_typ' par env (t, loc) = 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 @@ fun p_typ' par env (t, loc) = 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 @@ fun p_pat_preamble env (p, _) = | 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_pat_preamble env (p, _) = 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 @@ fun p_pat (env, exit, depth) (p, _) = (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 @@ fun p_pat (env, exit, depth) (p, _) = 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 @@ fun p_pat (env, exit, depth) (p, _) = string "disc", string (Int.toString depth), string ".__uwf_", - string x, + p_ident x, string ";", newline, p, @@ -379,14 +384,14 @@ fun patConInfo env pc = 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 @@ fun p_exp' par env (e, loc) = 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 @@ fun p_exp' par env (e, loc) = 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 @@ fun p_exp' par env (e, loc) = | 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 @@ fun p_exp' par env (e, loc) = p_typ env t, space, string "__uwr_", - string x, + p_ident x, string "_", string (Int.toString (E.countERels env)), space, @@ -708,9 +704,9 @@ fun p_exp' par env (e, loc) = | 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 @@ fun p_fun env (fx, n, args, ran, e) = 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 @@ fun p_decl env (dAll as (d, _) : decl) = 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 @@ fun p_decl env (dAll as (d, _) : decl) = | 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 @@ fun p_decl env (dAll as (d, _) : decl) = 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 @@ fun p_decl env (dAll as (d, _) : decl) = 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 @@ fun p_decl env (dAll as (d, _) : decl) = | 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 @@ fun p_decl env (dAll as (d, _) : decl) = 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 p_file env (ds, ps) = 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 @@ fun p_file env (ds, ps) = 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 @@ fun p_file env (ds, ps) = 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 @@ fun p_file env (ds, ps) = space, string "=", space, - string ("__uwc_" ^ x' ^ "_" ^ Int.toString n), + string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n), string ";", newline, string "request", @@ -1502,7 +1500,7 @@ fun p_file env (ds, ps) = case to of NONE => box [] | SOME t => box [string "tmp->data.uw_", - string x', + p_ident x', space, string "=", space, @@ -1540,7 +1538,7 @@ fun p_file env (ds, ps) = 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 @@ fun p_file env (ds, ps) = string "}", newline, string "uw_input_", - string x, + p_ident x, space, string "=", space, @@ -1587,7 +1585,7 @@ fun p_file env (ds, ps) = string "= {", newline, box (map (fn (x, _) => box [string "uw_input_", - string x, + p_ident x, string ",", newline]) xts), string "};", @@ -1671,7 +1669,7 @@ fun p_file env (ds, ps) = (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, diff --git a/src/cjrize.sml b/src/cjrize.sml index d6d7ba5e..9e426751 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -233,10 +233,17 @@ fun cifyExp (eAll as (e, loc), sm) = 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)]; diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 11a52a4c..e538f54e 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -95,6 +95,21 @@ fun subExpInExp (n, e1) e2 = 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 @@ fun exp env e = | 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 diff --git a/src/prepare.sml b/src/prepare.sml index bb1af6cc..a6b6a4f3 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -74,12 +74,12 @@ fun prepExp (e as (_, loc), sns) = 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) => diff --git a/src/unpoly.sml b/src/unpoly.sml index 917a8cc8..12cff6c8 100644 --- a/src/unpoly.sml +++ b/src/unpoly.sml @@ -46,6 +46,19 @@ val subConInCon = E.subConInCon 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 @@ fun exp (e, st : state) = 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 @@ fun exp (e, st : state) = 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 diff --git a/src/urweb.lex b/src/urweb.lex index 1e7876b4..9cb4d642 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -112,7 +112,7 @@ fun initialize () = (xmlTag := []; %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]*; |