diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/c/urweb.c | 34 | ||||
-rw-r--r-- | src/cjr_print.sml | 4 | ||||
-rw-r--r-- | src/cjrize.sml | 2 | ||||
-rw-r--r-- | src/iflow.sml | 4 | ||||
-rw-r--r-- | src/jscomp.sml | 11 | ||||
-rw-r--r-- | src/mono.sml | 4 | ||||
-rw-r--r-- | src/mono_opt.sml | 2 | ||||
-rw-r--r-- | src/mono_print.sml | 10 | ||||
-rw-r--r-- | src/mono_reduce.sml | 18 | ||||
-rw-r--r-- | src/mono_util.sml | 4 | ||||
-rw-r--r-- | src/monoize.sml | 30 | ||||
-rw-r--r-- | src/settings.sml | 1 | ||||
-rw-r--r-- | src/urweb.grm | 4 |
13 files changed, 90 insertions, 38 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c index a09978cd..efe50591 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -13,6 +13,7 @@ #include <stdint.h> #include <sys/types.h> #include <sys/socket.h> +#include <crypt.h> #include <pthread.h> @@ -2006,6 +2007,27 @@ uw_unit uw_Basis_htmlifyFloat_w(uw_context ctx, uw_Basis_float n) { return uw_unit_v; } +char *uw_Basis_jsifyTime(uw_context ctx, uw_Basis_time n) { + int len; + char *r; + + uw_check_heap(ctx, INTS_MAX); + r = ctx->heap.front; + sprintf(r, "%lld%n", (uw_Basis_int)n, &len); + ctx->heap.front += len+1; + return r; +} + +uw_unit uw_Basis_jsifyInt_w(uw_context ctx, uw_Basis_time n) { + int len; + + uw_check(ctx, INTS_MAX); + sprintf(ctx->page.front, "%lld%n", (uw_Basis_int)n, &len); + ctx->page.front += len; + + return uw_unit_v; +} + char *uw_Basis_htmlifyString(uw_context ctx, uw_Basis_string s) { char *r, *s2; @@ -3568,3 +3590,15 @@ failure_kind uw_runCallback(uw_context ctx, void (*callback)(uw_context)) { return r; } + +uw_Basis_string uw_Basis_crypt(uw_context ctx, uw_Basis_string key, uw_Basis_string salt) { + struct crypt_data *data; + + if ((data = uw_get_global(ctx, "crypt")) == NULL) { + data = malloc(sizeof(struct crypt_data)); + data->initialized = 0; + uw_set_global(ctx, "crypt", data, free); + } + + return uw_strdup(ctx, crypt_r(key, salt, data)); +} diff --git a/src/cjr_print.sml b/src/cjr_print.sml index b4f75eb5..53060ab2 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -635,7 +635,9 @@ fun unurlify fromClient env (t, loc) = string (Int.toString (size x')), string "] == 0 || request[", string (Int.toString (size x')), - string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n), + string "] == '/')) ? (request += ", + string (Int.toString (size x')), + string (", (*request == '/' ? ++request : NULL), __uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ")"), space, string ":", space, diff --git a/src/cjrize.sml b/src/cjrize.sml index 9c297fad..2c13e494 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -300,7 +300,7 @@ fun cifyExp (eAll as (e, loc), sm) = in ((L'.EUnop (s, e1), loc), sm) end - | L.EBinop (s, e1, e2) => + | L.EBinop (_, s, e1, e2) => let val (e1, sm) = cifyExp (e1, sm) val (e2, sm) = cifyExp (e2, sm) diff --git a/src/iflow.sml b/src/iflow.sml index c0e92cb1..f6e03271 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1965,7 +1965,7 @@ fun evalExp env (e as (_, loc)) k = | EAbs _ => default () | EUnop (s, e1) => evalExp env e1 (fn e1 => k (Func (Other s, [e1]))) - | EBinop (s, e1, e2) => evalExp env e1 (fn e1 => evalExp env e2 (fn e2 => k (Func (Other s, [e1, e2])))) + | EBinop (_, s, e1, e2) => evalExp env e1 (fn e1 => evalExp env e2 (fn e2 => k (Func (Other s, [e1, e2])))) | ERecord xets => let fun doFields (xes, acc) = @@ -2352,7 +2352,7 @@ fun check file = end | EAbs (x, t1, t2, e) => (EAbs (x, t1, t2, doExp (Unknown :: env) e), loc) | EUnop (uo, e1) => (EUnop (uo, doExp env e1), loc) - | EBinop (bo, e1, e2) => (EBinop (bo, doExp env e1, doExp env e2), loc) + | EBinop (bi, bo, e1, e2) => (EBinop (bi, bo, doExp env e1, doExp env e2), loc) | ERecord xets => (ERecord (map (fn (x, e, t) => (x, doExp env e, t)) xets), loc) | EField (e1, f) => (EField (doExp env e1, f), loc) | ECase (e, pes, ts) => diff --git a/src/jscomp.sml b/src/jscomp.sml index 992a2e30..3b859814 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -126,6 +126,7 @@ fun process file = | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [e]), loc), st) | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [e]), loc), st) | TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [e]), loc), st) + | TFfi ("Basis", "time") => ((EFfiApp ("Basis", "jsifyTime", [e]), loc), st) | TFfi ("Basis", "bool") => ((ECase (e, [((PCon (Enum, PConFfi {mod = "Basis", @@ -701,7 +702,7 @@ fun process file = str ",null)}"], st) end - | EBinop (s, e1, e2) => + | EBinop (bi, s, e1, e2) => let val name = case s of "==" => "eq" @@ -709,8 +710,8 @@ fun process file = | "+" => "plus" | "-" => "minus" | "*" => "times" - | "/" => "div" - | "%" => "mod" + | "/" => (case bi of Int => "divInt" | NotInt => "div") + | "%" => (case bi of Int => "modInt" | NotInt => "mod") | "<" => "lt" | "<=" => "le" | "strcmp" => "strcmp" @@ -1039,12 +1040,12 @@ fun process file = in ((EUnop (s, e), loc), st) end - | EBinop (s, e1, e2) => + | EBinop (bi, s, e1, e2) => let val (e1, st) = exp outer (e1, st) val (e2, st) = exp outer (e2, st) in - ((EBinop (s, e1, e2), loc), st) + ((EBinop (bi, s, e1, e2), loc), st) end | ERecord xets => diff --git a/src/mono.sml b/src/mono.sml index 1d446dda..bf38c0bc 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -68,6 +68,8 @@ datatype export_kind = datatype Export.export_kind datatype failure_mode = datatype Settings.failure_mode +datatype binop_intness = Int | NotInt + datatype exp' = EPrim of Prim.t | ERel of int @@ -81,7 +83,7 @@ datatype exp' = | EAbs of string * typ * typ * exp | EUnop of string * exp - | EBinop of string * exp * exp + | EBinop of binop_intness * string * exp * exp | ERecord of (string * exp * typ) list | EField of exp * string diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 34f43143..d05e38fd 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -536,7 +536,7 @@ fun exp e = | EFfiApp ("Basis", "attrifyString_w", [(EFfiApp ("Basis", "str1", [e]), _)]) => EFfiApp ("Basis", "attrifyChar_w", [e]) - | EBinop ("+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2))) + | EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2))) | _ => e diff --git a/src/mono_print.sml b/src/mono_print.sml index 63c98f44..2d296745 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -187,11 +187,11 @@ fun p_exp' par env (e, _) = | EUnop (s, e) => parenIf true (box [string s, space, p_exp' true env e]) - | EBinop (s, e1, e2) => parenIf true (box [p_exp' true env e1, - space, - string s, - space, - p_exp' true env e2]) + | EBinop (_, s, e1, e2) => parenIf true (box [p_exp' true env e1, + space, + string s, + space, + p_exp' true env e2]) | ERecord xes => box [string "{", p_list (fn (x, e, _) => diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 59ec5a55..f8b209d5 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -92,7 +92,7 @@ fun impure (e, _) = | EApp _ => true | EUnop (_, e) => impure e - | EBinop (_, e1, e2) => impure e1 orelse impure e2 + | EBinop (_, _, e1, e2) => impure e1 orelse impure e2 | ERecord xes => List.exists (fn (_, e, _) => impure e) xes | EField (e, _) => impure e @@ -365,11 +365,21 @@ fun reduce file = val size = U.Exp.fold {typ = fn (_, n) => n, exp = fn (_, n) => n + 1} 0 - fun mayInline (n, e) = + val functionInside' = U.Typ.exists (fn c => case c of + TFun _ => true + | _ => false) + + fun functionInside t = + case #1 t of + TFun (t1, t2) => functionInside' t1 orelse functionInside t2 + | _ => functionInside' t + + fun mayInline (n, e, t) = case IM.find (uses, n) of NONE => false | SOME count => count <= 1 orelse size e <= Settings.getMonoInline () + orelse functionInside t fun summarize d (e, _) = let @@ -426,7 +436,7 @@ fun reduce file = | EAbs _ => [] | EUnop (_, e) => summarize d e - | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2 + | EBinop (_, _, e1, e2) => summarize d e1 @ summarize d e2 | ERecord xets => List.concat (map (summarize d o #2) xets) | EField (e, _) => summarize d e @@ -701,7 +711,7 @@ fun reduce file = let val eo = case eo of NONE => NONE - | SOME e => if mayInline (n, e) then + | SOME e => if mayInline (n, e, t) then SOME e else NONE diff --git a/src/mono_util.sml b/src/mono_util.sml index 56472155..bb09f84d 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -200,12 +200,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (EUnop (s, e'), loc)) - | EBinop (s, e1, e2) => + | EBinop (bi, s, e1, e2) => S.bind2 (mfe ctx e1, fn e1' => S.map2 (mfe ctx e2, fn e2' => - (EBinop (s, e1', e2'), loc))) + (EBinop (bi, s, e1', e2'), loc))) | ERecord xes => S.map2 (ListUtil.mapfold (fn (x, e, t) => diff --git a/src/monoize.sml b/src/monoize.sml index 0c0d9d2e..35c6fa83 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -895,42 +895,42 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + (L'.EBinop (L'.Int, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) | L.EFfi ("Basis", "eq_float") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + (L'.EBinop (L'.NotInt, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) | L.EFfi ("Basis", "eq_bool") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + (L'.EBinop (L'.NotInt, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) | L.EFfi ("Basis", "eq_string") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop ("!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + (L'.EBinop (L'.NotInt, "!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) | L.EFfi ("Basis", "eq_char") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), (L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + (L'.EBinop (L'.NotInt, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) | L.EFfi ("Basis", "eq_time") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + (L'.EBinop (L'.NotInt, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) | L.ECApp ((L.EFfi ("Basis", "mkEq"), _), t) => @@ -999,7 +999,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "int"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "int"), loc), - (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + (L'.EBinop (L'.Int, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in numEx ((L'.TFfi ("Basis", "int"), loc), Prim.Int (Int64.fromInt 0), @@ -1019,7 +1019,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "float"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "float"), loc), - (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in numEx ((L'.TFfi ("Basis", "float"), loc), Prim.Float 0.0, @@ -1086,7 +1086,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + (L'.EBinop (L'.Int, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in ordEx ((L'.TFfi ("Basis", "int"), loc), intBin "<", @@ -1099,7 +1099,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in ordEx ((L'.TFfi ("Basis", "float"), loc), floatBin "<", @@ -1112,7 +1112,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in ordEx ((L'.TFfi ("Basis", "bool"), loc), boolBin "<", @@ -1125,8 +1125,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop (s, - (L'.EBinop ("strcmp", + (L'.EBinop (L'.NotInt, s, + (L'.EBinop (L'.NotInt, "strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc), (L'.EPrim (Prim.Int (Int64.fromInt 0)), loc)), loc)), loc)), loc) @@ -1142,7 +1142,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in ordEx ((L'.TFfi ("Basis", "char"), loc), charBin "<", @@ -1155,7 +1155,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in ordEx ((L'.TFfi ("Basis", "time"), loc), boolBin "<", diff --git a/src/settings.sml b/src/settings.sml index 4c611336..97c39abf 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -171,6 +171,7 @@ val jsFuncsBase = basisM [("alert", "alert"), ("stringToInt_error", "pi"), ("urlifyInt", "ts"), ("urlifyFloat", "ts"), + ("urlifyTime", "ts"), ("urlifyString", "uf"), ("urlifyBool", "ub"), ("recv", "rv"), diff --git a/src/urweb.grm b/src/urweb.grm index 21c4a50c..5803f445 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -1232,7 +1232,9 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) val e = (EApp (e, texp), loc) in if length fields <> length sqlexps then - ErrorMsg.errorAt loc "Length mismatch in INSERT field specification" + ErrorMsg.errorAt loc ("Length mismatch in INSERT field specification (" + ^ Int.toString (length fields) + ^ " vs. " ^ Int.toString (length sqlexps) ^ ")") else (); (EApp (e, (ERecord (ListPair.zip (fields, sqlexps)), loc)), loc) |