From d6d46e14a78cc387a7283e02759c11c4b90e65cb Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 8 Nov 2023 15:28:41 +0100 Subject: [PATCH 01/57] Typos --- ELPI.md | 4 ++-- INCOMPATIBILITIES.md | 4 ++-- README.md | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/ELPI.md b/ELPI.md index 5ba8b5054..41c07ccad 100644 --- a/ELPI.md +++ b/ELPI.md @@ -66,7 +66,7 @@ trivial-facts :- ``` Side note: no solution is computed for goals like `_ = something`. -On the contrary a problem like `DummyNameUsedOnlyOnce = somthing` demands the +On the contrary a problem like `DummyNameUsedOnlyOnce = something` demands the computation of the solution (even if it is not used), and hence can *fail* if some variable occurring in something is out of scope for `DummyNameUsedOnlyOnce`. @@ -618,7 +618,7 @@ syntax `{{:name` .. `}}` where `name` is any non-space or `\n` character. Quotations are elaborated before run-time. The [coq-elpi](https://github.com/LPCIC/coq-elpi) software embeds elpi -in Coq and provides a quatation for its terms. For example +in Coq and provides a quotation for its terms. For example ```prolog {{ nat -> bool }} ``` diff --git a/INCOMPATIBILITIES.md b/INCOMPATIBILITIES.md index ce581d932..7af327595 100644 --- a/INCOMPATIBILITIES.md +++ b/INCOMPATIBILITIES.md @@ -1,7 +1,7 @@ Known incompatibilities with Teyjus =================================== -This file tries to summarise known incompatibilities between Elpi and Teyjus. +This file tries to summarize known incompatibilities between Elpi and Teyjus. # Semantics @@ -37,7 +37,7 @@ This file tries to summarise known incompatibilities between Elpi and Teyjus. - Module signatures are ignored. - Elpi accumulates each file once; Teyjus does it multiple times, that is always bad (all clauses are duplicated and tried multiple times, that is - rarely the expected behaviour). + rarely the expected behavior). - Elpi understands relative paths as in `accumulate "../foo"`: resolution of relative paths is done according to the path of the accumulating file first or, if it fails, according to the TJPATH. diff --git a/README.md b/README.md index 5152d2139..526e49484 100644 --- a/README.md +++ b/README.md @@ -134,7 +134,7 @@ The elaborator manipulates terms with binders and holes (unification variables) representing missing piece of information. Some of them have to be filled in order to make the term well typed. Some others are filled in because -the user has programmed the eleborator to do so, e.g. ad-hoc polymorphism. +the user has programmed the elaborator to do so, e.g. ad-hoc polymorphism. Such software component is characterized by an high complexity coming from the interplay of binders, reduction and unification, From d62f0a32e4a57dbb2c255695b9237523e151be5a Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Thu, 9 Nov 2023 16:46:01 +0100 Subject: [PATCH 02/57] Start trie implementation --- src/compiler.ml | 19 ++- src/data.ml | 16 ++ src/dune | 4 +- src/path_trie.ml | 18 ++ src/runtime.ml | 99 ++++++++--- src/trie.ml | 148 ++++++++++++++++ src/trie.mli | 20 +++ src/utils/discrimination_tree.ml | 280 +++++++++++++++++++++++++++++++ 8 files changed, 570 insertions(+), 34 deletions(-) create mode 100644 src/path_trie.ml create mode 100644 src/trie.ml create mode 100644 src/trie.mli create mode 100644 src/utils/discrimination_tree.ml diff --git a/src/compiler.ml b/src/compiler.ml index e442f5651..928e80c78 100644 --- a/src/compiler.ml +++ b/src/compiler.ml @@ -2358,14 +2358,14 @@ let compile_clause modes initial_depth state state, cl let chose_indexing state predicate l = - let rec all_zero = function - | [] -> true - | 0 :: l -> all_zero l - | _ -> false in - let rec aux n = function + let all_zero = List.for_all ((=) 0) in + let rec aux argno = function + (* TODO: @FissoreD here we should raise an error if n > arity of the predicate? *) | [] -> error ("Wrong indexing for " ^ Symbols.show state predicate) - | 0 :: l -> aux (n+1) l - | 1 :: l when all_zero l -> MapOn n + | 0 :: l -> aux (argno+1) l + | 1 :: l when all_zero l -> MapOn argno + (* TODO: 33 is a random number chosen for indexing with tries *) + | 33 :: l when all_zero l -> Trie argno | _ -> Hash l in aux 0 l @@ -2406,7 +2406,10 @@ let run let mode = try C.Map.find name modes with Not_found -> [] in let declare_index, index = match tindex with - | Some (Ast.Structured.Index l) -> true, chose_indexing state name l + | Some (Ast.Structured.Index l) -> + (* TODO: @FissoreD should we assert (length l <= length mode) + for example if we have :index (1 0 0 1) pred binary i:int, i:int ? *) + true, chose_indexing state name l | _ -> false, chose_indexing state name [1] in try let _, old_tindex = C.Map.find name map in diff --git a/src/data.ml b/src/data.ml index 5f10aa804..7a0f6967e 100644 --- a/src/data.ml +++ b/src/data.ml @@ -148,6 +148,11 @@ and second_lvl_idx = time : int; (* time is used to recover the total order *) args_idx : (clause * int) list Ptmap.t; (* clause, insertion time *) } +| IndexWithTrie of { + mode : mode; + argno : int; + args_idx : (clause list) Path_trie.PathTrie.t; +} and clause = { depth : int; args : term list; @@ -167,9 +172,20 @@ type suspended_goal = { goal : int * term } +(** + Used to index the parameters of a predicate P + - [MapOn N] -> Indexing is done by unifying the Nth parameter of P with the + query + - [Hash L] -> L is the list of depths given by the urer for the parameters of + P. Indexing is done by hashing all the parameters with a non + zero depth and comparing it with the hashing of the parameters + of the query + - [IndexWithTrie N] -> Indexing is done on the Nth parameter using tries +*) type indexing = | MapOn of int | Hash of int list + | Trie of int [@@deriving show] let mkLam x = Lam x [@@inline] diff --git a/src/dune b/src/dune index dd67874c9..a1e35b612 100644 --- a/src/dune +++ b/src/dune @@ -14,11 +14,11 @@ ; ----- public API --------------------------------- elpi API builtin builtin_checker ; ----- internal stuff ----------------------------- - compiler data ptmap runtime_trace_off runtime + compiler data ptmap trie path_trie runtime_trace_off runtime builtin_stdlib builtin_map builtin_set legacy_parser_proxy) (private_modules - compiler data ptmap runtime_trace_off runtime + compiler data ptmap trie path_trie runtime_trace_off runtime builtin_stdlib builtin_map builtin_set legacy_parser_proxy) ) diff --git a/src/path_trie.ml b/src/path_trie.ml new file mode 100644 index 000000000..596ae7731 --- /dev/null +++ b/src/path_trie.ml @@ -0,0 +1,18 @@ +type 'a path_string_elem = + | Constant of 'a * int + | Variable + +type 'a path = ('a path_string_elem) + +module Indexable = struct + type c + type t = c path +end + +module OrderedPath = struct + type t = Indexable.t + let compare = compare +end + +module Dummy = Map.Make(OrderedPath) +module PathTrie = Trie.Make(Dummy) \ No newline at end of file diff --git a/src/runtime.ml b/src/runtime.ml index 586e7a595..c724db237 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2286,10 +2286,12 @@ let ppclause f ~hd { depth; args = args; hyps = hyps } = (uppterm ~min_prec:(Elpi_parser.Parser_config.appl_precedence+1) depth [] ~argsdepth:0 empty_env) (C.mkAppL hd args) (pplist (uppterm ~min_prec:(Elpi_parser.Parser_config.appl_precedence+1) depth [] ~argsdepth:0 empty_env) ", ") hyps +(** [tail_opt L] returns: [match L with [] -> [] | x :: xs -> xs] *) let tail_opt = function | [] -> [] | _ :: xs -> xs +(** [hd_opt L] returns false if L = [[]] otherwise L.(0) *) let hd_opt = function | b :: _ -> b | _ -> false @@ -2315,6 +2317,14 @@ let rec classify_clause_arg ~depth matching t = if hash > mustbevariablec then Rigid (hash,matching) else Rigid (hash+1,matching) +(** + [classify_clause_argno ~depth N mode L] + where L is the arguments of the clause. + Returns the classification of the Nth element of L wrt to the Nth mode. +*) +(* QUESTION: why do not simply List.nth argno modes of L. I think that mode and + and N should (len(L) = len(mode) < N). Is is true ? +*) let rec classify_clause_argno ~depth argno mode = function | [] -> Variable | x :: _ when argno == 0 -> classify_clause_arg ~depth (hd_opt mode) x @@ -2331,7 +2341,11 @@ let dec_to_bin2 num = let hash_bits = Sys.int_size - 1 (* the sign *) -let hash_arg_list goal hd ~depth args mode spec = +(** + Hashing function for clause and queries depending on the boolean [is_goal]. + This is done by hashing the parameters wrt to Sys.int_size - 1 (see [hash_bits]) +*) +let hash_arg_list is_goal hd ~depth args mode spec = let nargs = List.(length (filter (fun x -> x > 0) spec)) in (* we partition equally, that may not be smart, but is simple ;-) *) let arg_size = hash_bits / nargs in @@ -2368,9 +2382,9 @@ let hash_arg_list goal hd ~depth args mode spec = (hash size k) lor (shift 1 (self x)) lor List.(fold_left (lor) 0 (mapi (fun i x -> shift (i+2) (self x)) xs)) - | (UVar _ | AppUVar _) when matching && goal -> hash size mustbevariablec + | (UVar _ | AppUVar _) when matching && is_goal -> hash size mustbevariablec | (UVar _ | AppUVar _) when matching -> all_1 size - | (UVar _ | AppUVar _) -> if goal then all_0 size else all_1 size + | (UVar _ | AppUVar _) -> if is_goal then all_0 size else all_1 size | (Arg _ | AppArg _) -> all_1 size | Nil -> hash size Global_symbols.nilc | Cons (x,xs) -> @@ -2390,7 +2404,7 @@ let hash_arg_list goal hd ~depth args mode spec = in [%spy "dev:index:subhash" ~rid (fun fmt () -> Fmt.fprintf fmt "%s: %d: %s: %a" - (if goal then "goal" else "clause") + (if is_goal then "goal" else "clause") size (dec_to_bin2 h) (uppterm depth [] ~argsdepth:0 empty_env) arg) ()]; @@ -2399,7 +2413,7 @@ let hash_arg_list goal hd ~depth args mode spec = let h = aux 0 0 args mode spec in [%spy "dev:index:hash" ~rid (fun fmt () -> Fmt.fprintf fmt "%s: %s: %a" - (if goal then "goal" else "clause") + (if is_goal then "goal" else "clause") (dec_to_bin2 h) (pplist ~boxed:true (uppterm depth [] ~argsdepth:0 empty_env) " ") (Const hd :: args)) ()]; @@ -2408,11 +2422,20 @@ let hash_arg_list goal hd ~depth args mode spec = let hash_clause_arg_list = hash_arg_list false let hash_goal_arg_list = hash_arg_list true +(* bool -> constant -> depth:constant -> term list -> bool list ->constant list -> constant *) +let build_trie_list (is_goal : bool) (hd: constant) ~(depth: constant) + (args: term list) (mode: bool list) (spec : int) : Path_trie.PathTrie.key = + let build_path (term : term) = + match term with + | _ -> [Path_trie.Variable] + in + build_path (List.nth args spec) + let add1clause ~depth m (predicate,clause) = match Ptmap.find predicate m with | TwoLevelIndex { all_clauses; argno; mode; flex_arg_clauses; arg_idx } -> - (* X matches both rigid and flexible terms *) begin match classify_clause_argno ~depth argno mode clause.args with + (* X: matches both rigid and flexible terms *) | Variable -> Ptmap.add predicate (TwoLevelIndex { argno; mode; @@ -2421,7 +2444,7 @@ let add1clause ~depth m (predicate,clause) = arg_idx = Ptmap.map (fun l_rev -> clause :: l_rev) arg_idx; }) m | MustBeVariable -> - (* uvar matches only flexible terms (or itself at the meta level) *) + (* uvar: matches only flexible terms (or itself at the meta level) *) let l_rev = try Ptmap.find mustbevariablec arg_idx with Not_found -> flex_arg_clauses in @@ -2432,7 +2455,7 @@ let add1clause ~depth m (predicate,clause) = arg_idx = Ptmap.add mustbevariablec (clause::l_rev) arg_idx; }) m | Rigid (arg_hd,matching) -> - (* a rigid term matches flexible terms only in unification mode *) + (* t: a rigid term matches flexible terms only in unification mode *) let l_rev = try Ptmap.find arg_hd arg_idx with Not_found -> flex_arg_clauses in @@ -2455,6 +2478,16 @@ let add1clause ~depth m (predicate,clause) = time = time + 1; args_idx = Ptmap.add hash ((clause,time) :: clauses) args_idx }) m + | IndexWithTrie {mode; argno; args_idx} -> + let trie_path = build_trie_list true ~depth predicate clause.args mode argno in + let clauses = + try Path_trie.PathTrie.find trie_path args_idx + with Not_found -> [] in + Ptmap.add predicate (IndexWithTrie { + mode; argno; + (* TODO: is the order of the clauses respected ? *) + args_idx = Path_trie.PathTrie.add trie_path (clause :: clauses) args_idx + }) m | exception Not_found -> match classify_clause_argno ~depth 0 [] clause.args with | Variable -> @@ -2486,22 +2519,27 @@ let add_clauses ~depth clauses p = let make_index ~depth ~indexing ~clauses_rev:p = let m = C.Map.fold (fun predicate (mode, indexing) m -> - match indexing with - | Hash args -> - Ptmap.add predicate (BitHash { - args; - mode; - time = min_int; - args_idx = Ptmap.empty; - }) m - | MapOn argno -> - Ptmap.add predicate (TwoLevelIndex { - argno; - mode; - all_clauses = []; - flex_arg_clauses = []; - arg_idx = Ptmap.empty; - }) m) indexing Ptmap.empty in + Ptmap.add predicate + begin + match indexing with + | Hash args -> BitHash { + args; + mode; + time = min_int; + args_idx = Ptmap.empty; + } + | MapOn argno -> TwoLevelIndex { + argno; + mode; + all_clauses = []; + flex_arg_clauses = []; + arg_idx = Ptmap.empty; + } + | Trie argno -> IndexWithTrie { + argno; mode; + args_idx = Path_trie.PathTrie.empty; + } + end m) indexing Ptmap.empty in { index = add_clauses ~depth p m; src = [] } let add_clauses ~depth clauses clauses_src { index; src } = @@ -2545,6 +2583,12 @@ let hash_goal_args ~depth mode args goal = | App(k,x,xs) -> hash_goal_arg_list k ~depth (x::xs) mode args | _ -> assert false +let trie_goal_args ~depth mode args goal : Path_trie.PathTrie.key = + match goal with + | Const _ -> [Path_trie.Variable] + | App(k,x,xs) -> build_trie_list true k ~depth (x::xs) mode args + | _ -> assert false + let get_clauses ~depth predicate goal { index = m } = let rc = try @@ -2560,9 +2604,15 @@ let get_clauses ~depth predicate goal { index = m } = let hash = hash_goal_args ~depth mode args goal in let cl = List.flatten (Ptmap.find_unifiables hash args_idx) in List.(map fst (sort (fun (_,cl1) (_,cl2) -> cl2 - cl1) cl)) + | IndexWithTrie {argno; mode; args_idx} -> + (* TODO: is goal the right argument to pass *) + let trie_path = build_trie_list true ~depth predicate [goal] mode argno in + try Path_trie.PathTrie.find trie_path args_idx + with Not_found -> [] with Not_found -> [] in [%log "get_clauses" ~rid (C.show predicate) (List.length rc)]; + [%spy "dev:get_clauses" ~rid C.pp predicate pp_int (List.length rc)]; rc (* flatten_snd = List.flatten o (List.map ~~snd~~) *) @@ -2777,6 +2827,7 @@ let clausify ~loc { index } ~depth t = match Ptmap.find x index with | TwoLevelIndex { mode } -> mode | BitHash { mode } -> mode + | IndexWithTrie { mode } -> mode | exception Not_found -> [] in let l = split_conj ~depth t in let clauses, program, lcs = diff --git a/src/trie.ml b/src/trie.ml new file mode 100644 index 000000000..779046002 --- /dev/null +++ b/src/trie.ml @@ -0,0 +1,148 @@ +(* + * Trie: maps over lists. + * Copyright (C) 2000 Jean-Christophe FILLIATRE + * + * This software is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library General Public + * License version 2, as published by the Free Software Foundation. + * + * This software is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * + * See the GNU Library General Public License version 2 for more details + * (enclosed in the file LGPL). + *) + +(*s A trie is a tree-like structure to implement dictionaries over + keys which have list-like structures. The idea is that each node + branches on an element of the list and stores the value associated + to the path from the root, if any. Therefore, a trie can be + defined as soon as a map over the elements of the list is + given. *) + + +module Make (M : Map.S) = struct + +(*s Then a trie is just a tree-like structure, where a possible + information is stored at the node (['a option]) and where the sons + are given by a map from type [key] to sub-tries, so of type + ['a t M.t]. The empty trie is just the empty map. *) + + type key = M.key list + + type 'a t = Node of 'a option * 'a t M.t + + let empty = Node (None, M.empty) + +(*s To find a mapping in a trie is easy: when all the elements of the + key have been read, we just inspect the optional info at the + current node; otherwise, we descend in the appropriate sub-trie + using [M.find]. *) + + let rec find l t = match (l,t) with + | [], Node (None,_) -> raise Not_found + | [], Node (Some v,_) -> v + | x::r, Node (_,m) -> find r (M.find x m) + + let mem l t = + try Fun.const true (find l t) with Not_found -> false + +(*s Insertion is more subtle. When the final node is reached, we just + put the information ([Some v]). Otherwise, we have to insert the + binding in the appropriate sub-trie [t']. But it may not exists, + and in that case [t'] is bound to an empty trie. Then we get a new + sub-trie [t''] by a recursive insertion and we modify the + branching, so that it now points to [t''], with [M.add]. *) + + let add l v t = + let rec ins = function + | [], Node (_,m) -> Node (Some v,m) + | x::r, Node (v,m) -> + let t' = try M.find x m with Not_found -> empty in + let t'' = ins (r,t') in + Node (v, M.add x t'' m) + in + ins (l,t) + +(*s When removing a binding, we take care of not leaving bindings to empty + sub-tries in the nodes. Therefore, we test wether the result [t'] of + the recursive call is the empty trie [empty]: if so, we just remove + the branching with [M.remove]; otherwise, we modify it with [M.add]. *) + + let rec remove l t = match (l,t) with + | [], Node (_,m) -> Node (None,m) + | x::r, Node (v,m) -> + try + let t' = remove r (M.find x m) in + Node (v, if t' = empty then M.remove x m else M.add x t' m) + with Not_found -> + t + +(*s The iterators [map], [mapi], [iter] and [fold] are implemented in + a straigthforward way using the corresponding iterators [M.map], + [M.mapi], [M.iter] and [M.fold]. For the last three of them, + we have to remember the path from the root, as an extra argument + [revp]. Since elements are pushed in reverse order in [revp], + we have to reverse it with [List.rev] when the actual binding + has to be passed to function [f]. *) + + let rec map f = function + | Node (None,m) -> Node (None, M.map (map f) m) + | Node (Some v,m) -> Node (Some (f v), M.map (map f) m) + + let mapi f t = + let rec maprec revp = function + | Node (None,m) -> Node (None, M.mapi (fun x -> maprec (x::revp)) m) + | Node (Some v,m) -> + Node (Some (f (List.rev revp) v), M.mapi (fun x -> maprec (x::revp)) m) + in + maprec [] t + + let iter f t = + let rec traverse revp = function + | Node (None,m) -> M.iter (fun x -> traverse (x::revp)) m + | Node (Some v,m) -> + f (List.rev revp) v; + M.iter (fun x t -> traverse (x::revp) t) m + in + traverse [] t + + let fold f t acc = + let rec traverse revp t acc = match t with + | Node (None,m) -> M.fold (fun x -> traverse (x::revp)) m acc + | Node (Some v,m) -> + f (List.rev revp) v (M.fold (fun x -> traverse (x::revp)) m acc) + in + traverse [] t acc + + let compare cmp a b = + let rec comp a b = match a,b with + | Node (Some _, _), Node (None, _) -> 1 + | Node (None, _), Node (Some _, _) -> -1 + | Node (None, m1), Node (None, m2) -> M.compare comp m1 m2 + | Node (Some a, m1), Node (Some b, m2) -> + let c = cmp a b in + if c <> 0 then c else M.compare comp m1 m2 + in + comp a b + + let equal eq a b = + let rec comp a b = match a,b with + | Node (None, m1), Node (None, m2) -> M.equal comp m1 m2 + | Node (Some a, m1), Node (Some b, m2) -> eq a b && M.equal comp m1 m2 + | _ -> false + in + comp a b + + (* The base case is rather stupid, but constructable *) + let is_empty = function + | Node (None, m1) -> M.is_empty m1 + | _ -> false + + let pp f fmt m = + failwith "TODO: implement pp in trie" + + let show f m = + failwith "TODO: implement show in trie" +end diff --git a/src/trie.mli b/src/trie.mli new file mode 100644 index 000000000..9526c30c5 --- /dev/null +++ b/src/trie.mli @@ -0,0 +1,20 @@ +module Make : + functor (M : Map.S) -> + sig + type key = M.key list + type 'a t = Node of 'a option * 'a t M.t + val empty : 'a t + val find : key -> 'a t -> 'a + val mem : key -> 'a t -> bool + val add : key -> 'a -> 'a t -> 'a t + val remove : key -> 'a t -> 'a t + val map : ('a -> 'b) -> 'a t -> 'b t + val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t + val iter : (key -> 'a -> unit) -> 'a t -> unit + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val is_empty : 'a t -> bool + val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit + val show : (Format.formatter -> 'a -> unit) -> 'a t -> string + end diff --git a/src/utils/discrimination_tree.ml b/src/utils/discrimination_tree.ml new file mode 100644 index 000000000..d315bc13f --- /dev/null +++ b/src/utils/discrimination_tree.ml @@ -0,0 +1,280 @@ +(* Copyright (C) 2005, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + +(* $Id: discrimination_tree.ml 11171 2011-01-11 15:12:32Z tassi $ *) + +type 'a path_string_elem = + | Constant of 'a * int + | Variable + + +type 'a path = ('a path_string_elem) list + +module type Indexable = sig + type input + type constant_name + val compare: + constant_name path_string_elem -> + constant_name path_string_elem -> int + val path_string_of : input -> constant_name path +end + +let arity_of = function + | Constant (_,a) -> a + | Variable -> 0 + + +module type DiscriminationTree = + sig + + type input + type data + type dataset + type constant_name + type t + + val iter : t -> (constant_name path -> dataset -> unit) -> unit + val fold : t -> (constant_name path -> dataset -> 'b -> 'b) -> 'b -> 'b + + val empty : t + val index : t -> input -> data -> t + val remove_index : t -> input -> data -> t + val in_index : t -> input -> (data -> bool) -> bool + val retrieve_generalizations : t -> input -> dataset + val retrieve_unifiables : t -> input -> dataset + + module type Collector = sig + type t + val empty : t + val union : t -> t -> t + val inter : t -> t -> data list + val to_list : t -> data list + end + module Collector : Collector + val retrieve_generalizations_sorted : t -> input -> Collector.t + val retrieve_unifiables_sorted : t -> input -> Collector.t + end + +module Make (I:Indexable) (A:Set.S) : DiscriminationTree +with type constant_name = I.constant_name and type input = I.input +and type data = A.elt and type dataset = A.t = + + struct + + module OrderedPathStringElement = struct + type t = I.constant_name path_string_elem + let compare = I.compare + end + + type constant_name = I.constant_name + type data = A.elt + type dataset = A.t + type input = I.input + + module PSMap = Map.Make(OrderedPathStringElement) + + module DiscriminationTree = Trie.Make(PSMap) + + type t = A.t DiscriminationTree.t + + let empty = DiscriminationTree.empty + + let iter dt f = DiscriminationTree.iter (fun p x -> f p x) dt + + let fold dt f = DiscriminationTree.fold (fun p x -> f p x) dt + + let index tree term info = + let ps = I.path_string_of term in + let ps_set = + try DiscriminationTree.find ps tree with Not_found -> A.empty + in + DiscriminationTree.add ps (A.add info ps_set) tree + + + let remove_index tree term info = + let ps = I.path_string_of term in + try + let ps_set = A.remove info (DiscriminationTree.find ps tree) in + if A.is_empty ps_set then DiscriminationTree.remove ps tree + else DiscriminationTree.add ps ps_set tree + with Not_found -> tree + + + let in_index tree term test = + let ps = I.path_string_of term in + try + let ps_set = DiscriminationTree.find ps tree in + A.exists test ps_set + with Not_found -> false + + + (* You have h(f(x,g(y,z)),t) whose path_string_of_term_with_jl is + (h,2).(f,2).(x,0).(g,2).(y,0).(z,0).(t,0) and you are at f and want to + skip all its progeny, thus you want to reach t. + + You need to skip as many elements as the sum of all arieties contained + in the progeny of f. + + The input ariety is the one of f while the path is x.g....t + Should be the equivalent of after_t in the literature (handbook A.R.) + *) + let rec skip arity path = + if arity = 0 then path else match path with + | [] -> assert false + | m::tl -> skip (arity-1+arity_of m) tl + + + (* the equivalent of skip, but on the index, thus the list of trees + that are rooted just after the term represented by the tree root + are returned (we are skipping the root) *) + let skip_root = function DiscriminationTree.Node (_value, map) -> + let rec get n = function DiscriminationTree.Node (_v, m) as tree -> + if n = 0 then [tree] else + PSMap.fold (fun k v res -> (get (n-1 + arity_of k) v) @ res) m [] + in + PSMap.fold (fun k v res -> (get (arity_of k) v) @ res) map [] + + + let retrieve unif tree term = + let path = I.path_string_of term in + let rec retrieve path tree = + match tree, path with + | DiscriminationTree.Node (Some s, _), [] -> s + | DiscriminationTree.Node (None, _), [] -> A.empty + | DiscriminationTree.Node (_, _map), Variable::path when unif -> + List.fold_left A.union A.empty + (List.map (retrieve path) (skip_root tree)) + | DiscriminationTree.Node (_, map), node::path -> + A.union + (if not unif && node = Variable then A.empty else + try retrieve path (PSMap.find node map) + with Not_found -> A.empty) + (try + match PSMap.find Variable map,skip (arity_of node) path with + | DiscriminationTree.Node (Some s, _), [] -> s + | n, path -> retrieve path n + with Not_found -> A.empty) + in + retrieve path tree + + + let retrieve_generalizations tree term = retrieve false tree term + let retrieve_unifiables tree term = retrieve true tree term + + module O = struct + type t = A.t * int + let compare (sa,wa) (sb,wb) = + let c = compare wb wa in + if c <> 0 then c else A.compare sb sa + end + module S = Set.Make(O) + + (* TASSI: here we should think of a smarted data structure *) + module type Collector = sig + type t + val empty : t + val union : t -> t -> t + val inter : t -> t -> data list + val to_list : t -> data list + end + module Collector : Collector with type t = S.t = struct + type t = S.t + let union = S.union + let empty = S.empty + + let merge l = + let rec aux s w = function + | [] -> [s,w] + | (t, wt)::tl when w = wt -> aux (A.union s t) w tl + | (t, wt)::tl -> (s, w) :: aux t wt tl + in + match l with + | [] -> [] + | (s, w) :: l -> aux s w l + + let rec undup ~eq = function + | [] -> [] + | x :: tl -> x :: undup ~eq (List.filter (fun y -> not(eq x y)) tl) + + let to_list t = + undup ~eq:(fun x y -> A.equal (A.singleton x) (A.singleton y)) + (List.flatten (List.map + (fun (x,_) -> A.elements x) (merge (S.elements t)))) + + let rec filter_map f = function + | [] -> [] + | x :: xs -> + match f x with + | None -> filter_map f xs + | Some y -> y :: filter_map f xs + + let inter t1 t2 = + let l1 = merge (S.elements t1) in + let l2 = merge (S.elements t2) in + let res = + List.flatten + (List.map + (fun (s, w) -> + filter_map (fun x -> + try Some (x, w + snd (List.find (fun (s,_w) -> A.mem x s) l2)) + with Not_found -> None) + (A.elements s)) + l1) + in + undup ~eq:(fun x y -> A.equal (A.singleton x) (A.singleton y)) + (List.map fst (List.sort (fun (_,x) (_,y) -> y - x) res)) + end + + let retrieve_sorted unif tree term = + let path = I.path_string_of term in + let rec retrieve n path tree = + match tree, path with + | DiscriminationTree.Node (Some s, _), [] -> S.singleton (s, n) + | DiscriminationTree.Node (None, _), [] -> S.empty + | DiscriminationTree.Node (_, _map), Variable::path when unif -> + List.fold_left S.union S.empty + (List.map (retrieve n path) (skip_root tree)) + | DiscriminationTree.Node (_, map), node::path -> + S.union + (if not unif && node = Variable then S.empty else + try retrieve (n+1) path (PSMap.find node map) + with Not_found -> S.empty) + (try + match PSMap.find Variable map,skip (arity_of node) path with + | DiscriminationTree.Node (Some s, _), [] -> + S.singleton (s, n) + | no, path -> retrieve n path no + with Not_found -> S.empty) + in + retrieve 0 path tree + + + let retrieve_generalizations_sorted tree term = + retrieve_sorted false tree term + let retrieve_unifiables_sorted tree term = + retrieve_sorted true tree term + end + + From 8d41eb8112734dfa4142fc4415658ba73c5ddb31 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Mon, 13 Nov 2023 15:22:38 +0100 Subject: [PATCH 03/57] WIP --- Makefile | 3 ++ src/{utils => }/discrimination_tree.ml | 56 ++++++++++++------------ src/discrimination_tree_indexing.ml | 19 +++++++++ src/dune | 2 +- src/path_trie.ml | 59 ++++++++++++++++++++++++-- src/runtime.ml | 38 ++++++++++++----- src/trace_atd.ts | 48 +++++++++++---------- src/trie.ml | 21 +++++++-- test.elpi | 20 +++++++++ 9 files changed, 197 insertions(+), 69 deletions(-) rename src/{utils => }/discrimination_tree.ml (84%) create mode 100644 src/discrimination_tree_indexing.ml create mode 100644 test.elpi diff --git a/Makefile b/Makefile index 28e0ce211..982133770 100644 --- a/Makefile +++ b/Makefile @@ -135,3 +135,6 @@ menhir-strip-errormsgs: sed -e "/^##/d" -i.bak src/parser/error_messages.txt .PHONY: tests help install build clean gh-pages + +myMake: + dune exec elpi -- -test test.elpi \ No newline at end of file diff --git a/src/utils/discrimination_tree.ml b/src/discrimination_tree.ml similarity index 84% rename from src/utils/discrimination_tree.ml rename to src/discrimination_tree.ml index d315bc13f..36b0a51a7 100644 --- a/src/utils/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -54,7 +54,7 @@ module type DiscriminationTree = type dataset type constant_name type t - + val iter : t -> (constant_name path -> dataset -> unit) -> unit val fold : t -> (constant_name path -> dataset -> 'b -> 'b) -> 'b -> 'b @@ -65,6 +65,8 @@ module type DiscriminationTree = val retrieve_generalizations : t -> input -> dataset val retrieve_unifiables : t -> input -> dataset + val pp : Format.formatter -> 'a -> unit + module type Collector = sig type t val empty : t @@ -95,37 +97,35 @@ and type data = A.elt and type dataset = A.t = module PSMap = Map.Make(OrderedPathStringElement) - module DiscriminationTree = Trie.Make(PSMap) + module Trie = Trie.Make(PSMap) - type t = A.t DiscriminationTree.t + type t = A.t Trie.t - let empty = DiscriminationTree.empty + let empty = Trie.empty - let iter dt f = DiscriminationTree.iter (fun p x -> f p x) dt + let iter dt f = Trie.iter (fun p x -> f p x) dt - let fold dt f = DiscriminationTree.fold (fun p x -> f p x) dt + let fold dt f = Trie.fold (fun p x -> f p x) dt let index tree term info = let ps = I.path_string_of term in let ps_set = - try DiscriminationTree.find ps tree with Not_found -> A.empty + try Trie.find ps tree with Not_found -> A.empty in - DiscriminationTree.add ps (A.add info ps_set) tree - + Trie.add ps (A.add info ps_set) tree let remove_index tree term info = let ps = I.path_string_of term in try - let ps_set = A.remove info (DiscriminationTree.find ps tree) in - if A.is_empty ps_set then DiscriminationTree.remove ps tree - else DiscriminationTree.add ps ps_set tree + let ps_set = A.remove info (Trie.find ps tree) in + if A.is_empty ps_set then Trie.remove ps tree + else Trie.add ps ps_set tree with Not_found -> tree - let in_index tree term test = let ps = I.path_string_of term in try - let ps_set = DiscriminationTree.find ps tree in + let ps_set = Trie.find ps tree in A.exists test ps_set with Not_found -> false @@ -140,6 +140,7 @@ and type data = A.elt and type dataset = A.t = The input ariety is the one of f while the path is x.g....t Should be the equivalent of after_t in the literature (handbook A.R.) *) + (* MAYBE: a pointer to t from f should increase performances *) let rec skip arity path = if arity = 0 then path else match path with | [] -> assert false @@ -149,31 +150,30 @@ and type data = A.elt and type dataset = A.t = (* the equivalent of skip, but on the index, thus the list of trees that are rooted just after the term represented by the tree root are returned (we are skipping the root) *) - let skip_root = function DiscriminationTree.Node (_value, map) -> - let rec get n = function DiscriminationTree.Node (_v, m) as tree -> + let skip_root = function Trie.Node (_value, map) -> + let rec get n = function Trie.Node (_v, m) as tree -> if n = 0 then [tree] else PSMap.fold (fun k v res -> (get (n-1 + arity_of k) v) @ res) m [] in PSMap.fold (fun k v res -> (get (arity_of k) v) @ res) map [] - let retrieve unif tree term = let path = I.path_string_of term in let rec retrieve path tree = match tree, path with - | DiscriminationTree.Node (Some s, _), [] -> s - | DiscriminationTree.Node (None, _), [] -> A.empty - | DiscriminationTree.Node (_, _map), Variable::path when unif -> + | Trie.Node (Some s, _), [] -> s + | Trie.Node (None, _), [] -> A.empty + | Trie.Node (_, _map), Variable::path when unif -> List.fold_left A.union A.empty (List.map (retrieve path) (skip_root tree)) - | DiscriminationTree.Node (_, map), node::path -> + | Trie.Node (_, map), node::path -> A.union (if not unif && node = Variable then A.empty else try retrieve path (PSMap.find node map) with Not_found -> A.empty) (try match PSMap.find Variable map,skip (arity_of node) path with - | DiscriminationTree.Node (Some s, _), [] -> s + | Trie.Node (Some s, _), [] -> s | n, path -> retrieve path n with Not_found -> A.empty) in @@ -251,19 +251,19 @@ and type data = A.elt and type dataset = A.t = let path = I.path_string_of term in let rec retrieve n path tree = match tree, path with - | DiscriminationTree.Node (Some s, _), [] -> S.singleton (s, n) - | DiscriminationTree.Node (None, _), [] -> S.empty - | DiscriminationTree.Node (_, _map), Variable::path when unif -> + | Trie.Node (Some s, _), [] -> S.singleton (s, n) + | Trie.Node (None, _), [] -> S.empty + | Trie.Node (_, _map), Variable::path when unif -> List.fold_left S.union S.empty (List.map (retrieve n path) (skip_root tree)) - | DiscriminationTree.Node (_, map), node::path -> + | Trie.Node (_, map), node::path -> S.union (if not unif && node = Variable then S.empty else try retrieve (n+1) path (PSMap.find node map) with Not_found -> S.empty) (try match PSMap.find Variable map,skip (arity_of node) path with - | DiscriminationTree.Node (Some s, _), [] -> + | Trie.Node (Some s, _), [] -> S.singleton (s, n) | no, path -> retrieve n path no with Not_found -> S.empty) @@ -275,6 +275,8 @@ and type data = A.elt and type dataset = A.t = retrieve_sorted false tree term let retrieve_unifiables_sorted tree term = retrieve_sorted true tree term + + let pp = failwith "TODO" end diff --git a/src/discrimination_tree_indexing.ml b/src/discrimination_tree_indexing.ml new file mode 100644 index 000000000..538b6c3eb --- /dev/null +++ b/src/discrimination_tree_indexing.ml @@ -0,0 +1,19 @@ +type term = Data.term +type constant = Data.constant + +module TreeIndexable : Discrimination_tree.Indexable with + type input = term and type constant_name = constant += struct + type input = term + type constant_name = constant + + let compare = compare + + let rec path_string_of = function + | Data.App (hd, x, xs) -> + let tl = List.map path_string_of (x :: xs) |> List.flatten in + Discrimination_tree.Constant (hd, List.length xs + 1) :: tl + | _ -> [Variable] +end + +module DT = Discrimination_tree.Make(TreeIndexable)(Set.Make(Int)) \ No newline at end of file diff --git a/src/dune b/src/dune index a1e35b612..0a317ef04 100644 --- a/src/dune +++ b/src/dune @@ -14,7 +14,7 @@ ; ----- public API --------------------------------- elpi API builtin builtin_checker ; ----- internal stuff ----------------------------- - compiler data ptmap trie path_trie runtime_trace_off runtime + compiler data ptmap trie discrimination_tree discrimination_tree_indexing path_trie runtime_trace_off runtime builtin_stdlib builtin_map builtin_set legacy_parser_proxy) (private_modules diff --git a/src/path_trie.ml b/src/path_trie.ml index 596ae7731..56b3b0c07 100644 --- a/src/path_trie.ml +++ b/src/path_trie.ml @@ -1,18 +1,69 @@ type 'a path_string_elem = | Constant of 'a * int - | Variable + | Variable type 'a path = ('a path_string_elem) module Indexable = struct - type c + type c = int type t = c path end module OrderedPath = struct type t = Indexable.t - let compare = compare + let compare x y = match x, y with + | Variable, _ -> 0 + | _, Variable -> 0 + | a, b -> compare a b + + let print = function + | Constant (a, b) -> Printf.printf "Constant (%d, %d) " a b + | Variable -> Printf.printf "Variable " end module Dummy = Map.Make(OrderedPath) -module PathTrie = Trie.Make(Dummy) \ No newline at end of file +module PathTrie = struct + include Trie.Make(Dummy) + + let rec find_skip (t: 'a t) (depth: int) : 'a t list = + match t with + | Node (Some a, v) when depth = 0 -> + Printf.printf "In Node None when depth is 0 with length\n"; + Dummy.bindings v |> List.map snd + | Node (_, tmap) -> + let bindings = Dummy.bindings tmap in + Printf.printf "bindings length in rec call %d\n" (List.length bindings); + let x = List.map (fun (k, v) -> + if depth = 0 then [v] else + match k with + | Variable -> + Printf.printf "In Variable with remaining depth %d\n" depth; + find_skip v (depth - 1) + | Constant (c, arity) -> + Printf.printf "In Constant with value %d\n" c; + find_skip v (depth - 1 + arity) + ) bindings in + List.flatten x + + + let rec find1 l t : 'a list = + match (l, t) with + | [], Node (None, _) -> [] + | [], Node (Some v, _) -> [v] + (* TODO: Next line, Dummy.find should return also variables *) + | Constant (p,t) as c :: tl, Node (_, k) -> + find1 tl (Dummy.find c k) + | Variable :: tl, Node (_, k) -> + let bindings = Dummy.bindings k in + Printf.printf "bindings length is %d\n" (List.length bindings); + let elts = List.map (function + | Variable, x -> find1 tl x + | Constant (c, 0), x -> find1 tl x + | Constant (c, depth), x -> + Printf.printf "The depth of %d is %d\n" c depth; + let trees = find_skip x (depth - 1) in + Printf.printf "subtrees length is %d\n" (List.length trees); + let res = List.map (find1 tl) trees in + List.flatten res) bindings in + List.flatten elts +end \ No newline at end of file diff --git a/src/runtime.ml b/src/runtime.ml index c724db237..d31c1afcd 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2425,11 +2425,22 @@ let hash_goal_arg_list = hash_arg_list true (* bool -> constant -> depth:constant -> term list -> bool list ->constant list -> constant *) let build_trie_list (is_goal : bool) (hd: constant) ~(depth: constant) (args: term list) (mode: bool list) (spec : int) : Path_trie.PathTrie.key = - let build_path (term : term) = + let open Path_trie in + let rec build_path (term : term) : PathTrie.key = match term with - | _ -> [Path_trie.Variable] + | App (c, x, xs) -> Constant (c, List.length xs + 1) :: build_list (x :: xs) + | Const c -> [Constant (c, 0)] + | UVar _ | _ -> [Variable] + and + build_list x = List.map build_path x |> List.flatten in - build_path (List.nth args spec) + let res = + try build_path (List.nth args spec) + with Failure s as x -> if s = "nth" then failwith "Invalid indexing" else raise x + in + List.iter (fun x -> OrderedPath.print x) res; + Printf.printf "\n"; + res let add1clause ~depth m (predicate,clause) = match Ptmap.find predicate m with @@ -2481,12 +2492,15 @@ let add1clause ~depth m (predicate,clause) = | IndexWithTrie {mode; argno; args_idx} -> let trie_path = build_trie_list true ~depth predicate clause.args mode argno in let clauses = - try Path_trie.PathTrie.find trie_path args_idx + try + Path_trie.PathTrie.find1 trie_path args_idx |> List.flatten with Not_found -> [] in + (* Printf.printf "I have filtered %d\n" (List.length clauses); *) + (* List.iter (fun (x: clause) -> ) clauses; clause list *) Ptmap.add predicate (IndexWithTrie { mode; argno; (* TODO: is the order of the clauses respected ? *) - args_idx = Path_trie.PathTrie.add trie_path (clause :: clauses) args_idx + args_idx = Data.DT..PathTrie.add trie_path (clause :: clauses) args_idx }) m | exception Not_found -> match classify_clause_argno ~depth 0 [] clause.args with @@ -2583,10 +2597,10 @@ let hash_goal_args ~depth mode args goal = | App(k,x,xs) -> hash_goal_arg_list k ~depth (x::xs) mode args | _ -> assert false -let trie_goal_args ~depth mode args goal : Path_trie.PathTrie.key = +let trie_goal_args ~depth mode goal argno : Path_trie.PathTrie.key = match goal with | Const _ -> [Path_trie.Variable] - | App(k,x,xs) -> build_trie_list true k ~depth (x::xs) mode args + | App(k,x,xs) -> build_trie_list true k ~depth (x::xs) mode argno | _ -> assert false let get_clauses ~depth predicate goal { index = m } = @@ -2605,10 +2619,14 @@ let get_clauses ~depth predicate goal { index = m } = let cl = List.flatten (Ptmap.find_unifiables hash args_idx) in List.(map fst (sort (fun (_,cl1) (_,cl2) -> cl2 - cl1) cl)) | IndexWithTrie {argno; mode; args_idx} -> + Printf.printf "CIAO DAVIDE, I'm indexing %s\n" (Term.show_term goal); (* TODO: is goal the right argument to pass *) - let trie_path = build_trie_list true ~depth predicate [goal] mode argno in - try Path_trie.PathTrie.find trie_path args_idx - with Not_found -> [] + let trie_path = trie_goal_args ~depth mode goal argno in + let unifying_clauses = + try Path_trie.PathTrie.find1 trie_path args_idx |> List.flatten + with Not_found -> [] in + Printf.printf "Filtered clauses number is %d\n" (List.length unifying_clauses); + unifying_clauses with Not_found -> [] in [%log "get_clauses" ~rid (C.show predicate) (List.length rc)]; diff --git a/src/trace_atd.ts b/src/trace_atd.ts index 7bf7fa827..8d248245d 100644 --- a/src/trace_atd.ts +++ b/src/trace_atd.ts @@ -1,18 +1,22 @@ -// Generated by atdts from type definitions in 'trace.atd'. -// -// Type-safe translations from/to JSON -// -// For each type 'Foo', there is a pair of functions: -// - 'writeFoo': convert a 'Foo' value into a JSON-compatible value. -// - 'readFoo': convert a JSON-compatible value into a TypeScript value -// of type 'Foo'. +/* + Generated by atdts from type definitions in 'trace.atd'. + Type-safe translations from/to JSON + + For each type 'Foo', there is a pair of functions: + - 'writeFoo': convert a 'Foo' value into a JSON-compatible value. + - 'readFoo': convert a JSON-compatible value into a TypeScript value + of type 'Foo'. +*/ + +/* tslint:disable */ +/* eslint-disable */ export type Item = { kind: Kind[]; - goal_id: Int; - runtime_id: Int; - step: Int; + goal_id: number /*int*/; + runtime_id: number /*int*/; + step: number /*int*/; name: string; payload: string[]; } @@ -89,9 +93,9 @@ export type Location = export type FileLocation = { filename: string; - line: Int; - column: Int; - character: Int; + line: number /*int*/; + column: number /*int*/; + character: number /*int*/; } export type Event = @@ -124,11 +128,11 @@ export type Frame = { runtime_id: RuntimeId; } -export type GoalId = Int +export type GoalId = number /*int*/ -export type StepId = Int +export type StepId = number /*int*/ -export type RuntimeId = Int +export type RuntimeId = number /*int*/ export type GoalText = string @@ -786,8 +790,6 @@ export function readChrText(x: any, context: any = x): ChrText { // Runtime library ///////////////////////////////////////////////////////////////////// -export type Int = number - export type Option = null | { value: T } function _atd_missing_json_field(type_name: string, json_field_name: string) { @@ -820,7 +822,7 @@ function _atd_bad_ts(expected_type: string, ts_value: any, context: any) { ` Occurs in '${JSON.stringify(context)}'.`) } -function _atd_check_json_tuple(len: Int, x: any, context: any) { +function _atd_check_json_tuple(len: number /*int*/, x: any, context: any) { if (! Array.isArray(x) || x.length !== len) _atd_bad_json('tuple of length ' + len, x, context); } @@ -843,7 +845,7 @@ function _atd_read_bool(x: any, context: any): boolean { } } -function _atd_read_int(x: any, context: any): Int { +function _atd_read_int(x: any, context: any): number /*int*/ { if (Number.isInteger(x)) return x else { @@ -1024,7 +1026,7 @@ function _atd_write_bool(x: any, context: any): boolean { } } -function _atd_write_int(x: any, context: any): Int { +function _atd_write_int(x: any, context: any): number /*int*/ { if (Number.isInteger(x)) return x else { @@ -1133,7 +1135,7 @@ function _atd_write_required_field(type_name: string, } function _atd_write_optional_field(write_elt: (x: T, context: any) => any, - x: T, + x: T | undefined, context: any): any { if (x === undefined || x === null) return x diff --git a/src/trie.ml b/src/trie.ml index 779046002..6df88bbf2 100644 --- a/src/trie.ml +++ b/src/trie.ml @@ -139,10 +139,23 @@ module Make (M : Map.S) = struct let is_empty = function | Node (None, m1) -> M.is_empty m1 | _ -> false + + let rec pp (f: (Format.formatter -> 'a -> unit)) (fmt: Format.formatter) (m: 'a t) = + let print_key k = Printf.printf "k: " in + (match m with + | Node (None, sons) -> Printf.printf "None ["; M.iter (fun k v -> print_key k; Printf.printf " v:"; pp f fmt v) sons; Printf.printf "]" + | Node (Some k, sons) -> Printf.printf "Some ["; print_key k; M.iter (fun k v -> pp f fmt v) sons); Printf.printf "]" + + (* (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t *) + let show f m = + let b = Buffer.create 20 in + let fmt = Format.formatter_of_buffer b in + pp f fmt m; + Buffer.contents b - let pp f fmt m = - failwith "TODO: implement pp in trie" + (* let pp f fmt m = + let l = to_list m in + Elpi_util.Util.(pplist (pp_pair Int.pp f) " " fmt l) - let show f m = - failwith "TODO: implement show in trie" + *) end diff --git a/test.elpi b/test.elpi new file mode 100644 index 000000000..25ab4fac4 --- /dev/null +++ b/test.elpi @@ -0,0 +1,20 @@ +kind my_list type. +type mcons int -> my_list -> my_list. +type mint int -> my_list. +type mstring string -> my_list. +type mlist my_list -> my_list -> my_list. +type mnil my_list. + +:index (33 _) +pred davide_pred_with_custom_depth o:my_list. +davide_pred_with_custom_depth mnil. +davide_pred_with_custom_depth (mlist (mcons 0 mnil) (mcons 1 mnil)). +davide_pred_with_custom_depth (mlist (mcons 1 mnil) (mcons 2 mnil)). +davide_pred_with_custom_depth (mcons 0 (mint 0)). +davide_pred_with_custom_depth (mint X). +davide_pred_with_custom_depth (mstring "a"). + +main :- + davide_pred_with_custom_depth (mlist X (mcons 1 mnil)), print "Solution" X Y, fail. + +main :- print "End backtracking". \ No newline at end of file From 0f84202c0766cf0eaab23966df18fd315da4ef20 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Mon, 13 Nov 2023 15:23:22 +0100 Subject: [PATCH 04/57] Oups --- src/runtime.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/runtime.ml b/src/runtime.ml index d31c1afcd..2b53b75ac 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2500,7 +2500,7 @@ let add1clause ~depth m (predicate,clause) = Ptmap.add predicate (IndexWithTrie { mode; argno; (* TODO: is the order of the clauses respected ? *) - args_idx = Data.DT..PathTrie.add trie_path (clause :: clauses) args_idx + args_idx = Path_trie.PathTrie.add trie_path (clause :: clauses) args_idx }) m | exception Not_found -> match classify_clause_argno ~depth 0 [] clause.args with From 1ca7bc291c74b7695d6852d712dd62217a15f628 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Mon, 13 Nov 2023 17:32:43 +0100 Subject: [PATCH 05/57] Update DT --- src/data.ml | 79 +++++++++++++++++++++++++---- src/discrimination_tree.ml | 36 ++++++++++--- src/discrimination_tree_indexing.ml | 2 + src/runtime.ml | 30 ++++------- test.elpi | 18 ++++--- 5 files changed, 120 insertions(+), 45 deletions(-) diff --git a/src/data.ml b/src/data.ml index 7a0f6967e..3c750dbbb 100644 --- a/src/data.ml +++ b/src/data.ml @@ -115,6 +115,74 @@ let uvar_isnt_a_blocker { uid_private } = uid_private > 0 [@@inline];; let uvar_set_blocker r = r.uid_private <- -(uvar_id r) [@@inline];; let uvar_unset_blocker r = r.uid_private <- (uvar_id r) [@@inline];; +type clause = { + depth : int; + args : term list; + hyps : term list; + vars : int; + mode : mode; (* CACHE to avoid allocation in get_clauses *) + loc : Loc.t option; (* debug *) +} +and mode = bool list (* true=input, false=output *) +[@@deriving show] + +module TreeIndexable : Discrimination_tree.Indexable with + type input = term and type constant_name = constant += struct + type input = term + type constant_name = constant + + include Discrimination_tree + + let compare = compare + + let rec path_string_of = function + | Const a -> [Constant (a, 0)] + | App (hd, x, xs) -> + let tl = List.map path_string_of (x :: xs) |> List.flatten in + Constant (hd, List.length xs + 1) :: tl + | CData d -> [PrimitiveType d] + | _ -> [Variable] +end + +module MyListClause : Discrimination_tree.MyList with type elt = clause and type t = clause list = struct + type t = clause list + type elt = clause + let empty = [] + let is_empty = (=) [] + let mem = List.mem + let add = List.cons + let singleton a = [a] + let remove a l = List.filter ((<>) a) l + (* TODO: be careful to the order of this union since it changes + the order in which clauses are retrieved *) + let union a b = match b with [] -> a | _ -> List.append b a + let compare = compare + let equal = (=) + let exists = List.exists + let elements = Fun.id + let find a l = List.find ((=) a) l + let of_list = Fun.id + let pp = Util.pplist + (* let show x = failwith "TODO show of MyClauseList" *) +end + +module DT = struct + include Discrimination_tree.Make(TreeIndexable)(MyListClause) + + (* let pp f fmt t = + let p k v = Format.fprintf fmt "@[%a |->@ %a@]@ " (MyListClause.elt) k f v in + Format.fprintf fmt "@["; + iter p t; + Format.fprintf fmt "@]" *) + + let pp f fmt = + Printf.printf "PP of DT is to be done" + + let show x = "Show of DT is to be done" + +end + type stuck_goal = { mutable blockers : blockers; kind : unification_def stuck_goal_kind; @@ -151,17 +219,8 @@ and second_lvl_idx = | IndexWithTrie of { mode : mode; argno : int; - args_idx : (clause list) Path_trie.PathTrie.t; + args_idx : DT.t; } -and clause = { - depth : int; - args : term list; - hyps : term list; - vars : int; - mode : mode; (* CACHE to avoid allocation in get_clauses *) - loc : Loc.t option; (* debug *) -} -and mode = bool list (* true=input, false=output *) [@@deriving show] type constraints = stuck_goal list diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 36b0a51a7..9eaab5a95 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -28,6 +28,7 @@ type 'a path_string_elem = | Constant of 'a * int | Variable + | PrimitiveType of Elpi_util.Util.CData.t type 'a path = ('a path_string_elem) list @@ -43,7 +44,7 @@ end let arity_of = function | Constant (_,a) -> a - | Variable -> 0 + | Variable | PrimitiveType _ -> 0 module type DiscriminationTree = @@ -65,8 +66,6 @@ module type DiscriminationTree = val retrieve_generalizations : t -> input -> dataset val retrieve_unifiables : t -> input -> dataset - val pp : Format.formatter -> 'a -> unit - module type Collector = sig type t val empty : t @@ -79,7 +78,32 @@ module type DiscriminationTree = val retrieve_unifiables_sorted : t -> input -> Collector.t end -module Make (I:Indexable) (A:Set.S) : DiscriminationTree +module type MyList = sig + type elt + type t + val empty: t + val is_empty: t -> bool + val mem: elt -> t -> bool + val add: elt -> t -> t + val singleton: elt -> t + val remove: elt -> t -> t + val union: t -> t -> t + val compare: t -> t -> int + val equal: t -> t -> bool + val exists: (elt -> bool) -> t -> bool + val elements: t -> elt list + val find: elt -> t -> elt + val of_list: elt list -> t +end + +(* Question : Why to use a set ? This would mean that + in the case of a code like: + pred fail_twice. + fail_twice. + fail_twice. + the second fail_twice is not considered +*) +module Make (I:Indexable) (A:MyList) : DiscriminationTree with type constant_name = I.constant_name and type input = I.input and type data = A.elt and type dataset = A.t = @@ -275,8 +299,6 @@ and type data = A.elt and type dataset = A.t = retrieve_sorted false tree term let retrieve_unifiables_sorted tree term = retrieve_sorted true tree term - - let pp = failwith "TODO" - end +end diff --git a/src/discrimination_tree_indexing.ml b/src/discrimination_tree_indexing.ml index 538b6c3eb..585df848f 100644 --- a/src/discrimination_tree_indexing.ml +++ b/src/discrimination_tree_indexing.ml @@ -11,8 +11,10 @@ module TreeIndexable : Discrimination_tree.Indexable with let rec path_string_of = function | Data.App (hd, x, xs) -> + Printf.printf "In this first branch"; let tl = List.map path_string_of (x :: xs) |> List.flatten in Discrimination_tree.Constant (hd, List.length xs + 1) :: tl + | CData d -> Printf.printf "CIaO" ; [PrimitiveType d] | _ -> [Variable] end diff --git a/src/runtime.ml b/src/runtime.ml index 2b53b75ac..9273fadc6 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2423,7 +2423,7 @@ let hash_clause_arg_list = hash_arg_list false let hash_goal_arg_list = hash_arg_list true (* bool -> constant -> depth:constant -> term list -> bool list ->constant list -> constant *) -let build_trie_list (is_goal : bool) (hd: constant) ~(depth: constant) +(* let build_trie_list (is_goal : bool) (hd: constant) ~(depth: constant) (args: term list) (mode: bool list) (spec : int) : Path_trie.PathTrie.key = let open Path_trie in let rec build_path (term : term) : PathTrie.key = @@ -2440,7 +2440,7 @@ let build_trie_list (is_goal : bool) (hd: constant) ~(depth: constant) in List.iter (fun x -> OrderedPath.print x) res; Printf.printf "\n"; - res + res *) let add1clause ~depth m (predicate,clause) = match Ptmap.find predicate m with @@ -2490,17 +2490,11 @@ let add1clause ~depth m (predicate,clause) = args_idx = Ptmap.add hash ((clause,time) :: clauses) args_idx }) m | IndexWithTrie {mode; argno; args_idx} -> - let trie_path = build_trie_list true ~depth predicate clause.args mode argno in - let clauses = - try - Path_trie.PathTrie.find1 trie_path args_idx |> List.flatten - with Not_found -> [] in - (* Printf.printf "I have filtered %d\n" (List.length clauses); *) - (* List.iter (fun (x: clause) -> ) clauses; clause list *) + let path = DT.index args_idx (List.nth clause.args argno) clause in Ptmap.add predicate (IndexWithTrie { mode; argno; (* TODO: is the order of the clauses respected ? *) - args_idx = Path_trie.PathTrie.add trie_path (clause :: clauses) args_idx + args_idx = path }) m | exception Not_found -> match classify_clause_argno ~depth 0 [] clause.args with @@ -2551,7 +2545,7 @@ let make_index ~depth ~indexing ~clauses_rev:p = } | Trie argno -> IndexWithTrie { argno; mode; - args_idx = Path_trie.PathTrie.empty; + args_idx = DT.empty; } end m) indexing Ptmap.empty in { index = add_clauses ~depth p m; src = [] } @@ -2597,10 +2591,10 @@ let hash_goal_args ~depth mode args goal = | App(k,x,xs) -> hash_goal_arg_list k ~depth (x::xs) mode args | _ -> assert false -let trie_goal_args ~depth mode goal argno : Path_trie.PathTrie.key = +let trie_goal_args ~depth mode goal argno : term = match goal with - | Const _ -> [Path_trie.Variable] - | App(k,x,xs) -> build_trie_list true k ~depth (x::xs) mode argno + | Const a -> List.nth [Const a] argno + | App(k,x,xs) -> List.nth (x::xs) argno | _ -> assert false let get_clauses ~depth predicate goal { index = m } = @@ -2619,12 +2613,8 @@ let get_clauses ~depth predicate goal { index = m } = let cl = List.flatten (Ptmap.find_unifiables hash args_idx) in List.(map fst (sort (fun (_,cl1) (_,cl2) -> cl2 - cl1) cl)) | IndexWithTrie {argno; mode; args_idx} -> - Printf.printf "CIAO DAVIDE, I'm indexing %s\n" (Term.show_term goal); - (* TODO: is goal the right argument to pass *) - let trie_path = trie_goal_args ~depth mode goal argno in - let unifying_clauses = - try Path_trie.PathTrie.find1 trie_path args_idx |> List.flatten - with Not_found -> [] in + Printf.printf "Current goal to index %s\n" (Term.show_term goal); + let unifying_clauses = DT.retrieve_unifiables args_idx (trie_goal_args ~depth mode goal argno) in Printf.printf "Filtered clauses number is %d\n" (List.length unifying_clauses); unifying_clauses with Not_found -> [] diff --git a/test.elpi b/test.elpi index 25ab4fac4..c94c238db 100644 --- a/test.elpi +++ b/test.elpi @@ -6,15 +6,17 @@ type mlist my_list -> my_list -> my_list. type mnil my_list. :index (33 _) -pred davide_pred_with_custom_depth o:my_list. -davide_pred_with_custom_depth mnil. -davide_pred_with_custom_depth (mlist (mcons 0 mnil) (mcons 1 mnil)). -davide_pred_with_custom_depth (mlist (mcons 1 mnil) (mcons 2 mnil)). -davide_pred_with_custom_depth (mcons 0 (mint 0)). -davide_pred_with_custom_depth (mint X). -davide_pred_with_custom_depth (mstring "a"). +pred my_pred o:my_list. +my_pred mnil. +my_pred (mlist (mcons 0 mnil) (mcons 1 mnil)). +my_pred (mlist (mcons 1 mnil) (mcons 2 mnil)). +my_pred (mcons 0 (mint 0)). +my_pred (mint X) :- X = 3. +my_pred (mstring "a"). +my_pred (mstring "a"). +my_pred (mstring "b"). main :- - davide_pred_with_custom_depth (mlist X (mcons 1 mnil)), print "Solution" X Y, fail. + my_pred (mstring X), print "Solution" X _Y, fail. main :- print "End backtracking". \ No newline at end of file From d73f5c0f8aad9ccedad5a55ec2d9bef99b3b43f9 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Mon, 13 Nov 2023 21:08:02 +0100 Subject: [PATCH 06/57] indentations --- src/data.ml | 8 ++++---- src/discrimination_tree.ml | 6 ++---- 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/src/data.ml b/src/data.ml index 3c750dbbb..5c43f8f56 100644 --- a/src/data.ml +++ b/src/data.ml @@ -206,14 +206,14 @@ and second_lvl_idx = | TwoLevelIndex of { mode : mode; argno : int; - all_clauses : clause list; (* when the query is flexible *) - flex_arg_clauses : clause list; (* when the query is rigid but arg_id ha nothing *) - arg_idx : clause list Ptmap.t; (* when the query is rigid (includes in each binding flex_arg_clauses) *) + all_clauses : clause list; (* when the query is flexible *) + flex_arg_clauses : clause list; (* when the query is rigid but arg_id ha nothing *) + arg_idx : clause list Ptmap.t; (* when the query is rigid (includes in each binding flex_arg_clauses) *) } | BitHash of { mode : mode; args : int list; - time : int; (* time is used to recover the total order *) + time : int; (* time is used to recover the total order *) args_idx : (clause * int) list Ptmap.t; (* clause, insertion time *) } | IndexWithTrie of { diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 9eaab5a95..70d00433f 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -152,7 +152,6 @@ and type data = A.elt and type dataset = A.t = let ps_set = Trie.find ps tree in A.exists test ps_set with Not_found -> false - (* You have h(f(x,g(y,z)),t) whose path_string_of_term_with_jl is (h,2).(f,2).(x,0).(g,2).(y,0).(z,0).(t,0) and you are at f and want to @@ -169,15 +168,14 @@ and type data = A.elt and type dataset = A.t = if arity = 0 then path else match path with | [] -> assert false | m::tl -> skip (arity-1+arity_of m) tl - (* the equivalent of skip, but on the index, thus the list of trees that are rooted just after the term represented by the tree root are returned (we are skipping the root) *) let skip_root = function Trie.Node (_value, map) -> let rec get n = function Trie.Node (_v, m) as tree -> - if n = 0 then [tree] else - PSMap.fold (fun k v res -> (get (n-1 + arity_of k) v) @ res) m [] + if n = 0 then [tree] else + PSMap.fold (fun k v res -> (get (n-1 + arity_of k) v) @ res) m [] in PSMap.fold (fun k v res -> (get (arity_of k) v) @ res) map [] From 4900ea48f056971b325985c95cba37c32d9dcb9e Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 14 Nov 2023 11:38:31 +0100 Subject: [PATCH 07/57] discrimination tree jump to --- src/data.ml | 52 ++++-- src/discrimination_tree.ml | 34 ++-- src/discrimination_tree_jump_to.ml | 291 +++++++++++++++++++++++++++++ src/dune | 4 +- src/path_trie.ml | 69 ------- src/trie_jump_to.ml | 152 +++++++++++++++ 6 files changed, 494 insertions(+), 108 deletions(-) create mode 100644 src/discrimination_tree_jump_to.ml delete mode 100644 src/path_trie.ml create mode 100644 src/trie_jump_to.ml diff --git a/src/data.ml b/src/data.ml index 5c43f8f56..33c293e76 100644 --- a/src/data.ml +++ b/src/data.ml @@ -126,23 +126,48 @@ type clause = { and mode = bool list (* true=input, false=output *) [@@deriving show] -module TreeIndexable : Discrimination_tree.Indexable with - type input = term and type constant_name = constant -= struct - type input = term - type constant_name = constant +type 'a path_string_elem = + | Constant of 'a * int + | Variable + | PrimitiveType of Elpi_util.Util.CData.t + + +type 'a path = ('a path_string_elem) list + +let arity_of = function + | Constant (_,a) -> a + | Variable | PrimitiveType _ -> 0 - include Discrimination_tree +module TreeIndexable : Discrimination_tree_jump_to.IndexableTerm with + type input = term and type cell = ((constant path_string_elem)) += struct + type cell = (constant path_string_elem) + type path = cell list + type input = term + let variable = Variable let compare = compare let rec path_string_of = function - | Const a -> [Constant (a, 0)] + | Const a -> let c = Constant (a, 0) in [c] | App (hd, x, xs) -> let tl = List.map path_string_of (x :: xs) |> List.flatten in - Constant (hd, List.length xs + 1) :: tl + ( Constant (hd, List.length xs + 1)) :: tl | CData d -> [PrimitiveType d] | _ -> [Variable] + + let arity_of = function + | Constant (_,a) -> a + | Variable | PrimitiveType _ -> 0 + + let skip (path: path) : path = + let rec aux arity path = + if arity = 0 then path else match path with + | [] -> assert false + | m::tl -> aux (arity-1+arity_of m) tl in + match path with + | [] -> failwith "Skipping empty path is not possible" + | hd :: tl -> aux (arity_of hd) tl end module MyListClause : Discrimination_tree.MyList with type elt = clause and type t = clause list = struct @@ -164,23 +189,14 @@ module MyListClause : Discrimination_tree.MyList with type elt = clause and type let find a l = List.find ((=) a) l let of_list = Fun.id let pp = Util.pplist - (* let show x = failwith "TODO show of MyClauseList" *) end module DT = struct include Discrimination_tree.Make(TreeIndexable)(MyListClause) - - (* let pp f fmt t = - let p k v = Format.fprintf fmt "@[%a |->@ %a@]@ " (MyListClause.elt) k f v in - Format.fprintf fmt "@["; - iter p t; - Format.fprintf fmt "@]" *) - let pp f fmt = - Printf.printf "PP of DT is to be done" + let pp f fmt = Printf.printf "PP of DT is to be done" let show x = "Show of DT is to be done" - end type stuck_goal = { diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 70d00433f..8a8652dcb 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -36,6 +36,18 @@ type 'a path = ('a path_string_elem) list module type Indexable = sig type input type constant_name + (* You have h(f(x,g(y,z)),t) whose path_string_of_term_with_jl is + (h,2).(f,2).(x,0).(g,2).(y,0).(z,0).(t,0) and you are at f and want to + skip all its progeny, thus you want to reach t. + + You need to skip as many elements as the sum of all arieties contained + in the progeny of f. + + The input ariety is the one of f while the path is x.g....t + Should be the equivalent of after_t in the literature (handbook A.R.) + *) + (* MAYBE: a pointer to t from f should increase performances *) + val skip: constant_name path -> constant_name path val compare: constant_name path_string_elem -> constant_name path_string_elem -> int @@ -153,26 +165,10 @@ and type data = A.elt and type dataset = A.t = A.exists test ps_set with Not_found -> false - (* You have h(f(x,g(y,z)),t) whose path_string_of_term_with_jl is - (h,2).(f,2).(x,0).(g,2).(y,0).(z,0).(t,0) and you are at f and want to - skip all its progeny, thus you want to reach t. - - You need to skip as many elements as the sum of all arieties contained - in the progeny of f. - - The input ariety is the one of f while the path is x.g....t - Should be the equivalent of after_t in the literature (handbook A.R.) - *) - (* MAYBE: a pointer to t from f should increase performances *) - let rec skip arity path = - if arity = 0 then path else match path with - | [] -> assert false - | m::tl -> skip (arity-1+arity_of m) tl - (* the equivalent of skip, but on the index, thus the list of trees that are rooted just after the term represented by the tree root are returned (we are skipping the root) *) - let skip_root = function Trie.Node (_value, map) -> + let skip_root (Trie.Node (_value, map)) = let rec get n = function Trie.Node (_v, m) as tree -> if n = 0 then [tree] else PSMap.fold (fun k v res -> (get (n-1 + arity_of k) v) @ res) m [] @@ -194,7 +190,7 @@ and type data = A.elt and type dataset = A.t = try retrieve path (PSMap.find node map) with Not_found -> A.empty) (try - match PSMap.find Variable map,skip (arity_of node) path with + match PSMap.find Variable map, I.skip (node :: path) with | Trie.Node (Some s, _), [] -> s | n, path -> retrieve path n with Not_found -> A.empty) @@ -284,7 +280,7 @@ and type data = A.elt and type dataset = A.t = try retrieve (n+1) path (PSMap.find node map) with Not_found -> S.empty) (try - match PSMap.find Variable map,skip (arity_of node) path with + match PSMap.find Variable map,I.skip (node::path) with | Trie.Node (Some s, _), [] -> S.singleton (s, n) | no, path -> retrieve n path no diff --git a/src/discrimination_tree_jump_to.ml b/src/discrimination_tree_jump_to.ml new file mode 100644 index 000000000..50fdc55a3 --- /dev/null +++ b/src/discrimination_tree_jump_to.ml @@ -0,0 +1,291 @@ +(* Copyright (C) 2005, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + +(* $Id: discrimination_tree.ml 11171 2011-01-11 15:12:32Z tassi $ *) + + + +module type Indexable = sig + type input + type cell + type path = cell list + val compare: cell -> cell -> int + val path_string_of : input -> path +end + +module type IndexableTerm = sig + include Indexable + + (* You have h(f(x,g(y,z)),t) whose path_string_of_term_with_jl is + (h,2).(f,2).(x,0).(g,2).(y,0).(z,0).(t,0) and you are at f and want to + skip all its progeny, thus you want to reach t. + + You need to skip as many elements as the sum of all arieties contained + in the progeny of f. + + The input ariety is the one of f while the path is x.g....t + Should be the equivalent of after_t in the literature (handbook A.R.) + *) + (* MAYBE: a pointer to t from f should increase performances *) + val skip : path -> path + val arity_of : cell -> int + val variable : cell +end + +module type DiscriminationTree = + sig + + type input + type data + type dataset + type cell + type t + + val iter : t -> (cell list -> dataset -> unit) -> unit + val fold : t -> (cell list -> dataset -> 'b -> 'b) -> 'b -> 'b + + val empty : t + val index : t -> input -> data -> t + val remove_index : t -> input -> data -> t + val in_index : t -> input -> (data -> bool) -> bool + val retrieve_generalizations : t -> input -> dataset + val retrieve_unifiables : t -> input -> dataset + + module type Collector = sig + type t + val empty : t + val union : t -> t -> t + val inter : t -> t -> data list + val to_list : t -> data list + end + module Collector : Collector + val retrieve_generalizations_sorted : t -> input -> Collector.t + val retrieve_unifiables_sorted : t -> input -> Collector.t + end + +module type MyList = sig + type elt + type t + val empty: t + val is_empty: t -> bool + val mem: elt -> t -> bool + val add: elt -> t -> t + val singleton: elt -> t + val remove: elt -> t -> t + val union: t -> t -> t + val compare: t -> t -> int + val equal: t -> t -> bool + val exists: (elt -> bool) -> t -> bool + val elements: t -> elt list + val find: elt -> t -> elt + val of_list: elt list -> t +end + +(* Question : Why to use a set ? This would mean that + in the case of a code like: + pred fail_twice. + fail_twice. + fail_twice. + the second fail_twice is not considered +*) +module Make (I:IndexableTerm) (A:MyList) = + + struct + + module OrderedPathStringElement = struct + type t = I.cell + let compare = I.compare + end + + type data = A.elt + type dataset = A.t + type input = I.input + type cell = I.cell + + module PSMap = Map.Make(OrderedPathStringElement) + + module Trie = Trie.Make(PSMap) + + type t = A.t Trie.t + + let empty = Trie.empty + + let iter dt f = Trie.iter (fun p x -> f p x) dt + + let fold dt f = Trie.fold (fun p x -> f p x) dt + + let index tree term info = + let ps = I.path_string_of term in + let ps_set = + try Trie.find ps tree with Not_found -> A.empty + in + Trie.add ps (A.add info ps_set) tree + + let remove_index tree term info = + let ps = I.path_string_of term in + try + let ps_set = A.remove info (Trie.find ps tree) in + if A.is_empty ps_set then Trie.remove ps tree + else Trie.add ps ps_set tree + with Not_found -> tree + + let in_index tree term test = + let ps = I.path_string_of term in + try + let ps_set = Trie.find ps tree in + A.exists test ps_set + with Not_found -> false + + (* the equivalent of skip, but on the index, thus the list of trees + that are rooted just after the term represented by the tree root + are returned (we are skipping the root) *) + let skip_root (Trie.Node (_value, map)) = + let rec get n = function Trie.Node (_v, m) as tree -> + if n = 0 then [tree] else + PSMap.fold (fun k v res -> (get (n-1 + I.arity_of k) v) @ res) m [] + in + PSMap.fold (fun k v res -> (get (I.arity_of k) v) @ res) map [] + + let retrieve unif tree term = + let path = I.path_string_of term in + let rec retrieve path tree = + match tree, path with + | Trie.Node (Some s, _), [] -> s + | Trie.Node (None, _), [] -> A.empty + | Trie.Node (_, _map), v::path when v = I.variable && unif -> + List.fold_left A.union A.empty + (List.map (retrieve path) (skip_root tree)) + | Trie.Node (_, map), node::path -> + A.union + (if not unif && I.variable = node then A.empty else + try retrieve path (PSMap.find node map) + with Not_found -> A.empty) + (try + match PSMap.find I.variable map, I.skip (node :: path) with + | Trie.Node (Some s, _), [] -> s + | n, path -> retrieve path n + with Not_found -> A.empty) + in + retrieve path tree + + + let retrieve_generalizations tree term = retrieve false tree term + let retrieve_unifiables tree term = retrieve true tree term + + module O = struct + type t = A.t * int + let compare (sa,wa) (sb,wb) = + let c = compare wb wa in + if c <> 0 then c else A.compare sb sa + end + module S = Set.Make(O) + + (* TASSI: here we should think of a smarted data structure *) + module type Collector = sig + type t + val empty : t + val union : t -> t -> t + val inter : t -> t -> data list + val to_list : t -> data list + end + module Collector : Collector with type t = S.t = struct + type t = S.t + let union = S.union + let empty = S.empty + + let merge l = + let rec aux s w = function + | [] -> [s,w] + | (t, wt)::tl when w = wt -> aux (A.union s t) w tl + | (t, wt)::tl -> (s, w) :: aux t wt tl + in + match l with + | [] -> [] + | (s, w) :: l -> aux s w l + + let rec undup ~eq = function + | [] -> [] + | x :: tl -> x :: undup ~eq (List.filter (fun y -> not(eq x y)) tl) + + let to_list t = + undup ~eq:(fun x y -> A.equal (A.singleton x) (A.singleton y)) + (List.flatten (List.map + (fun (x,_) -> A.elements x) (merge (S.elements t)))) + + let rec filter_map f = function + | [] -> [] + | x :: xs -> + match f x with + | None -> filter_map f xs + | Some y -> y :: filter_map f xs + + let inter t1 t2 = + let l1 = merge (S.elements t1) in + let l2 = merge (S.elements t2) in + let res = + List.flatten + (List.map + (fun (s, w) -> + filter_map (fun x -> + try Some (x, w + snd (List.find (fun (s,_w) -> A.mem x s) l2)) + with Not_found -> None) + (A.elements s)) + l1) + in + undup ~eq:(fun x y -> A.equal (A.singleton x) (A.singleton y)) + (List.map fst (List.sort (fun (_,x) (_,y) -> y - x) res)) + end + + let retrieve_sorted unif tree term = + let path = I.path_string_of term in + let rec retrieve n path tree = + match tree, path with + | Trie.Node (Some s, _), [] -> S.singleton (s, n) + | Trie.Node (None, _), [] -> S.empty + | Trie.Node (_, _map), v::path when unif && v = I.variable -> + List.fold_left S.union S.empty + (List.map (retrieve n path) (skip_root tree)) + | Trie.Node (_, map), node::path -> + S.union + (if not unif && node = I.variable then S.empty else + try retrieve (n+1) path (PSMap.find node map) + with Not_found -> S.empty) + (try + match PSMap.find I.variable map,I.skip (node::path) with + | Trie.Node (Some s, _), [] -> + S.singleton (s, n) + | no, path -> retrieve n path no + with Not_found -> S.empty) + in + retrieve 0 path tree + + + let retrieve_generalizations_sorted tree term = + retrieve_sorted false tree term + let retrieve_unifiables_sorted tree term = + retrieve_sorted true tree term +end + + diff --git a/src/dune b/src/dune index 0a317ef04..e72caa853 100644 --- a/src/dune +++ b/src/dune @@ -14,11 +14,11 @@ ; ----- public API --------------------------------- elpi API builtin builtin_checker ; ----- internal stuff ----------------------------- - compiler data ptmap trie discrimination_tree discrimination_tree_indexing path_trie runtime_trace_off runtime + compiler data ptmap trie discrimination_tree discrimination_tree_jump_to trie_jump_to runtime_trace_off runtime builtin_stdlib builtin_map builtin_set legacy_parser_proxy) (private_modules - compiler data ptmap trie path_trie runtime_trace_off runtime + compiler data ptmap trie runtime_trace_off runtime builtin_stdlib builtin_map builtin_set legacy_parser_proxy) ) diff --git a/src/path_trie.ml b/src/path_trie.ml deleted file mode 100644 index 56b3b0c07..000000000 --- a/src/path_trie.ml +++ /dev/null @@ -1,69 +0,0 @@ -type 'a path_string_elem = - | Constant of 'a * int - | Variable - -type 'a path = ('a path_string_elem) - -module Indexable = struct - type c = int - type t = c path -end - -module OrderedPath = struct - type t = Indexable.t - let compare x y = match x, y with - | Variable, _ -> 0 - | _, Variable -> 0 - | a, b -> compare a b - - let print = function - | Constant (a, b) -> Printf.printf "Constant (%d, %d) " a b - | Variable -> Printf.printf "Variable " -end - -module Dummy = Map.Make(OrderedPath) -module PathTrie = struct - include Trie.Make(Dummy) - - let rec find_skip (t: 'a t) (depth: int) : 'a t list = - match t with - | Node (Some a, v) when depth = 0 -> - Printf.printf "In Node None when depth is 0 with length\n"; - Dummy.bindings v |> List.map snd - | Node (_, tmap) -> - let bindings = Dummy.bindings tmap in - Printf.printf "bindings length in rec call %d\n" (List.length bindings); - let x = List.map (fun (k, v) -> - if depth = 0 then [v] else - match k with - | Variable -> - Printf.printf "In Variable with remaining depth %d\n" depth; - find_skip v (depth - 1) - | Constant (c, arity) -> - Printf.printf "In Constant with value %d\n" c; - find_skip v (depth - 1 + arity) - ) bindings in - List.flatten x - - - let rec find1 l t : 'a list = - match (l, t) with - | [], Node (None, _) -> [] - | [], Node (Some v, _) -> [v] - (* TODO: Next line, Dummy.find should return also variables *) - | Constant (p,t) as c :: tl, Node (_, k) -> - find1 tl (Dummy.find c k) - | Variable :: tl, Node (_, k) -> - let bindings = Dummy.bindings k in - Printf.printf "bindings length is %d\n" (List.length bindings); - let elts = List.map (function - | Variable, x -> find1 tl x - | Constant (c, 0), x -> find1 tl x - | Constant (c, depth), x -> - Printf.printf "The depth of %d is %d\n" c depth; - let trees = find_skip x (depth - 1) in - Printf.printf "subtrees length is %d\n" (List.length trees); - let res = List.map (find1 tl) trees in - List.flatten res) bindings in - List.flatten elts -end \ No newline at end of file diff --git a/src/trie_jump_to.ml b/src/trie_jump_to.ml new file mode 100644 index 000000000..89c82099f --- /dev/null +++ b/src/trie_jump_to.ml @@ -0,0 +1,152 @@ +(* + * Trie: maps over lists. + * Copyright (C) 2000 Jean-Christophe FILLIATRE + * + * This software is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library General Public + * License version 2, as published by the Free Software Foundation. + * + * This software is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * + * See the GNU Library General Public License version 2 for more details + * (enclosed in the file LGPL). + *) + +(*s A trie is a tree-like structure to implement dictionaries over + keys which have list-like structures. The idea is that each node + branches on an element of the list and stores the value associated + to the path from the root, if any. Therefore, a trie can be + defined as soon as a map over the elements of the list is + given. *) + + +module Make (M : Map.S) = struct + +(*s Then a trie_jump_to is a variant of a trie for term representation + where a node contains a point to its desendents and its successor *) + + type key = M.key list + + type 'a t = Node of 'a option * 'a t M.t * 'a t M.t list + + let empty = Node (None, M.empty, []) + +(*s To find a mapping in a trie is easy: when all the elements of the + key have been read, we just inspect the optional info at the + current node; otherwise, we descend in the appropriate sub-trie + using [M.find]. *) + + let rec find l t = match (l,t) with + | [], Node (None,_,_) -> raise Not_found + | [], Node (Some v,_,_) -> v + | x::r, Node (_,m,_) -> find r (M.find x m) + + let mem l t = + try Fun.const true (find l t) with Not_found -> false + +(*s Insertion is more subtle. When the final node is reached, we just + put the information ([Some v]). Otherwise, we have to insert the + binding in the appropriate sub-trie [t']. But it may not exists, + and in that case [t'] is bound to an empty trie. Then we get a new + sub-trie [t''] by a recursive insertion and we modify the + branching, so that it now points to [t''], with [M.add]. *) + + let add l v t = + let rec ins = function + | [], Node (_,m,succ) -> Node (Some v,m,failwith "" :: succ) + | x::r, Node (v,m,succ) -> + let t' = try M.find x m with Not_found -> empty in + let t'' = ins (r,t') in + Node (v, M.add x t'' m, failwith "" :: succ) + in + ins (l,t) + +(*s When removing a binding, we take care of not leaving bindings to empty + sub-tries in the nodes. Therefore, we test wether the result [t'] of + the recursive call is the empty trie [empty]: if so, we just remove + the branching with [M.remove]; otherwise, we modify it with [M.add]. *) + + let remove l t = match (l,t) with + | [], Node (_,m,_) -> failwith "Here we should remove the succ from all of those pointing to m" + | x::r, Node (v,m, _) -> failwith "Same as before" + +(*s The iterators [map], [mapi], [iter] and [fold] are implemented in + a straigthforward way using the corresponding iterators [M.map], + [M.mapi], [M.iter] and [M.fold]. For the last three of them, + we have to remember the path from the root, as an extra argument + [revp]. Since elements are pushed in reverse order in [revp], + we have to reverse it with [List.rev] when the actual binding + has to be passed to function [f]. *) + + let rec map f = function + | Node (None,m,s) -> Node (None, M.map (map f) m,s) + | Node (Some v,m,s) -> Node (Some (f v), M.map (map f) m,s) + + let mapi f t = + let rec maprec revp = function + | Node (None,m,s) -> Node (None, M.mapi (fun x -> maprec (x::revp)) m,s) + | Node (Some v,m,s) -> + Node (Some (f (List.rev revp) v), M.mapi (fun x -> maprec (x::revp)) m,s) + in + maprec [] t + + let iter f t = + let rec traverse revp = function + | Node (None,m,s) -> M.iter (fun x -> traverse (x::revp)) m + | Node (Some v,m,s) -> + f (List.rev revp) v; + M.iter (fun x t -> traverse (x::revp) t) m + in + traverse [] t + + let fold f t acc = + let rec traverse revp t acc = match t with + | Node (None,m,s) -> M.fold (fun x -> traverse (x::revp)) m acc + | Node (Some v,m,s) -> + f (List.rev revp) v (M.fold (fun x -> traverse (x::revp)) m acc) + in + traverse [] t acc + + let compare cmp a b = + let rec comp a b = match a,b with + | Node (Some _, _, _), Node (None, _, _) -> 1 + | Node (None, _, _), Node (Some _, _, _) -> -1 + | Node (None, m1,s1), Node (None, m2, s2) -> M.compare comp m1 m2 + (* TODO: compare also s1 and s2 *) + | Node (Some a, m1, s1), Node (Some b, m2, s2) -> + let c = cmp a b in + (* TODO: compare also s1 and s2 *) + if c <> 0 then c else M.compare comp m1 m2 + in + comp a b + + let equal eq a b = + let rec comp a b = match a,b with + | Node (None, m1, s1), Node (None, m2, s2) -> M.equal comp m1 m2 + (* TODO: compare also s1 and s2 *) + | Node (Some a, m1, s1), Node (Some b, m2, s2) -> eq a b && M.equal comp m1 m2 + (* TODO: compare also s1 and s2 *) + | _ -> false + in + comp a b + + (* The base case is rather stupid, but constructable *) + let is_empty = function + | Node (None, m1, _) -> M.is_empty m1 + | _ -> false + + let rec pp (f: (Format.formatter -> 'a -> unit)) (fmt: Format.formatter) (m: 'a t) = + let print_key k = Printf.printf "k: " in + (match m with + | Node (None, sons,_) -> Printf.printf "None ["; M.iter (fun k v -> print_key k; Printf.printf " v:"; pp f fmt v) sons; Printf.printf "]" + | Node (Some k, sons,_) -> Printf.printf "Some ["; print_key k; M.iter (fun k v -> pp f fmt v) sons); Printf.printf "]" + + (* (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t *) + let show f m = + let b = Buffer.create 20 in + let fmt = Format.formatter_of_buffer b in + pp f fmt m; + Buffer.contents b +end From bb37a9c65e437e9b8828e3e518a9fe61b7337558 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 14 Nov 2023 11:39:58 +0100 Subject: [PATCH 08/57] Small correction --- src/data.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/data.ml b/src/data.ml index 33c293e76..3c71f3747 100644 --- a/src/data.ml +++ b/src/data.ml @@ -192,7 +192,7 @@ module MyListClause : Discrimination_tree.MyList with type elt = clause and type end module DT = struct - include Discrimination_tree.Make(TreeIndexable)(MyListClause) + include Discrimination_tree_jump_to.Make(TreeIndexable)(MyListClause) let pp f fmt = Printf.printf "PP of DT is to be done" From cca8c09ef8b3aa16f57a353d2430fffe2be1f660 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 14 Nov 2023 14:21:04 +0100 Subject: [PATCH 09/57] small update --- src/data.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/data.ml b/src/data.ml index 3c71f3747..8388b975e 100644 --- a/src/data.ml +++ b/src/data.ml @@ -139,7 +139,7 @@ let arity_of = function | Variable | PrimitiveType _ -> 0 module TreeIndexable : Discrimination_tree_jump_to.IndexableTerm with - type input = term and type cell = ((constant path_string_elem)) + type input = term and type cell = constant path_string_elem = struct type cell = (constant path_string_elem) type path = cell list From 26e0963fafe6f0ed5927442503795a303d2a290a Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Tue, 14 Nov 2023 17:43:31 +0100 Subject: [PATCH 10/57] Add time stamp to clauses --- src/data.ml | 28 +++++++++++++++++++--------- src/runtime.ml | 8 +++++--- test.elpi | 40 +++++++++++++++++++++++++++++----------- 3 files changed, 53 insertions(+), 23 deletions(-) diff --git a/src/data.ml b/src/data.ml index 8388b975e..e01e90263 100644 --- a/src/data.ml +++ b/src/data.ml @@ -166,22 +166,31 @@ module TreeIndexable : Discrimination_tree_jump_to.IndexableTerm with | [] -> assert false | m::tl -> aux (arity-1+arity_of m) tl in match path with - | [] -> failwith "Skipping empty path is not possible" - | hd :: tl -> aux (arity_of hd) tl + | [] -> failwith "Skipping empty path is not possible" + | hd :: tl -> aux (arity_of hd) tl end -module MyListClause : Discrimination_tree.MyList with type elt = clause and type t = clause list = struct - type t = clause list - type elt = clause +module MyListClause : Discrimination_tree.MyList with type elt = (clause * int) +and type t = (clause * int) list = struct + type elt = clause * int + type t = elt list let empty = [] let is_empty = (=) [] let mem = List.mem let add = List.cons let singleton a = [a] + (* + TODO: the order is obteined via a merge of the two lists. Note that each + are sorted by the timestamp of clauses. + *) + let rec union (l1: t) (l2 : t) = match l1, l2 with + | [], l | l, [] -> l + | (_, tx as x) :: xs, ((_, ty) :: _ as ys) when tx > ty -> + x :: union xs ys + | xs, y :: ys -> + y :: union xs ys + let remove a l = List.filter ((<>) a) l - (* TODO: be careful to the order of this union since it changes - the order in which clauses are retrieved *) - let union a b = match b with [] -> a | _ -> List.append b a let compare = compare let equal = (=) let exists = List.exists @@ -234,7 +243,8 @@ and second_lvl_idx = } | IndexWithTrie of { mode : mode; - argno : int; + argno : int; (* position of argument on which the trie is build *) + time : int; (* time is used to recover the total order *) args_idx : DT.t; } [@@deriving show] diff --git a/src/runtime.ml b/src/runtime.ml index 9273fadc6..10bb60d12 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2489,10 +2489,11 @@ let add1clause ~depth m (predicate,clause) = time = time + 1; args_idx = Ptmap.add hash ((clause,time) :: clauses) args_idx }) m - | IndexWithTrie {mode; argno; args_idx} -> - let path = DT.index args_idx (List.nth clause.args argno) clause in + | IndexWithTrie {mode; argno; args_idx; time} -> + let path = DT.index args_idx (List.nth clause.args argno) (clause, time) in Ptmap.add predicate (IndexWithTrie { mode; argno; + time = time+1; (* TODO: is the order of the clauses respected ? *) args_idx = path }) m @@ -2546,6 +2547,7 @@ let make_index ~depth ~indexing ~clauses_rev:p = | Trie argno -> IndexWithTrie { argno; mode; args_idx = DT.empty; + time = min_int; } end m) indexing Ptmap.empty in { index = add_clauses ~depth p m; src = [] } @@ -2616,7 +2618,7 @@ let get_clauses ~depth predicate goal { index = m } = Printf.printf "Current goal to index %s\n" (Term.show_term goal); let unifying_clauses = DT.retrieve_unifiables args_idx (trie_goal_args ~depth mode goal argno) in Printf.printf "Filtered clauses number is %d\n" (List.length unifying_clauses); - unifying_clauses + List.map fst unifying_clauses with Not_found -> [] in [%log "get_clauses" ~rid (C.show predicate) (List.length rc)]; diff --git a/test.elpi b/test.elpi index c94c238db..66de2ca99 100644 --- a/test.elpi +++ b/test.elpi @@ -5,18 +5,36 @@ type mstring string -> my_list. type mlist my_list -> my_list -> my_list. type mnil my_list. -:index (33 _) -pred my_pred o:my_list. -my_pred mnil. -my_pred (mlist (mcons 0 mnil) (mcons 1 mnil)). -my_pred (mlist (mcons 1 mnil) (mcons 2 mnil)). -my_pred (mcons 0 (mint 0)). -my_pred (mint X) :- X = 3. -my_pred (mstring "a"). -my_pred (mstring "a"). -my_pred (mstring "b"). +:index (_ 33 _) +pred my_pred o:my_list, o:int. +my_pred mnil 2. +my_pred (mlist (mcons 0 mnil) (mcons 1 mnil)) 3. +my_pred (mlist (mcons 1 mnil) (mcons 2 mnil)) 4. +my_pred (mcons 0 (mint 0)) 5. +my_pred (mint X) 6 :- X = 3. +my_pred (mstring "a") 7. +my_pred (mstring "a") 8. +my_pred (mstring "b") 9. + +:index (33) +pred order o:int. +order 0 :- print "0". +order _ :- print "1". +order 2 :- print "2". +order _ :- print "3". main :- - my_pred (mstring X), print "Solution" X _Y, fail. + print "first attempt with 0", + (order 0, fail); + print "second attempt with 1", + (order 1, fail); + print "third attempt with 2", + (order 2, fail); + print "fourth attempt with X", + (order X, fail). + +% main :- +% my_pred (mstring X) Y, +% print "Solution" X, fail. main :- print "End backtracking". \ No newline at end of file From 5b8ec2f20e1861f86e3d5955f731c06ba04a7a5c Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 15 Nov 2023 17:07:52 +0100 Subject: [PATCH 11/57] Take into account mode for filtering --- src/compiler.ml | 4 +- src/data.ml | 10 +- src/discrimination_tree.ml | 69 ++++--- src/discrimination_tree_jump_to.ml | 291 ----------------------------- src/dune | 2 +- src/runtime.ml | 14 +- src/trie.ml | 4 +- src/trie.mli | 2 +- src/trie_jump_to.ml | 152 --------------- 9 files changed, 56 insertions(+), 492 deletions(-) delete mode 100644 src/discrimination_tree_jump_to.ml delete mode 100644 src/trie_jump_to.ml diff --git a/src/compiler.ml b/src/compiler.ml index 928e80c78..a71dcfcea 100644 --- a/src/compiler.ml +++ b/src/compiler.ml @@ -2364,8 +2364,8 @@ let chose_indexing state predicate l = | [] -> error ("Wrong indexing for " ^ Symbols.show state predicate) | 0 :: l -> aux (argno+1) l | 1 :: l when all_zero l -> MapOn argno - (* TODO: 33 is a random number chosen for indexing with tries *) - | 33 :: l when all_zero l -> Trie argno + (* TODO: take hd into account to create "shorter" paths *) + | _ :: l when all_zero l -> Trie argno | _ -> Hash l in aux 0 l diff --git a/src/data.ml b/src/data.ml index e01e90263..751f70d11 100644 --- a/src/data.ml +++ b/src/data.ml @@ -130,6 +130,7 @@ type 'a path_string_elem = | Constant of 'a * int | Variable | PrimitiveType of Elpi_util.Util.CData.t +[@@deriving show] type 'a path = ('a path_string_elem) list @@ -138,10 +139,11 @@ let arity_of = function | Constant (_,a) -> a | Variable | PrimitiveType _ -> 0 -module TreeIndexable : Discrimination_tree_jump_to.IndexableTerm with +module TreeIndexable : Discrimination_tree.IndexableTerm with type input = term and type cell = constant path_string_elem = struct type cell = (constant path_string_elem) + [@@deriving show] type path = cell list type input = term let variable = Variable @@ -173,7 +175,10 @@ end module MyListClause : Discrimination_tree.MyList with type elt = (clause * int) and type t = (clause * int) list = struct type elt = clause * int + [@@deriving show] type t = elt list + [@@deriving show] + let empty = [] let is_empty = (=) [] let mem = List.mem @@ -197,11 +202,10 @@ and type t = (clause * int) list = struct let elements = Fun.id let find a l = List.find ((=) a) l let of_list = Fun.id - let pp = Util.pplist end module DT = struct - include Discrimination_tree_jump_to.Make(TreeIndexable)(MyListClause) + include Discrimination_tree.Make(TreeIndexable)(MyListClause) let pp f fmt = Printf.printf "PP of DT is to be done" diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 8a8652dcb..7d2968126 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -25,17 +25,18 @@ (* $Id: discrimination_tree.ml 11171 2011-01-11 15:12:32Z tassi $ *) -type 'a path_string_elem = - | Constant of 'a * int - | Variable - | PrimitiveType of Elpi_util.Util.CData.t +module type IndexableTerm = sig + type input + + type cell + val show_cell: cell -> string + val pp_cell: Format.formatter -> cell -> unit -type 'a path = ('a path_string_elem) list + type path = cell list + val compare: cell -> cell -> int + val path_string_of : input -> path -module type Indexable = sig - type input - type constant_name (* You have h(f(x,g(y,z)),t) whose path_string_of_term_with_jl is (h,2).(f,2).(x,0).(g,2).(y,0).(z,0).(t,0) and you are at f and want to skip all its progeny, thus you want to reach t. @@ -46,30 +47,23 @@ module type Indexable = sig The input ariety is the one of f while the path is x.g....t Should be the equivalent of after_t in the literature (handbook A.R.) *) - (* MAYBE: a pointer to t from f should increase performances *) - val skip: constant_name path -> constant_name path - val compare: - constant_name path_string_elem -> - constant_name path_string_elem -> int - val path_string_of : input -> constant_name path + (* MAYBE: a pointer to t from f should increase performances (i.e. jump list from McCune 1990) *) + val skip : path -> path + val arity_of : cell -> int + val variable : cell end -let arity_of = function - | Constant (_,a) -> a - | Variable | PrimitiveType _ -> 0 - - module type DiscriminationTree = sig type input type data type dataset - type constant_name + type cell type t - val iter : t -> (constant_name path -> dataset -> unit) -> unit - val fold : t -> (constant_name path -> dataset -> 'b -> 'b) -> 'b -> 'b + val iter : t -> (cell list -> dataset -> unit) -> unit + val fold : t -> (cell list -> dataset -> 'b -> 'b) -> 'b -> 'b val empty : t val index : t -> input -> data -> t @@ -92,7 +86,9 @@ module type DiscriminationTree = module type MyList = sig type elt + include Elpi_util.Util.Show with type t := elt type t + include Elpi_util.Util.Show with type t := t val empty: t val is_empty: t -> bool val mem: elt -> t -> bool @@ -115,23 +111,24 @@ end fail_twice. the second fail_twice is not considered *) -module Make (I:Indexable) (A:MyList) : DiscriminationTree -with type constant_name = I.constant_name and type input = I.input -and type data = A.elt and type dataset = A.t = +module Make (I:IndexableTerm) (A:MyList) = struct module OrderedPathStringElement = struct - type t = I.constant_name path_string_elem + type t = I.cell + + let show = I.show_cell + let pp = I.pp_cell let compare = I.compare end - type constant_name = I.constant_name type data = A.elt type dataset = A.t type input = I.input + type cell = I.cell - module PSMap = Map.Make(OrderedPathStringElement) + module PSMap = Elpi_util.Util.Map.Make(OrderedPathStringElement) module Trie = Trie.Make(PSMap) @@ -171,9 +168,9 @@ and type data = A.elt and type dataset = A.t = let skip_root (Trie.Node (_value, map)) = let rec get n = function Trie.Node (_v, m) as tree -> if n = 0 then [tree] else - PSMap.fold (fun k v res -> (get (n-1 + arity_of k) v) @ res) m [] + PSMap.fold (fun k v res -> (get (n-1 + I.arity_of k) v) @ res) m [] in - PSMap.fold (fun k v res -> (get (arity_of k) v) @ res) map [] + PSMap.fold (fun k v res -> (get (I.arity_of k) v) @ res) map [] let retrieve unif tree term = let path = I.path_string_of term in @@ -181,16 +178,16 @@ and type data = A.elt and type dataset = A.t = match tree, path with | Trie.Node (Some s, _), [] -> s | Trie.Node (None, _), [] -> A.empty - | Trie.Node (_, _map), Variable::path when unif -> + | Trie.Node (_, _map), v::path when v = I.variable && unif -> List.fold_left A.union A.empty (List.map (retrieve path) (skip_root tree)) | Trie.Node (_, map), node::path -> A.union - (if not unif && node = Variable then A.empty else + (if not unif && I.variable = node then A.empty else try retrieve path (PSMap.find node map) with Not_found -> A.empty) (try - match PSMap.find Variable map, I.skip (node :: path) with + match PSMap.find I.variable map, I.skip (node :: path) with | Trie.Node (Some s, _), [] -> s | n, path -> retrieve path n with Not_found -> A.empty) @@ -271,16 +268,16 @@ and type data = A.elt and type dataset = A.t = match tree, path with | Trie.Node (Some s, _), [] -> S.singleton (s, n) | Trie.Node (None, _), [] -> S.empty - | Trie.Node (_, _map), Variable::path when unif -> + | Trie.Node (_, _map), v::path when unif && v = I.variable -> List.fold_left S.union S.empty (List.map (retrieve n path) (skip_root tree)) | Trie.Node (_, map), node::path -> S.union - (if not unif && node = Variable then S.empty else + (if not unif && node = I.variable then S.empty else try retrieve (n+1) path (PSMap.find node map) with Not_found -> S.empty) (try - match PSMap.find Variable map,I.skip (node::path) with + match PSMap.find I.variable map,I.skip (node::path) with | Trie.Node (Some s, _), [] -> S.singleton (s, n) | no, path -> retrieve n path no diff --git a/src/discrimination_tree_jump_to.ml b/src/discrimination_tree_jump_to.ml deleted file mode 100644 index 50fdc55a3..000000000 --- a/src/discrimination_tree_jump_to.ml +++ /dev/null @@ -1,291 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id: discrimination_tree.ml 11171 2011-01-11 15:12:32Z tassi $ *) - - - -module type Indexable = sig - type input - type cell - type path = cell list - val compare: cell -> cell -> int - val path_string_of : input -> path -end - -module type IndexableTerm = sig - include Indexable - - (* You have h(f(x,g(y,z)),t) whose path_string_of_term_with_jl is - (h,2).(f,2).(x,0).(g,2).(y,0).(z,0).(t,0) and you are at f and want to - skip all its progeny, thus you want to reach t. - - You need to skip as many elements as the sum of all arieties contained - in the progeny of f. - - The input ariety is the one of f while the path is x.g....t - Should be the equivalent of after_t in the literature (handbook A.R.) - *) - (* MAYBE: a pointer to t from f should increase performances *) - val skip : path -> path - val arity_of : cell -> int - val variable : cell -end - -module type DiscriminationTree = - sig - - type input - type data - type dataset - type cell - type t - - val iter : t -> (cell list -> dataset -> unit) -> unit - val fold : t -> (cell list -> dataset -> 'b -> 'b) -> 'b -> 'b - - val empty : t - val index : t -> input -> data -> t - val remove_index : t -> input -> data -> t - val in_index : t -> input -> (data -> bool) -> bool - val retrieve_generalizations : t -> input -> dataset - val retrieve_unifiables : t -> input -> dataset - - module type Collector = sig - type t - val empty : t - val union : t -> t -> t - val inter : t -> t -> data list - val to_list : t -> data list - end - module Collector : Collector - val retrieve_generalizations_sorted : t -> input -> Collector.t - val retrieve_unifiables_sorted : t -> input -> Collector.t - end - -module type MyList = sig - type elt - type t - val empty: t - val is_empty: t -> bool - val mem: elt -> t -> bool - val add: elt -> t -> t - val singleton: elt -> t - val remove: elt -> t -> t - val union: t -> t -> t - val compare: t -> t -> int - val equal: t -> t -> bool - val exists: (elt -> bool) -> t -> bool - val elements: t -> elt list - val find: elt -> t -> elt - val of_list: elt list -> t -end - -(* Question : Why to use a set ? This would mean that - in the case of a code like: - pred fail_twice. - fail_twice. - fail_twice. - the second fail_twice is not considered -*) -module Make (I:IndexableTerm) (A:MyList) = - - struct - - module OrderedPathStringElement = struct - type t = I.cell - let compare = I.compare - end - - type data = A.elt - type dataset = A.t - type input = I.input - type cell = I.cell - - module PSMap = Map.Make(OrderedPathStringElement) - - module Trie = Trie.Make(PSMap) - - type t = A.t Trie.t - - let empty = Trie.empty - - let iter dt f = Trie.iter (fun p x -> f p x) dt - - let fold dt f = Trie.fold (fun p x -> f p x) dt - - let index tree term info = - let ps = I.path_string_of term in - let ps_set = - try Trie.find ps tree with Not_found -> A.empty - in - Trie.add ps (A.add info ps_set) tree - - let remove_index tree term info = - let ps = I.path_string_of term in - try - let ps_set = A.remove info (Trie.find ps tree) in - if A.is_empty ps_set then Trie.remove ps tree - else Trie.add ps ps_set tree - with Not_found -> tree - - let in_index tree term test = - let ps = I.path_string_of term in - try - let ps_set = Trie.find ps tree in - A.exists test ps_set - with Not_found -> false - - (* the equivalent of skip, but on the index, thus the list of trees - that are rooted just after the term represented by the tree root - are returned (we are skipping the root) *) - let skip_root (Trie.Node (_value, map)) = - let rec get n = function Trie.Node (_v, m) as tree -> - if n = 0 then [tree] else - PSMap.fold (fun k v res -> (get (n-1 + I.arity_of k) v) @ res) m [] - in - PSMap.fold (fun k v res -> (get (I.arity_of k) v) @ res) map [] - - let retrieve unif tree term = - let path = I.path_string_of term in - let rec retrieve path tree = - match tree, path with - | Trie.Node (Some s, _), [] -> s - | Trie.Node (None, _), [] -> A.empty - | Trie.Node (_, _map), v::path when v = I.variable && unif -> - List.fold_left A.union A.empty - (List.map (retrieve path) (skip_root tree)) - | Trie.Node (_, map), node::path -> - A.union - (if not unif && I.variable = node then A.empty else - try retrieve path (PSMap.find node map) - with Not_found -> A.empty) - (try - match PSMap.find I.variable map, I.skip (node :: path) with - | Trie.Node (Some s, _), [] -> s - | n, path -> retrieve path n - with Not_found -> A.empty) - in - retrieve path tree - - - let retrieve_generalizations tree term = retrieve false tree term - let retrieve_unifiables tree term = retrieve true tree term - - module O = struct - type t = A.t * int - let compare (sa,wa) (sb,wb) = - let c = compare wb wa in - if c <> 0 then c else A.compare sb sa - end - module S = Set.Make(O) - - (* TASSI: here we should think of a smarted data structure *) - module type Collector = sig - type t - val empty : t - val union : t -> t -> t - val inter : t -> t -> data list - val to_list : t -> data list - end - module Collector : Collector with type t = S.t = struct - type t = S.t - let union = S.union - let empty = S.empty - - let merge l = - let rec aux s w = function - | [] -> [s,w] - | (t, wt)::tl when w = wt -> aux (A.union s t) w tl - | (t, wt)::tl -> (s, w) :: aux t wt tl - in - match l with - | [] -> [] - | (s, w) :: l -> aux s w l - - let rec undup ~eq = function - | [] -> [] - | x :: tl -> x :: undup ~eq (List.filter (fun y -> not(eq x y)) tl) - - let to_list t = - undup ~eq:(fun x y -> A.equal (A.singleton x) (A.singleton y)) - (List.flatten (List.map - (fun (x,_) -> A.elements x) (merge (S.elements t)))) - - let rec filter_map f = function - | [] -> [] - | x :: xs -> - match f x with - | None -> filter_map f xs - | Some y -> y :: filter_map f xs - - let inter t1 t2 = - let l1 = merge (S.elements t1) in - let l2 = merge (S.elements t2) in - let res = - List.flatten - (List.map - (fun (s, w) -> - filter_map (fun x -> - try Some (x, w + snd (List.find (fun (s,_w) -> A.mem x s) l2)) - with Not_found -> None) - (A.elements s)) - l1) - in - undup ~eq:(fun x y -> A.equal (A.singleton x) (A.singleton y)) - (List.map fst (List.sort (fun (_,x) (_,y) -> y - x) res)) - end - - let retrieve_sorted unif tree term = - let path = I.path_string_of term in - let rec retrieve n path tree = - match tree, path with - | Trie.Node (Some s, _), [] -> S.singleton (s, n) - | Trie.Node (None, _), [] -> S.empty - | Trie.Node (_, _map), v::path when unif && v = I.variable -> - List.fold_left S.union S.empty - (List.map (retrieve n path) (skip_root tree)) - | Trie.Node (_, map), node::path -> - S.union - (if not unif && node = I.variable then S.empty else - try retrieve (n+1) path (PSMap.find node map) - with Not_found -> S.empty) - (try - match PSMap.find I.variable map,I.skip (node::path) with - | Trie.Node (Some s, _), [] -> - S.singleton (s, n) - | no, path -> retrieve n path no - with Not_found -> S.empty) - in - retrieve 0 path tree - - - let retrieve_generalizations_sorted tree term = - retrieve_sorted false tree term - let retrieve_unifiables_sorted tree term = - retrieve_sorted true tree term -end - - diff --git a/src/dune b/src/dune index e72caa853..cb0183a56 100644 --- a/src/dune +++ b/src/dune @@ -14,7 +14,7 @@ ; ----- public API --------------------------------- elpi API builtin builtin_checker ; ----- internal stuff ----------------------------- - compiler data ptmap trie discrimination_tree discrimination_tree_jump_to trie_jump_to runtime_trace_off runtime + compiler data ptmap trie discrimination_tree runtime_trace_off runtime builtin_stdlib builtin_map builtin_set legacy_parser_proxy) (private_modules diff --git a/src/runtime.ml b/src/runtime.ml index 10bb60d12..0275cad51 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2593,10 +2593,10 @@ let hash_goal_args ~depth mode args goal = | App(k,x,xs) -> hash_goal_arg_list k ~depth (x::xs) mode args | _ -> assert false -let trie_goal_args ~depth mode goal argno : term = +let trie_goal_args ~depth mode goal argno : (term * bool) = match goal with - | Const a -> List.nth [Const a] argno - | App(k,x,xs) -> List.nth (x::xs) argno + | Const a -> List.nth [Const a] argno, List.nth mode argno + | App(k,x,xs) -> List.nth (x::xs) argno, List.nth mode argno | _ -> assert false let get_clauses ~depth predicate goal { index = m } = @@ -2616,8 +2616,12 @@ let get_clauses ~depth predicate goal { index = m } = List.(map fst (sort (fun (_,cl1) (_,cl2) -> cl2 - cl1) cl)) | IndexWithTrie {argno; mode; args_idx} -> Printf.printf "Current goal to index %s\n" (Term.show_term goal); - let unifying_clauses = DT.retrieve_unifiables args_idx (trie_goal_args ~depth mode goal argno) in - Printf.printf "Filtered clauses number is %d\n" (List.length unifying_clauses); + let (arg, mode_arg) = trie_goal_args ~depth mode goal argno in + let unifying_clauses = if mode_arg then + DT.retrieve_generalizations args_idx arg else + DT.retrieve_unifiables args_idx arg in + [%spy "dev:disc-tree-filter-number" ~rid Elpi_util.Util.pp_string + (Printf.sprintf "Filtered clauses number is %d\n" (List.length unifying_clauses))]; List.map fst unifying_clauses with Not_found -> [] in diff --git a/src/trie.ml b/src/trie.ml index 6df88bbf2..e657c00e6 100644 --- a/src/trie.ml +++ b/src/trie.ml @@ -22,7 +22,7 @@ given. *) -module Make (M : Map.S) = struct +module Make (M : Elpi_util.Util.Map.S) = struct (*s Then a trie is just a tree-like structure, where a possible information is stored at the node (['a option]) and where the sons @@ -30,8 +30,10 @@ module Make (M : Map.S) = struct ['a t M.t]. The empty trie is just the empty map. *) type key = M.key list + [@@deriving show] type 'a t = Node of 'a option * 'a t M.t + [@@deriving show] let empty = Node (None, M.empty) diff --git a/src/trie.mli b/src/trie.mli index 9526c30c5..624296e3d 100644 --- a/src/trie.mli +++ b/src/trie.mli @@ -1,5 +1,5 @@ module Make : - functor (M : Map.S) -> + functor (M : Elpi_util.Util.Map.S) -> sig type key = M.key list type 'a t = Node of 'a option * 'a t M.t diff --git a/src/trie_jump_to.ml b/src/trie_jump_to.ml deleted file mode 100644 index 89c82099f..000000000 --- a/src/trie_jump_to.ml +++ /dev/null @@ -1,152 +0,0 @@ -(* - * Trie: maps over lists. - * Copyright (C) 2000 Jean-Christophe FILLIATRE - * - * This software is free software; you can redistribute it and/or - * modify it under the terms of the GNU Library General Public - * License version 2, as published by the Free Software Foundation. - * - * This software is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - * - * See the GNU Library General Public License version 2 for more details - * (enclosed in the file LGPL). - *) - -(*s A trie is a tree-like structure to implement dictionaries over - keys which have list-like structures. The idea is that each node - branches on an element of the list and stores the value associated - to the path from the root, if any. Therefore, a trie can be - defined as soon as a map over the elements of the list is - given. *) - - -module Make (M : Map.S) = struct - -(*s Then a trie_jump_to is a variant of a trie for term representation - where a node contains a point to its desendents and its successor *) - - type key = M.key list - - type 'a t = Node of 'a option * 'a t M.t * 'a t M.t list - - let empty = Node (None, M.empty, []) - -(*s To find a mapping in a trie is easy: when all the elements of the - key have been read, we just inspect the optional info at the - current node; otherwise, we descend in the appropriate sub-trie - using [M.find]. *) - - let rec find l t = match (l,t) with - | [], Node (None,_,_) -> raise Not_found - | [], Node (Some v,_,_) -> v - | x::r, Node (_,m,_) -> find r (M.find x m) - - let mem l t = - try Fun.const true (find l t) with Not_found -> false - -(*s Insertion is more subtle. When the final node is reached, we just - put the information ([Some v]). Otherwise, we have to insert the - binding in the appropriate sub-trie [t']. But it may not exists, - and in that case [t'] is bound to an empty trie. Then we get a new - sub-trie [t''] by a recursive insertion and we modify the - branching, so that it now points to [t''], with [M.add]. *) - - let add l v t = - let rec ins = function - | [], Node (_,m,succ) -> Node (Some v,m,failwith "" :: succ) - | x::r, Node (v,m,succ) -> - let t' = try M.find x m with Not_found -> empty in - let t'' = ins (r,t') in - Node (v, M.add x t'' m, failwith "" :: succ) - in - ins (l,t) - -(*s When removing a binding, we take care of not leaving bindings to empty - sub-tries in the nodes. Therefore, we test wether the result [t'] of - the recursive call is the empty trie [empty]: if so, we just remove - the branching with [M.remove]; otherwise, we modify it with [M.add]. *) - - let remove l t = match (l,t) with - | [], Node (_,m,_) -> failwith "Here we should remove the succ from all of those pointing to m" - | x::r, Node (v,m, _) -> failwith "Same as before" - -(*s The iterators [map], [mapi], [iter] and [fold] are implemented in - a straigthforward way using the corresponding iterators [M.map], - [M.mapi], [M.iter] and [M.fold]. For the last three of them, - we have to remember the path from the root, as an extra argument - [revp]. Since elements are pushed in reverse order in [revp], - we have to reverse it with [List.rev] when the actual binding - has to be passed to function [f]. *) - - let rec map f = function - | Node (None,m,s) -> Node (None, M.map (map f) m,s) - | Node (Some v,m,s) -> Node (Some (f v), M.map (map f) m,s) - - let mapi f t = - let rec maprec revp = function - | Node (None,m,s) -> Node (None, M.mapi (fun x -> maprec (x::revp)) m,s) - | Node (Some v,m,s) -> - Node (Some (f (List.rev revp) v), M.mapi (fun x -> maprec (x::revp)) m,s) - in - maprec [] t - - let iter f t = - let rec traverse revp = function - | Node (None,m,s) -> M.iter (fun x -> traverse (x::revp)) m - | Node (Some v,m,s) -> - f (List.rev revp) v; - M.iter (fun x t -> traverse (x::revp) t) m - in - traverse [] t - - let fold f t acc = - let rec traverse revp t acc = match t with - | Node (None,m,s) -> M.fold (fun x -> traverse (x::revp)) m acc - | Node (Some v,m,s) -> - f (List.rev revp) v (M.fold (fun x -> traverse (x::revp)) m acc) - in - traverse [] t acc - - let compare cmp a b = - let rec comp a b = match a,b with - | Node (Some _, _, _), Node (None, _, _) -> 1 - | Node (None, _, _), Node (Some _, _, _) -> -1 - | Node (None, m1,s1), Node (None, m2, s2) -> M.compare comp m1 m2 - (* TODO: compare also s1 and s2 *) - | Node (Some a, m1, s1), Node (Some b, m2, s2) -> - let c = cmp a b in - (* TODO: compare also s1 and s2 *) - if c <> 0 then c else M.compare comp m1 m2 - in - comp a b - - let equal eq a b = - let rec comp a b = match a,b with - | Node (None, m1, s1), Node (None, m2, s2) -> M.equal comp m1 m2 - (* TODO: compare also s1 and s2 *) - | Node (Some a, m1, s1), Node (Some b, m2, s2) -> eq a b && M.equal comp m1 m2 - (* TODO: compare also s1 and s2 *) - | _ -> false - in - comp a b - - (* The base case is rather stupid, but constructable *) - let is_empty = function - | Node (None, m1, _) -> M.is_empty m1 - | _ -> false - - let rec pp (f: (Format.formatter -> 'a -> unit)) (fmt: Format.formatter) (m: 'a t) = - let print_key k = Printf.printf "k: " in - (match m with - | Node (None, sons,_) -> Printf.printf "None ["; M.iter (fun k v -> print_key k; Printf.printf " v:"; pp f fmt v) sons; Printf.printf "]" - | Node (Some k, sons,_) -> Printf.printf "Some ["; print_key k; M.iter (fun k v -> pp f fmt v) sons); Printf.printf "]" - - (* (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t *) - let show f m = - let b = Buffer.create 20 in - let fmt = Format.formatter_of_buffer b in - pp f fmt m; - Buffer.contents b -end From eb720fe7fb135cc2bc372420e3e163ce629a344d Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 15 Nov 2023 17:22:36 +0100 Subject: [PATCH 12/57] printf to spy --- src/discrimination_tree.ml | 36 +++-------------------------- src/discrimination_tree_indexing.ml | 21 ----------------- src/runtime.ml | 5 ++-- 3 files changed, 6 insertions(+), 56 deletions(-) delete mode 100644 src/discrimination_tree_indexing.ml diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 7d2968126..19728ef73 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -1,29 +1,6 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id: discrimination_tree.ml 11171 2011-01-11 15:12:32Z tassi $ *) +(* elpi: embedded lambda prolog interpreter *) +(* license: GNU Lesser General Public License Version 2.1 or later *) +(* ------------------------------------------------------------------------- *) module type IndexableTerm = sig type input @@ -104,13 +81,6 @@ module type MyList = sig val of_list: elt list -> t end -(* Question : Why to use a set ? This would mean that - in the case of a code like: - pred fail_twice. - fail_twice. - fail_twice. - the second fail_twice is not considered -*) module Make (I:IndexableTerm) (A:MyList) = struct diff --git a/src/discrimination_tree_indexing.ml b/src/discrimination_tree_indexing.ml deleted file mode 100644 index 585df848f..000000000 --- a/src/discrimination_tree_indexing.ml +++ /dev/null @@ -1,21 +0,0 @@ -type term = Data.term -type constant = Data.constant - -module TreeIndexable : Discrimination_tree.Indexable with - type input = term and type constant_name = constant -= struct - type input = term - type constant_name = constant - - let compare = compare - - let rec path_string_of = function - | Data.App (hd, x, xs) -> - Printf.printf "In this first branch"; - let tl = List.map path_string_of (x :: xs) |> List.flatten in - Discrimination_tree.Constant (hd, List.length xs + 1) :: tl - | CData d -> Printf.printf "CIaO" ; [PrimitiveType d] - | _ -> [Variable] -end - -module DT = Discrimination_tree.Make(TreeIndexable)(Set.Make(Int)) \ No newline at end of file diff --git a/src/runtime.ml b/src/runtime.ml index 0275cad51..f620f5fd8 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2615,12 +2615,13 @@ let get_clauses ~depth predicate goal { index = m } = let cl = List.flatten (Ptmap.find_unifiables hash args_idx) in List.(map fst (sort (fun (_,cl1) (_,cl2) -> cl2 - cl1) cl)) | IndexWithTrie {argno; mode; args_idx} -> - Printf.printf "Current goal to index %s\n" (Term.show_term goal); + [%spy "dev:disc-tree-filter-number1" ~rid Elpi_util.Util.pp_string + (Printf.sprintf "Current goal is %s\n" (Term.show_term goal))]; let (arg, mode_arg) = trie_goal_args ~depth mode goal argno in let unifying_clauses = if mode_arg then DT.retrieve_generalizations args_idx arg else DT.retrieve_unifiables args_idx arg in - [%spy "dev:disc-tree-filter-number" ~rid Elpi_util.Util.pp_string + [%spy "dev:disc-tree-filter-number2" ~rid Elpi_util.Util.pp_string (Printf.sprintf "Filtered clauses number is %d\n" (List.length unifying_clauses))]; List.map fst unifying_clauses with Not_found -> [] From b01864a162f0748d6cf8095c92d8d111cbf020ca Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 15 Nov 2023 17:37:42 +0100 Subject: [PATCH 13/57] update changelog --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 1bc8ac46d..06f47343b 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,8 @@ Library: - New `std.fold-right` + - New clause retrieval through discrimination tree where the index of all the + parameters are set to `0` but one: the argument of which the search is done # v1.18.0 (October 2023) From e35f26ff1c01982fd6a5b3b98f83c49e1e02cfb0 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 15 Nov 2023 17:45:38 +0100 Subject: [PATCH 14/57] Error on invalid index arity (> arity of pred) --- src/compiler.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/compiler.ml b/src/compiler.ml index a71dcfcea..a9d9c721e 100644 --- a/src/compiler.ml +++ b/src/compiler.ml @@ -2406,10 +2406,10 @@ let run let mode = try C.Map.find name modes with Not_found -> [] in let declare_index, index = match tindex with - | Some (Ast.Structured.Index l) -> - (* TODO: @FissoreD should we assert (length l <= length mode) - for example if we have :index (1 0 0 1) pred binary i:int, i:int ? *) - true, chose_indexing state name l + | Some (Ast.Structured.Index l) -> + if (List.length l > List.length mode) + then failwith ("Invalid index arity for predicate" ^ Symbols.show state name) + else true, chose_indexing state name l | _ -> false, chose_indexing state name [1] in try let _, old_tindex = C.Map.find name map in From 6319f886736c3bfee4da2b08a6dce9f420084d92 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 15 Nov 2023 17:49:22 +0100 Subject: [PATCH 15/57] Update comment --- src/data.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/data.ml b/src/data.ml index 751f70d11..5ae822e79 100644 --- a/src/data.ml +++ b/src/data.ml @@ -185,8 +185,8 @@ and type t = (clause * int) list = struct let add = List.cons let singleton a = [a] (* - TODO: the order is obteined via a merge of the two lists. Note that each - are sorted by the timestamp of clauses. + NOTE: the lists l1 and l2 are supposed to be sorted by timestamp, + therefore we simply do the merge algorithm to have a sorted list *) let rec union (l1: t) (l2 : t) = match l1, l2 with | [], l | l, [] -> l From a0cd4260055ff05988a3ece8121f46fa726c5a21 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 15 Nov 2023 17:54:50 +0100 Subject: [PATCH 16/57] Minor updates --- src/data.ml | 2 +- src/runtime.ml | 30 +++--------------------------- src/trie.ml | 18 ------------------ src/trie.mli | 2 -- 4 files changed, 4 insertions(+), 48 deletions(-) diff --git a/src/data.ml b/src/data.ml index 5ae822e79..649b989aa 100644 --- a/src/data.ml +++ b/src/data.ml @@ -247,7 +247,7 @@ and second_lvl_idx = } | IndexWithTrie of { mode : mode; - argno : int; (* position of argument on which the trie is build *) + argno : int; (* position of argument on which the trie is built *) time : int; (* time is used to recover the total order *) args_idx : DT.t; } diff --git a/src/runtime.ml b/src/runtime.ml index f620f5fd8..503453291 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2318,12 +2318,9 @@ let rec classify_clause_arg ~depth matching t = else Rigid (hash+1,matching) (** - [classify_clause_argno ~depth N mode L] - where L is the arguments of the clause. - Returns the classification of the Nth element of L wrt to the Nth mode. -*) -(* QUESTION: why do not simply List.nth argno modes of L. I think that mode and - and N should (len(L) = len(mode) < N). Is is true ? + [classify_clause_argno ~depth N mode L] where L is the arguments of the + clause. Returns the classification of the Nth element of L wrt to the Nth mode + for the TwoLevelIndex *) let rec classify_clause_argno ~depth argno mode = function | [] -> Variable @@ -2422,26 +2419,6 @@ let hash_arg_list is_goal hd ~depth args mode spec = let hash_clause_arg_list = hash_arg_list false let hash_goal_arg_list = hash_arg_list true -(* bool -> constant -> depth:constant -> term list -> bool list ->constant list -> constant *) -(* let build_trie_list (is_goal : bool) (hd: constant) ~(depth: constant) - (args: term list) (mode: bool list) (spec : int) : Path_trie.PathTrie.key = - let open Path_trie in - let rec build_path (term : term) : PathTrie.key = - match term with - | App (c, x, xs) -> Constant (c, List.length xs + 1) :: build_list (x :: xs) - | Const c -> [Constant (c, 0)] - | UVar _ | _ -> [Variable] - and - build_list x = List.map build_path x |> List.flatten - in - let res = - try build_path (List.nth args spec) - with Failure s as x -> if s = "nth" then failwith "Invalid indexing" else raise x - in - List.iter (fun x -> OrderedPath.print x) res; - Printf.printf "\n"; - res *) - let add1clause ~depth m (predicate,clause) = match Ptmap.find predicate m with | TwoLevelIndex { all_clauses; argno; mode; flex_arg_clauses; arg_idx } -> @@ -2494,7 +2471,6 @@ let add1clause ~depth m (predicate,clause) = Ptmap.add predicate (IndexWithTrie { mode; argno; time = time+1; - (* TODO: is the order of the clauses respected ? *) args_idx = path }) m | exception Not_found -> diff --git a/src/trie.ml b/src/trie.ml index e657c00e6..8698c0b7b 100644 --- a/src/trie.ml +++ b/src/trie.ml @@ -142,22 +142,4 @@ module Make (M : Elpi_util.Util.Map.S) = struct | Node (None, m1) -> M.is_empty m1 | _ -> false - let rec pp (f: (Format.formatter -> 'a -> unit)) (fmt: Format.formatter) (m: 'a t) = - let print_key k = Printf.printf "k: " in - (match m with - | Node (None, sons) -> Printf.printf "None ["; M.iter (fun k v -> print_key k; Printf.printf " v:"; pp f fmt v) sons; Printf.printf "]" - | Node (Some k, sons) -> Printf.printf "Some ["; print_key k; M.iter (fun k v -> pp f fmt v) sons); Printf.printf "]" - - (* (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t *) - let show f m = - let b = Buffer.create 20 in - let fmt = Format.formatter_of_buffer b in - pp f fmt m; - Buffer.contents b - - (* let pp f fmt m = - let l = to_list m in - Elpi_util.Util.(pplist (pp_pair Int.pp f) " " fmt l) - - *) end diff --git a/src/trie.mli b/src/trie.mli index 624296e3d..1abe7bd97 100644 --- a/src/trie.mli +++ b/src/trie.mli @@ -15,6 +15,4 @@ module Make : val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val is_empty : 'a t -> bool - val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit - val show : (Format.formatter -> 'a -> unit) -> 'a t -> string end From 4d0bfbe27cbd52b29ce585287cc2b0a769f7503f Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 15 Nov 2023 18:08:39 +0100 Subject: [PATCH 17/57] Delete test.elpi --- test.elpi | 40 ---------------------------------------- 1 file changed, 40 deletions(-) delete mode 100644 test.elpi diff --git a/test.elpi b/test.elpi deleted file mode 100644 index 66de2ca99..000000000 --- a/test.elpi +++ /dev/null @@ -1,40 +0,0 @@ -kind my_list type. -type mcons int -> my_list -> my_list. -type mint int -> my_list. -type mstring string -> my_list. -type mlist my_list -> my_list -> my_list. -type mnil my_list. - -:index (_ 33 _) -pred my_pred o:my_list, o:int. -my_pred mnil 2. -my_pred (mlist (mcons 0 mnil) (mcons 1 mnil)) 3. -my_pred (mlist (mcons 1 mnil) (mcons 2 mnil)) 4. -my_pred (mcons 0 (mint 0)) 5. -my_pred (mint X) 6 :- X = 3. -my_pred (mstring "a") 7. -my_pred (mstring "a") 8. -my_pred (mstring "b") 9. - -:index (33) -pred order o:int. -order 0 :- print "0". -order _ :- print "1". -order 2 :- print "2". -order _ :- print "3". - -main :- - print "first attempt with 0", - (order 0, fail); - print "second attempt with 1", - (order 1, fail); - print "third attempt with 2", - (order 2, fail); - print "fourth attempt with X", - (order X, fail). - -% main :- -% my_pred (mstring X) Y, -% print "Solution" X, fail. - -main :- print "End backtracking". \ No newline at end of file From 02f96a78a76dcd447304696baffa894d2e25d716 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 15 Nov 2023 19:57:01 +0100 Subject: [PATCH 18/57] WIP: deriving show for trie and disc tree --- src/data.ml | 15 +++++++-------- src/discrimination_tree.ml | 16 ++++++++++++---- src/trie.ml | 23 ++++++++++++++++++++--- src/trie.mli | 1 + 4 files changed, 40 insertions(+), 15 deletions(-) diff --git a/src/data.ml b/src/data.ml index 649b989aa..1666649da 100644 --- a/src/data.ml +++ b/src/data.ml @@ -132,8 +132,8 @@ type 'a path_string_elem = | PrimitiveType of Elpi_util.Util.CData.t [@@deriving show] - type 'a path = ('a path_string_elem) list +[@@deriving show] let arity_of = function | Constant (_,a) -> a @@ -144,8 +144,12 @@ module TreeIndexable : Discrimination_tree.IndexableTerm with = struct type cell = (constant path_string_elem) [@@deriving show] + type path = cell list + [@@deriving show] + type input = term + let variable = Variable let compare = compare @@ -176,6 +180,7 @@ module MyListClause : Discrimination_tree.MyList with type elt = (clause * int) and type t = (clause * int) list = struct type elt = clause * int [@@deriving show] + type t = elt list [@@deriving show] @@ -204,13 +209,7 @@ and type t = (clause * int) list = struct let of_list = Fun.id end -module DT = struct - include Discrimination_tree.Make(TreeIndexable)(MyListClause) - - let pp f fmt = Printf.printf "PP of DT is to be done" - - let show x = "Show of DT is to be done" -end +module DT = Discrimination_tree.Make(TreeIndexable)(MyListClause) type stuck_goal = { mutable blockers : blockers; diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 19728ef73..cb8b08690 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -11,6 +11,7 @@ module type IndexableTerm = sig val pp_cell: Format.formatter -> cell -> unit type path = cell list + val compare: cell -> cell -> int val path_string_of : input -> path @@ -38,6 +39,8 @@ module type DiscriminationTree = type dataset type cell type t + + include Elpi_util.Util.Show with type t := t val iter : t -> (cell list -> dataset -> unit) -> unit val fold : t -> (cell list -> dataset -> 'b -> 'b) -> 'b -> 'b @@ -63,8 +66,7 @@ module type DiscriminationTree = module type MyList = sig type elt - include Elpi_util.Util.Show with type t := elt - type t + type t include Elpi_util.Util.Show with type t := t val empty: t val is_empty: t -> bool @@ -81,7 +83,9 @@ module type MyList = sig val of_list: elt list -> t end -module Make (I:IndexableTerm) (A:MyList) = +module Make (I:IndexableTerm) (A:MyList) : DiscriminationTree with +type data = A.elt and type dataset = A.t and type input = I.input and +type cell = I.cell = struct @@ -95,6 +99,7 @@ module Make (I:IndexableTerm) (A:MyList) = type data = A.elt type dataset = A.t + type input = I.input type cell = I.cell @@ -102,7 +107,10 @@ module Make (I:IndexableTerm) (A:MyList) = module Trie = Trie.Make(PSMap) - type t = A.t Trie.t + type t = dataset Trie.t [@@deriving show] + + let pp = Trie.pp A.pp + let show = Trie.show A.pp let empty = Trie.empty diff --git a/src/trie.ml b/src/trie.ml index 8698c0b7b..73f9341fd 100644 --- a/src/trie.ml +++ b/src/trie.ml @@ -21,7 +21,6 @@ defined as soon as a map over the elements of the list is given. *) - module Make (M : Elpi_util.Util.Map.S) = struct (*s Then a trie is just a tree-like structure, where a possible @@ -30,10 +29,8 @@ module Make (M : Elpi_util.Util.Map.S) = struct ['a t M.t]. The empty trie is just the empty map. *) type key = M.key list - [@@deriving show] type 'a t = Node of 'a option * 'a t M.t - [@@deriving show] let empty = Node (None, M.empty) @@ -141,5 +138,25 @@ module Make (M : Elpi_util.Util.Map.S) = struct let is_empty = function | Node (None, m1) -> M.is_empty m1 | _ -> false + + let show (fmt: (Format.formatter -> 'a -> unit)) (Node (a, b): 'a t) : string = + (* Format.fprintf fmt "." *) + (* M.show () b *) + (* M.show fmt b *) + (* let node_cnt = match a with + | None -> "None" + | Some a -> "Some ()" ^ Format.fprintf _x "%a ->@ %a;@ " Ord.pp k f v in + Printf.sprintf "Node [%s]" "a" *) + Printf.sprintf "TODO: show of trie" + + let rec pp (ppelem : (Format.formatter -> 'a -> unit)) (fmt : Format.formatter) (Node (a, b) : 'a t) : unit = + Format.fprintf fmt "[values:{"; + begin match a with + | None -> Format.fprintf fmt "." + | Some x -> ppelem fmt x + end; + Format.fprintf fmt "} key:{"; + M.pp (pp ppelem) fmt b; + Format.fprintf fmt "}]" end diff --git a/src/trie.mli b/src/trie.mli index 1abe7bd97..e4fbcdbb0 100644 --- a/src/trie.mli +++ b/src/trie.mli @@ -15,4 +15,5 @@ module Make : val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val is_empty : 'a t -> bool + include Elpi_util.Util.Show1 with type 'a t := 'a t end From 3e359c49676abbc87baeab4c5abc2d25433f7abe Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 15 Nov 2023 19:57:17 +0100 Subject: [PATCH 19/57] Update Makefile --- Makefile | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 982133770..e3b893321 100644 --- a/Makefile +++ b/Makefile @@ -134,7 +134,4 @@ menhir-complete-errormsgs: menhir-strip-errormsgs: sed -e "/^##/d" -i.bak src/parser/error_messages.txt -.PHONY: tests help install build clean gh-pages - -myMake: - dune exec elpi -- -test test.elpi \ No newline at end of file +.PHONY: tests help install build clean gh-pages \ No newline at end of file From ef2010a70ef9d1294761de6596b3bd4d82670a1d Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 15 Nov 2023 22:59:47 +0100 Subject: [PATCH 20/57] Update show and pp of Disc tree --- src/compiler.ml | 4 +--- src/data.ml | 9 ++++++++- src/trie.ml | 16 +++++----------- 3 files changed, 14 insertions(+), 15 deletions(-) diff --git a/src/compiler.ml b/src/compiler.ml index a9d9c721e..8a7884cb6 100644 --- a/src/compiler.ml +++ b/src/compiler.ml @@ -2407,9 +2407,7 @@ let run let declare_index, index = match tindex with | Some (Ast.Structured.Index l) -> - if (List.length l > List.length mode) - then failwith ("Invalid index arity for predicate" ^ Symbols.show state name) - else true, chose_indexing state name l + true, chose_indexing state name l | _ -> false, chose_indexing state name [1] in try let _, old_tindex = C.Map.find name map in diff --git a/src/data.ml b/src/data.ml index 1666649da..82389de3b 100644 --- a/src/data.ml +++ b/src/data.ml @@ -179,7 +179,14 @@ end module MyListClause : Discrimination_tree.MyList with type elt = (clause * int) and type t = (clause * int) list = struct type elt = clause * int - [@@deriving show] + (* [@@deriving show] *) + + let pp_elt (fmt:Format.formatter) ((cl, _): clause * int) = + Format.fprintf fmt "[clause_args:"; + pplist pp_term ", " fmt cl.args; + Format.fprintf fmt " ;; clause_hyps:"; + pplist pp_term ", " fmt cl.hyps; + Format.fprintf fmt "]"; type t = elt list [@@deriving show] diff --git a/src/trie.ml b/src/trie.ml index 73f9341fd..5c87a5e3b 100644 --- a/src/trie.ml +++ b/src/trie.ml @@ -138,17 +138,6 @@ module Make (M : Elpi_util.Util.Map.S) = struct let is_empty = function | Node (None, m1) -> M.is_empty m1 | _ -> false - - - let show (fmt: (Format.formatter -> 'a -> unit)) (Node (a, b): 'a t) : string = - (* Format.fprintf fmt "." *) - (* M.show () b *) - (* M.show fmt b *) - (* let node_cnt = match a with - | None -> "None" - | Some a -> "Some ()" ^ Format.fprintf _x "%a ->@ %a;@ " Ord.pp k f v in - Printf.sprintf "Node [%s]" "a" *) - Printf.sprintf "TODO: show of trie" let rec pp (ppelem : (Format.formatter -> 'a -> unit)) (fmt : Format.formatter) (Node (a, b) : 'a t) : unit = Format.fprintf fmt "[values:{"; @@ -159,4 +148,9 @@ module Make (M : Elpi_util.Util.Map.S) = struct Format.fprintf fmt "} key:{"; M.pp (pp ppelem) fmt b; Format.fprintf fmt "}]" + + let show (fmt: (Format.formatter -> 'a -> unit)) (n: 'a t) : string = + let b = Buffer.create 22 in + Format.fprintf (Format.formatter_of_buffer b) "@[%a@]" (pp fmt) n; + Buffer.contents b end From d599620a89653f634f8925a5c682978f85bad6cb Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 15 Nov 2023 23:01:55 +0100 Subject: [PATCH 21/57] remove print --- src/runtime.ml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/runtime.ml b/src/runtime.ml index 503453291..1d67dd811 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2591,14 +2591,12 @@ let get_clauses ~depth predicate goal { index = m } = let cl = List.flatten (Ptmap.find_unifiables hash args_idx) in List.(map fst (sort (fun (_,cl1) (_,cl2) -> cl2 - cl1) cl)) | IndexWithTrie {argno; mode; args_idx} -> - [%spy "dev:disc-tree-filter-number1" ~rid Elpi_util.Util.pp_string - (Printf.sprintf "Current goal is %s\n" (Term.show_term goal))]; + [%spy "dev:disc-tree-filter-number1" ~rid pp_string "Current goal is" pp_term goal]; let (arg, mode_arg) = trie_goal_args ~depth mode goal argno in let unifying_clauses = if mode_arg then DT.retrieve_generalizations args_idx arg else DT.retrieve_unifiables args_idx arg in - [%spy "dev:disc-tree-filter-number2" ~rid Elpi_util.Util.pp_string - (Printf.sprintf "Filtered clauses number is %d\n" (List.length unifying_clauses))]; + [%spy "dev:disc-tree-filter-number2" ~rid pp_string "Filtered clauses number is" pp_int (List.length unifying_clauses)]; List.map fst unifying_clauses with Not_found -> [] in From f084e23f004790e9469709104aa72e7e5f306dec Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 15 Nov 2023 23:16:13 +0100 Subject: [PATCH 22/57] Code format --- src/data.ml | 28 ++- src/discrimination_tree.ml | 363 +++++++++++++------------------------ 2 files changed, 142 insertions(+), 249 deletions(-) diff --git a/src/data.ml b/src/data.ml index 82389de3b..9ef2ef3a1 100644 --- a/src/data.ml +++ b/src/data.ml @@ -120,12 +120,20 @@ type clause = { args : term list; hyps : term list; vars : int; - mode : mode; (* CACHE to avoid allocation in get_clauses *) + mode : mode; (* CACHE to avoid allocation in get_clauses *) loc : Loc.t option; (* debug *) } and mode = bool list (* true=input, false=output *) [@@deriving show] +(* Simpler pretty printer for clause *) +let pp_clause_simple (fmt:Format.formatter) (cl: clause) = + Format.fprintf fmt "[clause_args:"; + pplist pp_term ", " fmt cl.args; + Format.fprintf fmt " ;; clause_hyps:"; + pplist pp_term ", " fmt cl.hyps; + Format.fprintf fmt "]"; + type 'a path_string_elem = | Constant of 'a * int | Variable @@ -142,12 +150,8 @@ let arity_of = function module TreeIndexable : Discrimination_tree.IndexableTerm with type input = term and type cell = constant path_string_elem = struct - type cell = (constant path_string_elem) - [@@deriving show] - - type path = cell list - [@@deriving show] - + type cell = (constant path_string_elem) [@@deriving show] + type path = cell list [@@deriving show] type input = term let variable = Variable @@ -179,14 +183,8 @@ end module MyListClause : Discrimination_tree.MyList with type elt = (clause * int) and type t = (clause * int) list = struct type elt = clause * int - (* [@@deriving show] *) - - let pp_elt (fmt:Format.formatter) ((cl, _): clause * int) = - Format.fprintf fmt "[clause_args:"; - pplist pp_term ", " fmt cl.args; - Format.fprintf fmt " ;; clause_hyps:"; - pplist pp_term ", " fmt cl.hyps; - Format.fprintf fmt "]"; + + let pp_elt a (cl, _) = pp_clause_simple a cl type t = elt list [@@deriving show] diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index cb8b08690..9c062d9fd 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -3,15 +3,14 @@ (* ------------------------------------------------------------------------- *) module type IndexableTerm = sig + type input - type cell + type path = cell list val show_cell: cell -> string val pp_cell: Format.formatter -> cell -> unit - type path = cell list - val compare: cell -> cell -> int val path_string_of : input -> path @@ -25,249 +24,145 @@ module type IndexableTerm = sig The input ariety is the one of f while the path is x.g....t Should be the equivalent of after_t in the literature (handbook A.R.) *) - (* MAYBE: a pointer to t from f should increase performances (i.e. jump list from McCune 1990) *) + (* MAYBE: a pointer to t from f should increase performances (i.e. jump list + from McCune 1990) *) val skip : path -> path val arity_of : cell -> int val variable : cell end module type DiscriminationTree = - sig - - type input - type data - type dataset - type cell - type t - - include Elpi_util.Util.Show with type t := t - - val iter : t -> (cell list -> dataset -> unit) -> unit - val fold : t -> (cell list -> dataset -> 'b -> 'b) -> 'b -> 'b - - val empty : t - val index : t -> input -> data -> t - val remove_index : t -> input -> data -> t - val in_index : t -> input -> (data -> bool) -> bool - val retrieve_generalizations : t -> input -> dataset - val retrieve_unifiables : t -> input -> dataset - - module type Collector = sig - type t - val empty : t - val union : t -> t -> t - val inter : t -> t -> data list - val to_list : t -> data list - end - module Collector : Collector - val retrieve_generalizations_sorted : t -> input -> Collector.t - val retrieve_unifiables_sorted : t -> input -> Collector.t - end +sig + type input + type data + type dataset + type cell + type t -module type MyList = sig - type elt - type t - include Elpi_util.Util.Show with type t := t - val empty: t - val is_empty: t -> bool - val mem: elt -> t -> bool - val add: elt -> t -> t - val singleton: elt -> t - val remove: elt -> t -> t - val union: t -> t -> t - val compare: t -> t -> int - val equal: t -> t -> bool - val exists: (elt -> bool) -> t -> bool - val elements: t -> elt list - val find: elt -> t -> elt - val of_list: elt list -> t + include Elpi_util.Util.Show with type t := t + + val iter : t -> (cell list -> dataset -> unit) -> unit + val fold : t -> (cell list -> dataset -> 'b -> 'b) -> 'b -> 'b + + val empty : t + val index : t -> input -> data -> t + val remove_index : t -> input -> data -> t + val in_index : t -> input -> (data -> bool) -> bool + val retrieve_generalizations : t -> input -> dataset + val retrieve_unifiables : t -> input -> dataset end -module Make (I:IndexableTerm) (A:MyList) : DiscriminationTree with -type data = A.elt and type dataset = A.t and type input = I.input and -type cell = I.cell = - - struct - - module OrderedPathStringElement = struct - type t = I.cell - - let show = I.show_cell - let pp = I.pp_cell - let compare = I.compare - end - - type data = A.elt - type dataset = A.t - - type input = I.input - type cell = I.cell - - module PSMap = Elpi_util.Util.Map.Make(OrderedPathStringElement) - - module Trie = Trie.Make(PSMap) - - type t = dataset Trie.t [@@deriving show] - - let pp = Trie.pp A.pp - let show = Trie.show A.pp - - let empty = Trie.empty - - let iter dt f = Trie.iter (fun p x -> f p x) dt - - let fold dt f = Trie.fold (fun p x -> f p x) dt - - let index tree term info = - let ps = I.path_string_of term in - let ps_set = - try Trie.find ps tree with Not_found -> A.empty - in - Trie.add ps (A.add info ps_set) tree - - let remove_index tree term info = - let ps = I.path_string_of term in - try - let ps_set = A.remove info (Trie.find ps tree) in - if A.is_empty ps_set then Trie.remove ps tree - else Trie.add ps ps_set tree - with Not_found -> tree - - let in_index tree term test = - let ps = I.path_string_of term in - try - let ps_set = Trie.find ps tree in - A.exists test ps_set - with Not_found -> false - - (* the equivalent of skip, but on the index, thus the list of trees - that are rooted just after the term represented by the tree root - are returned (we are skipping the root) *) - let skip_root (Trie.Node (_value, map)) = - let rec get n = function Trie.Node (_v, m) as tree -> - if n = 0 then [tree] else - PSMap.fold (fun k v res -> (get (n-1 + I.arity_of k) v) @ res) m [] - in - PSMap.fold (fun k v res -> (get (I.arity_of k) v) @ res) map [] - - let retrieve unif tree term = - let path = I.path_string_of term in - let rec retrieve path tree = - match tree, path with - | Trie.Node (Some s, _), [] -> s - | Trie.Node (None, _), [] -> A.empty - | Trie.Node (_, _map), v::path when v = I.variable && unif -> - List.fold_left A.union A.empty - (List.map (retrieve path) (skip_root tree)) - | Trie.Node (_, map), node::path -> - A.union - (if not unif && I.variable = node then A.empty else - try retrieve path (PSMap.find node map) - with Not_found -> A.empty) - (try - match PSMap.find I.variable map, I.skip (node :: path) with - | Trie.Node (Some s, _), [] -> s - | n, path -> retrieve path n - with Not_found -> A.empty) - in - retrieve path tree - - - let retrieve_generalizations tree term = retrieve false tree term - let retrieve_unifiables tree term = retrieve true tree term - - module O = struct - type t = A.t * int - let compare (sa,wa) (sb,wb) = - let c = compare wb wa in - if c <> 0 then c else A.compare sb sa - end - module S = Set.Make(O) - - (* TASSI: here we should think of a smarted data structure *) - module type Collector = sig - type t - val empty : t - val union : t -> t -> t - val inter : t -> t -> data list - val to_list : t -> data list - end - module Collector : Collector with type t = S.t = struct - type t = S.t - let union = S.union - let empty = S.empty - - let merge l = - let rec aux s w = function - | [] -> [s,w] - | (t, wt)::tl when w = wt -> aux (A.union s t) w tl - | (t, wt)::tl -> (s, w) :: aux t wt tl - in - match l with - | [] -> [] - | (s, w) :: l -> aux s w l - - let rec undup ~eq = function - | [] -> [] - | x :: tl -> x :: undup ~eq (List.filter (fun y -> not(eq x y)) tl) - - let to_list t = - undup ~eq:(fun x y -> A.equal (A.singleton x) (A.singleton y)) - (List.flatten (List.map - (fun (x,_) -> A.elements x) (merge (S.elements t)))) - - let rec filter_map f = function - | [] -> [] - | x :: xs -> - match f x with - | None -> filter_map f xs - | Some y -> y :: filter_map f xs +module type MyList = sig + type elt + type t - let inter t1 t2 = - let l1 = merge (S.elements t1) in - let l2 = merge (S.elements t2) in - let res = - List.flatten - (List.map - (fun (s, w) -> - filter_map (fun x -> - try Some (x, w + snd (List.find (fun (s,_w) -> A.mem x s) l2)) - with Not_found -> None) - (A.elements s)) - l1) - in - undup ~eq:(fun x y -> A.equal (A.singleton x) (A.singleton y)) - (List.map fst (List.sort (fun (_,x) (_,y) -> y - x) res)) - end + include Elpi_util.Util.Show with type t := t + + val empty: t + val is_empty: t -> bool + val mem: elt -> t -> bool + val add: elt -> t -> t + val singleton: elt -> t + val remove: elt -> t -> t + val union: t -> t -> t + val compare: t -> t -> int + val equal: t -> t -> bool + val exists: (elt -> bool) -> t -> bool + val elements: t -> elt list + val find: elt -> t -> elt + val of_list: elt list -> t +end - let retrieve_sorted unif tree term = - let path = I.path_string_of term in - let rec retrieve n path tree = - match tree, path with - | Trie.Node (Some s, _), [] -> S.singleton (s, n) - | Trie.Node (None, _), [] -> S.empty - | Trie.Node (_, _map), v::path when unif && v = I.variable -> - List.fold_left S.union S.empty - (List.map (retrieve n path) (skip_root tree)) - | Trie.Node (_, map), node::path -> - S.union - (if not unif && node = I.variable then S.empty else - try retrieve (n+1) path (PSMap.find node map) - with Not_found -> S.empty) - (try - match PSMap.find I.variable map,I.skip (node::path) with - | Trie.Node (Some s, _), [] -> - S.singleton (s, n) - | no, path -> retrieve n path no - with Not_found -> S.empty) - in - retrieve 0 path tree - +module Make (I:IndexableTerm) (A:MyList) : + DiscriminationTree with type data = A.elt and type dataset = A.t + and type input = I.input and type cell = I.cell = struct + + module OrderedPathStringElement = struct + type t = I.cell + + let show = I.show_cell + let pp = I.pp_cell + let compare = I.compare + end + + type data = A.elt + type dataset = A.t + + type input = I.input + type cell = I.cell + + module PSMap = Elpi_util.Util.Map.Make(OrderedPathStringElement) + + module Trie = Trie.Make(PSMap) + + type t = dataset Trie.t + + let pp = Trie.pp A.pp + let show = Trie.show A.pp + + let empty = Trie.empty + + let iter dt f = Trie.iter (fun p x -> f p x) dt + + let fold dt f = Trie.fold (fun p x -> f p x) dt + + let index tree term info = + let ps = I.path_string_of term in + let ps_set = + try Trie.find ps tree with Not_found -> A.empty + in + Trie.add ps (A.add info ps_set) tree + + let remove_index tree term info = + let ps = I.path_string_of term in + try + let ps_set = A.remove info (Trie.find ps tree) in + if A.is_empty ps_set then Trie.remove ps tree + else Trie.add ps ps_set tree + with Not_found -> tree + + let in_index tree term test = + let ps = I.path_string_of term in + try + let ps_set = Trie.find ps tree in + A.exists test ps_set + with Not_found -> false + + (* the equivalent of skip, but on the index, thus the list of trees + that are rooted just after the term represented by the tree root + are returned (we are skipping the root) *) + let skip_root (Trie.Node (_value, map)) = + let rec get n = function Trie.Node (_v, m) as tree -> + if n = 0 then [tree] else + PSMap.fold (fun k v res -> (get (n-1 + I.arity_of k) v) @ res) m [] + in + PSMap.fold (fun k v res -> (get (I.arity_of k) v) @ res) map [] + + let retrieve unif tree term = + let path = I.path_string_of term in + let rec retrieve path tree = + match tree, path with + | Trie.Node (Some s, _), [] -> s + | Trie.Node (None, _), [] -> A.empty + | Trie.Node (_, _map), v::path when v = I.variable && unif -> + List.fold_left A.union A.empty + (List.map (retrieve path) (skip_root tree)) + | Trie.Node (_, map), node::path -> + A.union + (if not unif && I.variable = node then A.empty else + try retrieve path (PSMap.find node map) + with Not_found -> A.empty) + (try + match PSMap.find I.variable map, I.skip (node :: path) with + | Trie.Node (Some s, _), [] -> s + | n, path -> retrieve path n + with Not_found -> A.empty) + in + retrieve path tree + - let retrieve_generalizations_sorted tree term = - retrieve_sorted false tree term - let retrieve_unifiables_sorted tree term = - retrieve_sorted true tree term + let retrieve_generalizations tree term = retrieve false tree term + let retrieve_unifiables tree term = retrieve true tree term end From 30997a95ab305befbe3ee4d13cfa279bc8e77eb0 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 15 Nov 2023 23:19:24 +0100 Subject: [PATCH 23/57] Code format --- src/trie.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/trie.ml b/src/trie.ml index 5c87a5e3b..dab7fe8ab 100644 --- a/src/trie.ml +++ b/src/trie.ml @@ -149,8 +149,8 @@ module Make (M : Elpi_util.Util.Map.S) = struct M.pp (pp ppelem) fmt b; Format.fprintf fmt "}]" - let show (fmt: (Format.formatter -> 'a -> unit)) (n: 'a t) : string = - let b = Buffer.create 22 in - Format.fprintf (Format.formatter_of_buffer b) "@[%a@]" (pp fmt) n; - Buffer.contents b + let show (fmt: (Format.formatter -> 'a -> unit)) (n: 'a t) : string = + let b = Buffer.create 22 in + Format.fprintf (Format.formatter_of_buffer b) "@[%a@]" (pp fmt) n; + Buffer.contents b end From e96bd4956054f480225c50188bc5664114db39bf Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 15 Nov 2023 23:25:57 +0100 Subject: [PATCH 24/57] code cleanup --- src/discrimination_tree.ml | 129 +++++++++++++++---------------- src/trie.ml | 150 ++++++++++++++++++------------------- src/trie.mli | 38 +++++----- 3 files changed, 152 insertions(+), 165 deletions(-) diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 9c062d9fd..f10211284 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -3,26 +3,24 @@ (* ------------------------------------------------------------------------- *) module type IndexableTerm = sig - type input type cell type path = cell list - - val show_cell: cell -> string - val pp_cell: Format.formatter -> cell -> unit - val compare: cell -> cell -> int + val show_cell : cell -> string + val pp_cell : Format.formatter -> cell -> unit + val compare : cell -> cell -> int val path_string_of : input -> path - (* You have h(f(x,g(y,z)),t) whose path_string_of_term_with_jl is - (h,2).(f,2).(x,0).(g,2).(y,0).(z,0).(t,0) and you are at f and want to - skip all its progeny, thus you want to reach t. + (* You have h(f(x,g(y,z)),t) whose path_string_of_term_with_jl is + (h,2).(f,2).(x,0).(g,2).(y,0).(z,0).(t,0) and you are at f and want to + skip all its progeny, thus you want to reach t. - You need to skip as many elements as the sum of all arieties contained - in the progeny of f. + You need to skip as many elements as the sum of all arieties contained + in the progeny of f. - The input ariety is the one of f while the path is x.g....t - Should be the equivalent of after_t in the literature (handbook A.R.) + The input ariety is the one of f while the path is x.g....t + Should be the equivalent of after_t in the literature (handbook A.R.) *) (* MAYBE: a pointer to t from f should increase performances (i.e. jump list from McCune 1990) *) @@ -31,19 +29,17 @@ module type IndexableTerm = sig val variable : cell end -module type DiscriminationTree = -sig - type input +module type DiscriminationTree = sig + type input type data type dataset type cell type t include Elpi_util.Util.Show with type t := t - + val iter : t -> (cell list -> dataset -> unit) -> unit val fold : t -> (cell list -> dataset -> 'b -> 'b) -> 'b -> 'b - val empty : t val index : t -> input -> data -> t val remove_index : t -> input -> data -> t @@ -54,29 +50,31 @@ end module type MyList = sig type elt - type t + type t include Elpi_util.Util.Show with type t := t - - val empty: t - val is_empty: t -> bool - val mem: elt -> t -> bool - val add: elt -> t -> t - val singleton: elt -> t - val remove: elt -> t -> t - val union: t -> t -> t - val compare: t -> t -> int - val equal: t -> t -> bool - val exists: (elt -> bool) -> t -> bool - val elements: t -> elt list - val find: elt -> t -> elt - val of_list: elt list -> t -end -module Make (I:IndexableTerm) (A:MyList) : - DiscriminationTree with type data = A.elt and type dataset = A.t - and type input = I.input and type cell = I.cell = struct + val empty : t + val is_empty : t -> bool + val mem : elt -> t -> bool + val add : elt -> t -> t + val singleton : elt -> t + val remove : elt -> t -> t + val union : t -> t -> t + val compare : t -> t -> int + val equal : t -> t -> bool + val exists : (elt -> bool) -> t -> bool + val elements : t -> elt list + val find : elt -> t -> elt + val of_list : elt list -> t +end +module Make (I : IndexableTerm) (A : MyList) : + DiscriminationTree + with type data = A.elt + and type dataset = A.t + and type input = I.input + and type cell = I.cell = struct module OrderedPathStringElement = struct type t = I.cell @@ -85,40 +83,31 @@ module Make (I:IndexableTerm) (A:MyList) : let compare = I.compare end + module PSMap = Elpi_util.Util.Map.Make (OrderedPathStringElement) + module Trie = Trie.Make (PSMap) + type data = A.elt type dataset = A.t - type input = I.input - type cell = I.cell - - module PSMap = Elpi_util.Util.Map.Make(OrderedPathStringElement) - - module Trie = Trie.Make(PSMap) - type t = dataset Trie.t + type cell = I.cell let pp = Trie.pp A.pp let show = Trie.show A.pp - let empty = Trie.empty - let iter dt f = Trie.iter (fun p x -> f p x) dt - let fold dt f = Trie.fold (fun p x -> f p x) dt let index tree term info = let ps = I.path_string_of term in - let ps_set = - try Trie.find ps tree with Not_found -> A.empty - in + let ps_set = try Trie.find ps tree with Not_found -> A.empty in Trie.add ps (A.add info ps_set) tree let remove_index tree term info = let ps = I.path_string_of term in try let ps_set = A.remove info (Trie.find ps tree) in - if A.is_empty ps_set then Trie.remove ps tree - else Trie.add ps ps_set tree + if A.is_empty ps_set then Trie.remove ps tree else Trie.add ps ps_set tree with Not_found -> tree let in_index tree term test = @@ -132,37 +121,37 @@ module Make (I:IndexableTerm) (A:MyList) : that are rooted just after the term represented by the tree root are returned (we are skipping the root) *) let skip_root (Trie.Node (_value, map)) = - let rec get n = function Trie.Node (_v, m) as tree -> - if n = 0 then [tree] else - PSMap.fold (fun k v res -> (get (n-1 + I.arity_of k) v) @ res) m [] + let rec get n = function + | Trie.Node (_v, m) as tree -> + if n = 0 then [ tree ] + else + PSMap.fold (fun k v res -> get (n - 1 + I.arity_of k) v @ res) m [] in - PSMap.fold (fun k v res -> (get (I.arity_of k) v) @ res) map [] + PSMap.fold (fun k v res -> get (I.arity_of k) v @ res) map [] let retrieve unif tree term = let path = I.path_string_of term in let rec retrieve path tree = - match tree, path with + match (tree, path) with | Trie.Node (Some s, _), [] -> s - | Trie.Node (None, _), [] -> A.empty - | Trie.Node (_, _map), v::path when v = I.variable && unif -> + | Trie.Node (None, _), [] -> A.empty + | Trie.Node (_, _map), v :: path when v = I.variable && unif -> List.fold_left A.union A.empty (List.map (retrieve path) (skip_root tree)) - | Trie.Node (_, map), node::path -> + | Trie.Node (_, map), node :: path -> A.union - (if not unif && I.variable = node then A.empty else - try retrieve path (PSMap.find node map) - with Not_found -> A.empty) - (try - match PSMap.find I.variable map, I.skip (node :: path) with - | Trie.Node (Some s, _), [] -> s - | n, path -> retrieve path n - with Not_found -> A.empty) + (if (not unif) && I.variable = node then A.empty + else + try retrieve path (PSMap.find node map) + with Not_found -> A.empty) + (try + match (PSMap.find I.variable map, I.skip (node :: path)) with + | Trie.Node (Some s, _), [] -> s + | n, path -> retrieve path n + with Not_found -> A.empty) in retrieve path tree - let retrieve_generalizations tree term = retrieve false tree term let retrieve_unifiables tree term = retrieve true tree term end - - diff --git a/src/trie.ml b/src/trie.ml index dab7fe8ab..c2f97be30 100644 --- a/src/trie.ml +++ b/src/trie.ml @@ -22,112 +22,114 @@ given. *) module Make (M : Elpi_util.Util.Map.S) = struct - -(*s Then a trie is just a tree-like structure, where a possible - information is stored at the node (['a option]) and where the sons - are given by a map from type [key] to sub-tries, so of type - ['a t M.t]. The empty trie is just the empty map. *) + (*s Then a trie is just a tree-like structure, where a possible + information is stored at the node (['a option]) and where the sons + are given by a map from type [key] to sub-tries, so of type + ['a t M.t]. The empty trie is just the empty map. *) type key = M.key list - type 'a t = Node of 'a option * 'a t M.t let empty = Node (None, M.empty) -(*s To find a mapping in a trie is easy: when all the elements of the - key have been read, we just inspect the optional info at the - current node; otherwise, we descend in the appropriate sub-trie - using [M.find]. *) + (*s To find a mapping in a trie is easy: when all the elements of the + key have been read, we just inspect the optional info at the + current node; otherwise, we descend in the appropriate sub-trie + using [M.find]. *) - let rec find l t = match (l,t) with - | [], Node (None,_) -> raise Not_found - | [], Node (Some v,_) -> v - | x::r, Node (_,m) -> find r (M.find x m) + let rec find l t = + match (l, t) with + | [], Node (None, _) -> raise Not_found + | [], Node (Some v, _) -> v + | x :: r, Node (_, m) -> find r (M.find x m) - let mem l t = - try Fun.const true (find l t) with Not_found -> false + let mem l t = try Fun.const true (find l t) with Not_found -> false -(*s Insertion is more subtle. When the final node is reached, we just - put the information ([Some v]). Otherwise, we have to insert the - binding in the appropriate sub-trie [t']. But it may not exists, - and in that case [t'] is bound to an empty trie. Then we get a new - sub-trie [t''] by a recursive insertion and we modify the - branching, so that it now points to [t''], with [M.add]. *) + (*s Insertion is more subtle. When the final node is reached, we just + put the information ([Some v]). Otherwise, we have to insert the + binding in the appropriate sub-trie [t']. But it may not exists, + and in that case [t'] is bound to an empty trie. Then we get a new + sub-trie [t''] by a recursive insertion and we modify the + branching, so that it now points to [t''], with [M.add]. *) let add l v t = let rec ins = function - | [], Node (_,m) -> Node (Some v,m) - | x::r, Node (v,m) -> - let t' = try M.find x m with Not_found -> empty in - let t'' = ins (r,t') in - Node (v, M.add x t'' m) + | [], Node (_, m) -> Node (Some v, m) + | x :: r, Node (v, m) -> + let t' = try M.find x m with Not_found -> empty in + let t'' = ins (r, t') in + Node (v, M.add x t'' m) in - ins (l,t) - -(*s When removing a binding, we take care of not leaving bindings to empty - sub-tries in the nodes. Therefore, we test wether the result [t'] of - the recursive call is the empty trie [empty]: if so, we just remove - the branching with [M.remove]; otherwise, we modify it with [M.add]. *) - - let rec remove l t = match (l,t) with - | [], Node (_,m) -> Node (None,m) - | x::r, Node (v,m) -> - try - let t' = remove r (M.find x m) in - Node (v, if t' = empty then M.remove x m else M.add x t' m) - with Not_found -> - t - -(*s The iterators [map], [mapi], [iter] and [fold] are implemented in - a straigthforward way using the corresponding iterators [M.map], - [M.mapi], [M.iter] and [M.fold]. For the last three of them, - we have to remember the path from the root, as an extra argument - [revp]. Since elements are pushed in reverse order in [revp], - we have to reverse it with [List.rev] when the actual binding - has to be passed to function [f]. *) + ins (l, t) + + (*s When removing a binding, we take care of not leaving bindings to empty + sub-tries in the nodes. Therefore, we test wether the result [t'] of + the recursive call is the empty trie [empty]: if so, we just remove + the branching with [M.remove]; otherwise, we modify it with [M.add]. *) + + let rec remove l t = + match (l, t) with + | [], Node (_, m) -> Node (None, m) + | x :: r, Node (v, m) -> ( + try + let t' = remove r (M.find x m) in + Node (v, if t' = empty then M.remove x m else M.add x t' m) + with Not_found -> t) + + (*s The iterators [map], [mapi], [iter] and [fold] are implemented in + a straigthforward way using the corresponding iterators [M.map], + [M.mapi], [M.iter] and [M.fold]. For the last three of them, + we have to remember the path from the root, as an extra argument + [revp]. Since elements are pushed in reverse order in [revp], + we have to reverse it with [List.rev] when the actual binding + has to be passed to function [f]. *) let rec map f = function - | Node (None,m) -> Node (None, M.map (map f) m) - | Node (Some v,m) -> Node (Some (f v), M.map (map f) m) + | Node (None, m) -> Node (None, M.map (map f) m) + | Node (Some v, m) -> Node (Some (f v), M.map (map f) m) let mapi f t = let rec maprec revp = function - | Node (None,m) -> Node (None, M.mapi (fun x -> maprec (x::revp)) m) - | Node (Some v,m) -> - Node (Some (f (List.rev revp) v), M.mapi (fun x -> maprec (x::revp)) m) + | Node (None, m) -> Node (None, M.mapi (fun x -> maprec (x :: revp)) m) + | Node (Some v, m) -> + Node + (Some (f (List.rev revp) v), M.mapi (fun x -> maprec (x :: revp)) m) in maprec [] t let iter f t = let rec traverse revp = function - | Node (None,m) -> M.iter (fun x -> traverse (x::revp)) m - | Node (Some v,m) -> - f (List.rev revp) v; - M.iter (fun x t -> traverse (x::revp) t) m + | Node (None, m) -> M.iter (fun x -> traverse (x :: revp)) m + | Node (Some v, m) -> + f (List.rev revp) v; + M.iter (fun x t -> traverse (x :: revp) t) m in traverse [] t let fold f t acc = - let rec traverse revp t acc = match t with - | Node (None,m) -> M.fold (fun x -> traverse (x::revp)) m acc - | Node (Some v,m) -> - f (List.rev revp) v (M.fold (fun x -> traverse (x::revp)) m acc) + let rec traverse revp t acc = + match t with + | Node (None, m) -> M.fold (fun x -> traverse (x :: revp)) m acc + | Node (Some v, m) -> + f (List.rev revp) v (M.fold (fun x -> traverse (x :: revp)) m acc) in traverse [] t acc let compare cmp a b = - let rec comp a b = match a,b with + let rec comp a b = + match (a, b) with | Node (Some _, _), Node (None, _) -> 1 | Node (None, _), Node (Some _, _) -> -1 | Node (None, m1), Node (None, m2) -> M.compare comp m1 m2 | Node (Some a, m1), Node (Some b, m2) -> - let c = cmp a b in - if c <> 0 then c else M.compare comp m1 m2 + let c = cmp a b in + if c <> 0 then c else M.compare comp m1 m2 in comp a b let equal eq a b = - let rec comp a b = match a,b with + let rec comp a b = + match (a, b) with | Node (None, m1), Node (None, m2) -> M.equal comp m1 m2 | Node (Some a, m1), Node (Some b, m2) -> eq a b && M.equal comp m1 m2 | _ -> false @@ -135,21 +137,17 @@ module Make (M : Elpi_util.Util.Map.S) = struct comp a b (* The base case is rather stupid, but constructable *) - let is_empty = function - | Node (None, m1) -> M.is_empty m1 - | _ -> false + let is_empty = function Node (None, m1) -> M.is_empty m1 | _ -> false - let rec pp (ppelem : (Format.formatter -> 'a -> unit)) (fmt : Format.formatter) (Node (a, b) : 'a t) : unit = + let rec pp (ppelem : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (Node (a, b) : 'a t) : unit = Format.fprintf fmt "[values:{"; - begin match a with - | None -> Format.fprintf fmt "." - | Some x -> ppelem fmt x - end; + (match a with None -> Format.fprintf fmt "." | Some x -> ppelem fmt x); Format.fprintf fmt "} key:{"; M.pp (pp ppelem) fmt b; Format.fprintf fmt "}]" - let show (fmt: (Format.formatter -> 'a -> unit)) (n: 'a t) : string = + let show (fmt : Format.formatter -> 'a -> unit) (n : 'a t) : string = let b = Buffer.create 22 in Format.fprintf (Format.formatter_of_buffer b) "@[%a@]" (pp fmt) n; Buffer.contents b diff --git a/src/trie.mli b/src/trie.mli index e4fbcdbb0..1c4a8b9e5 100644 --- a/src/trie.mli +++ b/src/trie.mli @@ -1,19 +1,19 @@ -module Make : - functor (M : Elpi_util.Util.Map.S) -> - sig - type key = M.key list - type 'a t = Node of 'a option * 'a t M.t - val empty : 'a t - val find : key -> 'a t -> 'a - val mem : key -> 'a t -> bool - val add : key -> 'a -> 'a t -> 'a t - val remove : key -> 'a t -> 'a t - val map : ('a -> 'b) -> 'a t -> 'b t - val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t - val iter : (key -> 'a -> unit) -> 'a t -> unit - val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - val is_empty : 'a t -> bool - include Elpi_util.Util.Show1 with type 'a t := 'a t - end +module Make : functor (M : Elpi_util.Util.Map.S) -> sig + type key = M.key list + type 'a t = Node of 'a option * 'a t M.t + + val empty : 'a t + val find : key -> 'a t -> 'a + val mem : key -> 'a t -> bool + val add : key -> 'a -> 'a t -> 'a t + val remove : key -> 'a t -> 'a t + val map : ('a -> 'b) -> 'a t -> 'b t + val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t + val iter : (key -> 'a -> unit) -> 'a t -> unit + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val is_empty : 'a t -> bool + + include Elpi_util.Util.Show1 with type 'a t := 'a t +end From c38e5ec214333d4385d6b5b6d80be8c6a401ee79 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Thu, 16 Nov 2023 16:06:05 +0100 Subject: [PATCH 25/57] WIP --- src/data.ml | 27 +++++-------------- src/discrimination_tree.ml | 49 +++++++++++++++++++++-------------- src/runtime.ml | 53 ++++++++++++++++++++++++++++++-------- src/utils/util.ml | 7 +++++ src/utils/util.mli | 6 +++++ 5 files changed, 92 insertions(+), 50 deletions(-) diff --git a/src/data.ml b/src/data.ml index 9ef2ef3a1..f55684333 100644 --- a/src/data.ml +++ b/src/data.ml @@ -123,7 +123,9 @@ type clause = { mode : mode; (* CACHE to avoid allocation in get_clauses *) loc : Loc.t option; (* debug *) } -and mode = bool list (* true=input, false=output *) +and +(** input = true; output = false *) +mode = bool list (* true=input, false=output *) [@@deriving show] (* Simpler pretty printer for clause *) @@ -157,14 +159,6 @@ module TreeIndexable : Discrimination_tree.IndexableTerm with let variable = Variable let compare = compare - - let rec path_string_of = function - | Const a -> let c = Constant (a, 0) in [c] - | App (hd, x, xs) -> - let tl = List.map path_string_of (x :: xs) |> List.flatten in - ( Constant (hd, List.length xs + 1)) :: tl - | CData d -> [PrimitiveType d] - | _ -> [Variable] let arity_of = function | Constant (_,a) -> a @@ -178,13 +172,14 @@ module TreeIndexable : Discrimination_tree.IndexableTerm with match path with | [] -> failwith "Skipping empty path is not possible" | hd :: tl -> aux (arity_of hd) tl + end module MyListClause : Discrimination_tree.MyList with type elt = (clause * int) and type t = (clause * int) list = struct type elt = clause * int - let pp_elt a (cl, _) = pp_clause_simple a cl + let pp_elt fmt (cl, _) = pp_string fmt "CLAUSE!!" type t = elt list [@@deriving show] @@ -194,16 +189,6 @@ and type t = (clause * int) list = struct let mem = List.mem let add = List.cons let singleton a = [a] - (* - NOTE: the lists l1 and l2 are supposed to be sorted by timestamp, - therefore we simply do the merge algorithm to have a sorted list - *) - let rec union (l1: t) (l2 : t) = match l1, l2 with - | [], l | l, [] -> l - | (_, tx as x) :: xs, ((_, ty) :: _ as ys) when tx > ty -> - x :: union xs ys - | xs, y :: ys -> - y :: union xs ys let remove a l = List.filter ((<>) a) l let compare = compare @@ -212,6 +197,8 @@ and type t = (clause * int) list = struct let elements = Fun.id let find a l = List.find ((=) a) l let of_list = Fun.id + + let get_time_stamp = snd end module DT = Discrimination_tree.Make(TreeIndexable)(MyListClause) diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index f10211284..c1b5bf0ae 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -10,7 +10,6 @@ module type IndexableTerm = sig val show_cell : cell -> string val pp_cell : Format.formatter -> cell -> unit val compare : cell -> cell -> int - val path_string_of : input -> path (* You have h(f(x,g(y,z)),t) whose path_string_of_term_with_jl is (h,2).(f,2).(x,0).(g,2).(y,0).(z,0).(t,0) and you are at f and want to @@ -34,6 +33,7 @@ module type DiscriminationTree = sig type data type dataset type cell + type path = cell list type t include Elpi_util.Util.Show with type t := t @@ -41,16 +41,17 @@ module type DiscriminationTree = sig val iter : t -> (cell list -> dataset -> unit) -> unit val fold : t -> (cell list -> dataset -> 'b -> 'b) -> 'b -> 'b val empty : t - val index : t -> input -> data -> t - val remove_index : t -> input -> data -> t - val in_index : t -> input -> (data -> bool) -> bool - val retrieve_generalizations : t -> input -> dataset - val retrieve_unifiables : t -> input -> dataset + val index : t -> path -> data -> t + + val remove_index : t -> path -> data -> t + val in_index : t -> path -> (data -> bool) -> bool + val retrieve_generalizations : t -> path -> dataset + val retrieve_unifiables : t -> path -> dataset end module type MyList = sig type elt - type t + type t = elt list include Elpi_util.Util.Show with type t := t @@ -60,13 +61,14 @@ module type MyList = sig val add : elt -> t -> t val singleton : elt -> t val remove : elt -> t -> t - val union : t -> t -> t val compare : t -> t -> int val equal : t -> t -> bool val exists : (elt -> bool) -> t -> bool val elements : t -> elt list val find : elt -> t -> elt val of_list : elt list -> t + + val get_time_stamp: elt -> int end module Make (I : IndexableTerm) (A : MyList) : @@ -74,7 +76,8 @@ module Make (I : IndexableTerm) (A : MyList) : with type data = A.elt and type dataset = A.t and type input = I.input - and type cell = I.cell = struct + and type cell = I.cell + and type path = I.path = struct module OrderedPathStringElement = struct type t = I.cell @@ -91,6 +94,7 @@ module Make (I : IndexableTerm) (A : MyList) : type input = I.input type t = dataset Trie.t type cell = I.cell + type path = I.path let pp = Trie.pp A.pp let show = Trie.show A.pp @@ -98,20 +102,17 @@ module Make (I : IndexableTerm) (A : MyList) : let iter dt f = Trie.iter (fun p x -> f p x) dt let fold dt f = Trie.fold (fun p x -> f p x) dt - let index tree term info = - let ps = I.path_string_of term in + let index tree ps info = let ps_set = try Trie.find ps tree with Not_found -> A.empty in Trie.add ps (A.add info ps_set) tree - let remove_index tree term info = - let ps = I.path_string_of term in + let remove_index tree ps info = try let ps_set = A.remove info (Trie.find ps tree) in if A.is_empty ps_set then Trie.remove ps tree else Trie.add ps ps_set tree with Not_found -> tree - let in_index tree term test = - let ps = I.path_string_of term in + let in_index tree ps test = try let ps_set = Trie.find ps tree in A.exists test ps_set @@ -129,17 +130,27 @@ module Make (I : IndexableTerm) (A : MyList) : in PSMap.fold (fun k v res -> get (I.arity_of k) v @ res) map [] - let retrieve unif tree term = - let path = I.path_string_of term in + (* + NOTE: the lists l1 and l2 are supposed to be sorted, + therefore we simply do the merge algorithm to have a sorted list + *) + let rec union (l1: dataset) (l2 : dataset) = match l1, l2 with + | [], l | l, [] -> l + | x :: xs, y :: ys when A.get_time_stamp x > A.get_time_stamp y -> + x :: union xs ys + | xs, y :: ys -> + y :: union xs ys + + let retrieve unif tree path = let rec retrieve path tree = match (tree, path) with | Trie.Node (Some s, _), [] -> s | Trie.Node (None, _), [] -> A.empty | Trie.Node (_, _map), v :: path when v = I.variable && unif -> - List.fold_left A.union A.empty + List.fold_left union A.empty (List.map (retrieve path) (skip_root tree)) | Trie.Node (_, map), node :: path -> - A.union + union (if (not unif) && I.variable = node then A.empty else try retrieve path (PSMap.find node map) diff --git a/src/runtime.ml b/src/runtime.ml index 1d67dd811..60d1ab002 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2419,6 +2419,25 @@ let hash_arg_list is_goal hd ~depth args mode spec = let hash_clause_arg_list = hash_arg_list false let hash_goal_arg_list = hash_arg_list true +let rec arg_to_trie_path ~depth t : constant path_string_elem list = + match deref_head ~depth t with + | Const k when k == Global_symbols.uvarc -> [Variable] + (* | Const k -> [Constant (k, 0)] *) + | CData d -> [PrimitiveType d] + | Builtin (k,tl) -> Constant (k, 0) :: [] + (* | App (k,a,_) when k == Global_symbols.asc -> arg_to_trie_path ~depth a *) + | Lam _ -> [Variable] (* loose indexing to enable eta *) + | Arg _ | UVar _ | AppArg _ | AppUVar _ | Discard -> [Variable] + | _ -> [Variable] + (* | Nil -> [Variable] + | Cons _ -> [Variable] + | App (k,_,_) when k == Global_symbols.uvarc -> [Variable] + | App (k, x, xs) -> Constant (k, 0) :: [] + (* :: arg_to_trie_path ~depth x @ List.flatten (List.map (arg_to_trie_path ~depth) xs) *) + + (* List.flatten (List.map (arg_to_trie_path ~depth) tl) *) + *) + let add1clause ~depth m (predicate,clause) = match Ptmap.find predicate m with | TwoLevelIndex { all_clauses; argno; mode; flex_arg_clauses; arg_idx } -> @@ -2467,11 +2486,13 @@ let add1clause ~depth m (predicate,clause) = args_idx = Ptmap.add hash ((clause,time) :: clauses) args_idx }) m | IndexWithTrie {mode; argno; args_idx; time} -> - let path = DT.index args_idx (List.nth clause.args argno) (clause, time) in - Ptmap.add predicate (IndexWithTrie { + let path = arg_to_trie_path ~depth (match clause.args with [] -> Discard | l -> List.nth l argno) in + [%spy "dev:disc-tree-filter-number0" ~rid pp_string "In adding clause path is" (pp_path pp_int) path DT.pp args_idx]; + let dt = DT.index args_idx path (clause, time) in + Ptmap.add predicate (IndexWithTrie { mode; argno; time = time+1; - args_idx = path + args_idx = dt }) m | exception Not_found -> match classify_clause_argno ~depth 0 [] clause.args with @@ -2563,16 +2584,25 @@ let classify_goal_argno ~depth argno = function classify_goal_arg ~depth x | _ -> assert false -let hash_goal_args ~depth mode args goal = - match goal with +let hash_goal_args ~depth mode args goal = match goal with | Const _ -> 0 | App(k,x,xs) -> hash_goal_arg_list k ~depth (x::xs) mode args | _ -> assert false -let trie_goal_args ~depth mode goal argno : (term * bool) = - match goal with - | Const a -> List.nth [Const a] argno, List.nth mode argno - | App(k,x,xs) -> List.nth (x::xs) argno, List.nth mode argno +let rec nth_not_found l n = match l with + | [] -> raise Not_found + | x :: _ when n = 0 -> x + | _ :: l -> nth_not_found l (n-1) + +let rec nth_not_bool_default l n = match l with + | [] -> false + | x :: _ when n = 0 -> x + | _ :: l -> nth_not_bool_default l (n - 1) + +let trie_goal_args goal argno : term = match goal with + | Const a when argno = 0 -> goal + | App(k, x, _) when argno = 0 -> x + | App (_, _, xs) -> nth_not_found xs (argno - 1) | _ -> assert false let get_clauses ~depth predicate goal { index = m } = @@ -2591,8 +2621,9 @@ let get_clauses ~depth predicate goal { index = m } = let cl = List.flatten (Ptmap.find_unifiables hash args_idx) in List.(map fst (sort (fun (_,cl1) (_,cl2) -> cl2 - cl1) cl)) | IndexWithTrie {argno; mode; args_idx} -> - [%spy "dev:disc-tree-filter-number1" ~rid pp_string "Current goal is" pp_term goal]; - let (arg, mode_arg) = trie_goal_args ~depth mode goal argno in + let mode_arg = nth_not_bool_default mode argno in + let arg = arg_to_trie_path ~depth (trie_goal_args goal argno) in + [%spy "dev:disc-tree-filter-number1" ~rid pp_string "Current path is" (pp_path pp_int) arg]; let unifying_clauses = if mode_arg then DT.retrieve_generalizations args_idx arg else DT.retrieve_unifiables args_idx arg in diff --git a/src/utils/util.ml b/src/utils/util.ml index 3a7d86106..cc79d0d90 100644 --- a/src/utils/util.ml +++ b/src/utils/util.ml @@ -83,6 +83,13 @@ module Int = struct let compare x y = x - y end +module Bool = struct + type t = bool + let pp fmt x = Format.pp_print_bool fmt x + let show x = Format.asprintf "@[%a@]" pp x + let compare = Bool.compare +end + module String = struct include String let pp fmt s = Format.fprintf fmt "%s" s diff --git a/src/utils/util.mli b/src/utils/util.mli index 1a2ebed48..4f996b4c6 100644 --- a/src/utils/util.mli +++ b/src/utils/util.mli @@ -60,6 +60,12 @@ module Int : sig include Show with type t := int end +module Bool : sig + type t = bool + val compare : t -> t -> int + include Show with type t := t +end + module String : sig include module type of String include Show with type t := string From e8862722bdf25b310f95bc2f6b3b6a85d1cfad48 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Thu, 16 Nov 2023 16:19:57 +0100 Subject: [PATCH 26/57] Time stamp list rename --- src/data.ml | 24 ++-------- src/discrimination_tree.ml | 98 ++++++++++++++------------------------ 2 files changed, 40 insertions(+), 82 deletions(-) diff --git a/src/data.ml b/src/data.ml index f55684333..c51b7e6a8 100644 --- a/src/data.ml +++ b/src/data.ml @@ -150,11 +150,10 @@ let arity_of = function | Variable | PrimitiveType _ -> 0 module TreeIndexable : Discrimination_tree.IndexableTerm with - type input = term and type cell = constant path_string_elem + type cell = constant path_string_elem = struct type cell = (constant path_string_elem) [@@deriving show] type path = cell list [@@deriving show] - type input = term let variable = Variable @@ -172,31 +171,14 @@ module TreeIndexable : Discrimination_tree.IndexableTerm with match path with | [] -> failwith "Skipping empty path is not possible" | hd :: tl -> aux (arity_of hd) tl - end -module MyListClause : Discrimination_tree.MyList with type elt = (clause * int) +module MyListClause : Discrimination_tree.TimeStampList with type elt = (clause * int) and type t = (clause * int) list = struct type elt = clause * int - let pp_elt fmt (cl, _) = pp_string fmt "CLAUSE!!" - type t = elt list - [@@deriving show] - - let empty = [] - let is_empty = (=) [] - let mem = List.mem - let add = List.cons - let singleton a = [a] - - let remove a l = List.filter ((<>) a) l - let compare = compare - let equal = (=) - let exists = List.exists - let elements = Fun.id - let find a l = List.find ((=) a) l - let of_list = Fun.id + type t = elt list [@@deriving show] let get_time_stamp = snd end diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index c1b5bf0ae..739a57e0a 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -3,7 +3,6 @@ (* ------------------------------------------------------------------------- *) module type IndexableTerm = sig - type input type cell type path = cell list @@ -29,55 +28,39 @@ module type IndexableTerm = sig end module type DiscriminationTree = sig - type input type data - type dataset - type cell - type path = cell list + type datalist = data list + type key + type keylist = key list type t include Elpi_util.Util.Show with type t := t - val iter : t -> (cell list -> dataset -> unit) -> unit - val fold : t -> (cell list -> dataset -> 'b -> 'b) -> 'b -> 'b + val iter : t -> (keylist -> datalist -> unit) -> unit + val fold : t -> (keylist -> datalist -> 'b -> 'b) -> 'b -> 'b val empty : t - val index : t -> path -> data -> t - - val remove_index : t -> path -> data -> t - val in_index : t -> path -> (data -> bool) -> bool - val retrieve_generalizations : t -> path -> dataset - val retrieve_unifiables : t -> path -> dataset + val index : t -> keylist -> data -> t + val remove_index : t -> keylist -> data -> t + val in_index : t -> keylist -> (data -> bool) -> bool + val retrieve_generalizations : t -> keylist -> datalist + val retrieve_unifiables : t -> keylist -> datalist end -module type MyList = sig +module type TimeStampList = sig type elt type t = elt list include Elpi_util.Util.Show with type t := t - val empty : t - val is_empty : t -> bool - val mem : elt -> t -> bool - val add : elt -> t -> t - val singleton : elt -> t - val remove : elt -> t -> t - val compare : t -> t -> int - val equal : t -> t -> bool - val exists : (elt -> bool) -> t -> bool - val elements : t -> elt list - val find : elt -> t -> elt - val of_list : elt list -> t - - val get_time_stamp: elt -> int + val get_time_stamp : elt -> int end -module Make (I : IndexableTerm) (A : MyList) : +module Make (I : IndexableTerm) (A : TimeStampList) : DiscriminationTree with type data = A.elt - and type dataset = A.t - and type input = I.input - and type cell = I.cell - and type path = I.path = struct + and type datalist = A.t + and type key = I.cell + and type keylist = I.path = struct module OrderedPathStringElement = struct type t = I.cell @@ -90,11 +73,10 @@ module Make (I : IndexableTerm) (A : MyList) : module Trie = Trie.Make (PSMap) type data = A.elt - type dataset = A.t - type input = I.input - type t = dataset Trie.t - type cell = I.cell - type path = I.path + type datalist = A.t + type key = I.cell + type keylist = I.path + type t = datalist Trie.t let pp = Trie.pp A.pp let show = Trie.show A.pp @@ -103,19 +85,19 @@ module Make (I : IndexableTerm) (A : MyList) : let fold dt f = Trie.fold (fun p x -> f p x) dt let index tree ps info = - let ps_set = try Trie.find ps tree with Not_found -> A.empty in - Trie.add ps (A.add info ps_set) tree + let ps_set = try Trie.find ps tree with Not_found -> [] in + Trie.add ps (info :: ps_set) tree let remove_index tree ps info = try - let ps_set = A.remove info (Trie.find ps tree) in - if A.is_empty ps_set then Trie.remove ps tree else Trie.add ps ps_set tree + let ps_set = List.filter (( = ) info) (Trie.find ps tree) in + if ps_set = [] then Trie.remove ps tree else Trie.add ps ps_set tree with Not_found -> tree let in_index tree ps test = try let ps_set = Trie.find ps tree in - A.exists test ps_set + List.exists test ps_set with Not_found -> false (* the equivalent of skip, but on the index, thus the list of trees @@ -130,36 +112,30 @@ module Make (I : IndexableTerm) (A : MyList) : in PSMap.fold (fun k v res -> get (I.arity_of k) v @ res) map [] - (* - NOTE: the lists l1 and l2 are supposed to be sorted, - therefore we simply do the merge algorithm to have a sorted list - *) - let rec union (l1: dataset) (l2 : dataset) = match l1, l2 with + (* NOTE: l1 and l2 are supposed to be sorted *) + let rec merge (l1 : datalist) (l2 : datalist) = + match (l1, l2) with | [], l | l, [] -> l - | x :: xs, y :: ys when A.get_time_stamp x > A.get_time_stamp y -> - x :: union xs ys - | xs, y :: ys -> - y :: union xs ys + | x :: xs, y :: ys when A.get_time_stamp x > A.get_time_stamp y -> + x :: merge xs ys + | xs, y :: ys -> y :: merge xs ys let retrieve unif tree path = let rec retrieve path tree = match (tree, path) with | Trie.Node (Some s, _), [] -> s - | Trie.Node (None, _), [] -> A.empty + | Trie.Node (None, _), [] -> [] | Trie.Node (_, _map), v :: path when v = I.variable && unif -> - List.fold_left union A.empty - (List.map (retrieve path) (skip_root tree)) + List.fold_left merge [] (List.map (retrieve path) (skip_root tree)) | Trie.Node (_, map), node :: path -> - union - (if (not unif) && I.variable = node then A.empty - else - try retrieve path (PSMap.find node map) - with Not_found -> A.empty) + merge + (if (not unif) && I.variable = node then [] + else try retrieve path (PSMap.find node map) with Not_found -> []) (try match (PSMap.find I.variable map, I.skip (node :: path)) with | Trie.Node (Some s, _), [] -> s | n, path -> retrieve path n - with Not_found -> A.empty) + with Not_found -> []) in retrieve path tree From 5f92078c74bdb81b0b38187c7a28bab72d4fd9fd Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Thu, 16 Nov 2023 17:38:00 +0100 Subject: [PATCH 27/57] pp for Indexable term --- src/data.ml | 6 +++++- src/discrimination_tree.ml | 4 +++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/src/data.ml b/src/data.ml index c51b7e6a8..be32d2b77 100644 --- a/src/data.ml +++ b/src/data.ml @@ -150,11 +150,15 @@ let arity_of = function | Variable | PrimitiveType _ -> 0 module TreeIndexable : Discrimination_tree.IndexableTerm with - type cell = constant path_string_elem + type cell = constant path_string_elem and + type path = constant path_string_elem list = struct type cell = (constant path_string_elem) [@@deriving show] type path = cell list [@@deriving show] + let pp = pp_path + let show = show_path + let variable = Variable let compare = compare diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 739a57e0a..385e598ea 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -25,6 +25,8 @@ module type IndexableTerm = sig val skip : path -> path val arity_of : cell -> int val variable : cell + val pp : Format.formatter -> path -> unit + val show : path -> string end module type DiscriminationTree = sig @@ -116,7 +118,7 @@ module Make (I : IndexableTerm) (A : TimeStampList) : let rec merge (l1 : datalist) (l2 : datalist) = match (l1, l2) with | [], l | l, [] -> l - | x :: xs, y :: ys when A.get_time_stamp x > A.get_time_stamp y -> + | x :: xs, (y :: _ as ys) when A.get_time_stamp x > A.get_time_stamp y -> x :: merge xs ys | xs, y :: ys -> y :: merge xs ys From a1941dc7acd0b2ddbc4e0f4e76670afd85c55bb6 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Thu, 16 Nov 2023 18:39:05 +0100 Subject: [PATCH 28/57] Update path generation from term for trie --- src/discrimination_tree.ml | 42 +++++++++++++++++++------------------- src/runtime.ml | 36 ++++++++++++++++---------------- 2 files changed, 39 insertions(+), 39 deletions(-) diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 385e598ea..caffe6336 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -57,31 +57,31 @@ module type TimeStampList = sig val get_time_stamp : elt -> int end -module Make (I : IndexableTerm) (A : TimeStampList) : +module Make (K : IndexableTerm) (D : TimeStampList) : DiscriminationTree - with type data = A.elt - and type datalist = A.t - and type key = I.cell - and type keylist = I.path = struct + with type data = D.elt + and type datalist = D.t + and type key = K.cell + and type keylist = K.path = struct module OrderedPathStringElement = struct - type t = I.cell + type t = K.cell - let show = I.show_cell - let pp = I.pp_cell - let compare = I.compare + let show = K.show_cell + let pp = K.pp_cell + let compare = K.compare end module PSMap = Elpi_util.Util.Map.Make (OrderedPathStringElement) module Trie = Trie.Make (PSMap) - type data = A.elt - type datalist = A.t - type key = I.cell - type keylist = I.path + type data = D.elt + type datalist = D.t + type key = K.cell + type keylist = K.path type t = datalist Trie.t - let pp = Trie.pp A.pp - let show = Trie.show A.pp + let pp = Trie.pp D.pp + let show = Trie.show D.pp let empty = Trie.empty let iter dt f = Trie.iter (fun p x -> f p x) dt let fold dt f = Trie.fold (fun p x -> f p x) dt @@ -110,15 +110,15 @@ module Make (I : IndexableTerm) (A : TimeStampList) : | Trie.Node (_v, m) as tree -> if n = 0 then [ tree ] else - PSMap.fold (fun k v res -> get (n - 1 + I.arity_of k) v @ res) m [] + PSMap.fold (fun k v res -> get (n - 1 + K.arity_of k) v @ res) m [] in - PSMap.fold (fun k v res -> get (I.arity_of k) v @ res) map [] + PSMap.fold (fun k v res -> get (K.arity_of k) v @ res) map [] (* NOTE: l1 and l2 are supposed to be sorted *) let rec merge (l1 : datalist) (l2 : datalist) = match (l1, l2) with | [], l | l, [] -> l - | x :: xs, (y :: _ as ys) when A.get_time_stamp x > A.get_time_stamp y -> + | x :: xs, (y :: _ as ys) when D.get_time_stamp x > D.get_time_stamp y -> x :: merge xs ys | xs, y :: ys -> y :: merge xs ys @@ -127,14 +127,14 @@ module Make (I : IndexableTerm) (A : TimeStampList) : match (tree, path) with | Trie.Node (Some s, _), [] -> s | Trie.Node (None, _), [] -> [] - | Trie.Node (_, _map), v :: path when v = I.variable && unif -> + | Trie.Node (_, _map), v :: path when v = K.variable && unif -> List.fold_left merge [] (List.map (retrieve path) (skip_root tree)) | Trie.Node (_, map), node :: path -> merge - (if (not unif) && I.variable = node then [] + (if (not unif) && K.variable = node then [] else try retrieve path (PSMap.find node map) with Not_found -> []) (try - match (PSMap.find I.variable map, I.skip (node :: path)) with + match (PSMap.find K.variable map, K.skip (node :: path)) with | Trie.Node (Some s, _), [] -> s | n, path -> retrieve path n with Not_found -> []) diff --git a/src/runtime.ml b/src/runtime.ml index 60d1ab002..c451b289b 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2419,25 +2419,22 @@ let hash_arg_list is_goal hd ~depth args mode spec = let hash_clause_arg_list = hash_arg_list false let hash_goal_arg_list = hash_arg_list true -let rec arg_to_trie_path ~depth t : constant path_string_elem list = - match deref_head ~depth t with +let rec arg_to_trie_path ~depth t : TreeIndexable.path = + match deref_head ~depth t with | Const k when k == Global_symbols.uvarc -> [Variable] - (* | Const k -> [Constant (k, 0)] *) + | Const k -> [Constant (k, 0)] | CData d -> [PrimitiveType d] - | Builtin (k,tl) -> Constant (k, 0) :: [] - (* | App (k,a,_) when k == Global_symbols.asc -> arg_to_trie_path ~depth a *) + | Builtin (k,tl) -> + let args = List.flatten (List.map (arg_to_trie_path ~depth) tl) in + Constant (k, List.length tl) :: args + | App (k,a,_) when k == Global_symbols.asc -> arg_to_trie_path ~depth a + | App (k, x, xs) -> + let args = List.flatten (List.map (arg_to_trie_path ~depth) xs) in + let fst_arg = arg_to_trie_path ~depth x in + Constant (k, 1 + List.length xs) :: fst_arg @ args + | Nil | Cons _ -> [Variable] | Lam _ -> [Variable] (* loose indexing to enable eta *) | Arg _ | UVar _ | AppArg _ | AppUVar _ | Discard -> [Variable] - | _ -> [Variable] - (* | Nil -> [Variable] - | Cons _ -> [Variable] - | App (k,_,_) when k == Global_symbols.uvarc -> [Variable] - | App (k, x, xs) -> Constant (k, 0) :: [] - (* :: arg_to_trie_path ~depth x @ List.flatten (List.map (arg_to_trie_path ~depth) xs) *) - - (* List.flatten (List.map (arg_to_trie_path ~depth) tl) *) - *) - let add1clause ~depth m (predicate,clause) = match Ptmap.find predicate m with | TwoLevelIndex { all_clauses; argno; mode; flex_arg_clauses; arg_idx } -> @@ -2487,7 +2484,6 @@ let add1clause ~depth m (predicate,clause) = }) m | IndexWithTrie {mode; argno; args_idx; time} -> let path = arg_to_trie_path ~depth (match clause.args with [] -> Discard | l -> List.nth l argno) in - [%spy "dev:disc-tree-filter-number0" ~rid pp_string "In adding clause path is" (pp_path pp_int) path DT.pp args_idx]; let dt = DT.index args_idx path (clause, time) in Ptmap.add predicate (IndexWithTrie { mode; argno; @@ -2623,11 +2619,15 @@ let get_clauses ~depth predicate goal { index = m } = | IndexWithTrie {argno; mode; args_idx} -> let mode_arg = nth_not_bool_default mode argno in let arg = arg_to_trie_path ~depth (trie_goal_args goal argno) in - [%spy "dev:disc-tree-filter-number1" ~rid pp_string "Current path is" (pp_path pp_int) arg]; + [%spy "dev:disc-tree-filter-number1" ~rid + pp_string "Current path is" (pp_path pp_int) arg + pp_string " and current DT is " DT.pp args_idx]; let unifying_clauses = if mode_arg then DT.retrieve_generalizations args_idx arg else DT.retrieve_unifiables args_idx arg in - [%spy "dev:disc-tree-filter-number2" ~rid pp_string "Filtered clauses number is" pp_int (List.length unifying_clauses)]; + [%spy "dev:disc-tree-filter-number2" ~rid + pp_string "Filtered clauses number is" + pp_int (List.length unifying_clauses)]; List.map fst unifying_clauses with Not_found -> [] in From 5b1042a8f9eaea7279088dd707be8d111650e4c1 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Thu, 16 Nov 2023 23:16:35 +0100 Subject: [PATCH 29/57] Pass more tests --- src/runtime.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/runtime.ml b/src/runtime.ml index c451b289b..27374e483 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2427,6 +2427,7 @@ let rec arg_to_trie_path ~depth t : TreeIndexable.path = | Builtin (k,tl) -> let args = List.flatten (List.map (arg_to_trie_path ~depth) tl) in Constant (k, List.length tl) :: args + | App (k,_,_) when k == Global_symbols.uvarc -> [Variable] | App (k,a,_) when k == Global_symbols.asc -> arg_to_trie_path ~depth a | App (k, x, xs) -> let args = List.flatten (List.map (arg_to_trie_path ~depth) xs) in @@ -2622,7 +2623,8 @@ let get_clauses ~depth predicate goal { index = m } = [%spy "dev:disc-tree-filter-number1" ~rid pp_string "Current path is" (pp_path pp_int) arg pp_string " and current DT is " DT.pp args_idx]; - let unifying_clauses = if mode_arg then + (* TODO: check better this bool of the condition... *) + let unifying_clauses = if false && mode_arg then DT.retrieve_generalizations args_idx arg else DT.retrieve_unifiables args_idx arg in [%spy "dev:disc-tree-filter-number2" ~rid From 07183c79a5716dee0e2dd83a1ab86124ef9b5e41 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Sat, 18 Nov 2023 16:06:26 +0100 Subject: [PATCH 30/57] Update Makefile Co-authored-by: Enrico Tassi --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index e3b893321..28e0ce211 100644 --- a/Makefile +++ b/Makefile @@ -134,4 +134,4 @@ menhir-complete-errormsgs: menhir-strip-errormsgs: sed -e "/^##/d" -i.bak src/parser/error_messages.txt -.PHONY: tests help install build clean gh-pages \ No newline at end of file +.PHONY: tests help install build clean gh-pages From be929a636278206e554be16482ba03ed6637626c Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Sat, 18 Nov 2023 16:06:57 +0100 Subject: [PATCH 31/57] Update CHANGES.md Co-authored-by: Enrico Tassi --- CHANGES.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 06f47343b..b6c0d9a0b 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,8 +2,8 @@ Library: - New `std.fold-right` - - New clause retrieval through discrimination tree where the index of all the - parameters are set to `0` but one: the argument of which the search is done + - New clause retrieval through discrimination tree. This new index is enabled + whenever the `:index` directive selects only one argument with a depth `> 1`. # v1.18.0 (October 2023) From a47ce20a8d0da9301c28e1993b07648ed53c2d75 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Sat, 18 Nov 2023 16:07:16 +0100 Subject: [PATCH 32/57] Update src/compiler.ml Co-authored-by: Enrico Tassi --- src/compiler.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/compiler.ml b/src/compiler.ml index 8a7884cb6..ed4a1893f 100644 --- a/src/compiler.ml +++ b/src/compiler.ml @@ -2406,8 +2406,7 @@ let run let mode = try C.Map.find name modes with Not_found -> [] in let declare_index, index = match tindex with - | Some (Ast.Structured.Index l) -> - true, chose_indexing state name l + | Some (Ast.Structured.Index l) -> true, chose_indexing state name l | _ -> false, chose_indexing state name [1] in try let _, old_tindex = C.Map.find name map in From 359548afc7780707e691a1dfbc3647bbfa48efc9 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Sat, 18 Nov 2023 16:07:52 +0100 Subject: [PATCH 33/57] Update src/data.ml Co-authored-by: Enrico Tassi --- src/data.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/data.ml b/src/data.ml index be32d2b77..818de5d2e 100644 --- a/src/data.ml +++ b/src/data.ml @@ -240,8 +240,7 @@ type suspended_goal = { (** Used to index the parameters of a predicate P - - [MapOn N] -> Indexing is done by unifying the Nth parameter of P with the - query + - [MapOn N] -> N-th argument at depth 1 (head symbol only) - [Hash L] -> L is the list of depths given by the urer for the parameters of P. Indexing is done by hashing all the parameters with a non zero depth and comparing it with the hashing of the parameters From e8e340dfc1e6632ddc93e2e72e6b1cc2eff1257a Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Sat, 18 Nov 2023 16:08:13 +0100 Subject: [PATCH 34/57] Update src/data.ml Co-authored-by: Enrico Tassi --- src/data.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/data.ml b/src/data.ml index 818de5d2e..2ec907269 100644 --- a/src/data.ml +++ b/src/data.ml @@ -245,7 +245,7 @@ type suspended_goal = { P. Indexing is done by hashing all the parameters with a non zero depth and comparing it with the hashing of the parameters of the query - - [IndexWithTrie N] -> Indexing is done on the Nth parameter using tries + - [IndexWithTrie N] -> N-th argument at arbitrary depth (TODO bound) *) type indexing = | MapOn of int From 739967a139ad31d2ac52982336b35b23c810b699 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Mon, 20 Nov 2023 17:58:44 +0100 Subject: [PATCH 35/57] `Other` constructor for non-variable element of path --- src/data.ml | 12 ++++-------- src/discrimination_tree.ml | 38 +++++++++++++++++++++++++++----------- src/runtime.ml | 13 ++++++------- 3 files changed, 37 insertions(+), 26 deletions(-) diff --git a/src/data.ml b/src/data.ml index 2ec907269..5ef7fe411 100644 --- a/src/data.ml +++ b/src/data.ml @@ -138,16 +138,11 @@ let pp_clause_simple (fmt:Format.formatter) (cl: clause) = type 'a path_string_elem = | Constant of 'a * int - | Variable - | PrimitiveType of Elpi_util.Util.CData.t + | Primitive of Elpi_util.Util.CData.t + | Variable | Other [@@deriving show] type 'a path = ('a path_string_elem) list -[@@deriving show] - -let arity_of = function - | Constant (_,a) -> a - | Variable | PrimitiveType _ -> 0 module TreeIndexable : Discrimination_tree.IndexableTerm with type cell = constant path_string_elem and @@ -160,12 +155,13 @@ module TreeIndexable : Discrimination_tree.IndexableTerm with let show = show_path let variable = Variable + let to_unify = Other let compare = compare let arity_of = function | Constant (_,a) -> a - | Variable | PrimitiveType _ -> 0 + | Variable | Other | Primitive _ -> 0 let skip (path: path) : path = let rec aux arity path = diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index caffe6336..7d6e18f29 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -25,6 +25,7 @@ module type IndexableTerm = sig val skip : path -> path val arity_of : cell -> int val variable : cell + val to_unify : cell val pp : Format.formatter -> path -> unit val show : path -> string end @@ -123,21 +124,36 @@ module Make (K : IndexableTerm) (D : TimeStampList) : | xs, y :: ys -> y :: merge xs ys let retrieve unif tree path = + let open Trie in + (* + to_unify returns if a key should be unified with all the values of + the current sub-tree. This key should be either K.to_unfy or K.variable. + In the latter case, the unif boolean to be true (we are in output mode). + *) + let to_unify v = v = K.to_unify || (v = K.variable && unif) in let rec retrieve path tree = match (tree, path) with - | Trie.Node (Some s, _), [] -> s - | Trie.Node (None, _), [] -> [] - | Trie.Node (_, _map), v :: path when v = K.variable && unif -> + | Node (Some s, _), [] -> s + | Node (None, _), [] -> [] + | Node (_, _map), v :: path when to_unify v -> List.fold_left merge [] (List.map (retrieve path) (skip_root tree)) - | Trie.Node (_, map), node :: path -> + (* Note: in the following branch the head of the path can't be K.to_unify *) + | Node (_, map), (node :: sub_path as path) -> + let find_by_key key = + try + match (PSMap.find key map, K.skip path) with + | Node (Some s, _), [] -> s + | n, path -> retrieve path n + with Not_found -> [] + in merge - (if (not unif) && K.variable = node then [] - else try retrieve path (PSMap.find node map) with Not_found -> []) - (try - match (PSMap.find K.variable map, K.skip (node :: path)) with - | Trie.Node (Some s, _), [] -> s - | n, path -> retrieve path n - with Not_found -> []) + (merge + (if (not unif) && K.variable = node then [] + else + try retrieve sub_path (PSMap.find node map) + with Not_found -> []) + (find_by_key K.variable)) + (find_by_key K.to_unify) in retrieve path tree diff --git a/src/runtime.ml b/src/runtime.ml index 27374e483..7fda7dded 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2423,7 +2423,7 @@ let rec arg_to_trie_path ~depth t : TreeIndexable.path = match deref_head ~depth t with | Const k when k == Global_symbols.uvarc -> [Variable] | Const k -> [Constant (k, 0)] - | CData d -> [PrimitiveType d] + | CData d -> [Primitive d] | Builtin (k,tl) -> let args = List.flatten (List.map (arg_to_trie_path ~depth) tl) in Constant (k, List.length tl) :: args @@ -2433,9 +2433,9 @@ let rec arg_to_trie_path ~depth t : TreeIndexable.path = let args = List.flatten (List.map (arg_to_trie_path ~depth) xs) in let fst_arg = arg_to_trie_path ~depth x in Constant (k, 1 + List.length xs) :: fst_arg @ args - | Nil | Cons _ -> [Variable] - | Lam _ -> [Variable] (* loose indexing to enable eta *) - | Arg _ | UVar _ | AppArg _ | AppUVar _ | Discard -> [Variable] + | Nil | Cons _ -> [Other] + | Lam _ -> [Other] (* loose indexing to enable eta *) + | Arg _ | UVar _ | AppArg _ | AppUVar _ | Discard -> [Other] let add1clause ~depth m (predicate,clause) = match Ptmap.find predicate m with | TwoLevelIndex { all_clauses; argno; mode; flex_arg_clauses; arg_idx } -> @@ -2621,10 +2621,9 @@ let get_clauses ~depth predicate goal { index = m } = let mode_arg = nth_not_bool_default mode argno in let arg = arg_to_trie_path ~depth (trie_goal_args goal argno) in [%spy "dev:disc-tree-filter-number1" ~rid - pp_string "Current path is" (pp_path pp_int) arg + pp_string "Current path is" TreeIndexable.pp arg pp_string " and current DT is " DT.pp args_idx]; - (* TODO: check better this bool of the condition... *) - let unifying_clauses = if false && mode_arg then + let unifying_clauses = if mode_arg then DT.retrieve_generalizations args_idx arg else DT.retrieve_unifiables args_idx arg in [%spy "dev:disc-tree-filter-number2" ~rid From ed6b886172e78df029388465ef8116b4ea37bbe4 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Mon, 20 Nov 2023 18:11:41 +0100 Subject: [PATCH 36/57] Aesthetic update --- src/data.ml | 2 +- src/trie.mli | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/data.ml b/src/data.ml index 5ef7fe411..7f554c1a6 100644 --- a/src/data.ml +++ b/src/data.ml @@ -169,7 +169,7 @@ module TreeIndexable : Discrimination_tree.IndexableTerm with | [] -> assert false | m::tl -> aux (arity-1+arity_of m) tl in match path with - | [] -> failwith "Skipping empty path is not possible" + | [] -> anomaly "Skipping empty path is not possible" | hd :: tl -> aux (arity_of hd) tl end diff --git a/src/trie.mli b/src/trie.mli index 1c4a8b9e5..5dd44d638 100644 --- a/src/trie.mli +++ b/src/trie.mli @@ -1,3 +1,7 @@ +(* elpi: embedded lambda prolog interpreter *) +(* license: GNU Lesser General Public License Version 2.1 or later *) +(* ------------------------------------------------------------------------- *) + module Make : functor (M : Elpi_util.Util.Map.S) -> sig type key = M.key list type 'a t = Node of 'a option * 'a t M.t From 4dd1c546f32a8433934aba7e2813f3acbcc0a3c3 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Mon, 20 Nov 2023 18:35:29 +0100 Subject: [PATCH 37/57] Add equal method to TimeStampList --- src/data.ml | 1 + src/discrimination_tree.ml | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/data.ml b/src/data.ml index 7f554c1a6..fc0c5e3b9 100644 --- a/src/data.ml +++ b/src/data.ml @@ -181,6 +181,7 @@ and type t = (clause * int) list = struct type t = elt list [@@deriving show] let get_time_stamp = snd + let equal a b = a = b end module DT = Discrimination_tree.Make(TreeIndexable)(MyListClause) diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 7d6e18f29..0171ab5be 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -56,6 +56,7 @@ module type TimeStampList = sig include Elpi_util.Util.Show with type t := t val get_time_stamp : elt -> int + val equal : elt -> elt -> bool end module Make (K : IndexableTerm) (D : TimeStampList) : @@ -93,7 +94,7 @@ module Make (K : IndexableTerm) (D : TimeStampList) : let remove_index tree ps info = try - let ps_set = List.filter (( = ) info) (Trie.find ps tree) in + let ps_set = List.filter (D.equal info) (Trie.find ps tree) in if ps_set = [] then Trie.remove ps tree else Trie.add ps ps_set tree with Not_found -> tree From 9e8d4af2f78b3fab1ee0bc807989c7e5144605d4 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Mon, 20 Nov 2023 18:41:43 +0100 Subject: [PATCH 38/57] Compare timestamps --- src/data.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/data.ml b/src/data.ml index fc0c5e3b9..61fbc675a 100644 --- a/src/data.ml +++ b/src/data.ml @@ -181,7 +181,7 @@ and type t = (clause * int) list = struct type t = elt list [@@deriving show] let get_time_stamp = snd - let equal a b = a = b + let equal a b = snd a = snd b end module DT = Discrimination_tree.Make(TreeIndexable)(MyListClause) From 2b498945092ca7e88fc88812246121edc786fa1f Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 21 Nov 2023 15:05:35 +0100 Subject: [PATCH 39/57] specialize Trie/DT on data with timestamp list --- src/data.ml | 15 +------- src/discrimination_tree.ml | 79 +++++++++++++------------------------- src/runtime.ml | 10 ++--- src/trie.ml | 55 +++++++++++++------------- src/trie.mli | 5 ++- 5 files changed, 65 insertions(+), 99 deletions(-) diff --git a/src/data.ml b/src/data.ml index 61fbc675a..a3eb19f33 100644 --- a/src/data.ml +++ b/src/data.ml @@ -173,18 +173,7 @@ module TreeIndexable : Discrimination_tree.IndexableTerm with | hd :: tl -> aux (arity_of hd) tl end -module MyListClause : Discrimination_tree.TimeStampList with type elt = (clause * int) -and type t = (clause * int) list = struct - type elt = clause * int - let pp_elt fmt (cl, _) = pp_string fmt "CLAUSE!!" - - type t = elt list [@@deriving show] - - let get_time_stamp = snd - let equal a b = snd a = snd b -end - -module DT = Discrimination_tree.Make(TreeIndexable)(MyListClause) +module DT = Discrimination_tree.Make(TreeIndexable) type stuck_goal = { mutable blockers : blockers; @@ -223,7 +212,7 @@ and second_lvl_idx = mode : mode; argno : int; (* position of argument on which the trie is built *) time : int; (* time is used to recover the total order *) - args_idx : DT.t; + args_idx : clause DT.t; } [@@deriving show] diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 0171ab5be..ed239a9d4 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -31,39 +31,24 @@ module type IndexableTerm = sig end module type DiscriminationTree = sig - type data - type datalist = data list type key type keylist = key list - type t - - include Elpi_util.Util.Show with type t := t - - val iter : t -> (keylist -> datalist -> unit) -> unit - val fold : t -> (keylist -> datalist -> 'b -> 'b) -> 'b -> 'b - val empty : t - val index : t -> keylist -> data -> t - val remove_index : t -> keylist -> data -> t - val in_index : t -> keylist -> (data -> bool) -> bool - val retrieve_generalizations : t -> keylist -> datalist - val retrieve_unifiables : t -> keylist -> datalist -end - -module type TimeStampList = sig - type elt - type t = elt list + type 'a t - include Elpi_util.Util.Show with type t := t + include Elpi_util.Util.Show1 with type 'a t := 'a t - val get_time_stamp : elt -> int - val equal : elt -> elt -> bool + val iter : 'a t -> (keylist -> 'a -> unit) -> unit + val fold : 'a t -> (keylist -> 'a -> 'b -> 'b) -> 'b -> 'b + val empty : 'a t + val index : 'a t -> keylist -> 'a -> time:int -> 'a t + val in_index : 'a t -> keylist -> ('a -> bool) -> bool + val retrieve_generalizations : 'a t -> keylist -> 'a list + val retrieve_unifiables : 'a t -> keylist -> 'a list end -module Make (K : IndexableTerm) (D : TimeStampList) : +module Make (K : IndexableTerm) : DiscriminationTree - with type data = D.elt - and type datalist = D.t - and type key = K.cell + with type key = K.cell and type keylist = K.path = struct module OrderedPathStringElement = struct type t = K.cell @@ -76,32 +61,23 @@ module Make (K : IndexableTerm) (D : TimeStampList) : module PSMap = Elpi_util.Util.Map.Make (OrderedPathStringElement) module Trie = Trie.Make (PSMap) - type data = D.elt - type datalist = D.t type key = K.cell type keylist = K.path - type t = datalist Trie.t + type 'a t = ('a * int) Trie.t - let pp = Trie.pp D.pp - let show = Trie.show D.pp + let pp pp_a fmt (t : 'a t) : unit = Trie.pp (fun fmt (a,_) -> pp_a fmt a) fmt t + let show pp_a (t : 'a t) : string = Trie.show (fun fmt (a,_) -> pp_a fmt a) t let empty = Trie.empty - let iter dt f = Trie.iter (fun p x -> f p x) dt - let fold dt f = Trie.fold (fun p x -> f p x) dt + let iter dt f = Trie.iter (fun p (x,_) -> f p x) dt + let fold dt f = Trie.fold (fun p (x,_) -> f p x) dt - let index tree ps info = - let ps_set = try Trie.find ps tree with Not_found -> [] in - Trie.add ps (info :: ps_set) tree - - let remove_index tree ps info = - try - let ps_set = List.filter (D.equal info) (Trie.find ps tree) in - if ps_set = [] then Trie.remove ps tree else Trie.add ps ps_set tree - with Not_found -> tree + let index tree ps info ~time = + Trie.add ps (info,time) tree let in_index tree ps test = try let ps_set = Trie.find ps tree in - List.exists test ps_set + List.exists (fun (x,_) -> test x) ps_set with Not_found -> false (* the equivalent of skip, but on the index, thus the list of trees @@ -117,12 +93,12 @@ module Make (K : IndexableTerm) (D : TimeStampList) : PSMap.fold (fun k v res -> get (K.arity_of k) v @ res) map [] (* NOTE: l1 and l2 are supposed to be sorted *) - let rec merge (l1 : datalist) (l2 : datalist) = + let rec merge l1 l2 = match (l1, l2) with | [], l | l, [] -> l - | x :: xs, (y :: _ as ys) when D.get_time_stamp x > D.get_time_stamp y -> - x :: merge xs ys - | xs, y :: ys -> y :: merge xs ys + | (_,tx as x) :: xs, (_,ty) :: _ when tx > ty -> + x :: merge xs l2 + | _, y :: ys -> y :: merge l1 ys let retrieve unif tree path = let open Trie in @@ -134,8 +110,7 @@ module Make (K : IndexableTerm) (D : TimeStampList) : let to_unify v = v = K.to_unify || (v = K.variable && unif) in let rec retrieve path tree = match (tree, path) with - | Node (Some s, _), [] -> s - | Node (None, _), [] -> [] + | Node (s, _), [] -> s | Node (_, _map), v :: path when to_unify v -> List.fold_left merge [] (List.map (retrieve path) (skip_root tree)) (* Note: in the following branch the head of the path can't be K.to_unify *) @@ -143,7 +118,7 @@ module Make (K : IndexableTerm) (D : TimeStampList) : let find_by_key key = try match (PSMap.find key map, K.skip path) with - | Node (Some s, _), [] -> s + | Node (s, _), [] -> s | n, path -> retrieve path n with Not_found -> [] in @@ -158,6 +133,6 @@ module Make (K : IndexableTerm) (D : TimeStampList) : in retrieve path tree - let retrieve_generalizations tree term = retrieve false tree term - let retrieve_unifiables tree term = retrieve true tree term + let retrieve_generalizations tree term = retrieve false tree term |> List.map fst + let retrieve_unifiables tree term = retrieve true tree term |> List.map fst end diff --git a/src/runtime.ml b/src/runtime.ml index 7fda7dded..bcf698ad2 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2485,7 +2485,7 @@ let add1clause ~depth m (predicate,clause) = }) m | IndexWithTrie {mode; argno; args_idx; time} -> let path = arg_to_trie_path ~depth (match clause.args with [] -> Discard | l -> List.nth l argno) in - let dt = DT.index args_idx path (clause, time) in + let dt = DT.index args_idx path clause ~time in Ptmap.add predicate (IndexWithTrie { mode; argno; time = time+1; @@ -2622,14 +2622,14 @@ let get_clauses ~depth predicate goal { index = m } = let arg = arg_to_trie_path ~depth (trie_goal_args goal argno) in [%spy "dev:disc-tree-filter-number1" ~rid pp_string "Current path is" TreeIndexable.pp arg - pp_string " and current DT is " DT.pp args_idx]; - let unifying_clauses = if mode_arg then + pp_string " and current DT is " (DT.pp pp_clause) args_idx]; + let candidates = if mode_arg then DT.retrieve_generalizations args_idx arg else DT.retrieve_unifiables args_idx arg in [%spy "dev:disc-tree-filter-number2" ~rid pp_string "Filtered clauses number is" - pp_int (List.length unifying_clauses)]; - List.map fst unifying_clauses + pp_int (List.length candidates)]; + candidates with Not_found -> [] in [%log "get_clauses" ~rid (C.show predicate) (List.length rc)]; diff --git a/src/trie.ml b/src/trie.ml index c2f97be30..52fc89a37 100644 --- a/src/trie.ml +++ b/src/trie.ml @@ -28,9 +28,9 @@ module Make (M : Elpi_util.Util.Map.S) = struct ['a t M.t]. The empty trie is just the empty map. *) type key = M.key list - type 'a t = Node of 'a option * 'a t M.t - let empty = Node (None, M.empty) + type 'a t = Node of 'a list * 'a t M.t + let empty = Node ([], M.empty) (*s To find a mapping in a trie is easy: when all the elements of the key have been read, we just inspect the optional info at the @@ -39,8 +39,8 @@ module Make (M : Elpi_util.Util.Map.S) = struct let rec find l t = match (l, t) with - | [], Node (None, _) -> raise Not_found - | [], Node (Some v, _) -> v + | [], Node ([], _) -> raise Not_found + | [], Node (v, _) -> v | x :: r, Node (_, m) -> find r (M.find x m) let mem l t = try Fun.const true (find l t) with Not_found -> false @@ -54,7 +54,17 @@ module Make (M : Elpi_util.Util.Map.S) = struct let add l v t = let rec ins = function - | [], Node (_, m) -> Node (Some v, m) + | [], Node (l, m) -> Node (v::l, m) + | x :: r, Node (v, m) -> + let t' = try M.find x m with Not_found -> empty in + let t'' = ins (r, t') in + Node (v, M.add x t'' m) + in + ins (l, t) + + let replace l v t = + let rec ins = function + | [], Node (_, m) -> Node (v, m) | x :: r, Node (v, m) -> let t' = try M.find x m with Not_found -> empty in let t'' = ins (r, t') in @@ -69,7 +79,7 @@ module Make (M : Elpi_util.Util.Map.S) = struct let rec remove l t = match (l, t) with - | [], Node (_, m) -> Node (None, m) + | [], Node (_, m) -> Node ([], m) | x :: r, Node (v, m) -> ( try let t' = remove r (M.find x m) in @@ -85,23 +95,20 @@ module Make (M : Elpi_util.Util.Map.S) = struct has to be passed to function [f]. *) let rec map f = function - | Node (None, m) -> Node (None, M.map (map f) m) - | Node (Some v, m) -> Node (Some (f v), M.map (map f) m) + | Node (v, m) -> Node (List.map f v, M.map (map f) m) let mapi f t = let rec maprec revp = function - | Node (None, m) -> Node (None, M.mapi (fun x -> maprec (x :: revp)) m) - | Node (Some v, m) -> + | Node (v, m) -> Node - (Some (f (List.rev revp) v), M.mapi (fun x -> maprec (x :: revp)) m) + (List.map (f (List.rev revp)) v, M.mapi (fun x -> maprec (x :: revp)) m) in maprec [] t let iter f t = let rec traverse revp = function - | Node (None, m) -> M.iter (fun x -> traverse (x :: revp)) m - | Node (Some v, m) -> - f (List.rev revp) v; + | Node (v, m) -> + List.iter (f (List.rev revp)) v; M.iter (fun x t -> traverse (x :: revp) t) m in traverse [] t @@ -109,20 +116,16 @@ module Make (M : Elpi_util.Util.Map.S) = struct let fold f t acc = let rec traverse revp t acc = match t with - | Node (None, m) -> M.fold (fun x -> traverse (x :: revp)) m acc - | Node (Some v, m) -> - f (List.rev revp) v (M.fold (fun x -> traverse (x :: revp)) m acc) + | Node (v, m) -> + List.fold_right (f (List.rev revp)) v (M.fold (fun x -> traverse (x :: revp)) m acc) in traverse [] t acc let compare cmp a b = let rec comp a b = match (a, b) with - | Node (Some _, _), Node (None, _) -> 1 - | Node (None, _), Node (Some _, _) -> -1 - | Node (None, m1), Node (None, m2) -> M.compare comp m1 m2 - | Node (Some a, m1), Node (Some b, m2) -> - let c = cmp a b in + | Node (a, m1), Node (b, m2) -> + let c = List.compare cmp a b in if c <> 0 then c else M.compare comp m1 m2 in comp a b @@ -130,19 +133,17 @@ module Make (M : Elpi_util.Util.Map.S) = struct let equal eq a b = let rec comp a b = match (a, b) with - | Node (None, m1), Node (None, m2) -> M.equal comp m1 m2 - | Node (Some a, m1), Node (Some b, m2) -> eq a b && M.equal comp m1 m2 - | _ -> false + | Node (a, m1), Node (b, m2) -> List.equal eq a b && M.equal comp m1 m2 in comp a b (* The base case is rather stupid, but constructable *) - let is_empty = function Node (None, m1) -> M.is_empty m1 | _ -> false + let is_empty = function Node ([], m1) -> M.is_empty m1 | _ -> false let rec pp (ppelem : Format.formatter -> 'a -> unit) (fmt : Format.formatter) (Node (a, b) : 'a t) : unit = Format.fprintf fmt "[values:{"; - (match a with None -> Format.fprintf fmt "." | Some x -> ppelem fmt x); + Elpi_util.Util.pplist ppelem "; " fmt a; Format.fprintf fmt "} key:{"; M.pp (pp ppelem) fmt b; Format.fprintf fmt "}]" diff --git a/src/trie.mli b/src/trie.mli index 5dd44d638..9cd90bb26 100644 --- a/src/trie.mli +++ b/src/trie.mli @@ -4,11 +4,12 @@ module Make : functor (M : Elpi_util.Util.Map.S) -> sig type key = M.key list - type 'a t = Node of 'a option * 'a t M.t + type 'a t = Node of 'a list * 'a t M.t val empty : 'a t - val find : key -> 'a t -> 'a + val find : key -> 'a t -> 'a list val mem : key -> 'a t -> bool + val replace : key -> 'a list -> 'a t -> 'a t val add : key -> 'a -> 'a t -> 'a t val remove : key -> 'a t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t From be72175cf868403b980b875f5641043fc34af877 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 21 Nov 2023 16:28:27 +0100 Subject: [PATCH 40/57] wip --- src/compiler.ml | 2 +- src/data.ml | 7 +++-- src/runtime.ml | 72 ++++++++++++++++++++++++++++++++++++++------ src/trace_atd.ts | 48 ++++++++++++++--------------- tests/suite/suite.ml | 2 +- 5 files changed, 91 insertions(+), 40 deletions(-) diff --git a/src/compiler.ml b/src/compiler.ml index ed4a1893f..8d434fed9 100644 --- a/src/compiler.ml +++ b/src/compiler.ml @@ -2365,7 +2365,7 @@ let chose_indexing state predicate l = | 0 :: l -> aux (argno+1) l | 1 :: l when all_zero l -> MapOn argno (* TODO: take hd into account to create "shorter" paths *) - | _ :: l when all_zero l -> Trie argno + | path_depth :: l when all_zero l -> Trie { argno ; path_depth } | _ -> Hash l in aux 0 l diff --git a/src/data.ml b/src/data.ml index a3eb19f33..b062bab11 100644 --- a/src/data.ml +++ b/src/data.ml @@ -129,12 +129,12 @@ mode = bool list (* true=input, false=output *) [@@deriving show] (* Simpler pretty printer for clause *) -let pp_clause_simple (fmt:Format.formatter) (cl: clause) = +let pp_clause_simple (fmt:Format.formatter) (cl: clause) = Format.fprintf fmt "clause" (* Format.fprintf fmt "[clause_args:"; pplist pp_term ", " fmt cl.args; Format.fprintf fmt " ;; clause_hyps:"; pplist pp_term ", " fmt cl.hyps; - Format.fprintf fmt "]"; + Format.fprintf fmt "]";*) type 'a path_string_elem = | Constant of 'a * int @@ -211,6 +211,7 @@ and second_lvl_idx = | IndexWithTrie of { mode : mode; argno : int; (* position of argument on which the trie is built *) + path_depth : int; (* depth bound at which the term is inspected *) time : int; (* time is used to recover the total order *) args_idx : clause DT.t; } @@ -236,7 +237,7 @@ type suspended_goal = { type indexing = | MapOn of int | Hash of int list - | Trie of int + | Trie of { argno : int; path_depth : int } [@@deriving show] let mkLam x = Lam x [@@inline] diff --git a/src/runtime.ml b/src/runtime.ml index bcf698ad2..3c2bb9daf 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2419,7 +2419,7 @@ let hash_arg_list is_goal hd ~depth args mode spec = let hash_clause_arg_list = hash_arg_list false let hash_goal_arg_list = hash_arg_list true -let rec arg_to_trie_path ~depth t : TreeIndexable.path = +(*let rec arg_to_trie_path ~depth t : TreeIndexable.path = match deref_head ~depth t with | Const k when k == Global_symbols.uvarc -> [Variable] | Const k -> [Constant (k, 0)] @@ -2435,7 +2435,58 @@ let rec arg_to_trie_path ~depth t : TreeIndexable.path = Constant (k, 1 + List.length xs) :: fst_arg @ args | Nil | Cons _ -> [Other] | Lam _ -> [Other] (* loose indexing to enable eta *) - | Arg _ | UVar _ | AppArg _ | AppUVar _ | Discard -> [Other] + | Arg _ | UVar _ | AppArg _ | AppUVar _ | Discard -> [Other]*) +(** + [arg_to_trie_path_aux ~depth t_list path_depth] + Takes a list of terms and builds the path representing this list with + height limited to [depth]. +*) +let rec arg_to_trie_path_aux ~depth t_list path_depth : TreeIndexable.path = + if path_depth = 0 then [] + else + match t_list with + | [] -> [] + | hd :: tl -> + let hd_path = arg_to_trie_path ~depth hd path_depth in + let tl_path = arg_to_trie_path_aux ~depth tl path_depth in + hd_path @ tl_path +(** + [arg_to_trie_path ~depth t path_depth] + Takes a [term] and returns it path representation with height bound by [path_depth] +*) +and arg_to_trie_path ~depth t path_depth : TreeIndexable.path = + if path_depth = 0 then [] + else + let path_depth = path_depth - 1 in + match deref_head ~depth t with + | Const k when k == Global_symbols.uvarc -> [Variable] + | Const k -> [Constant (k, 0)] + | CData d -> [Primitive d] + | App (k,_,_) when k == Global_symbols.uvarc -> [Variable] + | App (k,a,_) when k == Global_symbols.asc -> arg_to_trie_path ~depth a (path_depth+1) + | Nil -> [Constant(Global_symbols.nilc,0)] + | Lam _ -> [Other] (* loose indexing to enable eta *) + | Arg _ | UVar _ | AppArg _ | AppUVar _ | Discard -> [Other] + | Builtin (k,tl) -> + let path = arg_to_trie_path_aux ~depth tl path_depth in + Constant (k, if path_depth = 0 then 0 else List.length tl) :: path + | App (k, x, xs) -> + let arg_length = if path_depth = 0 then 0 else List.length xs + 1 in + let hd_path = arg_to_trie_path ~depth x path_depth in + let tl_path = arg_to_trie_path_aux ~depth xs path_depth in + Constant (k, arg_length) :: hd_path @ tl_path + | Cons (x,xs) -> + let hd_path = arg_to_trie_path ~depth x path_depth in + let tl_path = arg_to_trie_path ~depth xs path_depth in + Constant (Global_symbols.consc, 2) :: hd_path @ tl_path + +(** + [arg_to_trie_path ~path_depth ~depth t] + Take a term and returns its path representation up to path_depth +*) +let arg_to_trie_path ~path_depth ~depth t = + arg_to_trie_path ~depth t path_depth + let add1clause ~depth m (predicate,clause) = match Ptmap.find predicate m with | TwoLevelIndex { all_clauses; argno; mode; flex_arg_clauses; arg_idx } -> @@ -2483,11 +2534,11 @@ let add1clause ~depth m (predicate,clause) = time = time + 1; args_idx = Ptmap.add hash ((clause,time) :: clauses) args_idx }) m - | IndexWithTrie {mode; argno; args_idx; time} -> - let path = arg_to_trie_path ~depth (match clause.args with [] -> Discard | l -> List.nth l argno) in + | IndexWithTrie {mode; argno; args_idx; time; path_depth } -> + let path = arg_to_trie_path ~depth ~path_depth (match clause.args with [] -> Discard | l -> List.nth l argno) in let dt = DT.index args_idx path clause ~time in Ptmap.add predicate (IndexWithTrie { - mode; argno; + mode; argno; path_depth; time = time+1; args_idx = dt }) m @@ -2538,8 +2589,8 @@ let make_index ~depth ~indexing ~clauses_rev:p = flex_arg_clauses = []; arg_idx = Ptmap.empty; } - | Trie argno -> IndexWithTrie { - argno; mode; + | Trie { argno; path_depth } -> IndexWithTrie { + argno; path_depth; mode; args_idx = DT.empty; time = min_int; } @@ -2617,12 +2668,13 @@ let get_clauses ~depth predicate goal { index = m } = let hash = hash_goal_args ~depth mode args goal in let cl = List.flatten (Ptmap.find_unifiables hash args_idx) in List.(map fst (sort (fun (_,cl1) (_,cl2) -> cl2 - cl1) cl)) - | IndexWithTrie {argno; mode; args_idx} -> + | IndexWithTrie {argno; path_depth; mode; args_idx} -> let mode_arg = nth_not_bool_default mode argno in - let arg = arg_to_trie_path ~depth (trie_goal_args goal argno) in + let arg = arg_to_trie_path ~depth ~path_depth (trie_goal_args goal argno) in [%spy "dev:disc-tree-filter-number1" ~rid pp_string "Current path is" TreeIndexable.pp arg - pp_string " and current DT is " (DT.pp pp_clause) args_idx]; + pp_int path_depth + (*pp_string " and current DT is " (DT.pp pp_clause_simple) args_idx*)]; let candidates = if mode_arg then DT.retrieve_generalizations args_idx arg else DT.retrieve_unifiables args_idx arg in diff --git a/src/trace_atd.ts b/src/trace_atd.ts index 8d248245d..7bf7fa827 100644 --- a/src/trace_atd.ts +++ b/src/trace_atd.ts @@ -1,22 +1,18 @@ -/* - Generated by atdts from type definitions in 'trace.atd'. +// Generated by atdts from type definitions in 'trace.atd'. +// +// Type-safe translations from/to JSON +// +// For each type 'Foo', there is a pair of functions: +// - 'writeFoo': convert a 'Foo' value into a JSON-compatible value. +// - 'readFoo': convert a JSON-compatible value into a TypeScript value +// of type 'Foo'. - Type-safe translations from/to JSON - - For each type 'Foo', there is a pair of functions: - - 'writeFoo': convert a 'Foo' value into a JSON-compatible value. - - 'readFoo': convert a JSON-compatible value into a TypeScript value - of type 'Foo'. -*/ - -/* tslint:disable */ -/* eslint-disable */ export type Item = { kind: Kind[]; - goal_id: number /*int*/; - runtime_id: number /*int*/; - step: number /*int*/; + goal_id: Int; + runtime_id: Int; + step: Int; name: string; payload: string[]; } @@ -93,9 +89,9 @@ export type Location = export type FileLocation = { filename: string; - line: number /*int*/; - column: number /*int*/; - character: number /*int*/; + line: Int; + column: Int; + character: Int; } export type Event = @@ -128,11 +124,11 @@ export type Frame = { runtime_id: RuntimeId; } -export type GoalId = number /*int*/ +export type GoalId = Int -export type StepId = number /*int*/ +export type StepId = Int -export type RuntimeId = number /*int*/ +export type RuntimeId = Int export type GoalText = string @@ -790,6 +786,8 @@ export function readChrText(x: any, context: any = x): ChrText { // Runtime library ///////////////////////////////////////////////////////////////////// +export type Int = number + export type Option = null | { value: T } function _atd_missing_json_field(type_name: string, json_field_name: string) { @@ -822,7 +820,7 @@ function _atd_bad_ts(expected_type: string, ts_value: any, context: any) { ` Occurs in '${JSON.stringify(context)}'.`) } -function _atd_check_json_tuple(len: number /*int*/, x: any, context: any) { +function _atd_check_json_tuple(len: Int, x: any, context: any) { if (! Array.isArray(x) || x.length !== len) _atd_bad_json('tuple of length ' + len, x, context); } @@ -845,7 +843,7 @@ function _atd_read_bool(x: any, context: any): boolean { } } -function _atd_read_int(x: any, context: any): number /*int*/ { +function _atd_read_int(x: any, context: any): Int { if (Number.isInteger(x)) return x else { @@ -1026,7 +1024,7 @@ function _atd_write_bool(x: any, context: any): boolean { } } -function _atd_write_int(x: any, context: any): number /*int*/ { +function _atd_write_int(x: any, context: any): Int { if (Number.isInteger(x)) return x else { @@ -1135,7 +1133,7 @@ function _atd_write_required_field(type_name: string, } function _atd_write_optional_field(write_elt: (x: T, context: any) => any, - x: T | undefined, + x: T, context: any): any { if (x === undefined || x === null) return x diff --git a/tests/suite/suite.ml b/tests/suite/suite.ml index e9c9d798f..36a20fd8b 100644 --- a/tests/suite/suite.ml +++ b/tests/suite/suite.ml @@ -37,7 +37,7 @@ let tests = ref [] let declare name ~description ?source_elpi ?source_teyjus ?(deps_teyjus=[]) ?source_dune ?source_json ?after - ?(typecheck=true) ?input ?(expectation=Success) + ?(typecheck=false) ?input ?(expectation=Success) ?(outside_llam=false) ?(trace=Off) ?(legacy_parser=false) From decdc996addcba729ac8bc48251cea0095811478 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 21 Nov 2023 17:23:34 +0100 Subject: [PATCH 41/57] wip --- tests/sources/dt.elpi | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 tests/sources/dt.elpi diff --git a/tests/sources/dt.elpi b/tests/sources/dt.elpi new file mode 100644 index 000000000..6dc632ea2 --- /dev/null +++ b/tests/sources/dt.elpi @@ -0,0 +1,26 @@ +:index (12) +pred fast o:list int. +pred slow o:list int. + +pred mk-index i:int, i:(list int -> prop), o:list prop. +mk-index 0 _ []. +mk-index N P [C|CL] :- N > 0, N1 is N - 1, mk-clause P 10 [N] C, mk-index N1 P CL. + +pred mk-clause i:(list int -> prop), i:int, i:list int, o:prop. +mk-clause P 0 X (P X). +mk-clause P N ACC C :- N > 0, N1 is N - 1, + mk-clause P N1 [N|ACC] C. + +pred repeat i:int, i:prop. +repeat 0 _. +repeat N P :- N > 0, N1 is N - 1, P, !, repeat N1 P. + +main :- + mk-index 100 fast CL1, + mk-index 100 slow CL2, + !, + CL1 => CL2 => std.do! [ + std.time (repeat 90000 (fast [_,_,_,_,_,_,_,_,_,_,100])) TFast, + % std.time (repeat 90000 (slow [_,_,_,_,_,_,_,_,_,_,100])) TSlow, + print TFast TSlow, + ]. \ No newline at end of file From 1a79b763971a714666edd32db447ced5f6e52865 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Wed, 22 Nov 2023 11:35:30 +0100 Subject: [PATCH 42/57] mutual recurs function for retrieval search --- src/discrimination_tree.ml | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index ed239a9d4..c535881b2 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -47,9 +47,7 @@ module type DiscriminationTree = sig end module Make (K : IndexableTerm) : - DiscriminationTree - with type key = K.cell - and type keylist = K.path = struct + DiscriminationTree with type key = K.cell and type keylist = K.path = struct module OrderedPathStringElement = struct type t = K.cell @@ -65,19 +63,19 @@ module Make (K : IndexableTerm) : type keylist = K.path type 'a t = ('a * int) Trie.t - let pp pp_a fmt (t : 'a t) : unit = Trie.pp (fun fmt (a,_) -> pp_a fmt a) fmt t - let show pp_a (t : 'a t) : string = Trie.show (fun fmt (a,_) -> pp_a fmt a) t - let empty = Trie.empty - let iter dt f = Trie.iter (fun p (x,_) -> f p x) dt - let fold dt f = Trie.fold (fun p (x,_) -> f p x) dt + let pp pp_a fmt (t : 'a t) : unit = + Trie.pp (fun fmt (a, _) -> pp_a fmt a) fmt t - let index tree ps info ~time = - Trie.add ps (info,time) tree + let show pp_a (t : 'a t) : string = Trie.show (fun fmt (a, _) -> pp_a fmt a) t + let empty = Trie.empty + let iter dt f = Trie.iter (fun p (x, _) -> f p x) dt + let fold dt f = Trie.fold (fun p (x, _) -> f p x) dt + let index tree ps info ~time = Trie.add ps (info, time) tree let in_index tree ps test = try let ps_set = Trie.find ps tree in - List.exists (fun (x,_) -> test x) ps_set + List.exists (fun (x, _) -> test x) ps_set with Not_found -> false (* the equivalent of skip, but on the index, thus the list of trees @@ -96,8 +94,7 @@ module Make (K : IndexableTerm) : let rec merge l1 l2 = match (l1, l2) with | [], l | l, [] -> l - | (_,tx as x) :: xs, (_,ty) :: _ when tx > ty -> - x :: merge xs l2 + | ((_, tx) as x) :: xs, (_, ty) :: _ when tx > ty -> x :: merge xs l2 | _, y :: ys -> y :: merge l1 ys let retrieve unif tree path = @@ -108,11 +105,14 @@ module Make (K : IndexableTerm) : In the latter case, the unif boolean to be true (we are in output mode). *) let to_unify v = v = K.to_unify || (v = K.variable && unif) in - let rec retrieve path tree = + let rec retrieve_aux path = function + | [] -> [] + | hd :: tl -> merge (retrieve path hd) (retrieve_aux path tl) + and retrieve path tree = match (tree, path) with | Node (s, _), [] -> s | Node (_, _map), v :: path when to_unify v -> - List.fold_left merge [] (List.map (retrieve path) (skip_root tree)) + retrieve_aux path (skip_root tree) (* Note: in the following branch the head of the path can't be K.to_unify *) | Node (_, map), (node :: sub_path as path) -> let find_by_key key = @@ -133,6 +133,8 @@ module Make (K : IndexableTerm) : in retrieve path tree - let retrieve_generalizations tree term = retrieve false tree term |> List.map fst + let retrieve_generalizations tree term = + retrieve false tree term |> List.map fst + let retrieve_unifiables tree term = retrieve true tree term |> List.map fst end From 04056b919c703b414668226bd2245c48ce7d1aac Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 22 Nov 2023 21:58:23 +0100 Subject: [PATCH 43/57] wip --- src/data.ml | 11 +++++++++-- src/discrimination_tree.ml | 18 ++++++++++++++---- src/runtime.ml | 2 +- tests/sources/dt.elpi | 11 ++++++----- tests/suite/performance_FO.ml | 5 +++++ 5 files changed, 35 insertions(+), 12 deletions(-) diff --git a/src/data.ml b/src/data.ml index b062bab11..544bca44c 100644 --- a/src/data.ml +++ b/src/data.ml @@ -53,6 +53,7 @@ module Constants : sig module Set : Set.S with type elt = constant val pp : Format.formatter -> t -> unit val show : t -> string + val compare : t -> t -> int end = struct module Self = struct @@ -138,7 +139,7 @@ let pp_clause_simple (fmt:Format.formatter) (cl: clause) = Format.fprintf fmt "c type 'a path_string_elem = | Constant of 'a * int - | Primitive of Elpi_util.Util.CData.t + | Primitive of int (*Elpi_util.Util.CData.t*) | Variable | Other [@@deriving show] @@ -157,7 +158,13 @@ module TreeIndexable : Discrimination_tree.IndexableTerm with let variable = Variable let to_unify = Other - let compare = compare + let compare x y = + match x,y with + | Constant(x,_), Constant(y,_) -> Constants.compare x y + | Variable, Variable -> 0 + | Other, Other -> 0 + | Primitive x, Primitive y -> x - y + | _, _ -> compare x y let arity_of = function | Constant (_,a) -> a diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index c535881b2..588a829b0 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -2,6 +2,7 @@ (* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) +let (=) (x:int) (y:int) = x = y module type IndexableTerm = sig type cell type path = cell list @@ -91,7 +92,7 @@ module Make (K : IndexableTerm) : PSMap.fold (fun k v res -> get (K.arity_of k) v @ res) map [] (* NOTE: l1 and l2 are supposed to be sorted *) - let rec merge l1 l2 = + let rec merge (l1 : ('a * int) list) l2 = match (l1, l2) with | [], l | l, [] -> l | ((_, tx) as x) :: xs, (_, ty) :: _ when tx > ty -> x :: merge xs l2 @@ -111,7 +112,8 @@ module Make (K : IndexableTerm) : and retrieve path tree = match (tree, path) with | Node (s, _), [] -> s - | Node (_, _map), v :: path when to_unify v -> + | Node (_, _map), v :: path when false && to_unify v -> + assert false; retrieve_aux path (skip_root tree) (* Note: in the following branch the head of the path can't be K.to_unify *) | Node (_, map), (node :: sub_path as path) -> @@ -122,14 +124,22 @@ module Make (K : IndexableTerm) : | n, path -> retrieve path n with Not_found -> [] in + (* merge (merge + *) (if (not unif) && K.variable = node then [] else - try retrieve sub_path (PSMap.find node map) - with Not_found -> []) + let subtree = + try PSMap.find node map + with Not_found -> Node([],PSMap.empty) + in + retrieve sub_path subtree + ) + (* (find_by_key K.variable)) (find_by_key K.to_unify) + *) in retrieve path tree diff --git a/src/runtime.ml b/src/runtime.ml index 3c2bb9daf..2fdb51b21 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2461,7 +2461,7 @@ and arg_to_trie_path ~depth t path_depth : TreeIndexable.path = match deref_head ~depth t with | Const k when k == Global_symbols.uvarc -> [Variable] | Const k -> [Constant (k, 0)] - | CData d -> [Primitive d] + | CData d -> [Primitive (CData.hash d)] | App (k,_,_) when k == Global_symbols.uvarc -> [Variable] | App (k,a,_) when k == Global_symbols.asc -> arg_to_trie_path ~depth a (path_depth+1) | Nil -> [Constant(Global_symbols.nilc,0)] diff --git a/tests/sources/dt.elpi b/tests/sources/dt.elpi index 6dc632ea2..60ced3dd3 100644 --- a/tests/sources/dt.elpi +++ b/tests/sources/dt.elpi @@ -1,6 +1,6 @@ :index (12) -pred fast o:list int. -pred slow o:list int. +pred fast i:list int. +pred slow i:list int. pred mk-index i:int, i:(list int -> prop), o:list prop. mk-index 0 _ []. @@ -20,7 +20,8 @@ main :- mk-index 100 slow CL2, !, CL1 => CL2 => std.do! [ - std.time (repeat 90000 (fast [_,_,_,_,_,_,_,_,_,_,100])) TFast, - % std.time (repeat 90000 (slow [_,_,_,_,_,_,_,_,_,_,100])) TSlow, - print TFast TSlow, + std.time (repeat 90000 (fast [1,2,3,4,5,6,7,8,9,10,100])) TFast, + % std.time (repeat 90000 (slow [1,2,3,4,5,6,7,8,9,10,100])) TSlow, + print "DT=" TFast, + print "PT=" TSlow, ]. \ No newline at end of file diff --git a/tests/suite/performance_FO.ml b/tests/suite/performance_FO.ml index f75686c63..7b83da080 100644 --- a/tests/suite/performance_FO.ml +++ b/tests/suite/performance_FO.ml @@ -79,3 +79,8 @@ let () = declare "set" ~source_elpi:"set.elpi" ~description:"stdlib set" () + +let () = declare "dt" + ~source_elpi:"dt.elpi" + ~description:"discrimination_tree indexing" + () From f8f326aefd5b091a5a67e64013a493bcb221ffc9 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 23 Nov 2023 09:52:13 +0100 Subject: [PATCH 44/57] wip --- src/discrimination_tree.ml | 49 ++++++++++++++++------------------ src/elpi-checker.elpi | 54 ++++++++++++++++++++++---------------- tests/sources/dt.elpi | 4 +-- 3 files changed, 56 insertions(+), 51 deletions(-) diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 588a829b0..371cb4157 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -2,7 +2,7 @@ (* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) -let (=) (x:int) (y:int) = x = y +(*let (=) (x:int) (y:int) = x = y*) module type IndexableTerm = sig type cell type path = cell list @@ -96,34 +96,26 @@ module Make (K : IndexableTerm) : match (l1, l2) with | [], l | l, [] -> l | ((_, tx) as x) :: xs, (_, ty) :: _ when tx > ty -> x :: merge xs l2 - | _, y :: ys -> y :: merge l1 ys + | _, y :: ys -> y :: merge l1 ys + + let to_unify v unif = v = K.to_unify || (v = K.variable && unif) - let retrieve unif tree path = - let open Trie in (* to_unify returns if a key should be unified with all the values of the current sub-tree. This key should be either K.to_unfy or K.variable. In the latter case, the unif boolean to be true (we are in output mode). *) - let to_unify v = v = K.to_unify || (v = K.variable && unif) in - let rec retrieve_aux path = function + let rec retrieve_aux unif path = function | [] -> [] - | hd :: tl -> merge (retrieve path hd) (retrieve_aux path tl) - and retrieve path tree = + | hd :: tl -> merge (retrieve unif path hd) (retrieve_aux unif path tl) + and retrieve unif path tree = match (tree, path) with - | Node (s, _), [] -> s - | Node (_, _map), v :: path when false && to_unify v -> + | Trie.Node (s, _), [] -> s + | Trie.Node (_, _map), v :: path when false && to_unify v unif -> assert false; - retrieve_aux path (skip_root tree) + retrieve_aux unif path (skip_root tree) (* Note: in the following branch the head of the path can't be K.to_unify *) - | Node (_, map), (node :: sub_path as path) -> - let find_by_key key = - try - match (PSMap.find key map, K.skip path) with - | Node (s, _), [] -> s - | n, path -> retrieve path n - with Not_found -> [] - in + | Trie.Node (_, map), (node :: sub_path as path) -> (* merge (merge @@ -134,17 +126,22 @@ module Make (K : IndexableTerm) : try PSMap.find node map with Not_found -> Node([],PSMap.empty) in - retrieve sub_path subtree + retrieve unif sub_path subtree ) (* - (find_by_key K.variable)) - (find_by_key K.to_unify) + (find_by_key unif map path K.variable)) + (find_by_key unif map path K.to_unify) *) - in - retrieve path tree + and find_by_key unif key map path = + try + match (PSMap.find key map, K.skip path) with + | Trie.Node (s, _), [] -> s + | n, path -> retrieve unif path n + with Not_found -> [] + let retrieve_generalizations tree term = - retrieve false tree term |> List.map fst + retrieve false term tree |> List.map fst - let retrieve_unifiables tree term = retrieve true tree term |> List.map fst + let retrieve_unifiables tree term = retrieve true term tree |> List.map fst end diff --git a/src/elpi-checker.elpi b/src/elpi-checker.elpi index 0c6ef787c..43a11a297 100644 --- a/src/elpi-checker.elpi +++ b/src/elpi-checker.elpi @@ -175,27 +175,27 @@ refresh X X. safe-dest-app (app [X | A]) X A :- !. safe-dest-app X X []. -collect-symbols-term N _ X X :- name N, !. -collect-symbols-term (cdata _) _ X X :- !. -collect-symbols-term (app []) _ X X :- !. -collect-symbols-term (app [HD|L]) Known Acc Res :- !, - collect-symbols-term HD Known Acc Acc1, - collect-symbols-term (app L) Known Acc1 Res. -collect-symbols-term (lam F) Known Acc Res :- !, - pi x\ collect-symbols-term (F x) Known Acc Res. -collect-symbols-term (arg F) Known Acc Res :- !, - pi x\ collect-symbols-term (F x) Known Acc Res. -collect-symbols-term (const S) Known Acc Res :- !, - if (std.string.set.mem S Known ; std.string.map.mem S Acc) (Res = Acc) +collect-symbols-term N X X :- name N, !. +collect-symbols-term (cdata _) X X :- !. +collect-symbols-term (app []) X X :- !. +collect-symbols-term (app [HD|L]) Acc Res :- !, + collect-symbols-term HD Acc Acc1, + collect-symbols-term (app L) Acc1 Res. +collect-symbols-term (lam F) Acc Res :- !, + pi x\ collect-symbols-term (F x) Acc Res. +collect-symbols-term (arg F) Acc Res :- !, + pi x\ collect-symbols-term (F x) Acc Res. +collect-symbols-term (const S) Acc Res :- !, + if (std.string.map.mem S Acc) (Res = Acc) (checking Loc, std.string.map.add S Loc Acc Res). -collect-symbols-clause (clause Loc _ C) Known Acc Res :- - checking Loc => collect-symbols-term C Known Acc Res. +collect-symbols-clause (clause Loc _ C) Acc Res :- + checking Loc => collect-symbols-term C Acc Res. -collect-symbols-program [ C | P ] Known Acc Res :- - collect-symbols-clause C Known Acc Acc1, - collect-symbols-program P Known Acc1 Res. -collect-symbols-program [] _ X X. +collect-symbols-program [ C | P ] Acc Res :- + collect-symbols-clause C Acc Acc1, + collect-symbols-program P Acc1 Res. +collect-symbols-program [] X X. mode (under-env i i). @@ -241,21 +241,27 @@ under-undecl-env [ pr X _ | XS ] P :- %print "Assume" X PT, (of (const X) Ty_ :- !) => under-undecl-env XS P. -add-known (const N `: _) S S1 :- std.string.set.add N S S1. +rm-known (const N `: _) S S1 :- std.string.map.remove N S S1. :if "TIME:CHECKER" timing S P :- !, std.time P Time, print S Time. timing _ P :- P. +pred check-all-symbols i:std.string.map loc. +:name "check-all-symbols:main" +check-all-symbols _. + +:name "typecheck-program:main" typecheck-program P Q DeclaredTypes RC :- KnownTypes = [ ((const "pi") `: forall x\ (arrow (arrow x prop) prop)), ((const "sigma") `: forall x\ (arrow (arrow x prop) prop)), ((const "discard") `: forall x\ x)|DeclaredTypes], - timing "known set" (std.fold KnownTypes {std.string.set.empty} add-known Known), - timing "collect prog" (collect-symbols-program P Known {std.string.map.empty} TMP), - collect-symbols-clause Q Known TMP TMP1, - std.string.map.bindings TMP1 Undeclared, + timing "collect prog" (collect-symbols-program P {std.string.map.empty} TMP), + collect-symbols-clause Q TMP AllSymbols, + check-all-symbols AllSymbols, + std.fold KnownTypes AllSymbols rm-known Unknown, + std.string.map.bindings Unknown Undeclared, forall_uto10 {std.rev Undeclared} 0 (warn-undeclared KnownTypes), !, timing "typecheck " (under-decl-env {std.rev KnownTypes} @@ -310,6 +316,7 @@ check-non-linear [] (arg C) L :- pi x\ check-non-linear _ C L :- count C L, report-linear L. +:name "warn-linear:main" warn-linear []. warn-linear [ (clause Loc Names Clause) |CS] :- checking Loc => check-non-linear Names Clause [], @@ -337,6 +344,7 @@ compile-type-abbreviations [(S `:= T)|TS] [Clause|Clauses] :- type->ppt-clause S [] T Clause, compile-type-abbreviations TS Clauses. +:name "check:main" check P Q DeclaredTypes TypeAbbreviations :- compile-type-abbreviations TypeAbbreviations Abbrevs, Abbrevs => typecheck-program P Q DeclaredTypes RC, !, diff --git a/tests/sources/dt.elpi b/tests/sources/dt.elpi index 60ced3dd3..ca27ea709 100644 --- a/tests/sources/dt.elpi +++ b/tests/sources/dt.elpi @@ -20,8 +20,8 @@ main :- mk-index 100 slow CL2, !, CL1 => CL2 => std.do! [ - std.time (repeat 90000 (fast [1,2,3,4,5,6,7,8,9,10,100])) TFast, - % std.time (repeat 90000 (slow [1,2,3,4,5,6,7,8,9,10,100])) TSlow, + std.time (repeat 900000 (fast [1,2,3,4,5,6,7,8,9,10,100])) TFast, + % std.time (repeat 900000 (slow [1,2,3,4,5,6,7,8,9,10,100])) TSlow, print "DT=" TFast, print "PT=" TSlow, ]. \ No newline at end of file From b3f821c11e318df06fcf73bf20a6856cfdc983da Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 23 Nov 2023 10:02:10 +0100 Subject: [PATCH 45/57] wip --- src/data.ml | 45 +-------- src/discrimination_tree.ml | 194 +++++++++++++++++++++---------------- src/dune | 2 +- src/runtime.ml | 9 +- 4 files changed, 116 insertions(+), 134 deletions(-) diff --git a/src/data.ml b/src/data.ml index 544bca44c..c9fe0e60d 100644 --- a/src/data.ml +++ b/src/data.ml @@ -137,50 +137,7 @@ let pp_clause_simple (fmt:Format.formatter) (cl: clause) = Format.fprintf fmt "c pplist pp_term ", " fmt cl.hyps; Format.fprintf fmt "]";*) -type 'a path_string_elem = - | Constant of 'a * int - | Primitive of int (*Elpi_util.Util.CData.t*) - | Variable | Other -[@@deriving show] - -type 'a path = ('a path_string_elem) list - -module TreeIndexable : Discrimination_tree.IndexableTerm with - type cell = constant path_string_elem and - type path = constant path_string_elem list -= struct - type cell = (constant path_string_elem) [@@deriving show] - type path = cell list [@@deriving show] - - let pp = pp_path - let show = show_path - - let variable = Variable - let to_unify = Other - - let compare x y = - match x,y with - | Constant(x,_), Constant(y,_) -> Constants.compare x y - | Variable, Variable -> 0 - | Other, Other -> 0 - | Primitive x, Primitive y -> x - y - | _, _ -> compare x y - - let arity_of = function - | Constant (_,a) -> a - | Variable | Other | Primitive _ -> 0 - - let skip (path: path) : path = - let rec aux arity path = - if arity = 0 then path else match path with - | [] -> assert false - | m::tl -> aux (arity-1+arity_of m) tl in - match path with - | [] -> anomaly "Skipping empty path is not possible" - | hd :: tl -> aux (arity_of hd) tl -end - -module DT = Discrimination_tree.Make(TreeIndexable) +module DT = Discrimination_tree type stuck_goal = { mutable blockers : blockers; diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 371cb4157..471239bba 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -47,101 +47,125 @@ module type DiscriminationTree = sig val retrieve_unifiables : 'a t -> keylist -> 'a list end -module Make (K : IndexableTerm) : - DiscriminationTree with type key = K.cell and type keylist = K.path = struct - module OrderedPathStringElement = struct - type t = K.cell - - let show = K.show_cell - let pp = K.pp_cell - let compare = K.compare - end - - module PSMap = Elpi_util.Util.Map.Make (OrderedPathStringElement) - module Trie = Trie.Make (PSMap) - - type key = K.cell - type keylist = K.path - type 'a t = ('a * int) Trie.t - - let pp pp_a fmt (t : 'a t) : unit = - Trie.pp (fun fmt (a, _) -> pp_a fmt a) fmt t - - let show pp_a (t : 'a t) : string = Trie.show (fun fmt (a, _) -> pp_a fmt a) t - let empty = Trie.empty - let iter dt f = Trie.iter (fun p (x, _) -> f p x) dt - let fold dt f = Trie.fold (fun p (x, _) -> f p x) dt - let index tree ps info ~time = Trie.add ps (info, time) tree - - let in_index tree ps test = - try - let ps_set = Trie.find ps tree in - List.exists (fun (x, _) -> test x) ps_set - with Not_found -> false - - (* the equivalent of skip, but on the index, thus the list of trees - that are rooted just after the term represented by the tree root - are returned (we are skipping the root) *) - let skip_root (Trie.Node (_value, map)) = - let rec get n = function - | Trie.Node (_v, m) as tree -> - if n = 0 then [ tree ] - else - PSMap.fold (fun k v res -> get (n - 1 + K.arity_of k) v @ res) m [] - in - PSMap.fold (fun k v res -> get (K.arity_of k) v @ res) map [] - - (* NOTE: l1 and l2 are supposed to be sorted *) - let rec merge (l1 : ('a * int) list) l2 = - match (l1, l2) with - | [], l | l, [] -> l - | ((_, tx) as x) :: xs, (_, ty) :: _ when tx > ty -> x :: merge xs l2 - | _, y :: ys -> y :: merge l1 ys - - let to_unify v unif = v = K.to_unify || (v = K.variable && unif) - - (* +type cell = + | Constant of int * int (* constant , arity *) + | Primitive of int (*Elpi_util.Util.CData.t hash *) + | Variable + | Other +[@@deriving show] + +type path = cell list [@@deriving show] + +let compare x y = + match (x, y) with + | Constant (x, _), Constant (y, _) -> x - y + | Variable, Variable -> 0 + | Other, Other -> 0 + | Primitive x, Primitive y -> x - y + | _, _ -> compare x y + +let arity_of = function + | Constant (_, a) -> a + | Variable | Other | Primitive _ -> 0 + +let skip (path : path) : path = + let rec aux arity path = + if arity = 0 then path + else + match path with + | [] -> assert false + | m :: tl -> aux (arity - 1 + arity_of m) tl + in + match path with + | [] -> Elpi_util.Util.anomaly "Skipping empty path is not possible" + | hd :: tl -> aux (arity_of hd) tl + +module OrderedPathStringElement = struct + type t = cell + + let show = show_cell + let pp = pp_cell + let compare = compare +end + +module PSMap = Elpi_util.Util.Map.Make (OrderedPathStringElement) +module Trie = Trie.Make (PSMap) + +type 'a t = ('a * int) Trie.t + +let pp pp_a fmt (t : 'a t) : unit = Trie.pp (fun fmt (a, _) -> pp_a fmt a) fmt t +let show pp_a (t : 'a t) : string = Trie.show (fun fmt (a, _) -> pp_a fmt a) t +let empty = Trie.empty +let iter dt f = Trie.iter (fun p (x, _) -> f p x) dt +let fold dt f = Trie.fold (fun p (x, _) -> f p x) dt +let index tree ps info ~time = Trie.add ps (info, time) tree + +let in_index tree ps test = + try + let ps_set = Trie.find ps tree in + List.exists (fun (x, _) -> test x) ps_set + with Not_found -> false + +(* the equivalent of skip, but on the index, thus the list of trees + that are rooted just after the term represented by the tree root + are returned (we are skipping the root) *) +let skip_root (Trie.Node (_value, map)) = + let rec get n = function + | Trie.Node (_v, m) as tree -> + if n = 0 then [ tree ] + else PSMap.fold (fun k v res -> get (n - 1 + arity_of k) v @ res) m [] + in + PSMap.fold (fun k v res -> get (arity_of k) v @ res) map [] + +(* NOTE: l1 and l2 are supposed to be sorted *) +let rec merge (l1 : ('a * int) list) l2 = + match (l1, l2) with + | [], l | l, [] -> l + | ((_, tx) as x) :: xs, (_, ty) :: _ when tx > ty -> x :: merge xs l2 + | _, y :: ys -> y :: merge l1 ys + +let to_unify v unif = v == Other || (v == Variable && unif) + +(* to_unify returns if a key should be unified with all the values of the current sub-tree. This key should be either K.to_unfy or K.variable. In the latter case, the unif boolean to be true (we are in output mode). *) - let rec retrieve_aux unif path = function - | [] -> [] - | hd :: tl -> merge (retrieve unif path hd) (retrieve_aux unif path tl) - and retrieve unif path tree = - match (tree, path) with - | Trie.Node (s, _), [] -> s - | Trie.Node (_, _map), v :: path when false && to_unify v unif -> - assert false; - retrieve_aux unif path (skip_root tree) - (* Note: in the following branch the head of the path can't be K.to_unify *) - | Trie.Node (_, map), (node :: sub_path as path) -> - (* +let rec retrieve_aux unif path = function + | [] -> [] + | hd :: tl -> merge (retrieve unif path hd) (retrieve_aux unif path tl) + +and retrieve unif path tree = + match (tree, path) with + | Trie.Node (s, _), [] -> s + | Trie.Node (_, _map), v :: path when false && to_unify v unif -> + assert false; + retrieve_aux unif path (skip_root tree) + (* Note: in the following branch the head of the path can't be K.to_unify *) + | Trie.Node (_, map), (node :: sub_path as path) -> + (* merge (merge *) - (if (not unif) && K.variable = node then [] - else - let subtree = - try PSMap.find node map - with Not_found -> Node([],PSMap.empty) - in - retrieve unif sub_path subtree - ) - (* + if (not unif) && Variable == node then [] + else + let subtree = + try PSMap.find node map with Not_found -> Node ([], PSMap.empty) + in + retrieve unif sub_path subtree +(* (find_by_key unif map path K.variable)) (find_by_key unif map path K.to_unify) *) - and find_by_key unif key map path = - try - match (PSMap.find key map, K.skip path) with - | Trie.Node (s, _), [] -> s - | n, path -> retrieve unif path n - with Not_found -> [] +and find_by_key unif key map path = + try + match (PSMap.find key map, skip path) with + | Trie.Node (s, _), [] -> s + | n, path -> retrieve unif path n + with Not_found -> [] - let retrieve_generalizations tree term = - retrieve false term tree |> List.map fst +let retrieve_generalizations tree term = + retrieve false term tree |> List.map fst - let retrieve_unifiables tree term = retrieve true term tree |> List.map fst -end +let retrieve_unifiables tree term = retrieve true term tree |> List.map fst diff --git a/src/dune b/src/dune index cb0183a56..3a2ded984 100644 --- a/src/dune +++ b/src/dune @@ -1,7 +1,7 @@ (library (public_name elpi) (preprocess (per_module - ((pps ppx_deriving.std) API data compiler) + ((pps ppx_deriving.std) API data compiler discrimination_tree) ((pps ppx_deriving.std elpi.trace.ppx -- --cookie "elpi_trace=\"true\"") runtime) ((pps ppx_deriving.std elpi.trace.ppx -- --cookie "elpi_trace=\"false\"") runtime_trace_off) )) diff --git a/src/runtime.ml b/src/runtime.ml index 2fdb51b21..feb64fede 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2419,7 +2419,7 @@ let hash_arg_list is_goal hd ~depth args mode spec = let hash_clause_arg_list = hash_arg_list false let hash_goal_arg_list = hash_arg_list true -(*let rec arg_to_trie_path ~depth t : TreeIndexable.path = +(*let rec arg_to_trie_path ~depth t : Discrimination_tree.path = match deref_head ~depth t with | Const k when k == Global_symbols.uvarc -> [Variable] | Const k -> [Constant (k, 0)] @@ -2441,7 +2441,7 @@ let hash_goal_arg_list = hash_arg_list true Takes a list of terms and builds the path representing this list with height limited to [depth]. *) -let rec arg_to_trie_path_aux ~depth t_list path_depth : TreeIndexable.path = +let rec arg_to_trie_path_aux ~depth t_list path_depth : Discrimination_tree.path = if path_depth = 0 then [] else match t_list with @@ -2454,7 +2454,8 @@ let rec arg_to_trie_path_aux ~depth t_list path_depth : TreeIndexable.path = [arg_to_trie_path ~depth t path_depth] Takes a [term] and returns it path representation with height bound by [path_depth] *) -and arg_to_trie_path ~depth t path_depth : TreeIndexable.path = +and arg_to_trie_path ~depth t path_depth : Discrimination_tree.path = + let open Discrimination_tree in if path_depth = 0 then [] else let path_depth = path_depth - 1 in @@ -2672,7 +2673,7 @@ let get_clauses ~depth predicate goal { index = m } = let mode_arg = nth_not_bool_default mode argno in let arg = arg_to_trie_path ~depth ~path_depth (trie_goal_args goal argno) in [%spy "dev:disc-tree-filter-number1" ~rid - pp_string "Current path is" TreeIndexable.pp arg + pp_string "Current path is" Discrimination_tree.pp_path arg pp_int path_depth (*pp_string " and current DT is " (DT.pp pp_clause_simple) args_idx*)]; let candidates = if mode_arg then From 6a4887d0393b7a34d5d263f02f83c718e71096a7 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 23 Nov 2023 10:15:33 +0100 Subject: [PATCH 46/57] wip --- src/discrimination_tree.ml | 22 +++++++++++++++++----- src/runtime.ml | 20 ++++++++++---------- 2 files changed, 27 insertions(+), 15 deletions(-) diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 471239bba..42b0d4185 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -47,26 +47,38 @@ module type DiscriminationTree = sig val retrieve_unifiables : 'a t -> keylist -> 'a list end +let arity_bits = 4 +let arity_mask = (1 lsl arity_bits) - 1 +let encode c a = (c lsl arity_bits) lor a +let mask_low n = n land arity_mask + type cell = - | Constant of int * int (* constant , arity *) + | Constant of int (* (constant << arity_bits) lor arity *) | Primitive of int (*Elpi_util.Util.CData.t hash *) | Variable | Other [@@deriving show] +let mkConstant c a = Constant (encode c a) +let mkVariable = Variable +let mkOther = Other +let mkPrimitive c = Primitive (Elpi_util.Util.CData.hash c) + +let arity_of = function + | Constant n -> mask_low n + | Variable | Other | Primitive _ -> 0 + + type path = cell list [@@deriving show] let compare x y = match (x, y) with - | Constant (x, _), Constant (y, _) -> x - y + | Constant x, Constant y -> x - y | Variable, Variable -> 0 | Other, Other -> 0 | Primitive x, Primitive y -> x - y | _, _ -> compare x y -let arity_of = function - | Constant (_, a) -> a - | Variable | Other | Primitive _ -> 0 let skip (path : path) : path = let rec aux arity path = diff --git a/src/runtime.ml b/src/runtime.ml index feb64fede..a389ceaa5 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2460,26 +2460,26 @@ and arg_to_trie_path ~depth t path_depth : Discrimination_tree.path = else let path_depth = path_depth - 1 in match deref_head ~depth t with - | Const k when k == Global_symbols.uvarc -> [Variable] - | Const k -> [Constant (k, 0)] - | CData d -> [Primitive (CData.hash d)] - | App (k,_,_) when k == Global_symbols.uvarc -> [Variable] + | Const k when k == Global_symbols.uvarc -> [mkVariable] + | Const k -> [mkConstant k 0] + | CData d -> [mkPrimitive d] + | App (k,_,_) when k == Global_symbols.uvarc -> [mkVariable] | App (k,a,_) when k == Global_symbols.asc -> arg_to_trie_path ~depth a (path_depth+1) - | Nil -> [Constant(Global_symbols.nilc,0)] - | Lam _ -> [Other] (* loose indexing to enable eta *) - | Arg _ | UVar _ | AppArg _ | AppUVar _ | Discard -> [Other] + | Nil -> [mkConstant Global_symbols.nilc 0] + | Lam _ -> [mkOther] (* loose indexing to enable eta *) + | Arg _ | UVar _ | AppArg _ | AppUVar _ | Discard -> [mkOther] | Builtin (k,tl) -> let path = arg_to_trie_path_aux ~depth tl path_depth in - Constant (k, if path_depth = 0 then 0 else List.length tl) :: path + mkConstant k (if path_depth = 0 then 0 else List.length tl) :: path | App (k, x, xs) -> let arg_length = if path_depth = 0 then 0 else List.length xs + 1 in let hd_path = arg_to_trie_path ~depth x path_depth in let tl_path = arg_to_trie_path_aux ~depth xs path_depth in - Constant (k, arg_length) :: hd_path @ tl_path + mkConstant k arg_length :: hd_path @ tl_path | Cons (x,xs) -> let hd_path = arg_to_trie_path ~depth x path_depth in let tl_path = arg_to_trie_path ~depth xs path_depth in - Constant (Global_symbols.consc, 2) :: hd_path @ tl_path + mkConstant Global_symbols.consc 2 :: hd_path @ tl_path (** [arg_to_trie_path ~path_depth ~depth t] From dda99166b76f03e588daffc545b6b73225e92885 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 23 Nov 2023 10:27:54 +0100 Subject: [PATCH 47/57] wip --- src/discrimination_tree.ml | 60 ++++++++++++++++---------------------- 1 file changed, 25 insertions(+), 35 deletions(-) diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 42b0d4185..5d4fb879b 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -48,37 +48,35 @@ module type DiscriminationTree = sig end let arity_bits = 4 -let arity_mask = (1 lsl arity_bits) - 1 -let encode c a = (c lsl arity_bits) lor a +let k_bits = 2 + +(* value , arity, k *) +let kConstant = 0 (* (constant << arity_bits) lor arity *) +let kPrimitive = 1 (*Elpi_util.Util.CData.t hash *) +let kVariable = 2 +let kOther = 3 + +let k_mask = (1 lsl k_bits) - 1 +let arity_mask = ((1 lsl arity_bits) lsl k_bits) - 1 +let k_of n = n land k_mask + +let arity_of n = + let k = k_of n in + if k == kConstant then (n land arity_mask) lsr k_bits + else 0 +let encode k c a = ((c lsl arity_bits) lsl k_bits) lor (a lsl k_bits) lor k let mask_low n = n land arity_mask -type cell = - | Constant of int (* (constant << arity_bits) lor arity *) - | Primitive of int (*Elpi_util.Util.CData.t hash *) - | Variable - | Other -[@@deriving show] - -let mkConstant c a = Constant (encode c a) -let mkVariable = Variable -let mkOther = Other -let mkPrimitive c = Primitive (Elpi_util.Util.CData.hash c) - -let arity_of = function - | Constant n -> mask_low n - | Variable | Other | Primitive _ -> 0 +let mkConstant c a = encode kConstant c a +let mkVariable = kVariable +let mkOther = kOther +let mkPrimitive c = (Elpi_util.Util.CData.hash c lsl k_bits) lor kPrimitive +type cell = int [@@deriving show] type path = cell list [@@deriving show] -let compare x y = - match (x, y) with - | Constant x, Constant y -> x - y - | Variable, Variable -> 0 - | Other, Other -> 0 - | Primitive x, Primitive y -> x - y - | _, _ -> compare x y - +let compare x y = x - y let skip (path : path) : path = let rec aux arity path = @@ -92,14 +90,6 @@ let skip (path : path) : path = | [] -> Elpi_util.Util.anomaly "Skipping empty path is not possible" | hd :: tl -> aux (arity_of hd) tl -module OrderedPathStringElement = struct - type t = cell - - let show = show_cell - let pp = pp_cell - let compare = compare -end - module PSMap = Elpi_util.Util.Map.Make (OrderedPathStringElement) module Trie = Trie.Make (PSMap) @@ -136,7 +126,7 @@ let rec merge (l1 : ('a * int) list) l2 = | ((_, tx) as x) :: xs, (_, ty) :: _ when tx > ty -> x :: merge xs l2 | _, y :: ys -> y :: merge l1 ys -let to_unify v unif = v == Other || (v == Variable && unif) +let to_unify v unif = v == kOther || (v == kVariable && unif) (* to_unify returns if a key should be unified with all the values of @@ -159,7 +149,7 @@ and retrieve unif path tree = merge (merge *) - if (not unif) && Variable == node then [] + if (not unif) && kVariable == node then [] else let subtree = try PSMap.find node map with Not_found -> Node ([], PSMap.empty) From 40a44a23dd5cc91e5fc4acbf09d558d312f437a3 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 23 Nov 2023 11:24:09 +0100 Subject: [PATCH 48/57] wip --- src/discrimination_tree.ml | 222 +++++++++++++++++++++---------------- src/dune | 4 +- src/trie.ml | 155 -------------------------- src/trie.mli | 24 ---- 4 files changed, 129 insertions(+), 276 deletions(-) delete mode 100644 src/trie.ml delete mode 100644 src/trie.mli diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 5d4fb879b..ce05e4410 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -1,52 +1,6 @@ (* elpi: embedded lambda prolog interpreter *) (* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) - -(*let (=) (x:int) (y:int) = x = y*) -module type IndexableTerm = sig - type cell - type path = cell list - - val show_cell : cell -> string - val pp_cell : Format.formatter -> cell -> unit - val compare : cell -> cell -> int - - (* You have h(f(x,g(y,z)),t) whose path_string_of_term_with_jl is - (h,2).(f,2).(x,0).(g,2).(y,0).(z,0).(t,0) and you are at f and want to - skip all its progeny, thus you want to reach t. - - You need to skip as many elements as the sum of all arieties contained - in the progeny of f. - - The input ariety is the one of f while the path is x.g....t - Should be the equivalent of after_t in the literature (handbook A.R.) - *) - (* MAYBE: a pointer to t from f should increase performances (i.e. jump list - from McCune 1990) *) - val skip : path -> path - val arity_of : cell -> int - val variable : cell - val to_unify : cell - val pp : Format.formatter -> path -> unit - val show : path -> string -end - -module type DiscriminationTree = sig - type key - type keylist = key list - type 'a t - - include Elpi_util.Util.Show1 with type 'a t := 'a t - - val iter : 'a t -> (keylist -> 'a -> unit) -> unit - val fold : 'a t -> (keylist -> 'a -> 'b -> 'b) -> 'b -> 'b - val empty : 'a t - val index : 'a t -> keylist -> 'a -> time:int -> 'a t - val in_index : 'a t -> keylist -> ('a -> bool) -> bool - val retrieve_generalizations : 'a t -> keylist -> 'a list - val retrieve_unifiables : 'a t -> keylist -> 'a list -end - let arity_bits = 4 let k_bits = 2 @@ -55,23 +9,108 @@ let kConstant = 0 (* (constant << arity_bits) lor arity *) let kPrimitive = 1 (*Elpi_util.Util.CData.t hash *) let kVariable = 2 let kOther = 3 - -let k_mask = (1 lsl k_bits) - 1 -let arity_mask = ((1 lsl arity_bits) lsl k_bits) - 1 +let k_lshift = Sys.int_size - k_bits +let ka_lshift = Sys.int_size - k_bits - arity_bits +let k_mask = ((1 lsl k_bits) - 1) lsl k_lshift +let arity_mask = (((1 lsl arity_bits) lsl k_bits) - 1) lsl ka_lshift +let data_mask = (1 lsl ka_lshift) - 1 +let encode k c a = (k lsl k_lshift) lor (a lsl ka_lshift) lor (c land data_mask) let k_of n = n land k_mask let arity_of n = let k = k_of n in - if k == kConstant then (n land arity_mask) lsr k_bits - else 0 -let encode k c a = ((c lsl arity_bits) lsl k_bits) lor (a lsl k_bits) lor k -let mask_low n = n land arity_mask - + if k == kConstant then (n land arity_mask) lsr ka_lshift else 0 let mkConstant c a = encode kConstant c a -let mkVariable = kVariable -let mkOther = kOther -let mkPrimitive c = (Elpi_util.Util.CData.hash c lsl k_bits) lor kPrimitive +let mkVariable = encode kVariable 0 0 +let mkOther = encode kOther 0 0 +let mkPrimitive c = encode kPrimitive (Elpi_util.Util.CData.hash c lsl k_bits) 0 + +module Trie = struct + (* + * Trie: maps over lists. + * Copyright (C) 2000 Jean-Christophe FILLIATRE + * + * This software is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library General Public + * License version 2, as published by the Free Software Foundation. + * + * This software is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * + * See the GNU Library General Public License version 2 for more details + * (enclosed in the file LGPL). + *) + + (*s A trie is a tree-like structure to implement dictionaries over + keys which have list-like structures. The idea is that each node + branches on an element of the list and stores the value associated + to the path from the root, if any. Therefore, a trie can be + defined as soon as a map over the elements of the list is + given. *) + + (*s Then a trie is just a tree-like structure, where a possible + information is stored at the node (['a option]) and where the sons + are given by a map from type [key] to sub-tries, so of type + ['a t Ptmap.t]. The empty trie is just the empty map. *) + + type key = int list + + type 'a t = + | Node of { data : 'a list; other : 'a t option; map : 'a t Ptmap.t } + + let empty = Node { data = []; other = None; map = Ptmap.empty } + + (*s To find a mapping in a trie is easy: when all the elements of the + key have been read, we just inspect the optional info at the + current node; otherwise, we descend in the appropriate sub-trie + using [Ptmap.find]. *) + + let rec find l t = + match (l, t) with + | [], Node { data = [] } -> raise Not_found + | [], Node { data } -> data + | x :: r, Node { map } -> find r (Ptmap.find x map) + + let mem l t = try Fun.const true (find l t) with Not_found -> false + + (*s Insertion is more subtle. When the final node is reached, we just + put the information ([Some v]). Otherwise, we have to insert the + binding in the appropriate sub-trie [t']. But it may not exists, + and in that case [t'] is bound to an empty trie. Then we get a new + sub-trie [t''] by a recursive insertion and we modify the + branching, so that it now points to [t''], with [Ptmap.add]. *) + + let add l v t = + let rec ins = function + | [], Node ({ data } as t) -> Node { t with data = v :: data } + | x :: r, Node ({ other } as t) when x == kVariable || x == kOther -> + let t' = match other with None -> empty | Some x -> x in + let t'' = ins (r, t') in + Node { t with other = Some t'' } + | x :: r, Node ({ map } as t) -> + let t' = try Ptmap.find x map with Not_found -> empty in + let t'' = ins (r, t') in + Node { t with map = Ptmap.add x t'' map } + in + ins (l, t) + + let rec pp (ppelem : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (Node { data; other; map } : 'a t) : unit = + Format.fprintf fmt "[values:{"; + Elpi_util.Util.pplist ppelem "; " fmt data; + Format.fprintf fmt "} other:{"; + (match other with None -> () | Some m -> pp ppelem fmt m); + Format.fprintf fmt "} key:{"; + Ptmap.pp (pp ppelem) fmt map; + Format.fprintf fmt "}]" + + let show (fmt : Format.formatter -> 'a -> unit) (n : 'a t) : string = + let b = Buffer.create 22 in + Format.fprintf (Format.formatter_of_buffer b) "@[%a@]" (pp fmt) n; + Buffer.contents b +end type cell = int [@@deriving show] type path = cell list [@@deriving show] @@ -90,16 +129,11 @@ let skip (path : path) : path = | [] -> Elpi_util.Util.anomaly "Skipping empty path is not possible" | hd :: tl -> aux (arity_of hd) tl -module PSMap = Elpi_util.Util.Map.Make (OrderedPathStringElement) -module Trie = Trie.Make (PSMap) - type 'a t = ('a * int) Trie.t let pp pp_a fmt (t : 'a t) : unit = Trie.pp (fun fmt (a, _) -> pp_a fmt a) fmt t let show pp_a (t : 'a t) : string = Trie.show (fun fmt (a, _) -> pp_a fmt a) t let empty = Trie.empty -let iter dt f = Trie.iter (fun p (x, _) -> f p x) dt -let fold dt f = Trie.fold (fun p (x, _) -> f p x) dt let index tree ps info ~time = Trie.add ps (info, time) tree let in_index tree ps test = @@ -111,13 +145,23 @@ let in_index tree ps test = (* the equivalent of skip, but on the index, thus the list of trees that are rooted just after the term represented by the tree root are returned (we are skipping the root) *) -let skip_root (Trie.Node (_value, map)) = +let all_children other map = let rec get n = function - | Trie.Node (_v, m) as tree -> + | Trie.Node { other = None; map } as tree -> if n = 0 then [ tree ] - else PSMap.fold (fun k v res -> get (n - 1 + arity_of k) v @ res) m [] + else Ptmap.fold (fun k v res -> get (n - 1 + arity_of k) v @ res) map [] + | Trie.Node { other = Some other; map } as tree -> + if n = 0 then [ tree; other ] + else + Ptmap.fold + (fun k v res -> get (n - 1 + arity_of k) v @ res) + map [ other ] in - PSMap.fold (fun k v res -> get (arity_of k) v @ res) map [] + + Ptmap.fold + (fun k v res -> get (arity_of k) v @ res) + map + (match other with Some x -> [ x ] | None -> []) (* NOTE: l1 and l2 are supposed to be sorted *) let rec merge (l1 : ('a * int) list) l2 = @@ -128,44 +172,32 @@ let rec merge (l1 : ('a * int) list) l2 = let to_unify v unif = v == kOther || (v == kVariable && unif) -(* - to_unify returns if a key should be unified with all the values of - the current sub-tree. This key should be either K.to_unfy or K.variable. - In the latter case, the unif boolean to be true (we are in output mode). - *) +(* to_unify returns if a key should be unified with all the values of + the current sub-tree. This key should be either K.to_unfy or K.variable. + In the latter case, the unif boolean to be true (we are in output mode). *) let rec retrieve_aux unif path = function | [] -> [] | hd :: tl -> merge (retrieve unif path hd) (retrieve_aux unif path tl) and retrieve unif path tree = match (tree, path) with - | Trie.Node (s, _), [] -> s - | Trie.Node (_, _map), v :: path when false && to_unify v unif -> - assert false; - retrieve_aux unif path (skip_root tree) - (* Note: in the following branch the head of the path can't be K.to_unify *) - | Trie.Node (_, map), (node :: sub_path as path) -> - (* - merge - (merge - *) + | Trie.Node { data }, [] -> data + | Trie.Node { other; map }, v :: path when to_unify v unif -> + retrieve_aux unif path (all_children other map) + | Trie.Node { other = None; map }, node :: sub_path -> if (not unif) && kVariable == node then [] else - let subtree = - try PSMap.find node map with Not_found -> Node ([], PSMap.empty) - in + let subtree = try Ptmap.find node map with Not_found -> Trie.empty in retrieve unif sub_path subtree -(* - (find_by_key unif map path K.variable)) - (find_by_key unif map path K.to_unify) - *) - -and find_by_key unif key map path = - try - match (PSMap.find key map, skip path) with - | Trie.Node (s, _), [] -> s - | n, path -> retrieve unif path n - with Not_found -> [] + | Trie.Node { other = Some other; map }, (node :: sub_path as path) -> + merge + (if (not unif) && kVariable == node then [] + else + let subtree = + try Ptmap.find node map with Not_found -> Trie.empty + in + retrieve unif sub_path subtree) + (retrieve unif (skip path) other) let retrieve_generalizations tree term = retrieve false term tree |> List.map fst diff --git a/src/dune b/src/dune index 3a2ded984..20a1b2aa0 100644 --- a/src/dune +++ b/src/dune @@ -14,11 +14,11 @@ ; ----- public API --------------------------------- elpi API builtin builtin_checker ; ----- internal stuff ----------------------------- - compiler data ptmap trie discrimination_tree runtime_trace_off runtime + compiler data ptmap discrimination_tree runtime_trace_off runtime builtin_stdlib builtin_map builtin_set legacy_parser_proxy) (private_modules - compiler data ptmap trie runtime_trace_off runtime + compiler data ptmap runtime_trace_off runtime builtin_stdlib builtin_map builtin_set legacy_parser_proxy) ) diff --git a/src/trie.ml b/src/trie.ml deleted file mode 100644 index 52fc89a37..000000000 --- a/src/trie.ml +++ /dev/null @@ -1,155 +0,0 @@ -(* - * Trie: maps over lists. - * Copyright (C) 2000 Jean-Christophe FILLIATRE - * - * This software is free software; you can redistribute it and/or - * modify it under the terms of the GNU Library General Public - * License version 2, as published by the Free Software Foundation. - * - * This software is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - * - * See the GNU Library General Public License version 2 for more details - * (enclosed in the file LGPL). - *) - -(*s A trie is a tree-like structure to implement dictionaries over - keys which have list-like structures. The idea is that each node - branches on an element of the list and stores the value associated - to the path from the root, if any. Therefore, a trie can be - defined as soon as a map over the elements of the list is - given. *) - -module Make (M : Elpi_util.Util.Map.S) = struct - (*s Then a trie is just a tree-like structure, where a possible - information is stored at the node (['a option]) and where the sons - are given by a map from type [key] to sub-tries, so of type - ['a t M.t]. The empty trie is just the empty map. *) - - type key = M.key list - - type 'a t = Node of 'a list * 'a t M.t - let empty = Node ([], M.empty) - - (*s To find a mapping in a trie is easy: when all the elements of the - key have been read, we just inspect the optional info at the - current node; otherwise, we descend in the appropriate sub-trie - using [M.find]. *) - - let rec find l t = - match (l, t) with - | [], Node ([], _) -> raise Not_found - | [], Node (v, _) -> v - | x :: r, Node (_, m) -> find r (M.find x m) - - let mem l t = try Fun.const true (find l t) with Not_found -> false - - (*s Insertion is more subtle. When the final node is reached, we just - put the information ([Some v]). Otherwise, we have to insert the - binding in the appropriate sub-trie [t']. But it may not exists, - and in that case [t'] is bound to an empty trie. Then we get a new - sub-trie [t''] by a recursive insertion and we modify the - branching, so that it now points to [t''], with [M.add]. *) - - let add l v t = - let rec ins = function - | [], Node (l, m) -> Node (v::l, m) - | x :: r, Node (v, m) -> - let t' = try M.find x m with Not_found -> empty in - let t'' = ins (r, t') in - Node (v, M.add x t'' m) - in - ins (l, t) - - let replace l v t = - let rec ins = function - | [], Node (_, m) -> Node (v, m) - | x :: r, Node (v, m) -> - let t' = try M.find x m with Not_found -> empty in - let t'' = ins (r, t') in - Node (v, M.add x t'' m) - in - ins (l, t) - - (*s When removing a binding, we take care of not leaving bindings to empty - sub-tries in the nodes. Therefore, we test wether the result [t'] of - the recursive call is the empty trie [empty]: if so, we just remove - the branching with [M.remove]; otherwise, we modify it with [M.add]. *) - - let rec remove l t = - match (l, t) with - | [], Node (_, m) -> Node ([], m) - | x :: r, Node (v, m) -> ( - try - let t' = remove r (M.find x m) in - Node (v, if t' = empty then M.remove x m else M.add x t' m) - with Not_found -> t) - - (*s The iterators [map], [mapi], [iter] and [fold] are implemented in - a straigthforward way using the corresponding iterators [M.map], - [M.mapi], [M.iter] and [M.fold]. For the last three of them, - we have to remember the path from the root, as an extra argument - [revp]. Since elements are pushed in reverse order in [revp], - we have to reverse it with [List.rev] when the actual binding - has to be passed to function [f]. *) - - let rec map f = function - | Node (v, m) -> Node (List.map f v, M.map (map f) m) - - let mapi f t = - let rec maprec revp = function - | Node (v, m) -> - Node - (List.map (f (List.rev revp)) v, M.mapi (fun x -> maprec (x :: revp)) m) - in - maprec [] t - - let iter f t = - let rec traverse revp = function - | Node (v, m) -> - List.iter (f (List.rev revp)) v; - M.iter (fun x t -> traverse (x :: revp) t) m - in - traverse [] t - - let fold f t acc = - let rec traverse revp t acc = - match t with - | Node (v, m) -> - List.fold_right (f (List.rev revp)) v (M.fold (fun x -> traverse (x :: revp)) m acc) - in - traverse [] t acc - - let compare cmp a b = - let rec comp a b = - match (a, b) with - | Node (a, m1), Node (b, m2) -> - let c = List.compare cmp a b in - if c <> 0 then c else M.compare comp m1 m2 - in - comp a b - - let equal eq a b = - let rec comp a b = - match (a, b) with - | Node (a, m1), Node (b, m2) -> List.equal eq a b && M.equal comp m1 m2 - in - comp a b - - (* The base case is rather stupid, but constructable *) - let is_empty = function Node ([], m1) -> M.is_empty m1 | _ -> false - - let rec pp (ppelem : Format.formatter -> 'a -> unit) (fmt : Format.formatter) - (Node (a, b) : 'a t) : unit = - Format.fprintf fmt "[values:{"; - Elpi_util.Util.pplist ppelem "; " fmt a; - Format.fprintf fmt "} key:{"; - M.pp (pp ppelem) fmt b; - Format.fprintf fmt "}]" - - let show (fmt : Format.formatter -> 'a -> unit) (n : 'a t) : string = - let b = Buffer.create 22 in - Format.fprintf (Format.formatter_of_buffer b) "@[%a@]" (pp fmt) n; - Buffer.contents b -end diff --git a/src/trie.mli b/src/trie.mli deleted file mode 100644 index 9cd90bb26..000000000 --- a/src/trie.mli +++ /dev/null @@ -1,24 +0,0 @@ -(* elpi: embedded lambda prolog interpreter *) -(* license: GNU Lesser General Public License Version 2.1 or later *) -(* ------------------------------------------------------------------------- *) - -module Make : functor (M : Elpi_util.Util.Map.S) -> sig - type key = M.key list - type 'a t = Node of 'a list * 'a t M.t - - val empty : 'a t - val find : key -> 'a t -> 'a list - val mem : key -> 'a t -> bool - val replace : key -> 'a list -> 'a t -> 'a t - val add : key -> 'a -> 'a t -> 'a t - val remove : key -> 'a t -> 'a t - val map : ('a -> 'b) -> 'a t -> 'b t - val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t - val iter : (key -> 'a -> unit) -> 'a t -> unit - val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - val is_empty : 'a t -> bool - - include Elpi_util.Util.Show1 with type 'a t := 'a t -end From 2956db1556579a89bc19b6837d3b5bd36893da64 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 23 Nov 2023 14:10:51 +0100 Subject: [PATCH 49/57] wip --- .ocamlformat | 0 src/compiler.ml | 9 ++--- src/data.ml | 7 ++-- src/discrimination_tree.ml | 64 ++++++++++++++++++++++------------- src/runtime.ml | 47 ++++++++++++------------- src/utils/util.ml | 7 ++-- src/utils/util.mli | 3 +- tests/sources/dt.elpi | 16 ++++----- tests/sources/dt_off.elpi | 25 ++++++++++++++ tests/sources/dt_var.elpi | 8 +++++ tests/sources/dt_var2.elpi | 8 +++++ tests/suite/correctness_FO.ml | 17 ++++++++++ tests/suite/performance_FO.ml | 6 ++++ 13 files changed, 150 insertions(+), 67 deletions(-) create mode 100644 .ocamlformat create mode 100644 tests/sources/dt_off.elpi create mode 100644 tests/sources/dt_var.elpi create mode 100644 tests/sources/dt_var2.elpi diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 000000000..e69de29bb diff --git a/src/compiler.ml b/src/compiler.ml index 8d434fed9..d798d2980 100644 --- a/src/compiler.ml +++ b/src/compiler.ml @@ -1233,6 +1233,7 @@ let query_preterm_of_ast ~depth macros state (loc, t) = Loc.show (snd (C.Map.find name map)) ^ ")") let compile_mode (state, modes) { Ast.Mode.name; args; loc } = + let args = List.map to_mode args in let state, mname = funct_of_ast state name in check_duplicate_mode state mname (args,loc) modes; state, C.Map.add mname (args,loc) modes @@ -1356,7 +1357,7 @@ let query_preterm_of_ast ~depth macros state (loc, t) = (state : State.t), lcs, active_macros, { Structured.types; type_abbrevs; modes; body; symbols } - and compile_body macros types type_abbrevs modes lcs defs state = function + and compile_body macros types type_abbrevs (modes : (mode * Loc.t) C.Map.t) lcs defs state = function | [] -> lcs, state, types, type_abbrevs, modes, defs, [] | Locals (nlist, p) :: rest -> let orig_varmap = get_varmap state in @@ -1673,11 +1674,11 @@ module Spill : sig val spill_clause : - State.t -> types:Structured.typ list C.Map.t -> modes:(constant -> bool list) -> + State.t -> types:Structured.typ list C.Map.t -> modes:(constant -> mode) -> (preterm, 'a) Ast.Clause.t -> (preterm, 'a) Ast.Clause.t val spill_chr : - State.t -> types:Structured.typ list C.Map.t -> modes:(constant -> bool list) -> + State.t -> types:Structured.typ list C.Map.t -> modes:(constant -> mode) -> (constant list * prechr_rule list) -> (constant list * prechr_rule list) (* Exported to compile the query *) @@ -1727,7 +1728,7 @@ end = struct (* {{{ *) | `Arrow(arity,_),_ -> let missing = arity - nargs in let output_suffix = - let rec aux = function false :: l -> 1 + aux l | _ -> 0 in + let rec aux = function Output :: l -> 1 + aux l | _ -> 0 in aux (List.rev mode) in if missing > output_suffix then error ~loc Printf.(sprintf diff --git a/src/data.ml b/src/data.ml index c9fe0e60d..dc59d3494 100644 --- a/src/data.ml +++ b/src/data.ml @@ -116,6 +116,8 @@ let uvar_isnt_a_blocker { uid_private } = uid_private > 0 [@@inline];; let uvar_set_blocker r = r.uid_private <- -(uvar_id r) [@@inline];; let uvar_unset_blocker r = r.uid_private <- (uvar_id r) [@@inline];; +type arg_mode = Util.arg_mode = Input | Output [@@deriving show] + type clause = { depth : int; args : term list; @@ -125,10 +127,11 @@ type clause = { loc : Loc.t option; (* debug *) } and -(** input = true; output = false *) -mode = bool list (* true=input, false=output *) +mode = arg_mode list [@@deriving show] +let to_mode = function true -> Input | false -> Output + (* Simpler pretty printer for clause *) let pp_clause_simple (fmt:Format.formatter) (cl: clause) = Format.fprintf fmt "clause" (* Format.fprintf fmt "[clause_args:"; diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index ce05e4410..77ffe4144 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -15,7 +15,7 @@ let k_mask = ((1 lsl k_bits) - 1) lsl k_lshift let arity_mask = (((1 lsl arity_bits) lsl k_bits) - 1) lsl ka_lshift let data_mask = (1 lsl ka_lshift) - 1 let encode k c a = (k lsl k_lshift) lor (a lsl ka_lshift) lor (c land data_mask) -let k_of n = n land k_mask +let k_of n = (n land k_mask) lsr k_lshift let arity_of n = let k = k_of n in @@ -26,6 +26,28 @@ let mkVariable = encode kVariable 0 0 let mkOther = encode kOther 0 0 let mkPrimitive c = encode kPrimitive (Elpi_util.Util.CData.hash c lsl k_bits) 0 +let () = assert(k_of (mkConstant ~-17 0) == kConstant) +let () = assert(k_of mkVariable == kVariable) +let () = assert(k_of mkOther == kOther) + +let isVariable x = k_of x == kVariable +let isOther x = k_of x == kOther + +type cell = int +let pp_cell fmt n = + let k = k_of n in + if k == kConstant then + let data = data_mask land n in + let arity = (arity_mask land n) lsr ka_lshift in + Format.fprintf fmt "Constant(%d,%d)" data arity + else if k == kVariable then Format.fprintf fmt "Variable" + else if k == kOther then Format.fprintf fmt "Other" + else if k == kPrimitive then Format.fprintf fmt "Primitive" + else Format.fprintf fmt "%o" k + +let show_cell n = + Format.asprintf "%a" pp_cell n + module Trie = struct (* * Trie: maps over lists. @@ -85,7 +107,7 @@ module Trie = struct let add l v t = let rec ins = function | [], Node ({ data } as t) -> Node { t with data = v :: data } - | x :: r, Node ({ other } as t) when x == kVariable || x == kOther -> + | x :: r, Node ({ other } as t) when isVariable x || isOther x -> let t' = match other with None -> empty | Some x -> x in let t'' = ins (r, t') in Node { t with other = Some t'' } @@ -103,7 +125,7 @@ module Trie = struct Format.fprintf fmt "} other:{"; (match other with None -> () | Some m -> pp ppelem fmt m); Format.fprintf fmt "} key:{"; - Ptmap.pp (pp ppelem) fmt map; + Ptmap.to_list map |> Elpi_util.Util.pplist (fun fmt (k,v) -> pp_cell fmt k; pp ppelem fmt v) "; " fmt; Format.fprintf fmt "}]" let show (fmt : Format.formatter -> 'a -> unit) (n : 'a t) : string = @@ -112,7 +134,6 @@ module Trie = struct Buffer.contents b end -type cell = int [@@deriving show] type path = cell list [@@deriving show] let compare x y = x - y @@ -170,36 +191,31 @@ let rec merge (l1 : ('a * int) list) l2 = | ((_, tx) as x) :: xs, (_, ty) :: _ when tx > ty -> x :: merge xs l2 | _, y :: ys -> y :: merge l1 ys -let to_unify v unif = v == kOther || (v == kVariable && unif) +let get_all_children v mode = isOther v || (isVariable v && Elpi_util.Util.Output == mode) -(* to_unify returns if a key should be unified with all the values of +(* get_all_children returns if a key should be unified with all the values of the current sub-tree. This key should be either K.to_unfy or K.variable. - In the latter case, the unif boolean to be true (we are in output mode). *) -let rec retrieve_aux unif path = function + In the latter case, the mode boolean to be true (we are in output mode). *) +let rec retrieve_aux mode path = function | [] -> [] - | hd :: tl -> merge (retrieve unif path hd) (retrieve_aux unif path tl) + | hd :: tl -> merge (retrieve mode path hd) (retrieve_aux mode path tl) -and retrieve unif path tree = +and retrieve mode path tree = match (tree, path) with | Trie.Node { data }, [] -> data - | Trie.Node { other; map }, v :: path when to_unify v unif -> - retrieve_aux unif path (all_children other map) + | Trie.Node { other; map }, v :: path when get_all_children v mode -> + retrieve_aux mode path (all_children other map) | Trie.Node { other = None; map }, node :: sub_path -> - if (not unif) && kVariable == node then [] + if mode == Elpi_util.Util.Input && isVariable node then [] else let subtree = try Ptmap.find node map with Not_found -> Trie.empty in - retrieve unif sub_path subtree + retrieve mode sub_path subtree | Trie.Node { other = Some other; map }, (node :: sub_path as path) -> merge - (if (not unif) && kVariable == node then [] + (if mode == Elpi_util.Util.Input && isVariable node then [] else - let subtree = - try Ptmap.find node map with Not_found -> Trie.empty - in - retrieve unif sub_path subtree) - (retrieve unif (skip path) other) - -let retrieve_generalizations tree term = - retrieve false term tree |> List.map fst + let subtree = try Ptmap.find node map with Not_found -> Trie.empty in + retrieve mode sub_path subtree) + (retrieve mode (skip path) other) -let retrieve_unifiables tree term = retrieve true term tree |> List.map fst +let retrieve mode path index = retrieve mode path index |> List.map fst diff --git a/src/runtime.ml b/src/runtime.ml index a389ceaa5..345c866a4 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2294,12 +2294,12 @@ let tail_opt = function (** [hd_opt L] returns false if L = [[]] otherwise L.(0) *) let hd_opt = function | b :: _ -> b - | _ -> false + | _ -> Output type clause_arg_classification = | Variable | MustBeVariable - | Rigid of constant * bool (* matching *) + | Rigid of constant * arg_mode let rec classify_clause_arg ~depth matching t = match deref_head ~depth t with @@ -2362,10 +2362,10 @@ let hash_arg_list is_goal hd ~depth args mode spec = | x::xs, n::spec -> let h = aux_arg arg_size (hd_opt mode) n x in aux (off + arg_size) (acc lor (h lsl off)) xs (tail_opt mode) spec - and aux_arg size matching deep arg = + and aux_arg size mode deep arg = let h = match deref_head ~depth arg with - | App (k,a,_) when k == Global_symbols.asc -> aux_arg size matching deep a + | App (k,a,_) when k == Global_symbols.asc -> aux_arg size mode deep a | Const k when k == Global_symbols.uvarc -> hash size mustbevariablec | App(k,_,_) when k == Global_symbols.uvarc && deep = 1 -> @@ -2374,19 +2374,19 @@ let hash_arg_list is_goal hd ~depth args mode spec = | App(k,_,_) when deep = 1 -> hash size k | App(k,x,xs) -> let size = size / (List.length xs + 2) in - let self = aux_arg size matching (deep-1) in + let self = aux_arg size mode (deep-1) in let shift = shift size in (hash size k) lor (shift 1 (self x)) lor List.(fold_left (lor) 0 (mapi (fun i x -> shift (i+2) (self x)) xs)) - | (UVar _ | AppUVar _) when matching && is_goal -> hash size mustbevariablec - | (UVar _ | AppUVar _) when matching -> all_1 size + | (UVar _ | AppUVar _) when mode == Input && is_goal -> hash size mustbevariablec + | (UVar _ | AppUVar _) when mode == Input -> all_1 size | (UVar _ | AppUVar _) -> if is_goal then all_0 size else all_1 size | (Arg _ | AppArg _) -> all_1 size | Nil -> hash size Global_symbols.nilc | Cons (x,xs) -> let size = size / 2 in - let self = aux_arg size matching (deep-1) in + let self = aux_arg size mode (deep-1) in let shift = shift size in (hash size Global_symbols.consc) lor (shift 1 (self x)) | CData s -> hash size (CData.hash s) @@ -2394,7 +2394,7 @@ let hash_arg_list is_goal hd ~depth args mode spec = | Discard -> all_1 size | Builtin(k,xs) -> let size = size / (List.length xs + 1) in - let self = aux_arg size matching (deep-1) in + let self = aux_arg size mode (deep-1) in let shift = shift size in (hash size k) lor List.(fold_left (lor) 0 (mapi (fun i x -> shift (i+1) (self x)) xs)) @@ -2467,7 +2467,7 @@ and arg_to_trie_path ~depth t path_depth : Discrimination_tree.path = | App (k,a,_) when k == Global_symbols.asc -> arg_to_trie_path ~depth a (path_depth+1) | Nil -> [mkConstant Global_symbols.nilc 0] | Lam _ -> [mkOther] (* loose indexing to enable eta *) - | Arg _ | UVar _ | AppArg _ | AppUVar _ | Discard -> [mkOther] + | Arg _ | UVar _ | AppArg _ | AppUVar _ | Discard -> [mkVariable] | Builtin (k,tl) -> let path = arg_to_trie_path_aux ~depth tl path_depth in mkConstant k (if path_depth = 0 then 0 else List.length tl) :: path @@ -2511,13 +2511,13 @@ let add1clause ~depth m (predicate,clause) = flex_arg_clauses; arg_idx = Ptmap.add mustbevariablec (clause::l_rev) arg_idx; }) m - | Rigid (arg_hd,matching) -> + | Rigid (arg_hd,arg_mode) -> (* t: a rigid term matches flexible terms only in unification mode *) let l_rev = try Ptmap.find arg_hd arg_idx with Not_found -> flex_arg_clauses in let all_clauses = - if matching then all_clauses else clause :: all_clauses in + if arg_mode = Input then all_clauses else clause :: all_clauses in Ptmap.add predicate (TwoLevelIndex { argno; mode; all_clauses; @@ -2559,8 +2559,8 @@ let add1clause ~depth m (predicate,clause) = flex_arg_clauses = []; arg_idx = Ptmap.add mustbevariablec [clause] Ptmap.empty; }) m - | Rigid (arg_hd,matching) -> - let all_clauses = if matching then [] else [clause] in + | Rigid (arg_hd,arg_mode) -> + let all_clauses = if arg_mode == Input then [] else [clause] in Ptmap.add predicate (TwoLevelIndex { argno = 0;mode = []; all_clauses; @@ -2644,7 +2644,7 @@ let rec nth_not_found l n = match l with | _ :: l -> nth_not_found l (n-1) let rec nth_not_bool_default l n = match l with - | [] -> false + | [] -> Output | x :: _ when n = 0 -> x | _ :: l -> nth_not_bool_default l (n - 1) @@ -2671,16 +2671,13 @@ let get_clauses ~depth predicate goal { index = m } = List.(map fst (sort (fun (_,cl1) (_,cl2) -> cl2 - cl1) cl)) | IndexWithTrie {argno; path_depth; mode; args_idx} -> let mode_arg = nth_not_bool_default mode argno in - let arg = arg_to_trie_path ~depth ~path_depth (trie_goal_args goal argno) in - [%spy "dev:disc-tree-filter-number1" ~rid - pp_string "Current path is" Discrimination_tree.pp_path arg + let path = arg_to_trie_path ~depth ~path_depth (trie_goal_args goal argno) in + [%spy "dev:disc-tree:path" ~rid + Discrimination_tree.pp_path path pp_int path_depth - (*pp_string " and current DT is " (DT.pp pp_clause_simple) args_idx*)]; - let candidates = if mode_arg then - DT.retrieve_generalizations args_idx arg else - DT.retrieve_unifiables args_idx arg in - [%spy "dev:disc-tree-filter-number2" ~rid - pp_string "Filtered clauses number is" + Discrimination_tree.(pp pp_clause) args_idx]; + let candidates = DT.retrieve mode_arg path args_idx in + [%spy "dev:disc-tree:candidates" ~rid pp_int (List.length candidates)]; candidates with Not_found -> [] @@ -3758,7 +3755,7 @@ let make_runtime : ?max_steps: int -> ?delay_outside_fragment: bool -> 'x execut | x :: xs -> arg != C.dummy && match c_mode with | [] -> unif ~argsdepth:depth ~matching:false (gid[@trace]) depth env c_depth arg x && for_all23 ~argsdepth:depth (unif (gid[@trace])) depth env c_depth args_of_g xs - | matching :: ms -> unif ~argsdepth:depth ~matching (gid[@trace]) depth env c_depth arg x && for_all3b3 ~argsdepth:depth (unif (gid[@trace])) depth env c_depth args_of_g xs ms false + | arg_mode :: ms -> unif ~argsdepth:depth ~matching:(arg_mode == Input) (gid[@trace]) depth env c_depth arg x && for_all3b3 ~argsdepth:depth (unif (gid[@trace])) depth env c_depth args_of_g xs ms false with | false -> T.undo old_trail (); [%tcall backchain depth p (k, arg, args_of_g, gs) (gid[@trace]) next alts cutto_alts cs] diff --git a/src/utils/util.ml b/src/utils/util.ml index cc79d0d90..f40e4074e 100644 --- a/src/utils/util.ml +++ b/src/utils/util.ml @@ -218,13 +218,16 @@ let rec for_all3b p l1 l2 bl b = | (a1::l1, a2::l2, b3::bl) -> p a1 a2 b3 && for_all3b p l1 l2 bl b | (_, _, _) -> false ;; + +type arg_mode = Input | Output + let rec for_all3b3 ~argsdepth (p : argsdepth:int -> matching:bool -> 'a) x1 x2 x3 l1 l2 bl b = match (l1, l2, bl) with | ([], [], _) -> true | ([a1], [a2], []) -> p ~argsdepth x1 x2 x3 a1 a2 ~matching:b - | ([a1], [a2], b3::_) -> p ~argsdepth x1 x2 x3 a1 a2 ~matching:b3 + | ([a1], [a2], b3::_) -> p ~argsdepth x1 x2 x3 a1 a2 ~matching:(b3 == Input) | (a1::l1, a2::l2, []) -> p ~argsdepth x1 x2 x3 a1 a2 ~matching:b && for_all3b3 ~argsdepth p x1 x2 x3 l1 l2 bl b - | (a1::l1, a2::l2, b3::bl) -> p ~argsdepth x1 x2 x3 a1 a2 ~matching:b3 && for_all3b3 ~argsdepth p x1 x2 x3 l1 l2 bl b + | (a1::l1, a2::l2, b3::bl) -> p ~argsdepth x1 x2 x3 a1 a2 ~matching:(b3 == Input) && for_all3b3 ~argsdepth p x1 x2 x3 l1 l2 bl b | (_, _, _) -> false ;; diff --git a/src/utils/util.mli b/src/utils/util.mli index 4f996b4c6..bf5c5ec5f 100644 --- a/src/utils/util.mli +++ b/src/utils/util.mli @@ -112,7 +112,8 @@ val uniqq: 'a list -> 'a list val for_all2 : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool val for_all23 : argsdepth:int -> (argsdepth:int -> matching:bool -> 'x -> 'y -> 'z -> 'a -> 'a -> bool) -> 'x -> 'y -> 'z -> 'a list -> 'a list -> bool val for_all3b : ('a -> 'a -> bool -> bool) -> 'a list -> 'a list -> bool list -> bool -> bool -val for_all3b3 : argsdepth:int -> (argsdepth:int -> matching:bool -> 'x -> 'y -> 'z -> 'a -> 'a -> bool) -> 'x -> 'y -> 'z -> 'a list -> 'a list -> bool list -> bool -> bool +type arg_mode = Input | Output +val for_all3b3 : argsdepth:int -> (argsdepth:int -> matching:bool -> 'x -> 'y -> 'z -> 'a -> 'a -> bool) -> 'x -> 'y -> 'z -> 'a list -> 'a list -> arg_mode list -> bool -> bool (*uses physical equality and calls anomaly if the element is not in the list*) val remove_from_list : 'a -> 'a list -> 'a list (* returns Some t where f x = Some t for the first x in the list s.t. diff --git a/tests/sources/dt.elpi b/tests/sources/dt.elpi index ca27ea709..47d775b00 100644 --- a/tests/sources/dt.elpi +++ b/tests/sources/dt.elpi @@ -1,6 +1,5 @@ -:index (12) -pred fast i:list int. -pred slow i:list int. +:index (12) % DT is on +pred f i:list int. pred mk-index i:int, i:(list int -> prop), o:list prop. mk-index 0 _ []. @@ -16,12 +15,11 @@ repeat 0 _. repeat N P :- N > 0, N1 is N - 1, P, !, repeat N1 P. main :- - mk-index 100 fast CL1, - mk-index 100 slow CL2, + mk-index 100 f CL1, !, - CL1 => CL2 => std.do! [ - std.time (repeat 900000 (fast [1,2,3,4,5,6,7,8,9,10,100])) TFast, - % std.time (repeat 900000 (slow [1,2,3,4,5,6,7,8,9,10,100])) TSlow, + CL1 => std.do! [ + std.time (repeat 300000 (f [1,2,3,4,5,6,7,8,9,10,1])) TFast, + std.time (repeat 300000 (f [1,2,3,4,5,6,7,8,9,10,100])) TSlow, print "DT=" TFast, print "PT=" TSlow, - ]. \ No newline at end of file + ]. diff --git a/tests/sources/dt_off.elpi b/tests/sources/dt_off.elpi new file mode 100644 index 000000000..6492b733c --- /dev/null +++ b/tests/sources/dt_off.elpi @@ -0,0 +1,25 @@ +:index (1) % DT is off +pred f i:list int. + +pred mk-index i:int, i:(list int -> prop), o:list prop. +mk-index 0 _ []. +mk-index N P [C|CL] :- N > 0, N1 is N - 1, mk-clause P 10 [N] C, mk-index N1 P CL. + +pred mk-clause i:(list int -> prop), i:int, i:list int, o:prop. +mk-clause P 0 X (P X). +mk-clause P N ACC C :- N > 0, N1 is N - 1, + mk-clause P N1 [N|ACC] C. + +pred repeat i:int, i:prop. +repeat 0 _. +repeat N P :- N > 0, N1 is N - 1, P, !, repeat N1 P. + +main :- + mk-index 100 f CL1, + !, + CL1 => std.do! [ + std.time (repeat 300000 (f [1,2,3,4,5,6,7,8,9,10,1])) TFast, + std.time (repeat 300000 (f [1,2,3,4,5,6,7,8,9,10,100])) TSlow, + print "DT=" TFast, + print "PT=" TSlow, + ]. diff --git a/tests/sources/dt_var.elpi b/tests/sources/dt_var.elpi new file mode 100644 index 000000000..6e8a9bf44 --- /dev/null +++ b/tests/sources/dt_var.elpi @@ -0,0 +1,8 @@ +:index(20) +pred f i:int. +f uvar :- print "uvar". +f X :- var X, print "X". +f 1 :- halt "bug". + +main :- + (f X, fail) ; true. \ No newline at end of file diff --git a/tests/sources/dt_var2.elpi b/tests/sources/dt_var2.elpi new file mode 100644 index 000000000..9c93bc96d --- /dev/null +++ b/tests/sources/dt_var2.elpi @@ -0,0 +1,8 @@ +:index(20) +pred f o:int. +f uvar :- print "uvar". +f X :- var X, print "X". +f 1 :- print "Y". + +main :- + (f X, fail) ; true. \ No newline at end of file diff --git a/tests/suite/correctness_FO.ml b/tests/suite/correctness_FO.ml index 7bf18a8cc..e3c08ad4d 100644 --- a/tests/suite/correctness_FO.ml +++ b/tests/suite/correctness_FO.ml @@ -109,3 +109,20 @@ let () = declare "conj2_legacy" ~description:"parsing and evaluation of & (binary conj)" ~legacy_parser:true () + +let () = declare "dt_var" + ~source_elpi:"dt_var.elpi" + ~description:"discrimination_tree indexing flex" + ~typecheck:false + ~trace:(On["tty";"stdout";"-trace-at";"1";"9999";"-trace-only";"dev:disc-tree:candidates"]) + ~expectation:(SuccessOutput (Str.regexp "dev:disc-tree:candidates = 2")) + () + +let () = declare "dt_var2" + ~source_elpi:"dt_var2.elpi" + ~description:"discrimination_tree indexing flex" + ~typecheck:false + ~trace:(On["tty";"stdout";"-trace-at";"1";"9999";"-trace-only";"dev:disc-tree:candidates"]) + ~expectation:(SuccessOutput (Str.regexp "dev:disc-tree:candidates = 3")) + () + diff --git a/tests/suite/performance_FO.ml b/tests/suite/performance_FO.ml index 7b83da080..1963cf106 100644 --- a/tests/suite/performance_FO.ml +++ b/tests/suite/performance_FO.ml @@ -84,3 +84,9 @@ let () = declare "dt" ~source_elpi:"dt.elpi" ~description:"discrimination_tree indexing" () + +let () = declare "dt_off" + ~source_elpi:"dt_off.elpi" + ~description:"(without) discrimination_tree indexing" + () + From 356b4c22601af036a14e528d39be2854d1e8dcc0 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 23 Nov 2023 14:15:18 +0100 Subject: [PATCH 50/57] wip --- src/compiler.ml | 1 - src/runtime.ml | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/compiler.ml b/src/compiler.ml index d798d2980..c4184aaeb 100644 --- a/src/compiler.ml +++ b/src/compiler.ml @@ -2365,7 +2365,6 @@ let chose_indexing state predicate l = | [] -> error ("Wrong indexing for " ^ Symbols.show state predicate) | 0 :: l -> aux (argno+1) l | 1 :: l when all_zero l -> MapOn argno - (* TODO: take hd into account to create "shorter" paths *) | path_depth :: l when all_zero l -> Trie { argno ; path_depth } | _ -> Hash l in diff --git a/src/runtime.ml b/src/runtime.ml index 345c866a4..d526a7e5d 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2675,7 +2675,7 @@ let get_clauses ~depth predicate goal { index = m } = [%spy "dev:disc-tree:path" ~rid Discrimination_tree.pp_path path pp_int path_depth - Discrimination_tree.(pp pp_clause) args_idx]; + (*Discrimination_tree.(pp pp_clause) args_idx*)]; let candidates = DT.retrieve mode_arg path args_idx in [%spy "dev:disc-tree:candidates" ~rid pp_int (List.length candidates)]; From 339a4486636f8aab2b3fd4048a5e5cd617a07a9d Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 23 Nov 2023 14:35:23 +0100 Subject: [PATCH 51/57] wip --- src/discrimination_tree.ml | 8 ++++-- src/runtime.ml | 56 ++++++++++++++------------------------ 2 files changed, 26 insertions(+), 38 deletions(-) diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index 77ffe4144..f7f8d4984 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -21,12 +21,16 @@ let arity_of n = let k = k_of n in if k == kConstant then (n land arity_mask) lsr ka_lshift else 0 -let mkConstant c a = encode kConstant c a +let mkConstant ~safe c a = + let rc = encode kConstant c a in + if safe && (abs c > data_mask || a >= 1 lsl arity_bits) then + Elpi_util.Util.anomaly (Printf.sprintf "Indexing at depth > 1 is unsupported since constant %d/%d is too large or wide" c a); + rc let mkVariable = encode kVariable 0 0 let mkOther = encode kOther 0 0 let mkPrimitive c = encode kPrimitive (Elpi_util.Util.CData.hash c lsl k_bits) 0 -let () = assert(k_of (mkConstant ~-17 0) == kConstant) +let () = assert(k_of (mkConstant ~safe:false ~-17 0) == kConstant) let () = assert(k_of mkVariable == kVariable) let () = assert(k_of mkOther == kOther) diff --git a/src/runtime.ml b/src/runtime.ml index d526a7e5d..599e681c0 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2419,74 +2419,58 @@ let hash_arg_list is_goal hd ~depth args mode spec = let hash_clause_arg_list = hash_arg_list false let hash_goal_arg_list = hash_arg_list true -(*let rec arg_to_trie_path ~depth t : Discrimination_tree.path = - match deref_head ~depth t with - | Const k when k == Global_symbols.uvarc -> [Variable] - | Const k -> [Constant (k, 0)] - | CData d -> [Primitive d] - | Builtin (k,tl) -> - let args = List.flatten (List.map (arg_to_trie_path ~depth) tl) in - Constant (k, List.length tl) :: args - | App (k,_,_) when k == Global_symbols.uvarc -> [Variable] - | App (k,a,_) when k == Global_symbols.asc -> arg_to_trie_path ~depth a - | App (k, x, xs) -> - let args = List.flatten (List.map (arg_to_trie_path ~depth) xs) in - let fst_arg = arg_to_trie_path ~depth x in - Constant (k, 1 + List.length xs) :: fst_arg @ args - | Nil | Cons _ -> [Other] - | Lam _ -> [Other] (* loose indexing to enable eta *) - | Arg _ | UVar _ | AppArg _ | AppUVar _ | Discard -> [Other]*) (** [arg_to_trie_path_aux ~depth t_list path_depth] Takes a list of terms and builds the path representing this list with height limited to [depth]. *) -let rec arg_to_trie_path_aux ~depth t_list path_depth : Discrimination_tree.path = +let rec arg_to_trie_path_aux ~safe ~depth t_list path_depth : Discrimination_tree.path = if path_depth = 0 then [] else match t_list with | [] -> [] | hd :: tl -> - let hd_path = arg_to_trie_path ~depth hd path_depth in - let tl_path = arg_to_trie_path_aux ~depth tl path_depth in + let hd_path = arg_to_trie_path ~safe ~depth hd path_depth in + let tl_path = arg_to_trie_path_aux ~safe ~depth tl path_depth in hd_path @ tl_path (** [arg_to_trie_path ~depth t path_depth] Takes a [term] and returns it path representation with height bound by [path_depth] *) -and arg_to_trie_path ~depth t path_depth : Discrimination_tree.path = +and arg_to_trie_path ~safe ~depth t path_depth : Discrimination_tree.path = let open Discrimination_tree in if path_depth = 0 then [] else let path_depth = path_depth - 1 in match deref_head ~depth t with | Const k when k == Global_symbols.uvarc -> [mkVariable] - | Const k -> [mkConstant k 0] + | Const k when safe -> [mkConstant ~safe k 0] + | Const k -> [mkConstant ~safe k 0] | CData d -> [mkPrimitive d] | App (k,_,_) when k == Global_symbols.uvarc -> [mkVariable] - | App (k,a,_) when k == Global_symbols.asc -> arg_to_trie_path ~depth a (path_depth+1) - | Nil -> [mkConstant Global_symbols.nilc 0] + | App (k,a,_) when k == Global_symbols.asc -> arg_to_trie_path ~safe ~depth a (path_depth+1) + | Nil -> [mkConstant ~safe Global_symbols.nilc 0] | Lam _ -> [mkOther] (* loose indexing to enable eta *) | Arg _ | UVar _ | AppArg _ | AppUVar _ | Discard -> [mkVariable] | Builtin (k,tl) -> - let path = arg_to_trie_path_aux ~depth tl path_depth in - mkConstant k (if path_depth = 0 then 0 else List.length tl) :: path + let path = arg_to_trie_path_aux ~safe ~depth tl path_depth in + mkConstant ~safe k (if path_depth = 0 then 0 else List.length tl) :: path | App (k, x, xs) -> let arg_length = if path_depth = 0 then 0 else List.length xs + 1 in - let hd_path = arg_to_trie_path ~depth x path_depth in - let tl_path = arg_to_trie_path_aux ~depth xs path_depth in - mkConstant k arg_length :: hd_path @ tl_path + let hd_path = arg_to_trie_path ~safe ~depth x path_depth in + let tl_path = arg_to_trie_path_aux ~safe ~depth xs path_depth in + mkConstant ~safe k arg_length :: hd_path @ tl_path | Cons (x,xs) -> - let hd_path = arg_to_trie_path ~depth x path_depth in - let tl_path = arg_to_trie_path ~depth xs path_depth in - mkConstant Global_symbols.consc 2 :: hd_path @ tl_path + let hd_path = arg_to_trie_path ~safe ~depth x path_depth in + let tl_path = arg_to_trie_path ~safe ~depth xs path_depth in + mkConstant ~safe Global_symbols.consc 2 :: hd_path @ tl_path (** [arg_to_trie_path ~path_depth ~depth t] Take a term and returns its path representation up to path_depth *) -let arg_to_trie_path ~path_depth ~depth t = - arg_to_trie_path ~depth t path_depth +let arg_to_trie_path ~safe ~path_depth ~depth t = + arg_to_trie_path ~safe ~depth t path_depth let add1clause ~depth m (predicate,clause) = match Ptmap.find predicate m with @@ -2536,7 +2520,7 @@ let add1clause ~depth m (predicate,clause) = args_idx = Ptmap.add hash ((clause,time) :: clauses) args_idx }) m | IndexWithTrie {mode; argno; args_idx; time; path_depth } -> - let path = arg_to_trie_path ~depth ~path_depth (match clause.args with [] -> Discard | l -> List.nth l argno) in + let path = arg_to_trie_path ~safe:true ~depth ~path_depth (match clause.args with [] -> Discard | l -> List.nth l argno) in let dt = DT.index args_idx path clause ~time in Ptmap.add predicate (IndexWithTrie { mode; argno; path_depth; @@ -2671,7 +2655,7 @@ let get_clauses ~depth predicate goal { index = m } = List.(map fst (sort (fun (_,cl1) (_,cl2) -> cl2 - cl1) cl)) | IndexWithTrie {argno; path_depth; mode; args_idx} -> let mode_arg = nth_not_bool_default mode argno in - let path = arg_to_trie_path ~depth ~path_depth (trie_goal_args goal argno) in + let path = arg_to_trie_path ~safe:false ~depth ~path_depth (trie_goal_args goal argno) in [%spy "dev:disc-tree:path" ~rid Discrimination_tree.pp_path path pp_int path_depth From 832744169a8c7c7b9f9d9fcdc20e0b23e176c619 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 23 Nov 2023 14:50:53 +0100 Subject: [PATCH 52/57] doc --- CHANGES.md | 2 ++ ELPI.md | 16 ++++++++++++++-- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index b6c0d9a0b..9d8287c2f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,8 @@ Library: - New `std.fold-right` + +Runtime: - New clause retrieval through discrimination tree. This new index is enabled whenever the `:index` directive selects only one argument with a depth `> 1`. diff --git a/ELPI.md b/ELPI.md index 41c07ccad..a04d4a9b0 100644 --- a/ELPI.md +++ b/ELPI.md @@ -308,8 +308,20 @@ If only one argument is indexed, and it is indexed at depth one, then Elpi uses a standard indexing technique based on a perfect (for depth 1) search tree. This means that no false positives are returned by the index. -If more than one argument is indexed, or if some argument is indexed at depth -greater than 1, then Elpi uses an index based on the idea of +### Discrimination tree index + +If only one argument is indexed at depth greater than one, then Elpi uses +a [discrimination tree](https://www.cs.cmu.edu/~fp/courses/99-atp/lectures/lecture28.html). +Both the rule argument and the goal argument are +indexed up to the given depth. The indexing is not perfect, false positives may +be returned and ruled out by unification. + +Indexed terms are linearized into paths. Paths are inserted into a trie data +structure sharing common prefixes. + +### Hash based index + +If more than one argument is indexed then Elpi uses an index based on the idea of [unification hashes](http://blog.ndrix.com/2013/03/prolog-unification-hashes.html). ```prolog From d1960f496bac1bfd36fabdb6e9de1f63d96abde8 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Thu, 23 Nov 2023 17:44:49 +0100 Subject: [PATCH 53/57] Arity of Cons is 0 when remaining depth is 0 --- src/runtime.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/runtime.ml b/src/runtime.ml index 599e681c0..48849b68a 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -2463,7 +2463,7 @@ and arg_to_trie_path ~safe ~depth t path_depth : Discrimination_tree.path = | Cons (x,xs) -> let hd_path = arg_to_trie_path ~safe ~depth x path_depth in let tl_path = arg_to_trie_path ~safe ~depth xs path_depth in - mkConstant ~safe Global_symbols.consc 2 :: hd_path @ tl_path + mkConstant ~safe Global_symbols.consc (if path_depth = 0 then 0 else 2) :: hd_path @ tl_path (** [arg_to_trie_path ~path_depth ~depth t] From ee36bf9e987299d11bb9c8a3676b7fcb919faa10 Mon Sep 17 00:00:00 2001 From: Davide Fissore Date: Thu, 23 Nov 2023 22:29:35 +0100 Subject: [PATCH 54/57] readd typecheck on test-suite (now typeabbrv tests pass) --- tests/suite/suite.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/suite/suite.ml b/tests/suite/suite.ml index 36a20fd8b..e9c9d798f 100644 --- a/tests/suite/suite.ml +++ b/tests/suite/suite.ml @@ -37,7 +37,7 @@ let tests = ref [] let declare name ~description ?source_elpi ?source_teyjus ?(deps_teyjus=[]) ?source_dune ?source_json ?after - ?(typecheck=false) ?input ?(expectation=Success) + ?(typecheck=true) ?input ?(expectation=Success) ?(outside_llam=false) ?(trace=Off) ?(legacy_parser=false) From a0f7d9eaaed57a42219d79f56adaeffc1c75cb0e Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 23 Nov 2023 23:51:11 +0100 Subject: [PATCH 55/57] Apply suggestions from code review --- src/data.ml | 9 +-------- src/discrimination_tree.ml | 8 +++++--- 2 files changed, 6 insertions(+), 11 deletions(-) diff --git a/src/data.ml b/src/data.ml index dc59d3494..c72b8d6fe 100644 --- a/src/data.ml +++ b/src/data.ml @@ -132,13 +132,6 @@ mode = arg_mode list let to_mode = function true -> Input | false -> Output -(* Simpler pretty printer for clause *) -let pp_clause_simple (fmt:Format.formatter) (cl: clause) = Format.fprintf fmt "clause" (* - Format.fprintf fmt "[clause_args:"; - pplist pp_term ", " fmt cl.args; - Format.fprintf fmt " ;; clause_hyps:"; - pplist pp_term ", " fmt cl.hyps; - Format.fprintf fmt "]";*) module DT = Discrimination_tree @@ -199,7 +192,7 @@ type suspended_goal = { P. Indexing is done by hashing all the parameters with a non zero depth and comparing it with the hashing of the parameters of the query - - [IndexWithTrie N] -> N-th argument at arbitrary depth (TODO bound) + - [IndexWithTrie N D] -> N-th argument at D depth *) type indexing = | MapOn of int diff --git a/src/discrimination_tree.ml b/src/discrimination_tree.ml index f7f8d4984..a884750f8 100644 --- a/src/discrimination_tree.ml +++ b/src/discrimination_tree.ml @@ -4,11 +4,12 @@ let arity_bits = 4 let k_bits = 2 -(* value , arity, k *) -let kConstant = 0 (* (constant << arity_bits) lor arity *) -let kPrimitive = 1 (*Elpi_util.Util.CData.t hash *) +(* 4 constructors encoded as: arg_value , arity, kno *) +let kConstant = 0 +let kPrimitive = 1 let kVariable = 2 let kOther = 3 + let k_lshift = Sys.int_size - k_bits let ka_lshift = Sys.int_size - k_bits - arity_bits let k_mask = ((1 lsl k_bits) - 1) lsl k_lshift @@ -55,6 +56,7 @@ let show_cell n = module Trie = struct (* * Trie: maps over lists. + * Note: This code is a heavily modified version of the original code. * Copyright (C) 2000 Jean-Christophe FILLIATRE * * This software is free software; you can redistribute it and/or From 8713ff5d1f13026b86563c4a042eaea14c4fe5a7 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 23 Nov 2023 23:59:29 +0100 Subject: [PATCH 56/57] fix win ci --- .github/workflows/main.yml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 4f3d96502..7cef97bbb 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -86,10 +86,11 @@ jobs: & "$Env:CYGWIN_ROOT/setup-x86_64.exe" -q -P time & "$Env:CYGWIN_ROOT/setup-x86_64.exe" -q -P which & "$Env:CYGWIN_ROOT/setup-x86_64.exe" -q -P wdiff - opam exec -- which which - opam exec -- time which - opam exec -- which time - opam exec -- which wdiff + +# opam exec -- which which +# opam exec -- time which +# opam exec -- which time +# opam exec -- which wdiff # Build ###################################################################### # From ffae80ccb90a4a98db916996241140b23e8b2c49 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 24 Nov 2023 00:10:21 +0100 Subject: [PATCH 57/57] blind fix --- .github/workflows/main.yml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 7cef97bbb..98a7ad6f3 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -83,9 +83,7 @@ jobs: opam exec -- cygpath -m ${{ github.workspace }} | % {$_ -replace "^","workspace=" } | Out-File -FilePath $Env:GITHUB_ENV -Encoding utf8 -Append opam exec -- cygpath -m "$Env:CYGWIN_ROOT" | % {$_ -replace "^","cygwin_root=" } | Out-File -FilePath $Env:GITHUB_ENV -Encoding utf8 -Append opam exec -- sed -i ' ' tests/sources/*.elpi - & "$Env:CYGWIN_ROOT/setup-x86_64.exe" -q -P time - & "$Env:CYGWIN_ROOT/setup-x86_64.exe" -q -P which - & "$Env:CYGWIN_ROOT/setup-x86_64.exe" -q -P wdiff + & "$Env:CYGWIN_ROOT/setup-x86_64.exe" -v -q -P time,which,wdiff # opam exec -- which which # opam exec -- time which