Evaluate typed queries over persistent maps

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)

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

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

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

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

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

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

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) );
+  ]

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)