From 35d9cebcc306bb67659b638f3401989a7670fa25 Mon Sep 17 00:00:00 2001 From: milner Date: Fri, 17 Feb 2017 18:21:00 +0000 Subject: [PATCH] Evaluate typed queries over persistent maps --- Makefile | 4 +- runtime/delta_runtime.ml | 90 ++++++++++++++++++++++++ runtime/delta_runtime.mli | 38 +++++++++++ src/interpret.ml | 140 ++++++++++++++++++++++++++++++++++++++ src/interpret.mli | 11 +++ src/value.ml | 45 ++++++++++++ src/value.mli | 15 ++++ test/test_incremental.ml | 122 +++++++++++++++++++++++++++++++++ test/test_main.ml | 1 + 9 files changed, 464 insertions(+), 2 deletions(-) create mode 100644 runtime/delta_runtime.ml create mode 100644 runtime/delta_runtime.mli create mode 100644 src/interpret.ml create mode 100644 src/interpret.mli create mode 100644 src/value.ml create mode 100644 src/value.mli create mode 100644 test/test_incremental.ml diff --git a/Makefile b/Makefile index 3545c7d..120b385 100644 --- a/Makefile +++ b/Makefile @@ -133,7 +133,7 @@ $(LIB_ARCHIVE): $(LIB_CMX) $(BUILD)/order.mk $(OCAMLOPT) -a -o $@ $(LIB_ORDER) deltac: $(BUILD)/main.cmx $(LIB_ARCHIVE) $(RUNTIME_ARCHIVE) - $(OCAMLOPT) $(FLAGS) -o $@ $(LIBS) $(LIB_ARCHIVE) $(RUNTIME_ARCHIVE) $(BUILD)/main.cmx + $(OCAMLOPT) $(FLAGS) -o $@ $(LIBS) $(RUNTIME_ARCHIVE) $(LIB_ARCHIVE) $(BUILD)/main.cmx $(RUNTIME_ARCHIVE) $(RUNTIME_NATIVE): $(RT_CMX) ifeq ($(strip $(RT_ML)),) @@ -146,7 +146,7 @@ ifeq ($(strip $(TEST_ML)),) TEST_EXE = else $(TEST_EXE): $(TEST_CMX) $(LIB_ARCHIVE) $(RUNTIME_ARCHIVE) - $(OCAMLOPT) $(FLAGS) -o $@ $(LIBS) $(LIB_ARCHIVE) $(RUNTIME_ARCHIVE) $(TEST_ORDER) + $(OCAMLOPT) $(FLAGS) -o $@ $(LIBS) $(RUNTIME_ARCHIVE) $(LIB_ARCHIVE) $(TEST_ORDER) endif test: $(TEST_EXE) diff --git a/runtime/delta_runtime.ml b/runtime/delta_runtime.ml new file mode 100644 index 0000000..c4ac063 --- /dev/null +++ b/runtime/delta_runtime.ml @@ -0,0 +1,90 @@ +module Pure_map = struct + module Ordered = struct + type t = int + + let compare left right = if left < right then -1 else if left > right then 1 else 0 + end + + module Map = Map.Make (Ordered) + + type 'a t = 'a Map.t + + let empty = Map.empty + + let add key value map = Map.add key value map + + let remove key map = Map.remove key map + + let find key map = Map.find key map + + let find_opt key map = try Some (Map.find key map) with Not_found -> None + + let mem key map = Map.mem key map + + let cardinal map = Map.cardinal map + + let is_empty map = Map.is_empty map + + let bindings map = Map.bindings map + + let fold f map init = Map.fold f map init + + let iter f map = Map.iter f map + + let map f map = Map.map f map + + let keys map = Map.fold (fun key _ acc -> key :: acc) map [] |> List.rev + + let equal equal_value left right = Map.equal equal_value left right +end + +type counters = { + mutable predicate_evaluations : int; + mutable mapping_evaluations : int; + mutable changed_key_visits : int; + mutable full_traversals : int; + mutable scalar_deltas : int; +} + +let new_counters () = + { + predicate_evaluations = 0; + mapping_evaluations = 0; + changed_key_visits = 0; + full_traversals = 0; + scalar_deltas = 0; + } + +let copy_counters counters = + { + predicate_evaluations = counters.predicate_evaluations; + mapping_evaluations = counters.mapping_evaluations; + changed_key_visits = counters.changed_key_visits; + full_traversals = counters.full_traversals; + scalar_deltas = counters.scalar_deltas; + } + +let reset_counters counters = + counters.predicate_evaluations <- 0; + counters.mapping_evaluations <- 0; + counters.changed_key_visits <- 0; + counters.full_traversals <- 0; + counters.scalar_deltas <- 0 + +let count_predicate counters = counters.predicate_evaluations <- counters.predicate_evaluations + 1 + +let count_mapping counters = counters.mapping_evaluations <- counters.mapping_evaluations + 1 + +let count_changed_key counters = counters.changed_key_visits <- counters.changed_key_visits + 1 + +let count_full_traversal counters = counters.full_traversals <- counters.full_traversals + 1 + +let count_scalar_delta counters = counters.scalar_deltas <- counters.scalar_deltas + 1 + +let counters_to_string counters = + Printf.sprintf + "predicate_evaluations=%d mapping_evaluations=%d changed_key_visits=%d full_traversals=%d scalar_deltas=%d" + counters.predicate_evaluations counters.mapping_evaluations counters.changed_key_visits + counters.full_traversals counters.scalar_deltas + +type 'a outcome = Success of 'a | Failure of string diff --git a/runtime/delta_runtime.mli b/runtime/delta_runtime.mli new file mode 100644 index 0000000..4bbf51d --- /dev/null +++ b/runtime/delta_runtime.mli @@ -0,0 +1,38 @@ +module Pure_map : sig + type 'a t + + val empty : 'a t + val add : int -> 'a -> 'a t -> 'a t + val remove : int -> 'a t -> 'a t + val find : int -> 'a t -> 'a + val find_opt : int -> 'a t -> 'a option + val mem : int -> 'a t -> bool + val cardinal : 'a t -> int + val is_empty : 'a t -> bool + val bindings : 'a t -> (int * 'a) list + val fold : (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val iter : (int -> 'a -> unit) -> 'a t -> unit + val map : ('a -> 'b) -> 'a t -> 'b t + val keys : 'a t -> int list + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool +end + +type counters = { + mutable predicate_evaluations : int; + mutable mapping_evaluations : int; + mutable changed_key_visits : int; + mutable full_traversals : int; + mutable scalar_deltas : int; +} + +val new_counters : unit -> counters +val copy_counters : counters -> counters +val reset_counters : counters -> unit +val count_predicate : counters -> unit +val count_mapping : counters -> unit +val count_changed_key : counters -> unit +val count_full_traversal : counters -> unit +val count_scalar_delta : counters -> unit +val counters_to_string : counters -> string + +type 'a outcome = Success of 'a | Failure of string diff --git a/src/interpret.ml b/src/interpret.ml new file mode 100644 index 0000000..4fbaa21 --- /dev/null +++ b/src/interpret.ml @@ -0,0 +1,140 @@ +type env = { + helpers : (int * Typed.expr) list; + values : (int * Value.t) list; +} + +let empty_env helpers = { helpers = helpers; values = [] } + +let helpers_of_program program = + List.map + (fun helper -> (Ident.stamp helper.Typed.th_ident, helper.Typed.th_body)) + program.Typed.tp_helpers + +let bind env ident value = { env with values = (Ident.stamp ident, value) :: env.values } + +let lookup env ident = + let rec search = function + | [] -> None + | (stamp, value) :: rest -> if stamp = Ident.stamp ident then Some value else search rest + in + search env.values + +let int_of span value = + match value with + | Value.VInt number -> number + | other -> Diagnostic.error span "runtime error: expected an integer but got %s" (Value.to_string other) + +let bool_of span value = + match value with + | Value.VBool truth -> truth + | other -> Diagnostic.error span "runtime error: expected a boolean but got %s" (Value.to_string other) + +let collection_of span value = + match value with + | Value.VCollection map -> map + | other -> Diagnostic.error span "runtime error: expected a collection but got %s" (Value.to_string other) + +let rec eval env expr = + let span = expr.Typed.tspan in + match expr.Typed.te with + | Typed.TInt value -> Value.VInt value + | Typed.TBool value -> Value.VBool value + | Typed.TString value -> Value.VString value + | Typed.TUnit -> Value.VUnit + | Typed.TVar ident -> ( + match lookup env ident with + | Some value -> value + | None -> Diagnostic.error span "runtime error: `%s` has no value" (Ident.display ident)) + | Typed.TSource ident -> ( + match lookup env ident with + | Some value -> value + | None -> Diagnostic.error span "runtime error: the input collection has no value") + | Typed.TLet (ident, bound, body) -> eval (bind env ident (eval env bound)) body + | Typed.TLambda _ -> + Diagnostic.error span "runtime error: a function cannot be used as a value" + | Typed.TApp (fn, argument) -> apply env fn (eval env argument) + | Typed.TIf (condition, then_branch, else_branch) -> + if bool_of condition.Typed.tspan (eval env condition) then eval env then_branch + else eval env else_branch + | Typed.TBinop (Syntax.And, left, right) -> + if bool_of left.Typed.tspan (eval env left) then Value.VBool (bool_of right.Typed.tspan (eval env right)) + else Value.VBool false + | Typed.TBinop (Syntax.Or, left, right) -> + if bool_of left.Typed.tspan (eval env left) then Value.VBool true + else Value.VBool (bool_of right.Typed.tspan (eval env right)) + | Typed.TBinop (operator, left, right) -> + eval_binop span operator (eval env left) (eval env right) + | Typed.TTuple items -> Value.VTuple (List.map (eval env) items) + | Typed.TRecord (name, fields) -> + Value.VRecord (name, List.map (fun (label, value) -> (label, eval env value)) fields) + | Typed.TField (record, label) -> ( + match Value.field (eval env record) label with + | Some value -> value + | None -> Diagnostic.error span "runtime error: the record has no field `%s`" label) + | Typed.TFilter (collection, predicate) -> + let map = collection_of collection.Typed.tspan (eval env collection) in + let kept = + Delta_runtime.Pure_map.fold + (fun key value acc -> + if bool_of predicate.Typed.tspan (apply env predicate value) then + Delta_runtime.Pure_map.add key value acc + else acc) + map Delta_runtime.Pure_map.empty + in + Value.VCollection kept + | Typed.TMap (collection, projection) -> + let map = collection_of collection.Typed.tspan (eval env collection) in + let mapped = + Delta_runtime.Pure_map.fold + (fun key value acc -> + Delta_runtime.Pure_map.add key (apply env projection value) acc) + map Delta_runtime.Pure_map.empty + in + Value.VCollection mapped + | Typed.TSum collection -> + let map = collection_of collection.Typed.tspan (eval env collection) in + let total = + Delta_runtime.Pure_map.fold + (fun _ value acc -> acc + int_of collection.Typed.tspan value) + map 0 + in + Value.VInt total + | Typed.TCount collection -> + let map = collection_of collection.Typed.tspan (eval env collection) in + Value.VInt (Delta_runtime.Pure_map.cardinal map) + +and apply env fn argument = + match fn.Typed.te with + | Typed.TLambda (ident, body) -> eval (bind env ident argument) body + | Typed.TVar ident -> ( + match Util.assoc_opt (Ident.stamp ident) env.helpers with + | Some body -> apply env body argument + | None -> + Diagnostic.error fn.Typed.tspan "runtime error: `%s` is not a function" (Ident.display ident)) + | _ -> Diagnostic.error fn.Typed.tspan "runtime error: this expression is not a function" + +and eval_binop span operator left right = + match operator with + | Syntax.Add -> Value.VInt (int_of span left + int_of span right) + | Syntax.Sub -> Value.VInt (int_of span left - int_of span right) + | Syntax.Mul -> Value.VInt (int_of span left * int_of span right) + | Syntax.Div -> Value.VInt (int_of span left / int_of span right) + | Syntax.Eq -> Value.VBool (Value.equal left right) + | Syntax.Ne -> Value.VBool (not (Value.equal left right)) + | Syntax.Lt -> Value.VBool (int_of span left < int_of span right) + | Syntax.Le -> Value.VBool (int_of span left <= int_of span right) + | Syntax.Gt -> Value.VBool (int_of span left > int_of span right) + | Syntax.Ge -> Value.VBool (int_of span left >= int_of span right) + | Syntax.And | Syntax.Or -> Diagnostic.error span "runtime error: boolean operator evaluated eagerly" + +let call env fn argument = apply env fn argument + +let program typed input = + let map = Value.collection_of_list input in + let env = + { + helpers = helpers_of_program typed; + values = [ (Ident.stamp typed.Typed.tp_input, Value.VCollection map) ]; + } + in + eval env typed.Typed.tp_query_body diff --git a/src/interpret.mli b/src/interpret.mli new file mode 100644 index 0000000..ca248c4 --- /dev/null +++ b/src/interpret.mli @@ -0,0 +1,11 @@ +type env = { + helpers : (int * Typed.expr) list; + values : (int * Value.t) list; +} + +val empty_env : (int * Typed.expr) list -> env +val helpers_of_program : Typed.program -> (int * Typed.expr) list +val bind : env -> Ident.t -> Value.t -> env +val eval : env -> Typed.expr -> Value.t +val call : env -> Typed.expr -> Value.t -> Value.t +val program : Typed.program -> (int * Value.t) list -> Value.t diff --git a/src/value.ml b/src/value.ml new file mode 100644 index 0000000..7fa2d93 --- /dev/null +++ b/src/value.ml @@ -0,0 +1,45 @@ +type t = + | VUnit + | VInt of int + | VBool of bool + | VString of string + | VTuple of t list + | VRecord of string * (string * t) list + | VCollection of t Delta_runtime.Pure_map.t + +let rec to_string value = + match value with + | VUnit -> "unit" + | VInt number -> string_of_int number + | VBool true -> "true" + | VBool false -> "false" + | VString text -> Printf.sprintf "%S" text + | VTuple items -> "(tuple " ^ Util.join " " (List.map to_string items) ^ ")" + | VRecord (name, fields) -> + Printf.sprintf "(record:%s %s)" name + (Util.join " " (List.map (fun (label, field) -> "(" ^ label ^ " " ^ to_string field ^ ")") fields)) + | VCollection map -> + let entries = + List.map (fun (key, item) -> Printf.sprintf "(%d %s)" key (to_string item)) + (Delta_runtime.Pure_map.bindings map) + in + "(collection " ^ Util.join " " entries ^ ")" + +let collection_of_list entries = + List.fold_left + (fun map (key, value) -> + if Delta_runtime.Pure_map.mem key map then + Diagnostic.error Location.none "duplicate key %d in the initial input" key; + Delta_runtime.Pure_map.add key value map) + Delta_runtime.Pure_map.empty entries + +let collection_to_list map = Delta_runtime.Pure_map.bindings map + +let equal (left : t) (right : t) = left = right + +let field record label = + match record with + | VRecord (_, fields) -> Util.assoc_opt label fields + | _ -> None + +let is_collection = function VCollection _ -> true | _ -> false diff --git a/src/value.mli b/src/value.mli new file mode 100644 index 0000000..690d021 --- /dev/null +++ b/src/value.mli @@ -0,0 +1,15 @@ +type t = + | VUnit + | VInt of int + | VBool of bool + | VString of string + | VTuple of t list + | VRecord of string * (string * t) list + | VCollection of t Delta_runtime.Pure_map.t + +val to_string : t -> string +val collection_of_list : (int * t) list -> t Delta_runtime.Pure_map.t +val collection_to_list : t Delta_runtime.Pure_map.t -> (int * t) list +val equal : t -> t -> bool +val field : t -> string -> t option +val is_collection : t -> bool diff --git a/test/test_incremental.ml b/test/test_incremental.ml new file mode 100644 index 0000000..4debeb6 --- /dev/null +++ b/test/test_incremental.ml @@ -0,0 +1,122 @@ +open Test_harness + +let row customer total = Value.VRecord ("order", [ ("customer", Value.VString customer); ("total", Value.VInt total) ]) + +let input entries = List.mapi (fun index entry -> (index + 1, entry)) entries + +let run fixture_name entries = + let program = infer (read_fixture fixture_name) in + Interpret.program program (input entries) + +let run_text text entries = + let program = infer text in + Interpret.program program (input entries) + +let cases = + [ + ( "the example query selects and projects rows", + fun () -> + let result = + run "expensive_order.delta" + [ row "Ada" 1500; row "Bo" 900; row "Lin" 2200 ] + in + check_equal_string "result" "(collection (1 (tuple \"Ada\" 300)) (3 (tuple \"Lin\" 440)))" + (Value.to_string result) ); + ( "a filter that keeps nothing yields an empty collection", + fun () -> + let result = run "expensive_order.delta" [ row "Bo" 10 ] in + check_equal_string "empty" "(collection )" (Value.to_string result) ); + ( "an empty input yields an empty collection and zero aggregates", + fun () -> + check_equal_string "no rows" "(collection )" (Value.to_string (run "expensive_order.delta" [])); + check_equal_int "revenue" 0 + (match run "revenue.delta" [] with Value.VInt total -> total | _ -> -1); + check_equal_int "count" 0 + (match run "count_large.delta" [] with Value.VInt total -> total | _ -> -1) ); + ( "revenue sums the taxed totals", + fun () -> + let result = run "revenue.delta" [ row "Ada" 1000; row "Bo" 250 ] in + check_equal_string "revenue" "250" (Value.to_string result) ); + ( "count_large counts the retained rows", + fun () -> + let result = run "count_large.delta" [ row "Ada" 1000; row "Bo" 250; row "Lin" 501 ] in + check_equal_string "count" "2" (Value.to_string result) ); + ( "negative values are preserved", + fun () -> + let result = + run_text "input rows : collection int\nquery q = rows |> filter (fun r -> r < 0) |> sum\n" + [ Value.VInt (-5); Value.VInt 3; Value.VInt (-7) ] + in + check_equal_string "sum" "-12" (Value.to_string result) ); + ( "integer division truncates towards zero", + fun () -> + let result = run_text "input rows : collection int\nquery q = rows |> map (fun r -> r / 3) |> sum\n" + [ Value.VInt 10; Value.VInt (-10) ] + in + check_equal_string "sum" "0" (Value.to_string result) ); + ( "division by zero is a runtime error", + fun () -> + (try + ignore (run_text "input rows : collection int\nquery q = rows |> map (fun r -> 100 / r) |> sum\n" + [ Value.VInt 5; Value.VInt 0 ]); + fail "division" "expected a runtime error" + with Division_by_zero -> check "raised" true) ); + ( "the mapping expression runs only where the filter keeps rows", + fun () -> + let result = + run_text "input rows : collection int\nquery q = rows |> filter (fun r -> r > 10) |> map (fun r -> 1000 / r) |> sum\n" + [ Value.VInt 5; Value.VInt 20 ] + in + check_equal_string "sum" "50" (Value.to_string result) ); + ( "boolean operators short circuit", + fun () -> + let result = + run_text "input rows : collection int\nquery q = rows |> count\n" + [ Value.VInt 1 ] + in + check_equal_string "count" "1" (Value.to_string result); + let result = + run_text "input rows : collection int\nquery q = rows |> filter (fun r -> false && 1 / r > 0) |> count\n" + [ Value.VInt 0 ] + in + check_equal_string "short circuit and" "0" (Value.to_string result); + let result = + run_text "input rows : collection int\nquery q = rows |> filter (fun r -> true || 1 / r > 0) |> count\n" + [ Value.VInt 0 ] + in + check_equal_string "short circuit or" "1" (Value.to_string result) ); + ( "map preserves keys and filter keeps the original keys", + fun () -> + let result = + run_text "input rows : collection int\nquery q = rows |> filter (fun r -> r > 1) |> map (fun r -> r * 10)\n" + [ Value.VInt 1; Value.VInt 2; Value.VInt 3 ] + in + check_equal_string "keys" "(collection (2 20) (3 30))" (Value.to_string result) ); + ( "helpers are applied at their call sites", + fun () -> + let result = + run_text + "input rows : collection int\nlet scale n = n * 3\nlet offset n = scale n + 1\nquery q = rows |> map offset |> sum\n" + [ Value.VInt 1; Value.VInt 2 ] + in + check_equal_string "sum" "11" (Value.to_string result) ); + ( "records and tuples are compared structurally", + fun () -> + let result = + run_text + "type pair = { first : int; second : int }\ninput rows : collection pair\nquery q = rows |> filter (fun r -> r = { first = 1; second = 2 }) |> count\n" + [ Value.VRecord ("pair", [ ("first", Value.VInt 1); ("second", Value.VInt 2) ]); Value.VRecord ("pair", [ ("first", Value.VInt 2); ("second", Value.VInt 1) ]) ] + in + check_equal_string "count" "1" (Value.to_string result) ); + ( "a constant query ignores the input", + fun () -> + let result = run_text "input rows : collection int\nquery q = 6 * 7\n" [ Value.VInt 1 ] in + check_equal_string "constant" "42" (Value.to_string result) ); + ( "out of range arithmetic follows machine integers", + fun () -> + let result = + run_text "input rows : collection int\nquery q = rows |> sum\n" + [ Value.VInt max_int; Value.VInt 1 ] + in + check_equal_string "wrapped" (string_of_int min_int) (Value.to_string result) ); + ] diff --git a/test/test_main.ml b/test/test_main.ml index 2a98865..96ee292 100644 --- a/test/test_main.ml +++ b/test/test_main.ml @@ -374,5 +374,6 @@ let () = Test_harness.run_suite "program" program_cases; Test_harness.run_suite "resolve" resolve_cases; Test_harness.run_suite "types" Test_type.cases; + Test_harness.run_suite "interpret" Test_incremental.cases; Printf.printf "%d cases, %d failures\n" (Test_harness.case_count ()) (Test_harness.failure_count ()); exit (if Test_harness.failure_count () = 0 then 0 else 1)