From c9fa8c52b19b6069ca8b135a760576ce31b08855 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 10 Aug 2026 11:01:30 +0200 Subject: [PATCH] Replace compiler CPPO specializations with functors Replace the compiler's six data-structure CPPO templates and their Dune generation rules with ordinary OCaml functors and small, explicit instantiation modules. Keep Hash_set_poly as a plain polymorphic implementation because its key type is not fixed by a functor argument. Audit every resulting module against production consumers. Remove the unused Hash_set_int specialization and the effectively dead Hash_string specialization, whose only apparent compiler consumer was an always-empty cache for a commented-out function. Remove that cache and its uncalled Ext_ident.reset API; tests instantiate Hash.Make locally where a string-key table is useful. Remove CPPO from the analysis and tools package dependencies. Retain it in the rescript package, with an explanatory comment, because the runtime's explicit regeneration script still invokes the external CPPO executable for its checked-in ReScript specializations. This makes every compiler implementation visible to editors and build tooling, removes generated-source indirection, and uses the language's standard abstraction mechanism while preserving each retained specialization's comparison, equality, hashing, and printing semantics. A four-way OCaml 5.3 release-build experiment compared concrete CPPO and functor implementations, both with and without Flambda. No meaningful compiler-speed difference was observed between CPPO and functors on clean builds of the 150-module runtime corpus, parallel builds, or incremental rebuilds; generated JavaScript was identical. Isolated data-structure benchmarks did show differences without Flambda, but those differences disappeared with Flambda. Flambda itself was slower for representative compilation workloads while improving several sustained parsing and printing benchmarks. Its larger binary and startup cost appear to contribute to the typical-build slowdown, although startup-only measurements do not explain all of it. Investigating Flambda further remains worthwhile, particularly together with a persistent compiler server that can amortize per-file process startup. Add direct coverage for the ordered local-identifier map and retain the existing map, set, hash, hash-set, and vector tests. Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 1 + analysis.opam | 1 - compiler/ext/dune | 108 ---- compiler/ext/ext_ident.ml | 31 -- compiler/ext/ext_ident.mli | 2 - compiler/ext/ext_map.ml | 201 +++++++ compiler/ext/ext_map.mli | 32 ++ compiler/ext/ext_set.ml | 207 +++++++ compiler/ext/ext_set.mli | 33 ++ compiler/ext/hash.cppo.ml | 143 ----- compiler/ext/hash.ml | 140 +++++ compiler/ext/hash_ident.ml | 31 ++ compiler/ext/hash_int.ml | 30 + compiler/ext/hash_set.cppo.ml | 123 ----- compiler/ext/hash_set.ml | 82 +++ compiler/ext/hash_set_ident.ml | 31 ++ compiler/ext/hash_set_poly.ml | 58 ++ compiler/ext/hash_set_string.ml | 30 + compiler/ext/map.cppo.ml | 217 -------- compiler/ext/map_ident.ml | 30 + compiler/ext/map_int.ml | 30 + compiler/ext/map_string.ml | 30 + compiler/ext/ordered_hash_map.cppo.ml | 110 ---- compiler/ext/ordered_hash_map.ml | 109 ++++ .../{hash_string.mli => ordered_hash_map.mli} | 7 +- compiler/ext/ordered_hash_map_local_ident.ml | 30 + compiler/ext/set.cppo.ml | 249 --------- compiler/ext/set_ident.ml | 37 ++ compiler/ext/set_int.ml | 31 ++ compiler/ext/set_string.ml | 31 ++ compiler/ext/vec.cppo.ml | 512 ------------------ compiler/ext/vec.ml | 407 ++++++++++++++ compiler/ext/{hash_set_int.mli => vec_int.ml} | 10 +- dune-project | 5 +- tests/ounit_tests/ounit_hash_stubs_test.ml | 24 - tests/ounit_tests/ounit_hashtbl_tests.ml | 53 +- tests/ounit_tests/ounit_scc_tests.ml | 33 +- tools.opam | 1 - 38 files changed, 1683 insertions(+), 1557 deletions(-) create mode 100644 compiler/ext/ext_map.ml create mode 100644 compiler/ext/ext_map.mli create mode 100644 compiler/ext/ext_set.ml create mode 100644 compiler/ext/ext_set.mli delete mode 100644 compiler/ext/hash.cppo.ml create mode 100644 compiler/ext/hash.ml create mode 100644 compiler/ext/hash_ident.ml create mode 100644 compiler/ext/hash_int.ml delete mode 100644 compiler/ext/hash_set.cppo.ml create mode 100644 compiler/ext/hash_set.ml create mode 100644 compiler/ext/hash_set_ident.ml create mode 100644 compiler/ext/hash_set_poly.ml create mode 100644 compiler/ext/hash_set_string.ml delete mode 100644 compiler/ext/map.cppo.ml create mode 100644 compiler/ext/map_ident.ml create mode 100644 compiler/ext/map_int.ml create mode 100644 compiler/ext/map_string.ml delete mode 100644 compiler/ext/ordered_hash_map.cppo.ml create mode 100644 compiler/ext/ordered_hash_map.ml rename compiler/ext/{hash_string.mli => ordered_hash_map.mli} (93%) create mode 100644 compiler/ext/ordered_hash_map_local_ident.ml delete mode 100644 compiler/ext/set.cppo.ml create mode 100644 compiler/ext/set_ident.ml create mode 100644 compiler/ext/set_int.ml create mode 100644 compiler/ext/set_string.ml delete mode 100644 compiler/ext/vec.cppo.ml create mode 100644 compiler/ext/vec.ml rename compiler/ext/{hash_set_int.mli => vec_int.ml} (95%) diff --git a/CHANGELOG.md b/CHANGELOG.md index eee2c3a2e70..60f0ff692e0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -36,6 +36,7 @@ - Add the `-check-lam` compiler option, enable Lambda invariant checking in compiler tests, and remove build-profile-dependent checking. https://github.com/rescript-lang/rescript/pull/8534 - Replace `-bs-diagnose` with `-debug-ir` and make IR diagnostic artifacts deterministic, compilation-local, and easy to clean. https://github.com/rescript-lang/rescript/pull/8535 - Replace CPPO-based browser conditionals with Dune-selected native and playground compiler implementations. https://github.com/rescript-lang/rescript/pull/8541 +- Replace compiler data-structure CPPO specializations with OCaml functors. https://github.com/rescript-lang/rescript/pull/8542 # 13.0.0-alpha.5 diff --git a/analysis.opam b/analysis.opam index db0433c0aa3..5cef5b297f2 100644 --- a/analysis.opam +++ b/analysis.opam @@ -9,7 +9,6 @@ bug-reports: "https://github.com/rescript-lang/rescript-compiler/issues" depends: [ "dune" {>= "3.17"} "ocaml" {>= "5.0.0"} - "cppo" {= "1.8.0"} "odoc" {with-doc} "lsp" {>= "1.23.0"} "yojson" {= "3.0.0"} diff --git a/compiler/ext/dune b/compiler/ext/dune index e8379a964c5..a2daf826b76 100644 --- a/compiler/ext/dune +++ b/compiler/ext/dune @@ -31,111 +31,3 @@ (foreign_stubs (language c) (names ext_platform_primitives_stubs))) - -(rule - (targets hash_set_string.ml) - (deps hash_set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_STRING %{deps} -o %{targets}))) - -(rule - (targets hash_set_int.ml) - (deps hash_set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) - -(rule - (targets hash_set_ident.ml) - (deps hash_set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_IDENT %{deps} -o %{targets}))) - -(rule - (targets hash_set.ml) - (deps hash_set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_FUNCTOR %{deps} -o %{targets}))) - -(rule - (targets hash_set_poly.ml) - (deps hash_set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_POLY %{deps} -o %{targets}))) - -(rule - (targets vec_int.ml) - (deps vec.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) - -(rule - (targets vec.ml) - (deps vec.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_FUNCTOR %{deps} -o %{targets}))) - -(rule - (targets set_string.ml) - (deps set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_STRING %{deps} -o %{targets}))) - -(rule - (targets set_int.ml) - (deps set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) - -(rule - (targets set_ident.ml) - (deps set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_IDENT %{deps} -o %{targets}))) - -(rule - (targets map_string.ml) - (deps map.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_STRING %{deps} -o %{targets}))) - -(rule - (targets map_int.ml) - (deps map.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) - -(rule - (targets map_ident.ml) - (deps map.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_IDENT %{deps} -o %{targets}))) - -(rule - (targets ordered_hash_map_local_ident.ml) - (deps ordered_hash_map.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_LOCAL_IDENT %{deps} -o %{targets}))) - -(rule - (targets hash_string.ml) - (deps hash.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_STRING %{deps} -o %{targets}))) - -(rule - (targets hash_int.ml) - (deps hash.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) - -(rule - (targets hash_ident.ml) - (deps hash.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_IDENT %{deps} -o %{targets}))) - -(rule - (targets hash.ml) - (deps hash.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_FUNCTOR %{deps} -o %{targets}))) diff --git a/compiler/ext/ext_ident.ml b/compiler/ext/ext_ident.ml index 8a7910ca381..a7a2f3bec14 100644 --- a/compiler/ext/ext_ident.ml +++ b/compiler/ext/ext_ident.ml @@ -52,35 +52,6 @@ let create = Ident.create (* FIXME: no need for `$' operator *) let create_tmp ?(name = Literals.tmp) () = create name -let js_module_table : Ident.t Hash_string.t = Hash_string.create 31 - -(* This is for a js exeternal module, we can change it when printing - for example - {[ - var React$1 = require('react'); - React$1.render(..) - ]} - - Given a name, if duplicated, they should have the same id -*) -(* let create_js_module (name : string) : Ident.t = - let name = - String.concat "" @@ Ext_list.map - (Ext_string.split name '-') Ext_string.capitalize_ascii in - (* TODO: if we do such transformation, we should avoid collision for example: - react-dom - react--dom - check collision later - *) - match Hash_string.find_exn js_module_table name with - | exception Not_found -> - let ans = Ident.create name in - (* let ans = { v with flags = js_module_flag} in *) - Hash_string.add js_module_table name ans; - ans - | v -> (* v *) Ident.rename v -*) - let[@inline] convert ?(op = false) (c : char) : string = match c with | '*' -> "$star" @@ -169,8 +140,6 @@ let convert (name : string) = *) let make_unused () = create "_" -let reset () = Hash_string.clear js_module_table - (* Has to be total order, [x < y] and [x > y] should be consistent flags are not relevant here diff --git a/compiler/ext/ext_ident.mli b/compiler/ext/ext_ident.mli index ff21fca3c56..446ce8fb881 100644 --- a/compiler/ext/ext_ident.mli +++ b/compiler/ext/ext_ident.mli @@ -35,8 +35,6 @@ val create : string -> Ident.t val make_js_object : Ident.t -> unit -val reset : unit -> unit - val create_tmp : ?name:string -> unit -> Ident.t val make_unused : unit -> Ident.t diff --git a/compiler/ext/ext_map.ml b/compiler/ext/ext_map.ml new file mode 100644 index 00000000000..9bb91449a8b --- /dev/null +++ b/compiler/ext/ext_map.ml @@ -0,0 +1,201 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +module type OrderedType = sig + type t + + val compare : t -> t -> int + val equal : t -> t -> bool +end + +module Make (Key : OrderedType) = struct + type key = Key.t + + let compare_key = Key.compare + let eq_key = Key.equal + + type +'a t = (key, 'a) Map_gen.t + + let empty = Map_gen.empty + let is_empty = Map_gen.is_empty + let iter = Map_gen.iter + let fold = Map_gen.fold + let for_all = Map_gen.for_all + let exists = Map_gen.exists + let singleton = Map_gen.singleton + let cardinal = Map_gen.cardinal + let bindings = Map_gen.bindings + let to_sorted_array = Map_gen.to_sorted_array + let to_sorted_array_with_f = Map_gen.to_sorted_array_with_f + let keys = Map_gen.keys + + let map = Map_gen.map + let mapi = Map_gen.mapi + let bal = Map_gen.bal + let height = Map_gen.height + + let rec add (tree : _ Map_gen.t as 'a) x data : 'a = + match tree with + | Empty -> singleton x data + | Leaf {k; v} -> + let c = compare_key x k in + if c = 0 then singleton x data + else if c < 0 then Map_gen.unsafe_two_elements x data k v + else Map_gen.unsafe_two_elements k v x data + | Node {l; k; v; r; h} -> + let c = compare_key x k in + if c = 0 then + Map_gen.unsafe_node x data l r h (* at least need update data *) + else if c < 0 then bal (add l x data) k v r + else bal l k v (add r x data) + + let rec adjust (tree : _ Map_gen.t as 'a) x replace : 'a = + match tree with + | Empty -> singleton x (replace None) + | Leaf {k; v} -> + let c = compare_key x k in + if c = 0 then singleton x (replace (Some v)) + else if c < 0 then Map_gen.unsafe_two_elements x (replace None) k v + else Map_gen.unsafe_two_elements k v x (replace None) + | Node ({l; k; r} as tree) -> + let c = compare_key x k in + if c = 0 then Map_gen.unsafe_node x (replace (Some tree.v)) l r tree.h + else if c < 0 then bal (adjust l x replace) k tree.v r + else bal l k tree.v (adjust r x replace) + + let rec find_exn (tree : _ Map_gen.t) x = + match tree with + | Empty -> raise Not_found + | Leaf leaf -> if eq_key x leaf.k then leaf.v else raise Not_found + | Node tree -> + let c = compare_key x tree.k in + if c = 0 then tree.v else find_exn (if c < 0 then tree.l else tree.r) x + + let rec find_opt (tree : _ Map_gen.t) x = + match tree with + | Empty -> None + | Leaf leaf -> if eq_key x leaf.k then Some leaf.v else None + | Node tree -> + let c = compare_key x tree.k in + if c = 0 then Some tree.v + else find_opt (if c < 0 then tree.l else tree.r) x + + let rec find_default (tree : _ Map_gen.t) x default = + match tree with + | Empty -> default + | Leaf leaf -> if eq_key x leaf.k then leaf.v else default + | Node tree -> + let c = compare_key x tree.k in + if c = 0 then tree.v + else find_default (if c < 0 then tree.l else tree.r) x default + + let rec mem (tree : _ Map_gen.t) x = + match tree with + | Empty -> false + | Leaf leaf -> eq_key x leaf.k + | Node {l; k; r} -> + let c = compare_key x k in + c = 0 || mem (if c < 0 then l else r) x + + let rec remove (tree : _ Map_gen.t as 'a) x : 'a = + match tree with + | Empty -> empty + | Leaf leaf -> if eq_key x leaf.k then empty else tree + | Node {l; k; v; r} -> + let c = compare_key x k in + if c = 0 then Map_gen.merge l r + else if c < 0 then bal (remove l x) k v r + else bal l k v (remove r x) + + type 'a split = + | Yes of {l: (key, 'a) Map_gen.t; r: (key, 'a) Map_gen.t; v: 'a} + | No of {l: (key, 'a) Map_gen.t; r: (key, 'a) Map_gen.t} + + let rec split (tree : (key, 'a) Map_gen.t) x : 'a split = + match tree with + | Empty -> No {l = empty; r = empty} + | Leaf leaf -> + let c = compare_key x leaf.k in + if c = 0 then Yes {l = empty; v = leaf.v; r = empty} + else if c < 0 then No {l = empty; r = tree} + else No {l = tree; r = empty} + | Node {l; k; v; r} -> ( + let c = compare_key x k in + if c = 0 then Yes {l; v; r} + else if c < 0 then + match split l x with + | Yes result -> Yes {result with r = Map_gen.join result.r k v r} + | No result -> No {result with r = Map_gen.join result.r k v r} + else + match split r x with + | Yes result -> Yes {result with l = Map_gen.join l k v result.l} + | No result -> No {result with l = Map_gen.join l k v result.l}) + + let rec disjoint_merge_exn (s1 : _ Map_gen.t) (s2 : _ Map_gen.t) fail : + _ Map_gen.t = + match s1 with + | Empty -> s2 + | Leaf ({k} as l1) -> ( + match s2 with + | Empty -> s1 + | Leaf l2 -> + let c = compare_key k l2.k in + if c = 0 then raise_notrace (fail k l1.v l2.v) + else if c < 0 then Map_gen.unsafe_two_elements l1.k l1.v l2.k l2.v + else Map_gen.unsafe_two_elements l2.k l2.v k l1.v + | Node _ -> + adjust s2 k (fun data -> + match data with + | None -> l1.v + | Some s2v -> raise_notrace (fail k l1.v s2v))) + | Node ({k} as xs1) -> ( + if xs1.h >= height s2 then + match split s2 k with + | No {l; r} -> + Map_gen.join + (disjoint_merge_exn xs1.l l fail) + k xs1.v + (disjoint_merge_exn xs1.r r fail) + | Yes {v = s2v} -> raise_notrace (fail k xs1.v s2v) + else + match s2 with + | Empty | Leaf _ -> + (* Neither can be taller than [xs1], which is a node. *) + assert false + | Node ({k} as s2) -> ( + match split s1 k with + | No {l; r} -> + Map_gen.join + (disjoint_merge_exn l s2.l fail) + k s2.v + (disjoint_merge_exn r s2.r fail) + | Yes {v = s1v} -> raise_notrace (fail k s1v s2.v))) + + let add_list (xs : _ list) init = + Ext_list.fold_left xs init (fun acc (k, v) -> add acc k v) + + let of_list xs = add_list xs empty + + let of_array xs = Ext_array.fold_left xs empty (fun acc (k, v) -> add acc k v) +end diff --git a/compiler/ext/ext_map.mli b/compiler/ext/ext_map.mli new file mode 100644 index 00000000000..4d3bd38e41c --- /dev/null +++ b/compiler/ext/ext_map.mli @@ -0,0 +1,32 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +module type OrderedType = sig + type t + + val compare : t -> t -> int + val equal : t -> t -> bool +end + +module Make (Key : OrderedType) : Map_gen.S with type key = Key.t diff --git a/compiler/ext/ext_set.ml b/compiler/ext/ext_set.ml new file mode 100644 index 00000000000..f1b70d62e9a --- /dev/null +++ b/compiler/ext/ext_set.ml @@ -0,0 +1,207 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +module type OrderedType = sig + type t + + val compare : t -> t -> int + val equal : t -> t -> bool + val print : Format.formatter -> t -> unit +end + +module Make (Elt : OrderedType) = struct + type elt = Elt.t + + let compare_elt = Elt.compare + let eq_elt = Elt.equal + let print_elt = Elt.print + + type 'a t0 = 'a Set_gen.t + + type t = elt t0 + + let empty = Set_gen.empty + let is_empty = Set_gen.is_empty + let iter = Set_gen.iter + let fold = Set_gen.fold + let for_all = Set_gen.for_all + let exists = Set_gen.exists + let singleton = Set_gen.singleton + let cardinal = Set_gen.cardinal + let elements = Set_gen.elements + let choose = Set_gen.choose + + let of_sorted_array = Set_gen.of_sorted_array + + let rec mem (tree : t) (x : elt) = + match tree with + | Empty -> false + | Leaf v -> eq_elt x v + | Node {l; v; r} -> + let c = compare_elt x v in + c = 0 || mem (if c < 0 then l else r) x + + type split = Yes of {l: t; r: t} | No of {l: t; r: t} + + let[@inline] split_l (x : split) = + match x with + | Yes {l} | No {l} -> l + + let[@inline] split_r (x : split) = + match x with + | Yes {r} | No {r} -> r + + let[@inline] split_pres (x : split) = + match x with + | Yes _ -> true + | No _ -> false + + let rec split (tree : t) x : split = + match tree with + | Empty -> No {l = empty; r = empty} + | Leaf v -> + let c = compare_elt x v in + if c = 0 then Yes {l = empty; r = empty} + else if c < 0 then No {l = empty; r = tree} + else No {l = tree; r = empty} + | Node {l; v; r} -> ( + let c = compare_elt x v in + if c = 0 then Yes {l; r} + else if c < 0 then + match split l x with + | Yes result -> Yes {result with r = Set_gen.internal_join result.r v r} + | No result -> No {result with r = Set_gen.internal_join result.r v r} + else + match split r x with + | Yes result -> Yes {result with l = Set_gen.internal_join l v result.l} + | No result -> No {result with l = Set_gen.internal_join l v result.l}) + + let rec add (tree : t) x : t = + match tree with + | Empty -> singleton x + | Leaf v -> + let c = compare_elt x v in + if c = 0 then tree + else if c < 0 then Set_gen.unsafe_two_elements x v + else Set_gen.unsafe_two_elements v x + | Node {l; v; r} as t -> + let c = compare_elt x v in + if c = 0 then t + else if c < 0 then Set_gen.bal (add l x) v r + else Set_gen.bal l v (add r x) + + let rec union (s1 : t) (s2 : t) : t = + match (s1, s2) with + | Empty, t | t, Empty -> t + | Node _, Leaf v2 -> add s1 v2 + | Leaf v1, Node _ -> add s2 v1 + | Leaf x, Leaf v -> + let c = compare_elt x v in + if c = 0 then s1 + else if c < 0 then Set_gen.unsafe_two_elements x v + else Set_gen.unsafe_two_elements v x + | ( Node {l = l1; v = v1; r = r1; h = h1}, + Node {l = l2; v = v2; r = r2; h = h2} ) -> + if h1 >= h2 then + let split_result = split s2 v1 in + Set_gen.internal_join + (union l1 (split_l split_result)) + v1 + (union r1 (split_r split_result)) + else + let split_result = split s1 v2 in + Set_gen.internal_join + (union (split_l split_result) l2) + v2 + (union (split_r split_result) r2) + + let rec inter (s1 : t) (s2 : t) : t = + match (s1, s2) with + | Empty, _ | _, Empty -> empty + | Leaf v, _ -> if mem s2 v then s1 else empty + | Node ({v} as s1), _ -> + let result = split s2 v in + if split_pres result then + Set_gen.internal_join + (inter s1.l (split_l result)) + v + (inter s1.r (split_r result)) + else + Set_gen.internal_concat + (inter s1.l (split_l result)) + (inter s1.r (split_r result)) + + let rec diff (s1 : t) (s2 : t) : t = + match (s1, s2) with + | Empty, _ -> empty + | t1, Empty -> t1 + | Leaf v, _ -> if mem s2 v then empty else s1 + | Node ({v} as s1), _ -> + let result = split s2 v in + if split_pres result then + Set_gen.internal_concat + (diff s1.l (split_l result)) + (diff s1.r (split_r result)) + else + Set_gen.internal_join + (diff s1.l (split_l result)) + v + (diff s1.r (split_r result)) + + let rec remove (tree : t) (x : elt) : t = + match tree with + | Empty -> empty (* This case actually would be never reached *) + | Leaf v -> if eq_elt x v then empty else tree + | Node {l; v; r} -> + let c = compare_elt x v in + if c = 0 then Set_gen.internal_merge l r + else if c < 0 then Set_gen.bal (remove l x) v r + else Set_gen.bal l v (remove r x) + + (* let compare s1 s2 = Set_gen.compare ~cmp:compare_elt s1 s2 *) + + let of_list l = + match l with + | [] -> empty + | [x0] -> singleton x0 + | [x0; x1] -> add (singleton x0) x1 + | [x0; x1; x2] -> add (add (singleton x0) x1) x2 + | [x0; x1; x2; x3] -> add (add (add (singleton x0) x1) x2) x3 + | [x0; x1; x2; x3; x4] -> add (add (add (add (singleton x0) x1) x2) x3) x4 + | _ -> + let arrs = Array.of_list l in + Array.sort compare_elt arrs; + of_sorted_array arrs + + (* also check order *) + let invariant t = + Set_gen.check t; + Set_gen.is_ordered ~cmp:compare_elt t + + let print fmt s = + Format.fprintf fmt "@[{%a}@]@." + (fun fmt s -> + iter s (fun e -> Format.fprintf fmt "@[%a@],@ " print_elt e)) + s +end diff --git a/compiler/ext/ext_set.mli b/compiler/ext/ext_set.mli new file mode 100644 index 00000000000..eca44b0e70d --- /dev/null +++ b/compiler/ext/ext_set.mli @@ -0,0 +1,33 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +module type OrderedType = sig + type t + + val compare : t -> t -> int + val equal : t -> t -> bool + val print : Format.formatter -> t -> unit +end + +module Make (Elt : OrderedType) : Set_gen.S with type elt = Elt.t diff --git a/compiler/ext/hash.cppo.ml b/compiler/ext/hash.cppo.ml deleted file mode 100644 index 905d1c97ea2..00000000000 --- a/compiler/ext/hash.cppo.ml +++ /dev/null @@ -1,143 +0,0 @@ -#if defined TYPE_IDENT -type key = Ident.t -type 'a t = (key, 'a) Hash_gen.t -let key_index (h : _ t ) (key : key) = - (Ext_platform_primitives.hash_stamp_and_name key.stamp key.name ) land (Array.length h.data - 1) -let eq_key = Ext_ident.equal -#elif defined TYPE_STRING -type key = string -type 'a t = (key, 'a) Hash_gen.t -let key_index (h : _ t ) (key : key) = - (Ext_platform_primitives.hash_string key ) land (Array.length h.data - 1) -let eq_key = Ext_string.equal -#elif defined TYPE_INT -type key = int -type 'a t = (key, 'a) Hash_gen.t -let key_index (h : _ t ) (key : key) = - (Ext_platform_primitives.hash_int key ) land (Array.length h.data - 1) -let eq_key = Ext_int.equal - -#elif defined TYPE_FUNCTOR -module Make (Key : Hashtbl.HashedType) = struct - type key = Key.t - type 'a t = (key, 'a) Hash_gen.t - let key_index (h : _ t ) (key : key) = - (Key.hash key ) land (Array.length h.data - 1) - let eq_key = Key.equal - -#else - [%error "unknown type"] -#endif - - type ('a, 'b) bucket = ('a,'b) Hash_gen.bucket - let create = Hash_gen.create - let clear = Hash_gen.clear - let reset = Hash_gen.reset - let iter = Hash_gen.iter - let to_list = Hash_gen.to_list - let fold = Hash_gen.fold - let length = Hash_gen.length - (* let stats = Hash_gen.stats *) - - - - let add (h : _ t) key data = - let i = key_index h key in - let h_data = h.data in - Array.unsafe_set h_data i (Cons{key; data; next=Array.unsafe_get h_data i}); - h.size <- h.size + 1; - if h.size > Array.length h_data lsl 1 then Hash_gen.resize key_index h - - (* after upgrade to 4.04 we should provide an efficient [replace_or_init] *) - let add_or_update - (h : 'a t) - (key : key) - ~update:(modf : 'a -> 'a) - (default : 'a) : unit = - let rec find_bucket (bucketlist : _ bucket) : bool = - match bucketlist with - | Cons rhs -> - if eq_key rhs.key key then begin rhs.data <- modf rhs.data; false end - else find_bucket rhs.next - | Empty -> true in - let i = key_index h key in - let h_data = h.data in - if find_bucket (Array.unsafe_get h_data i) then - begin - Array.unsafe_set h_data i (Cons{key; data=default; next = Array.unsafe_get h_data i}); - h.size <- h.size + 1 ; - if h.size > Array.length h_data lsl 1 then Hash_gen.resize key_index h - end - - let remove (h : _ t ) key = - let i = key_index h key in - let h_data = h.data in - Hash_gen.remove_bucket h i key ~prec:Empty (Array.unsafe_get h_data i) eq_key - - (* for short bucket list, [find_rec is not called ] *) - let rec find_rec key (bucketlist : _ bucket) = match bucketlist with - | Empty -> - raise Not_found - | Cons rhs -> - if eq_key key rhs.key then rhs.data else find_rec key rhs.next - - let find_exn (h : _ t) key = - match Array.unsafe_get h.data (key_index h key) with - | Empty -> raise Not_found - | Cons rhs -> - if eq_key key rhs.key then rhs.data else - match rhs.next with - | Empty -> raise Not_found - | Cons rhs -> - if eq_key key rhs.key then rhs.data else - match rhs.next with - | Empty -> raise Not_found - | Cons rhs -> - if eq_key key rhs.key then rhs.data else find_rec key rhs.next - - let find_opt (h : _ t) key = - Hash_gen.small_bucket_opt eq_key key (Array.unsafe_get h.data (key_index h key)) - - let find_key_opt (h : _ t) key = - Hash_gen.small_bucket_key_opt eq_key key (Array.unsafe_get h.data (key_index h key)) - - let find_default (h : _ t) key default = - Hash_gen.small_bucket_default eq_key key default (Array.unsafe_get h.data (key_index h key)) - - let find_all (h : _ t) key = - let rec find_in_bucket (bucketlist : _ bucket) = match bucketlist with - | Empty -> - [] - | Cons rhs -> - if eq_key key rhs.key - then rhs.data :: find_in_bucket rhs.next - else find_in_bucket rhs.next in - find_in_bucket (Array.unsafe_get h.data (key_index h key)) - - - let replace h key data = - let i = key_index h key in - let h_data = h.data in - let l = Array.unsafe_get h_data i in - if Hash_gen.replace_bucket key data l eq_key then - begin - Array.unsafe_set h_data i (Cons{key; data; next=l}); - h.size <- h.size + 1; - if h.size > Array.length h_data lsl 1 then Hash_gen.resize key_index h; - end - - let mem (h : _ t) key = - Hash_gen.small_bucket_mem - (Array.unsafe_get h.data (key_index h key)) - eq_key key - - - let of_list2 ks vs = - let len = List.length ks in - let map = create len in - List.iter2 (fun k v -> add map k v) ks vs ; - map - -#if defined TYPE_FUNCTOR -end -#endif diff --git a/compiler/ext/hash.ml b/compiler/ext/hash.ml new file mode 100644 index 00000000000..76e13b292cd --- /dev/null +++ b/compiler/ext/hash.ml @@ -0,0 +1,140 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +module Make (Key : Hashtbl.HashedType) = struct + type key = Key.t + type 'a t = (key, 'a) Hash_gen.t + let key_index (h : _ t) (key : key) = + Key.hash key land (Array.length h.data - 1) + let eq_key = Key.equal + + type ('a, 'b) bucket = ('a, 'b) Hash_gen.bucket + let create = Hash_gen.create + let clear = Hash_gen.clear + let reset = Hash_gen.reset + let iter = Hash_gen.iter + let to_list = Hash_gen.to_list + let fold = Hash_gen.fold + let length = Hash_gen.length + (* let stats = Hash_gen.stats *) + + let add (h : _ t) key data = + let i = key_index h key in + let h_data = h.data in + Array.unsafe_set h_data i + (Cons {key; data; next = Array.unsafe_get h_data i}); + h.size <- h.size + 1; + if h.size > Array.length h_data lsl 1 then Hash_gen.resize key_index h + + (* after upgrade to 4.04 we should provide an efficient [replace_or_init] *) + let add_or_update (h : 'a t) (key : key) ~update:(modf : 'a -> 'a) + (default : 'a) : unit = + let rec find_bucket (bucketlist : _ bucket) : bool = + match bucketlist with + | Cons rhs -> + if eq_key rhs.key key then ( + rhs.data <- modf rhs.data; + false) + else find_bucket rhs.next + | Empty -> true + in + let i = key_index h key in + let h_data = h.data in + if find_bucket (Array.unsafe_get h_data i) then ( + Array.unsafe_set h_data i + (Cons {key; data = default; next = Array.unsafe_get h_data i}); + h.size <- h.size + 1; + if h.size > Array.length h_data lsl 1 then Hash_gen.resize key_index h) + + let remove (h : _ t) key = + let i = key_index h key in + let h_data = h.data in + Hash_gen.remove_bucket h i key ~prec:Empty + (Array.unsafe_get h_data i) + eq_key + + (* for short bucket list, [find_rec is not called ] *) + let rec find_rec key (bucketlist : _ bucket) = + match bucketlist with + | Empty -> raise Not_found + | Cons rhs -> if eq_key key rhs.key then rhs.data else find_rec key rhs.next + + let find_exn (h : _ t) key = + match Array.unsafe_get h.data (key_index h key) with + | Empty -> raise Not_found + | Cons rhs -> ( + if eq_key key rhs.key then rhs.data + else + match rhs.next with + | Empty -> raise Not_found + | Cons rhs -> ( + if eq_key key rhs.key then rhs.data + else + match rhs.next with + | Empty -> raise Not_found + | Cons rhs -> + if eq_key key rhs.key then rhs.data else find_rec key rhs.next)) + + let find_opt (h : _ t) key = + Hash_gen.small_bucket_opt eq_key key + (Array.unsafe_get h.data (key_index h key)) + + let find_key_opt (h : _ t) key = + Hash_gen.small_bucket_key_opt eq_key key + (Array.unsafe_get h.data (key_index h key)) + + let find_default (h : _ t) key default = + Hash_gen.small_bucket_default eq_key key default + (Array.unsafe_get h.data (key_index h key)) + + let find_all (h : _ t) key = + let rec find_in_bucket (bucketlist : _ bucket) = + match bucketlist with + | Empty -> [] + | Cons rhs -> + if eq_key key rhs.key then rhs.data :: find_in_bucket rhs.next + else find_in_bucket rhs.next + in + find_in_bucket (Array.unsafe_get h.data (key_index h key)) + + let replace h key data = + let i = key_index h key in + let h_data = h.data in + let l = Array.unsafe_get h_data i in + if Hash_gen.replace_bucket key data l eq_key then ( + Array.unsafe_set h_data i (Cons {key; data; next = l}); + h.size <- h.size + 1; + if h.size > Array.length h_data lsl 1 then Hash_gen.resize key_index h) + + let mem (h : _ t) key = + Hash_gen.small_bucket_mem + (Array.unsafe_get h.data (key_index h key)) + eq_key key + + let of_list2 ks vs = + let len = List.length ks in + let map = create len in + List.iter2 (fun k v -> add map k v) ks vs; + map +end diff --git a/compiler/ext/hash_ident.ml b/compiler/ext/hash_ident.ml new file mode 100644 index 00000000000..7001326b75e --- /dev/null +++ b/compiler/ext/hash_ident.ml @@ -0,0 +1,31 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +include Hash.Make (struct + type t = Ident.t + + let equal = Ext_ident.equal + let hash key = + Ext_platform_primitives.hash_stamp_and_name key.Ident.stamp key.Ident.name +end) diff --git a/compiler/ext/hash_int.ml b/compiler/ext/hash_int.ml new file mode 100644 index 00000000000..a2c6540d6f5 --- /dev/null +++ b/compiler/ext/hash_int.ml @@ -0,0 +1,30 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +include Hash.Make (struct + type t = int + + let equal = Ext_int.equal + let hash = Ext_platform_primitives.hash_int +end) diff --git a/compiler/ext/hash_set.cppo.ml b/compiler/ext/hash_set.cppo.ml deleted file mode 100644 index 93b51a340c4..00000000000 --- a/compiler/ext/hash_set.cppo.ml +++ /dev/null @@ -1,123 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -[@@@warning "-32"] (* FIXME *) -#ifdef TYPE_INT -type key = int -let key_index (h : _ Hash_set_gen.t ) (key : key) = - (Ext_platform_primitives.hash_int key) land (Array.length h.data - 1) -let eq_key = Ext_int.equal -type t = key Hash_set_gen.t -#elif defined TYPE_STRING -type key = string -let key_index (h : _ Hash_set_gen.t ) (key : key) = - (Ext_platform_primitives.hash_string key) land (Array.length h.data - 1) -let eq_key = Ext_string.equal -type t = key Hash_set_gen.t -#elif defined TYPE_IDENT -type key = Ident.t -let key_index (h : _ Hash_set_gen.t ) (key : key) = - (Ext_platform_primitives.hash_string_int key.name key.stamp) land (Array.length h.data - 1) -let eq_key = Ext_ident.equal -type t = key Hash_set_gen.t -#elif defined TYPE_FUNCTOR -module Make (H: Hashtbl.HashedType) : (Hash_set_gen.S with type key = H.t) = struct - type key = H.t - let eq_key = H.equal - let key_index (h : _ Hash_set_gen.t ) key = - (H.hash key) land (Array.length h.data - 1) - type t = key Hash_set_gen.t - -#elif defined TYPE_POLY - [@@@warning "-3"] - (* we used cppo the mixture does not work*) - external seeded_hash_param : - int -> int -> int -> 'a -> int = "caml_hash" "noalloc" - let key_index (h : _ Hash_set_gen.t ) (key : 'a) = - seeded_hash_param 10 100 0 key land (Array.length h.data - 1) - let eq_key = (=) - type 'a t = 'a Hash_set_gen.t -#else - [%error "unknown type"] -#endif - - - let create = Hash_set_gen.create - let clear = Hash_set_gen.clear - let reset = Hash_set_gen.reset - (* let copy = Hash_set_gen.copy *) - let iter = Hash_set_gen.iter - let fold = Hash_set_gen.fold - let length = Hash_set_gen.length - (* let stats = Hash_set_gen.stats *) - let to_list = Hash_set_gen.to_list - - - - let remove (h : _ Hash_set_gen.t ) key = - let i = key_index h key in - let h_data = h.data in - Hash_set_gen.remove_bucket h i key ~prec:Empty (Array.unsafe_get h_data i) eq_key - - - - let add (h : _ Hash_set_gen.t) key = - let i = key_index h key in - let h_data = h.data in - let old_bucket = (Array.unsafe_get h_data i) in - if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then - begin - Array.unsafe_set h_data i (Cons {key = key ; next = old_bucket}); - h.size <- h.size + 1 ; - if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h - end - - let of_array arr = - let len = Array.length arr in - let tbl = create len in - for i = 0 to len - 1 do - add tbl (Array.unsafe_get arr i); - done ; - tbl - - - let check_add (h : _ Hash_set_gen.t) key : bool = - let i = key_index h key in - let h_data = h.data in - let old_bucket = (Array.unsafe_get h_data i) in - if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then - begin - Array.unsafe_set h_data i (Cons { key = key ; next = old_bucket}); - h.size <- h.size + 1 ; - if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h; - true - end - else false - - - let mem (h : _ Hash_set_gen.t) key = - Hash_set_gen.small_bucket_mem eq_key key (Array.unsafe_get h.data (key_index h key)) - -#ifdef TYPE_FUNCTOR -end -#endif diff --git a/compiler/ext/hash_set.ml b/compiler/ext/hash_set.ml new file mode 100644 index 00000000000..7702476d5e0 --- /dev/null +++ b/compiler/ext/hash_set.ml @@ -0,0 +1,82 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +module Make (H : Hashtbl.HashedType) : Hash_set_gen.S with type key = H.t = +struct + type key = H.t + let eq_key = H.equal + let key_index (h : _ Hash_set_gen.t) key = + H.hash key land (Array.length h.data - 1) + type t = key Hash_set_gen.t + + let create = Hash_set_gen.create + let clear = Hash_set_gen.clear + let reset = Hash_set_gen.reset + + (* let copy = Hash_set_gen.copy *) + let iter = Hash_set_gen.iter + let fold = Hash_set_gen.fold + let length = Hash_set_gen.length + + (* let stats = Hash_set_gen.stats *) + let to_list = Hash_set_gen.to_list + + let remove (h : _ Hash_set_gen.t) key = + let i = key_index h key in + let h_data = h.data in + Hash_set_gen.remove_bucket h i key ~prec:Empty + (Array.unsafe_get h_data i) + eq_key + + let add (h : _ Hash_set_gen.t) key = + let i = key_index h key in + let h_data = h.data in + let old_bucket = Array.unsafe_get h_data i in + if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then ( + Array.unsafe_set h_data i (Cons {key; next = old_bucket}); + h.size <- h.size + 1; + if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h) + + let of_array arr = + let len = Array.length arr in + let tbl = create len in + for i = 0 to len - 1 do + add tbl (Array.unsafe_get arr i) + done; + tbl + + let check_add (h : _ Hash_set_gen.t) key : bool = + let i = key_index h key in + let h_data = h.data in + let old_bucket = Array.unsafe_get h_data i in + if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then ( + Array.unsafe_set h_data i (Cons {key; next = old_bucket}); + h.size <- h.size + 1; + if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h; + true) + else false + + let mem (h : _ Hash_set_gen.t) key = + Hash_set_gen.small_bucket_mem eq_key key + (Array.unsafe_get h.data (key_index h key)) +end diff --git a/compiler/ext/hash_set_ident.ml b/compiler/ext/hash_set_ident.ml new file mode 100644 index 00000000000..20b87a084c0 --- /dev/null +++ b/compiler/ext/hash_set_ident.ml @@ -0,0 +1,31 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +include Hash_set.Make (struct + type t = Ident.t + + let equal = Ext_ident.equal + let hash key = + Ext_platform_primitives.hash_string_int key.Ident.name key.Ident.stamp +end) diff --git a/compiler/ext/hash_set_poly.ml b/compiler/ext/hash_set_poly.ml new file mode 100644 index 00000000000..441cc880562 --- /dev/null +++ b/compiler/ext/hash_set_poly.ml @@ -0,0 +1,58 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +let key_index (h : _ Hash_set_gen.t) (key : 'a) = + Hashtbl.hash key land (Array.length h.data - 1) +let eq_key = ( = ) +type 'a t = 'a Hash_set_gen.t + +let create = Hash_set_gen.create +let clear = Hash_set_gen.clear +let reset = Hash_set_gen.reset + +(* let copy = Hash_set_gen.copy *) +let iter = Hash_set_gen.iter +let length = Hash_set_gen.length + +(* let stats = Hash_set_gen.stats *) +let to_list = Hash_set_gen.to_list + +let remove (h : _ Hash_set_gen.t) key = + let i = key_index h key in + let h_data = h.data in + Hash_set_gen.remove_bucket h i key ~prec:Empty + (Array.unsafe_get h_data i) + eq_key + +let add (h : _ Hash_set_gen.t) key = + let i = key_index h key in + let h_data = h.data in + let old_bucket = Array.unsafe_get h_data i in + if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then ( + Array.unsafe_set h_data i (Cons {key; next = old_bucket}); + h.size <- h.size + 1; + if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h) + +let mem (h : _ Hash_set_gen.t) key = + Hash_set_gen.small_bucket_mem eq_key key + (Array.unsafe_get h.data (key_index h key)) diff --git a/compiler/ext/hash_set_string.ml b/compiler/ext/hash_set_string.ml new file mode 100644 index 00000000000..71df8f0499d --- /dev/null +++ b/compiler/ext/hash_set_string.ml @@ -0,0 +1,30 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +include Hash_set.Make (struct + type t = string + + let equal = Ext_string.equal + let hash = Ext_platform_primitives.hash_string +end) diff --git a/compiler/ext/map.cppo.ml b/compiler/ext/map.cppo.ml deleted file mode 100644 index a7d4e1d69fe..00000000000 --- a/compiler/ext/map.cppo.ml +++ /dev/null @@ -1,217 +0,0 @@ - -(* we don't create [map_poly], since some operations require raise an exception which carries [key] *) - -#ifdef TYPE_STRING -type key = string -let compare_key = Ext_string.compare -let [@inline] eq_key (x : key) y = x = y -#elif defined TYPE_INT -type key = int -let compare_key = Ext_int.compare -let [@inline] eq_key (x : key) y = x = y -#elif defined TYPE_IDENT -type key = Ident.t -let compare_key = Ext_ident.compare -let [@inline] eq_key (x : key) y = Ident.same x y -#else - [%error "unknown type"] -#endif - (* let [@inline] (=) (a : int) b = a = b *) -type + 'a t = (key,'a) Map_gen.t - -let empty = Map_gen.empty -let is_empty = Map_gen.is_empty -let iter = Map_gen.iter -let fold = Map_gen.fold -let for_all = Map_gen.for_all -let exists = Map_gen.exists -let singleton = Map_gen.singleton -let cardinal = Map_gen.cardinal -let bindings = Map_gen.bindings -let to_sorted_array = Map_gen.to_sorted_array -let to_sorted_array_with_f = Map_gen.to_sorted_array_with_f -let keys = Map_gen.keys - - - -let map = Map_gen.map -let mapi = Map_gen.mapi -let bal = Map_gen.bal -let height = Map_gen.height - - -let rec add (tree : _ Map_gen.t as 'a) x data : 'a = match tree with - | Empty -> - singleton x data - | Leaf {k;v} -> - let c = compare_key x k in - if c = 0 then singleton x data else - if c < 0 then - Map_gen.unsafe_two_elements x data k v - else - Map_gen.unsafe_two_elements k v x data - | Node {l; k ; v ; r; h} -> - let c = compare_key x k in - if c = 0 then - Map_gen.unsafe_node x data l r h (* at least need update data *) - else if c < 0 then - bal (add l x data ) k v r - else - bal l k v (add r x data ) - - -let rec adjust (tree : _ Map_gen.t as 'a) x replace : 'a = - match tree with - | Empty -> - singleton x (replace None) - | Leaf {k ; v} -> - let c = compare_key x k in - if c = 0 then singleton x (replace (Some v)) else - if c < 0 then - Map_gen.unsafe_two_elements x (replace None) k v - else - Map_gen.unsafe_two_elements k v x (replace None) - | Node ({l; k ; r} as tree) -> - let c = compare_key x k in - if c = 0 then - Map_gen.unsafe_node x (replace (Some tree.v)) l r tree.h - else if c < 0 then - bal (adjust l x replace ) k tree.v r - else - bal l k tree.v (adjust r x replace ) - - -let rec find_exn (tree : _ Map_gen.t ) x = match tree with - | Empty -> - raise Not_found - | Leaf leaf -> - if eq_key x leaf.k then leaf.v else raise Not_found - | Node tree -> - let c = compare_key x tree.k in - if c = 0 then tree.v - else find_exn (if c < 0 then tree.l else tree.r) x - -let rec find_opt (tree : _ Map_gen.t ) x = match tree with - | Empty -> None - | Leaf leaf -> - if eq_key x leaf.k then Some leaf.v else None - | Node tree -> - let c = compare_key x tree.k in - if c = 0 then Some tree.v - else find_opt (if c < 0 then tree.l else tree.r) x - -let rec find_default (tree : _ Map_gen.t ) x default = match tree with - | Empty -> default - | Leaf leaf -> - if eq_key x leaf.k then leaf.v else default - | Node tree -> - let c = compare_key x tree.k in - if c = 0 then tree.v - else find_default (if c < 0 then tree.l else tree.r) x default - -let rec mem (tree : _ Map_gen.t ) x= match tree with - | Empty -> - false - | Leaf leaf -> eq_key x leaf.k - | Node{l; k ; r} -> - let c = compare_key x k in - c = 0 || mem (if c < 0 then l else r) x - -let rec remove (tree : _ Map_gen.t as 'a) x : 'a = match tree with - | Empty -> empty - | Leaf leaf -> - if eq_key x leaf.k then empty - else tree - | Node{l; k ; v; r} -> - let c = compare_key x k in - if c = 0 then - Map_gen.merge l r - else if c < 0 then - bal (remove l x) k v r - else - bal l k v (remove r x ) - -type 'a split = - | Yes of {l : (key,'a) Map_gen.t; r : (key,'a)Map_gen.t ; v : 'a} - | No of {l : (key,'a) Map_gen.t; r : (key,'a)Map_gen.t } - - -let rec split (tree : (key,'a) Map_gen.t) x : 'a split = - match tree with - | Empty -> - No {l = empty; r = empty} - | Leaf leaf -> - let c = compare_key x leaf.k in - if c = 0 then Yes {l = empty; v= leaf.v; r = empty} - else if c < 0 then No { l = empty; r = tree } - else No { l = tree; r = empty} - | Node {l; k ; v ; r} -> - let c = compare_key x k in - if c = 0 then Yes {l; v; r} - else if c < 0 then - match split l x with - | Yes result -> Yes {result with r = Map_gen.join result.r k v r } - | No result -> No {result with r = Map_gen.join result.r k v r } - else - match split r x with - | Yes result -> - Yes {result with l = Map_gen.join l k v result.l} - | No result -> - No {result with l = Map_gen.join l k v result.l} - - -let rec disjoint_merge_exn - (s1 : _ Map_gen.t) - (s2 : _ Map_gen.t) - fail : _ Map_gen.t = - match s1 with - | Empty -> s2 - | Leaf ({k } as l1) -> - begin match s2 with - | Empty -> s1 - | Leaf l2 -> - let c = compare_key k l2.k in - if c = 0 then raise_notrace (fail k l1.v l2.v) - else if c < 0 then Map_gen.unsafe_two_elements l1.k l1.v l2.k l2.v - else Map_gen.unsafe_two_elements l2.k l2.v k l1.v - | Node _ -> - adjust s2 k (fun data -> - match data with - | None -> l1.v - | Some s2v -> raise_notrace (fail k l1.v s2v) - ) - end - | Node ({k} as xs1) -> - if xs1.h >= height s2 then - begin match split s2 k with - | No {l; r} -> - Map_gen.join - (disjoint_merge_exn xs1.l l fail) - k - xs1.v - (disjoint_merge_exn xs1.r r fail) - | Yes { v = s2v} -> - raise_notrace (fail k xs1.v s2v) - end - else let [@warning "-8"] (Node ({k} as s2) : _ Map_gen.t) = s2 in - begin match split s1 k with - | No {l; r} -> - Map_gen.join - (disjoint_merge_exn l s2.l fail) k s2.v - (disjoint_merge_exn r s2.r fail) - | Yes { v = s1v} -> - raise_notrace (fail k s1v s2.v) - end - - - - - - -let add_list (xs : _ list ) init = - Ext_list.fold_left xs init (fun acc (k,v) -> add acc k v ) - -let of_list xs = add_list xs empty - -let of_array xs = - Ext_array.fold_left xs empty (fun acc (k,v) -> add acc k v ) diff --git a/compiler/ext/map_ident.ml b/compiler/ext/map_ident.ml new file mode 100644 index 00000000000..032c9c7783b --- /dev/null +++ b/compiler/ext/map_ident.ml @@ -0,0 +1,30 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +include Ext_map.Make (struct + type t = Ident.t + + let compare = Ext_ident.compare + let equal = Ident.same +end) diff --git a/compiler/ext/map_int.ml b/compiler/ext/map_int.ml new file mode 100644 index 00000000000..176a3e8e999 --- /dev/null +++ b/compiler/ext/map_int.ml @@ -0,0 +1,30 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +include Ext_map.Make (struct + type t = int + + let compare = Ext_int.compare + let equal = Ext_int.equal +end) diff --git a/compiler/ext/map_string.ml b/compiler/ext/map_string.ml new file mode 100644 index 00000000000..511e196f561 --- /dev/null +++ b/compiler/ext/map_string.ml @@ -0,0 +1,30 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +include Ext_map.Make (struct + type t = string + + let compare = Ext_string.compare + let equal = Ext_string.equal +end) diff --git a/compiler/ext/ordered_hash_map.cppo.ml b/compiler/ext/ordered_hash_map.cppo.ml deleted file mode 100644 index 24ec39b2797..00000000000 --- a/compiler/ext/ordered_hash_map.cppo.ml +++ /dev/null @@ -1,110 +0,0 @@ -#if defined TYPE_FUNCTOR -module Make(H: Hashtbl.HashedType): (S with type key = H.t) = -struct - type key = H.t - type 'value t = (key,'value) Ordered_hash_map_gen.t - let key_index (h : _ t) key = - (H.hash key) land (Array.length h.data - 1) - let equal_key = H.equal -#elif defined TYPE_LOCAL_IDENT - type key = Ident.t - type 'value t = (key,'value) Ordered_hash_map_gen.t - let key_index (h : _ t) (key : key) = - (Ext_platform_primitives.hash_int key.stamp) land (Array.length h.data - 1) - let equal_key = Ext_ident.equal - -#else - [%error "unknown type"] -#endif - - open Ordered_hash_map_gen - - let create = create - let clear = clear - let reset = reset - - let iter = iter - let fold = fold - let length = length - - let elements = elements - let choose = choose - let to_sorted_array = to_sorted_array - - - - let rec small_bucket_mem key lst = - match lst with - | Empty -> false - | Cons rhs -> - equal_key key rhs.key || - match rhs.next with - | Empty -> false - | Cons rhs -> - equal_key key rhs.key || - match rhs.next with - | Empty -> false - | Cons rhs -> - equal_key key rhs.key || - small_bucket_mem key rhs.next - - let rec small_bucket_rank key lst = - match lst with - | Empty -> -1 - | Cons rhs -> - if equal_key key rhs.key then rhs.ord - else match rhs.next with - | Empty -> -1 - | Cons rhs -> - if equal_key key rhs.key then rhs.ord else - match rhs.next with - | Empty -> -1 - | Cons rhs -> - if equal_key key rhs.key then rhs.ord else - small_bucket_rank key rhs.next - - let rec small_bucket_find_value key (lst : (_,_) bucket) = - match lst with - | Empty -> raise Not_found - | Cons rhs -> - if equal_key key rhs.key then rhs.data - else match rhs.next with - | Empty -> raise Not_found - | Cons rhs -> - if equal_key key rhs.key then rhs.data else - match rhs.next with - | Empty -> raise Not_found - | Cons rhs -> - if equal_key key rhs.key then rhs.data else - small_bucket_find_value key rhs.next - - let add h key value = - let i = key_index h key in - if not (small_bucket_mem key h.data.(i)) then - begin - h.data.(i) <- Cons {key; ord = h.size; data = value; next = h.data.(i)}; - h.size <- h.size + 1 ; - if h.size > Array.length h.data lsl 1 then resize key_index h - end - - let mem h key = - small_bucket_mem key (Array.unsafe_get h.data (key_index h key)) - let rank h key = - small_bucket_rank key(Array.unsafe_get h.data (key_index h key)) - - let find_value h key = - small_bucket_find_value key (Array.unsafe_get h.data (key_index h key)) - - -#if defined TYPE_FUNCTOR -end -#endif - - - - - - - - - diff --git a/compiler/ext/ordered_hash_map.ml b/compiler/ext/ordered_hash_map.ml new file mode 100644 index 00000000000..9b7440447b5 --- /dev/null +++ b/compiler/ext/ordered_hash_map.ml @@ -0,0 +1,109 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +module Make (H : Hashtbl.HashedType) : + Ordered_hash_map_gen.S with type key = H.t = struct + type key = H.t + type 'value t = (key, 'value) Ordered_hash_map_gen.t + let key_index (h : _ t) key = H.hash key land (Array.length h.data - 1) + let equal_key = H.equal + + open Ordered_hash_map_gen + + let create = create + let clear = clear + let reset = reset + + let iter = iter + let fold = fold + let length = length + + let elements = elements + let choose = choose + let to_sorted_array = to_sorted_array + + let rec small_bucket_mem key lst = + match lst with + | Empty -> false + | Cons rhs -> ( + equal_key key rhs.key + || + match rhs.next with + | Empty -> false + | Cons rhs -> ( + equal_key key rhs.key + || + match rhs.next with + | Empty -> false + | Cons rhs -> equal_key key rhs.key || small_bucket_mem key rhs.next)) + + let rec small_bucket_rank key lst = + match lst with + | Empty -> -1 + | Cons rhs -> ( + if equal_key key rhs.key then rhs.ord + else + match rhs.next with + | Empty -> -1 + | Cons rhs -> ( + if equal_key key rhs.key then rhs.ord + else + match rhs.next with + | Empty -> -1 + | Cons rhs -> + if equal_key key rhs.key then rhs.ord + else small_bucket_rank key rhs.next)) + + let rec small_bucket_find_value key (lst : (_, _) bucket) = + match lst with + | Empty -> raise Not_found + | Cons rhs -> ( + if equal_key key rhs.key then rhs.data + else + match rhs.next with + | Empty -> raise Not_found + | Cons rhs -> ( + if equal_key key rhs.key then rhs.data + else + match rhs.next with + | Empty -> raise Not_found + | Cons rhs -> + if equal_key key rhs.key then rhs.data + else small_bucket_find_value key rhs.next)) + + let add h key value = + let i = key_index h key in + if not (small_bucket_mem key h.data.(i)) then ( + h.data.(i) <- Cons {key; ord = h.size; data = value; next = h.data.(i)}; + h.size <- h.size + 1; + if h.size > Array.length h.data lsl 1 then resize key_index h) + + let mem h key = + small_bucket_mem key (Array.unsafe_get h.data (key_index h key)) + let rank h key = + small_bucket_rank key (Array.unsafe_get h.data (key_index h key)) + + let find_value h key = + small_bucket_find_value key (Array.unsafe_get h.data (key_index h key)) +end diff --git a/compiler/ext/hash_string.mli b/compiler/ext/ordered_hash_map.mli similarity index 93% rename from compiler/ext/hash_string.mli rename to compiler/ext/ordered_hash_map.mli index ef6b14450a1..62f160ed6a5 100644 --- a/compiler/ext/hash_string.mli +++ b/compiler/ext/ordered_hash_map.mli @@ -1,5 +1,5 @@ (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -17,9 +17,10 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -include Hash_gen.S with type key = string +module Make (Key : Hashtbl.HashedType) : + Ordered_hash_map_gen.S with type key = Key.t diff --git a/compiler/ext/ordered_hash_map_local_ident.ml b/compiler/ext/ordered_hash_map_local_ident.ml new file mode 100644 index 00000000000..a3c24eb9b24 --- /dev/null +++ b/compiler/ext/ordered_hash_map_local_ident.ml @@ -0,0 +1,30 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +include Ordered_hash_map.Make (struct + type t = Ident.t + + let equal = Ext_ident.equal + let hash key = Ext_platform_primitives.hash_int key.Ident.stamp +end) diff --git a/compiler/ext/set.cppo.ml b/compiler/ext/set.cppo.ml deleted file mode 100644 index e3e3b068fb7..00000000000 --- a/compiler/ext/set.cppo.ml +++ /dev/null @@ -1,249 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - -#if defined TYPE_STRING -type elt = string -let compare_elt = Ext_string.compare -let [@inline] eq_elt (x : elt) y = x = y -let print_elt = Format.pp_print_string -#elif defined TYPE_IDENT -type elt = Ident.t -let compare_elt (x : elt) (y : elt) = - let a = Stdlib.compare (x.stamp : int) y.stamp in - if a <> 0 then a - else - let b = Stdlib.compare (x.name : string) y.name in - if b <> 0 then b - else Stdlib.compare (x.flags : int) y.flags -let [@inline] eq_elt (x : elt) y = Ident.same x y -let print_elt = Ident.print -#elif defined TYPE_INT -type elt = int -let compare_elt = Ext_int.compare -let print_elt = Format.pp_print_int -let [@inline] eq_elt (x : elt) y = x = y -#else -[%error "unknown type" ] -#endif - - -(* let (=) (a:int) b = a = b *) - -type ('a ) t0 = 'a Set_gen.t - -type t = elt t0 - -let empty = Set_gen.empty -let is_empty = Set_gen.is_empty -let iter = Set_gen.iter -let fold = Set_gen.fold -let for_all = Set_gen.for_all -let exists = Set_gen.exists -let singleton = Set_gen.singleton -let cardinal = Set_gen.cardinal -let elements = Set_gen.elements -let choose = Set_gen.choose - -let of_sorted_array = Set_gen.of_sorted_array - -let rec mem (tree : t) (x : elt) = match tree with - | Empty -> false - | Leaf v -> eq_elt x v - | Node{l; v; r} -> - let c = compare_elt x v in - c = 0 || mem (if c < 0 then l else r) x - -type split = - | Yes of {l : t ; r : t } - | No of { l : t; r : t} - -let [@inline] split_l (x : split) = - match x with - | Yes {l} | No {l} -> l - -let [@inline] split_r (x : split) = - match x with - | Yes {r} | No {r} -> r - -let [@inline] split_pres (x : split) = match x with | Yes _ -> true | No _ -> false - -let rec split (tree : t) x : split = match tree with - | Empty -> - No {l = empty; r = empty} - | Leaf v -> - let c = compare_elt x v in - if c = 0 then Yes {l = empty; r = empty} - else if c < 0 then - No {l = empty; r = tree} - else - No {l = tree; r = empty} - | Node {l; v; r} -> - let c = compare_elt x v in - if c = 0 then Yes {l; r} - else if c < 0 then - match split l x with - | Yes result -> - Yes { result with r = Set_gen.internal_join result.r v r } - | No result -> - No { result with r= Set_gen.internal_join result.r v r } - else - match split r x with - | Yes result -> - Yes {result with l = Set_gen.internal_join l v result.l} - | No result -> - No {result with l = Set_gen.internal_join l v result.l} - -let rec add (tree : t) x : t = match tree with - | Empty -> singleton x - | Leaf v -> - let c = compare_elt x v in - if c = 0 then tree else - if c < 0 then - Set_gen.unsafe_two_elements x v - else - Set_gen.unsafe_two_elements v x - | Node {l; v; r} as t -> - let c = compare_elt x v in - if c = 0 then t else - if c < 0 then Set_gen.bal (add l x ) v r else Set_gen.bal l v (add r x ) - -let rec union (s1 : t) (s2 : t) : t = - match (s1, s2) with - | (Empty, t) - | (t, Empty) -> t - | Node _, Leaf v2 -> - add s1 v2 - | Leaf v1, Node _ -> - add s2 v1 - | Leaf x, Leaf v -> - let c = compare_elt x v in - if c = 0 then s1 else - if c < 0 then - Set_gen.unsafe_two_elements x v - else - Set_gen.unsafe_two_elements v x - | Node{l=l1; v=v1; r=r1; h=h1}, Node{l=l2; v=v2; r=r2; h=h2} -> - if h1 >= h2 then - let split_result = split s2 v1 in - Set_gen.internal_join - (union l1 (split_l split_result)) v1 - (union r1 (split_r split_result)) - else - let split_result = split s1 v2 in - Set_gen.internal_join - (union (split_l split_result) l2) v2 - (union (split_r split_result) r2) - - -let rec inter (s1 : t) (s2 : t) : t = - match (s1, s2) with - | (Empty, _) - | (_, Empty) -> empty - | Leaf v, _ -> - if mem s2 v then s1 else empty - | Node ({ v } as s1), _ -> - let result = split s2 v in - if split_pres result then - Set_gen.internal_join - (inter s1.l (split_l result)) - v - (inter s1.r (split_r result)) - else - Set_gen.internal_concat - (inter s1.l (split_l result)) - (inter s1.r (split_r result)) - - -let rec diff (s1 : t) (s2 : t) : t = - match (s1, s2) with - | (Empty, _) -> empty - | (t1, Empty) -> t1 - | Leaf v, _-> - if mem s2 v then empty else s1 - | (Node({ v} as s1), _) -> - let result = split s2 v in - if split_pres result then - Set_gen.internal_concat - (diff s1.l (split_l result)) - (diff s1.r (split_r result)) - else - Set_gen.internal_join - (diff s1.l (split_l result)) - v - (diff s1.r (split_r result)) - - - - - - - -let rec remove (tree : t) (x : elt) : t = match tree with - | Empty -> empty (* This case actually would be never reached *) - | Leaf v -> - if eq_elt x v then empty else tree - | Node{l; v; r} -> - let c = compare_elt x v in - if c = 0 then Set_gen.internal_merge l r else - if c < 0 then Set_gen.bal (remove l x) v r else Set_gen.bal l v (remove r x ) - -(* let compare s1 s2 = Set_gen.compare ~cmp:compare_elt s1 s2 *) - - - -let of_list l = - match l with - | [] -> empty - | [x0] -> singleton x0 - | [x0; x1] -> add (singleton x0) x1 - | [x0; x1; x2] -> add (add (singleton x0) x1) x2 - | [x0; x1; x2; x3] -> add (add (add (singleton x0) x1 ) x2 ) x3 - | [x0; x1; x2; x3; x4] -> add (add (add (add (singleton x0) x1) x2 ) x3 ) x4 - | _ -> - let arrs = Array.of_list l in - Array.sort compare_elt arrs ; - of_sorted_array arrs - - - -(* also check order *) -let invariant t = - Set_gen.check t ; - Set_gen.is_ordered ~cmp:compare_elt t - -let print fmt s = - Format.fprintf - fmt "@[{%a}@]@." - (fun fmt s -> - iter s - (fun e -> Format.fprintf fmt "@[%a@],@ " - print_elt e) - ) - s - - - - - diff --git a/compiler/ext/set_ident.ml b/compiler/ext/set_ident.ml new file mode 100644 index 00000000000..bf75cd3be41 --- /dev/null +++ b/compiler/ext/set_ident.ml @@ -0,0 +1,37 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +include Ext_set.Make (struct + type t = Ident.t + + let compare (x : t) (y : t) = + let stamp = Stdlib.compare x.stamp y.stamp in + if stamp <> 0 then stamp + else + let name = Stdlib.compare x.name y.name in + if name <> 0 then name else Stdlib.compare x.flags y.flags + + let equal = Ident.same + let print = Ident.print +end) diff --git a/compiler/ext/set_int.ml b/compiler/ext/set_int.ml new file mode 100644 index 00000000000..bd10d7c6b8a --- /dev/null +++ b/compiler/ext/set_int.ml @@ -0,0 +1,31 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +include Ext_set.Make (struct + type t = int + + let compare = Ext_int.compare + let equal = Ext_int.equal + let print = Format.pp_print_int +end) diff --git a/compiler/ext/set_string.ml b/compiler/ext/set_string.ml new file mode 100644 index 00000000000..be1d2d1fb32 --- /dev/null +++ b/compiler/ext/set_string.ml @@ -0,0 +1,31 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +include Ext_set.Make (struct + type t = string + + let compare = Ext_string.compare + let equal = Ext_string.equal + let print = Format.pp_print_string +end) diff --git a/compiler/ext/vec.cppo.ml b/compiler/ext/vec.cppo.ml deleted file mode 100644 index 14027008aa0..00000000000 --- a/compiler/ext/vec.cppo.ml +++ /dev/null @@ -1,512 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - -let [@inline] min (x :int) y = if x < y then x else y - -#if defined TYPE_FUNCTOR -external unsafe_blit : - 'a array -> int -> 'a array -> int -> int -> unit = "caml_array_blit" -module Make ( Resize : Vec_gen.ResizeType) = struct - type elt = Resize.t - - let null = Resize.null - -#elif defined TYPE_INT - -type elt = int -let null = 0 (* can be optimized *) -let unsafe_blit = Ext_platform_primitives.int_unsafe_blit -#else -[%error "unknown type"] -#endif - -external unsafe_sub : 'a array -> int -> int -> 'a array = "caml_array_sub" - -type t = { - mutable arr : elt array ; - mutable len : int ; -} - -let length d = d.len - -let compact d = - let d_arr = d.arr in - if d.len <> Array.length d_arr then - begin - let newarr = unsafe_sub d_arr 0 d.len in - d.arr <- newarr - end -let singleton v = - { - len = 1 ; - arr = [|v|] - } - -let empty () = - { - len = 0; - arr = [||]; - } - -let is_empty d = - d.len = 0 - -let reset d = - d.len <- 0; - d.arr <- [||] - - -(* For [to_*] operations, we should be careful to call {!Array.*} function - in case we operate on the whole array -*) -let to_list d = - let rec loop (d_arr : elt array) idx accum = - if idx < 0 then accum else loop d_arr (idx - 1) (Array.unsafe_get d_arr idx :: accum) - in - loop d.arr (d.len - 1) [] - - -let of_list lst = - let arr = Array.of_list lst in - { arr ; len = Array.length arr} - - -let to_array d = - unsafe_sub d.arr 0 d.len - -let of_array src = - { - len = Array.length src; - arr = Array.copy src; - (* okay to call {!Array.copy}*) - } -let of_sub_array arr off len = - { - len = len ; - arr = Array.sub arr off len - } -let unsafe_internal_array v = v.arr -(* we can not call {!Array.copy} *) -let copy src = - let len = src.len in - { - len ; - arr = unsafe_sub src.arr 0 len ; - } - -(* FIXME *) -let reverse_in_place src = - Ext_array.reverse_range src.arr 0 src.len - - - - -(* {!Array.sub} is not enough for error checking, it - may contain some garbage - *) -let sub (src : t) start len = - let src_len = src.len in - if len < 0 || start > src_len - len then invalid_arg "Vec.sub" - else - { len ; - arr = unsafe_sub src.arr start len } - -let iter d f = - let arr = d.arr in - for i = 0 to d.len - 1 do - f (Array.unsafe_get arr i) - done - -let iteri d f = - let arr = d.arr in - for i = 0 to d.len - 1 do - f i (Array.unsafe_get arr i) - done - -let iter_range d ~from ~to_ f = - if from < 0 || to_ >= d.len then invalid_arg "Vec.iter_range" - else - let d_arr = d.arr in - for i = from to to_ do - f (Array.unsafe_get d_arr i) - done - -let iteri_range d ~from ~to_ f = - if from < 0 || to_ >= d.len then invalid_arg "Vec.iteri_range" - else - let d_arr = d.arr in - for i = from to to_ do - f i (Array.unsafe_get d_arr i) - done - -let map_into_array f src = - let src_len = src.len in - let src_arr = src.arr in - if src_len = 0 then [||] - else - let first_one = f (Array.unsafe_get src_arr 0) in - let arr = Array.make src_len first_one in - for i = 1 to src_len - 1 do - Array.unsafe_set arr i (f (Array.unsafe_get src_arr i)) - done; - arr -let map_into_list f src = - let src_len = src.len in - let src_arr = src.arr in - if src_len = 0 then [] - else - let acc = ref [] in - for i = src_len - 1 downto 0 do - acc := f (Array.unsafe_get src_arr i) :: !acc - done; - !acc - -let mapi f src = - let len = src.len in - if len = 0 then { len ; arr = [| |] } - else - let src_arr = src.arr in - let arr = Array.make len (Array.unsafe_get src_arr 0) in - for i = 1 to len - 1 do - Array.unsafe_set arr i (f i (Array.unsafe_get src_arr i)) - done; - { - len ; - arr ; - } - -let fold_left f x a = - let rec loop a_len (a_arr : elt array) idx x = - if idx >= a_len then x else - loop a_len a_arr (idx + 1) (f x (Array.unsafe_get a_arr idx)) - in - loop a.len a.arr 0 x - -let fold_right f a x = - let rec loop (a_arr : elt array) idx x = - if idx < 0 then x - else loop a_arr (idx - 1) (f (Array.unsafe_get a_arr idx) x) - in - loop a.arr (a.len - 1) x - -(** - [filter] and [inplace_filter] -*) -let filter f d = - let new_d = copy d in - let new_d_arr = new_d.arr in - let d_arr = d.arr in - let p = ref 0 in - for i = 0 to d.len - 1 do - let x = Array.unsafe_get d_arr i in - (* TODO: can be optimized for segments blit *) - if f x then - begin - Array.unsafe_set new_d_arr !p x; - incr p; - end; - done; - new_d.len <- !p; - new_d - -let equal eq x y : bool = - if x.len <> y.len then false - else - let rec aux x_arr y_arr i = - if i < 0 then true else - if eq (Array.unsafe_get x_arr i) (Array.unsafe_get y_arr i) then - aux x_arr y_arr (i - 1) - else false in - aux x.arr y.arr (x.len - 1) - -let get d i = - if i < 0 || i >= d.len then invalid_arg "Vec.get" - else Array.unsafe_get d.arr i -let unsafe_get d i = Array.unsafe_get d.arr i -let last d = - if d.len <= 0 then invalid_arg "Vec.last" - else Array.unsafe_get d.arr (d.len - 1) - -let capacity d = Array.length d.arr - -(* Attention can not use {!Array.exists} since the bound is not the same *) -let exists p d = - let a = d.arr in - let n = d.len in - let rec loop i = - if i = n then false - else if p (Array.unsafe_get a i) then true - else loop (succ i) in - loop 0 - -let map f src = - let src_len = src.len in - if src_len = 0 then { len = 0 ; arr = [||]} - (* TODO: we may share the empty array - but sharing mutable state is very challenging, - the tricky part is to avoid mutating the immutable array, - here it looks fine -- - invariant: whenever [.arr] mutated, make sure it is not an empty array - Actually no: since starting from an empty array - {[ - push v (* the address of v should not be changed *) - ]} - *) - else - let src_arr = src.arr in - let first = f (Array.unsafe_get src_arr 0 ) in - let arr = Array.make src_len first in - for i = 1 to src_len - 1 do - Array.unsafe_set arr i (f (Array.unsafe_get src_arr i)) - done; - { - len = src_len; - arr = arr; - } - -let init len f = - if len < 0 then invalid_arg "Vec.init" - else if len = 0 then { len = 0 ; arr = [||] } - else - let first = f 0 in - let arr = Array.make len first in - for i = 1 to len - 1 do - Array.unsafe_set arr i (f i) - done; - { - - len ; - arr - } - - - - let make initsize : t = - if initsize < 0 then invalid_arg "Vec.make" ; - { - - len = 0; - arr = Array.make initsize null ; - } - - - - let reserve (d : t ) s = - let d_len = d.len in - let d_arr = d.arr in - if s < d_len || s < Array.length d_arr then () - else - let new_capacity = min Sys.max_array_length s in - let new_d_arr = Array.make new_capacity null in - unsafe_blit d_arr 0 new_d_arr 0 d_len; - d.arr <- new_d_arr - - let push (d : t) v = - let d_len = d.len in - let d_arr = d.arr in - let d_arr_len = Array.length d_arr in - if d_arr_len = 0 then - begin - d.len <- 1 ; - d.arr <- [| v |] - end - else - begin - if d_len = d_arr_len then - begin - if d_len >= Sys.max_array_length then - failwith "exceeds max_array_length"; - let new_capacity = min Sys.max_array_length d_len * 2 - (* [d_len] can not be zero, so [*2] will enlarge *) - in - let new_d_arr = Array.make new_capacity null in - d.arr <- new_d_arr; - unsafe_blit d_arr 0 new_d_arr 0 d_len ; - end; - d.len <- d_len + 1; - Array.unsafe_set d.arr d_len v - end - -(** delete element at offset [idx], will raise exception when have invalid input *) - let delete (d : t) idx = - let d_len = d.len in - if idx < 0 || idx >= d_len then invalid_arg "Vec.delete" ; - let arr = d.arr in - unsafe_blit arr (idx + 1) arr idx (d_len - idx - 1); - let idx = d_len - 1 in - d.len <- idx -#ifdef TYPE_INT -#else - ; - Array.unsafe_set arr idx null -#endif - -(** pop the last element, a specialized version of [delete] *) - let pop (d : t) = - let idx = d.len - 1 in - if idx < 0 then invalid_arg "Vec.pop"; - d.len <- idx -#ifdef TYPE_INT -#else - ; - Array.unsafe_set d.arr idx null -#endif - -(** pop and return the last element *) - let get_last_and_pop (d : t) = - let idx = d.len - 1 in - if idx < 0 then invalid_arg "Vec.get_last_and_pop"; - let last = Array.unsafe_get d.arr idx in - d.len <- idx -#ifdef TYPE_INT -#else - ; - Array.unsafe_set d.arr idx null -#endif - ; - last - -(** delete elements start from [idx] with length [len] *) - let delete_range (d : t) idx len = - let d_len = d.len in - if len < 0 || idx < 0 || idx + len > d_len then invalid_arg "Vec.delete_range" ; - let arr = d.arr in - unsafe_blit arr (idx + len) arr idx (d_len - idx - len); - d.len <- d_len - len -#ifdef TYPE_INT -#else - ; - for i = d_len - len to d_len - 1 do - Array.unsafe_set arr i null - done -#endif - -(** delete elements from [idx] with length [len] return the deleted elements as a new vec*) - let get_and_delete_range (d : t) idx len : t = - let d_len = d.len in - if len < 0 || idx < 0 || idx + len > d_len then invalid_arg "Vec.get_and_delete_range" ; - let arr = d.arr in - let value = unsafe_sub arr idx len in - unsafe_blit arr (idx + len) arr idx (d_len - idx - len); - d.len <- d_len - len; -#ifdef TYPE_INT -#else - for i = d_len - len to d_len - 1 do - Array.unsafe_set arr i null - done; -#endif - {len = len ; arr = value} - - - (** Below are simple wrapper around normal Array operations *) - - let clear (d : t ) = -#ifdef TYPE_INT -#else - for i = 0 to d.len - 1 do - Array.unsafe_set d.arr i null - done; -#endif - d.len <- 0 - - - - let inplace_filter f (d : t) : unit = - let d_arr = d.arr in - let d_len = d.len in - let p = ref 0 in - for i = 0 to d_len - 1 do - let x = Array.unsafe_get d_arr i in - if f x then - begin - let curr_p = !p in - (if curr_p <> i then - Array.unsafe_set d_arr curr_p x) ; - incr p - end - done ; - let last = !p in -#ifdef TYPE_INT - d.len <- last - (* INT , there is not need to reset it, since it will cause GC behavior *) -#else - delete_range d last (d_len - last) -#endif - - let inplace_filter_from start f (d : t) : unit = - if start < 0 then invalid_arg "Vec.inplace_filter_from"; - let d_arr = d.arr in - let d_len = d.len in - let p = ref start in - for i = start to d_len - 1 do - let x = Array.unsafe_get d_arr i in - if f x then - begin - let curr_p = !p in - (if curr_p <> i then - Array.unsafe_set d_arr curr_p x) ; - incr p - end - done ; - let last = !p in -#ifdef TYPE_INT - d.len <- last -#else - delete_range d last (d_len - last) -#endif - - -(** inplace filter the elements and accumulate the non-filtered elements *) - let inplace_filter_with f ~cb_no acc (d : t) = - let d_arr = d.arr in - let p = ref 0 in - let d_len = d.len in - let acc = ref acc in - for i = 0 to d_len - 1 do - let x = Array.unsafe_get d_arr i in - if f x then - begin - let curr_p = !p in - (if curr_p <> i then - Array.unsafe_set d_arr curr_p x) ; - incr p - end - else - acc := cb_no x !acc - done ; - let last = !p in -#ifdef TYPE_INT - d.len <- last - (* INT , there is not need to reset it, since it will cause GC behavior *) -#else - delete_range d last (d_len - last) -#endif - ; !acc - - - -#ifdef TYPE_FUNCTOR -end -#endif diff --git a/compiler/ext/vec.ml b/compiler/ext/vec.ml new file mode 100644 index 00000000000..c51e5a52527 --- /dev/null +++ b/compiler/ext/vec.ml @@ -0,0 +1,407 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +let[@inline] min (x : int) y = if x < y then x else y + +external unsafe_blit : 'a array -> int -> 'a array -> int -> int -> unit + = "caml_array_blit" +module Make (Resize : Vec_gen.ResizeType) = struct + type elt = Resize.t + + let null = Resize.null + + external unsafe_sub : 'a array -> int -> int -> 'a array = "caml_array_sub" + + type t = {mutable arr: elt array; mutable len: int} + + let length d = d.len + + let compact d = + let d_arr = d.arr in + if d.len <> Array.length d_arr then + let newarr = unsafe_sub d_arr 0 d.len in + d.arr <- newarr + let singleton v = {len = 1; arr = [|v|]} + + let empty () = {len = 0; arr = [||]} + + let is_empty d = d.len = 0 + + let reset d = + d.len <- 0; + d.arr <- [||] + + (* For [to_*] operations, we should be careful to call {!Array.*} function + in case we operate on the whole array +*) + let to_list d = + let rec loop (d_arr : elt array) idx accum = + if idx < 0 then accum + else loop d_arr (idx - 1) (Array.unsafe_get d_arr idx :: accum) + in + loop d.arr (d.len - 1) [] + + let of_list lst = + let arr = Array.of_list lst in + {arr; len = Array.length arr} + + let to_array d = unsafe_sub d.arr 0 d.len + + let of_array src = + { + len = Array.length src; + arr = Array.copy src; + (* okay to call {!Array.copy}*) + } + let of_sub_array arr off len = {len; arr = Array.sub arr off len} + let unsafe_internal_array v = v.arr + + (* we can not call {!Array.copy} *) + let copy src = + let len = src.len in + {len; arr = unsafe_sub src.arr 0 len} + + (* FIXME *) + let reverse_in_place src = Ext_array.reverse_range src.arr 0 src.len + + (* {!Array.sub} is not enough for error checking, it + may contain some garbage + *) + let sub (src : t) start len = + let src_len = src.len in + if len < 0 || start > src_len - len then invalid_arg "Vec.sub" + else {len; arr = unsafe_sub src.arr start len} + + let iter d f = + let arr = d.arr in + for i = 0 to d.len - 1 do + f (Array.unsafe_get arr i) + done + + let iteri d f = + let arr = d.arr in + for i = 0 to d.len - 1 do + f i (Array.unsafe_get arr i) + done + + let iter_range d ~from ~to_ f = + if from < 0 || to_ >= d.len then invalid_arg "Vec.iter_range" + else + let d_arr = d.arr in + for i = from to to_ do + f (Array.unsafe_get d_arr i) + done + + let iteri_range d ~from ~to_ f = + if from < 0 || to_ >= d.len then invalid_arg "Vec.iteri_range" + else + let d_arr = d.arr in + for i = from to to_ do + f i (Array.unsafe_get d_arr i) + done + + let map_into_array f src = + let src_len = src.len in + let src_arr = src.arr in + if src_len = 0 then [||] + else + let first_one = f (Array.unsafe_get src_arr 0) in + let arr = Array.make src_len first_one in + for i = 1 to src_len - 1 do + Array.unsafe_set arr i (f (Array.unsafe_get src_arr i)) + done; + arr + let map_into_list f src = + let src_len = src.len in + let src_arr = src.arr in + if src_len = 0 then [] + else + let acc = ref [] in + for i = src_len - 1 downto 0 do + acc := f (Array.unsafe_get src_arr i) :: !acc + done; + !acc + + let mapi f src = + let len = src.len in + if len = 0 then {len; arr = [||]} + else + let src_arr = src.arr in + let arr = Array.make len (Array.unsafe_get src_arr 0) in + for i = 1 to len - 1 do + Array.unsafe_set arr i (f i (Array.unsafe_get src_arr i)) + done; + {len; arr} + + let fold_left f x a = + let rec loop a_len (a_arr : elt array) idx x = + if idx >= a_len then x + else loop a_len a_arr (idx + 1) (f x (Array.unsafe_get a_arr idx)) + in + loop a.len a.arr 0 x + + let fold_right f a x = + let rec loop (a_arr : elt array) idx x = + if idx < 0 then x + else loop a_arr (idx - 1) (f (Array.unsafe_get a_arr idx) x) + in + loop a.arr (a.len - 1) x + + (** + [filter] and [inplace_filter] +*) + let filter f d = + let new_d = copy d in + let new_d_arr = new_d.arr in + let d_arr = d.arr in + let p = ref 0 in + for i = 0 to d.len - 1 do + let x = Array.unsafe_get d_arr i in + (* TODO: can be optimized for segments blit *) + if f x then ( + Array.unsafe_set new_d_arr !p x; + incr p) + done; + new_d.len <- !p; + new_d + + let equal eq x y : bool = + if x.len <> y.len then false + else + let rec aux x_arr y_arr i = + if i < 0 then true + else if eq (Array.unsafe_get x_arr i) (Array.unsafe_get y_arr i) then + aux x_arr y_arr (i - 1) + else false + in + aux x.arr y.arr (x.len - 1) + + let get d i = + if i < 0 || i >= d.len then invalid_arg "Vec.get" + else Array.unsafe_get d.arr i + let unsafe_get d i = Array.unsafe_get d.arr i + let last d = + if d.len <= 0 then invalid_arg "Vec.last" + else Array.unsafe_get d.arr (d.len - 1) + + let capacity d = Array.length d.arr + + (* Attention can not use {!Array.exists} since the bound is not the same *) + let exists p d = + let a = d.arr in + let n = d.len in + let rec loop i = + if i = n then false + else if p (Array.unsafe_get a i) then true + else loop (succ i) + in + loop 0 + + let map f src = + let src_len = src.len in + if src_len = 0 then {len = 0; arr = [||]} + (* TODO: we may share the empty array + but sharing mutable state is very challenging, + the tricky part is to avoid mutating the immutable array, + here it looks fine -- + invariant: whenever [.arr] mutated, make sure it is not an empty array + Actually no: since starting from an empty array + {[ + push v (* the address of v should not be changed *) + ]} + *) + else + let src_arr = src.arr in + let first = f (Array.unsafe_get src_arr 0) in + let arr = Array.make src_len first in + for i = 1 to src_len - 1 do + Array.unsafe_set arr i (f (Array.unsafe_get src_arr i)) + done; + {len = src_len; arr} + + let init len f = + if len < 0 then invalid_arg "Vec.init" + else if len = 0 then {len = 0; arr = [||]} + else + let first = f 0 in + let arr = Array.make len first in + for i = 1 to len - 1 do + Array.unsafe_set arr i (f i) + done; + {len; arr} + + let make initsize : t = + if initsize < 0 then invalid_arg "Vec.make"; + {len = 0; arr = Array.make initsize null} + + let reserve (d : t) s = + let d_len = d.len in + let d_arr = d.arr in + if s < d_len || s < Array.length d_arr then () + else + let new_capacity = min Sys.max_array_length s in + let new_d_arr = Array.make new_capacity null in + unsafe_blit d_arr 0 new_d_arr 0 d_len; + d.arr <- new_d_arr + + let push (d : t) v = + let d_len = d.len in + let d_arr = d.arr in + let d_arr_len = Array.length d_arr in + if d_arr_len = 0 then ( + d.len <- 1; + d.arr <- [|v|]) + else ( + if d_len = d_arr_len then ( + if d_len >= Sys.max_array_length then + failwith "exceeds max_array_length"; + let new_capacity = + min Sys.max_array_length d_len * 2 + (* [d_len] can not be zero, so [*2] will enlarge *) + in + let new_d_arr = Array.make new_capacity null in + d.arr <- new_d_arr; + unsafe_blit d_arr 0 new_d_arr 0 d_len); + d.len <- d_len + 1; + Array.unsafe_set d.arr d_len v) + + (** delete element at offset [idx], will raise exception when have invalid input *) + let delete (d : t) idx = + let d_len = d.len in + if idx < 0 || idx >= d_len then invalid_arg "Vec.delete"; + let arr = d.arr in + unsafe_blit arr (idx + 1) arr idx (d_len - idx - 1); + let idx = d_len - 1 in + d.len <- idx; + + Array.unsafe_set arr idx null + + (** pop the last element, a specialized version of [delete] *) + let pop (d : t) = + let idx = d.len - 1 in + if idx < 0 then invalid_arg "Vec.pop"; + d.len <- idx; + + Array.unsafe_set d.arr idx null + + (** pop and return the last element *) + let get_last_and_pop (d : t) = + let idx = d.len - 1 in + if idx < 0 then invalid_arg "Vec.get_last_and_pop"; + let last = Array.unsafe_get d.arr idx in + d.len <- idx; + + Array.unsafe_set d.arr idx null; + + last + + (** delete elements start from [idx] with length [len] *) + let delete_range (d : t) idx len = + let d_len = d.len in + if len < 0 || idx < 0 || idx + len > d_len then + invalid_arg "Vec.delete_range"; + let arr = d.arr in + unsafe_blit arr (idx + len) arr idx (d_len - idx - len); + d.len <- d_len - len; + + for i = d_len - len to d_len - 1 do + Array.unsafe_set arr i null + done + + (** delete elements from [idx] with length [len] return the deleted elements as a new vec*) + let get_and_delete_range (d : t) idx len : t = + let d_len = d.len in + if len < 0 || idx < 0 || idx + len > d_len then + invalid_arg "Vec.get_and_delete_range"; + let arr = d.arr in + let value = unsafe_sub arr idx len in + unsafe_blit arr (idx + len) arr idx (d_len - idx - len); + d.len <- d_len - len; + + for i = d_len - len to d_len - 1 do + Array.unsafe_set arr i null + done; + + {len; arr = value} + + (** Below are simple wrapper around normal Array operations *) + + let clear (d : t) = + for i = 0 to d.len - 1 do + Array.unsafe_set d.arr i null + done; + + d.len <- 0 + + let inplace_filter f (d : t) : unit = + let d_arr = d.arr in + let d_len = d.len in + let p = ref 0 in + for i = 0 to d_len - 1 do + let x = Array.unsafe_get d_arr i in + if f x then ( + let curr_p = !p in + if curr_p <> i then Array.unsafe_set d_arr curr_p x; + incr p) + done; + let last = !p in + + delete_range d last (d_len - last) + + let inplace_filter_from start f (d : t) : unit = + if start < 0 then invalid_arg "Vec.inplace_filter_from"; + let d_arr = d.arr in + let d_len = d.len in + let p = ref start in + for i = start to d_len - 1 do + let x = Array.unsafe_get d_arr i in + if f x then ( + let curr_p = !p in + if curr_p <> i then Array.unsafe_set d_arr curr_p x; + incr p) + done; + let last = !p in + + delete_range d last (d_len - last) + + (** inplace filter the elements and accumulate the non-filtered elements *) + let inplace_filter_with f ~cb_no acc (d : t) = + let d_arr = d.arr in + let p = ref 0 in + let d_len = d.len in + let acc = ref acc in + for i = 0 to d_len - 1 do + let x = Array.unsafe_get d_arr i in + if f x then ( + let curr_p = !p in + if curr_p <> i then Array.unsafe_set d_arr curr_p x; + incr p) + else acc := cb_no x !acc + done; + let last = !p in + + delete_range d last (d_len - last); + + !acc +end diff --git a/compiler/ext/hash_set_int.mli b/compiler/ext/vec_int.ml similarity index 95% rename from compiler/ext/hash_set_int.mli rename to compiler/ext/vec_int.ml index 9e5cf155e63..da57e5d3057 100644 --- a/compiler/ext/hash_set_int.mli +++ b/compiler/ext/vec_int.ml @@ -1,5 +1,5 @@ (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -17,9 +17,13 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -include Hash_set_gen.S with type key = int +include Vec.Make (struct + type t = int + + let null = 0 +end) diff --git a/dune-project b/dune-project index 0d2207b7244..2e4af6f0bc4 100644 --- a/dune-project +++ b/dune-project @@ -21,6 +21,7 @@ (ocaml (>= 5.0.0)) dune + ; Used by packages/@rescript/runtime/scripts/cppo.js to regenerate checked-in ReScript sources. (cppo (= 1.8.0)) (flow_parser @@ -53,8 +54,6 @@ (depends (ocaml (>= 5.0.0)) - (cppo - (= 1.8.0)) (odoc :with-doc) (lsp (>= 1.23.0)) @@ -69,8 +68,6 @@ (>= 5.0.0)) (cmarkit (>= 0.3.0)) - (cppo - (= 1.8.0)) analysis (yojson (= 3.0.0)) diff --git a/tests/ounit_tests/ounit_hash_stubs_test.ml b/tests/ounit_tests/ounit_hash_stubs_test.ml index 0c033af7f22..d22062006cf 100644 --- a/tests/ounit_tests/ounit_hash_stubs_test.ml +++ b/tests/ounit_tests/ounit_hash_stubs_test.ml @@ -2,30 +2,6 @@ let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let ( =~ ) = OUnit.assert_equal -let count = 2_000_000 - -let bench () = - Ounit_tests_util.time "int hash set" (fun _ -> - let v = Hash_set_int.create 2_000_000 in - for i = 0 to count do - Hash_set_int.add v i - done; - for _ = 0 to 3 do - for i = 0 to count do - assert (Hash_set_int.mem v i) - done - done); - Ounit_tests_util.time "int hash set" (fun _ -> - let v = Hash_set_poly.create 2_000_000 in - for i = 0 to count do - Hash_set_poly.add v i - done; - for _ = 0 to 3 do - for i = 0 to count do - assert (Hash_set_poly.mem v i) - done - done) - type id = {stamp: int; name: string; mutable flags: int} (* = Ident.t *) let hash id = Ext_platform_primitives.hash_stamp_and_name id.stamp id.name let suites = diff --git a/tests/ounit_tests/ounit_hashtbl_tests.ml b/tests/ounit_tests/ounit_hashtbl_tests.ml index fde7bb0aaed..64d24d28753 100644 --- a/tests/ounit_tests/ounit_hashtbl_tests.ml +++ b/tests/ounit_tests/ounit_hashtbl_tests.ml @@ -2,45 +2,72 @@ let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let ( =~ ) = OUnit.assert_equal ~printer:Ext_obj.dump +module String_hash = Hash.Make (struct + type t = string + + let equal = Ext_string.equal + let hash = Ext_platform_primitives.hash_string +end) + let suites = __FILE__ >::: [ (* __LOC__ >:: begin fun _ -> *) - (* let h = Hash_string.create 0 in *) + (* let h = String_hash.create 0 in *) (* let accu key = *) - (* Hash_string.replace_or_init h key succ 1 in *) + (* String_hash.replace_or_init h key succ 1 in *) (* let count = 1000 in *) (* for i = 0 to count - 1 do *) (* Array.iter accu [|"a";"b";"c";"d";"e";"f"|] *) (* done; *) - (* Hash_string.length h =~ 6; *) - (* Hash_string.iter (fun _ v -> v =~ count ) h *) + (* String_hash.length h =~ 6; *) + (* String_hash.iter (fun _ v -> v =~ count ) h *) (* end; *) ( "add semantics " >:: fun _ -> - let h = Hash_string.create 0 in + let h = String_hash.create 0 in let count = 1000 in for _ = 0 to 1 do for i = 0 to count - 1 do - Hash_string.add h (string_of_int i) i + String_hash.add h (string_of_int i) i done done; - Hash_string.length h =~ 2 * count ); + String_hash.length h =~ 2 * count ); ( "replace semantics" >:: fun _ -> - let h = Hash_string.create 0 in + let h = String_hash.create 0 in let count = 1000 in for _ = 0 to 1 do for i = 0 to count - 1 do - Hash_string.replace h (string_of_int i) i + String_hash.replace h (string_of_int i) i done done; - Hash_string.length h =~ count ); + String_hash.length h =~ count ); ( __LOC__ >:: fun _ -> - let h = Hash_string.create 0 in + let h = String_hash.create 0 in let count = 10 in for i = 0 to count - 1 do - Hash_string.replace h (string_of_int i) i + String_hash.replace h (string_of_int i) i done; - let xs = Hash_string.to_list h (fun k _ -> k) in + let xs = String_hash.to_list h (fun k _ -> k) in let ys = List.sort compare xs in ys =~ ["0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"] ); + ( "ordered local identifiers" >:: fun _ -> + let table = Ordered_hash_map_local_ident.create 1 in + let identifiers = + Array.init 100 (fun stamp -> + ({stamp = stamp + 1; name = "value"; flags = 0} : Ident.t)) + in + Array.iteri + (fun value ident -> + Ordered_hash_map_local_ident.add table ident value) + identifiers; + Array.iteri + (fun value ident -> + OUnit.assert_equal value + (Ordered_hash_map_local_ident.rank table ident); + OUnit.assert_equal value + (Ordered_hash_map_local_ident.find_value table ident)) + identifiers; + OUnit.assert_equal 100 (Ordered_hash_map_local_ident.length table); + OUnit.assert_equal identifiers + (Ordered_hash_map_local_ident.to_sorted_array table) ); ] diff --git a/tests/ounit_tests/ounit_scc_tests.ml b/tests/ounit_tests/ounit_scc_tests.ml index e0bb9f33a05..fc1f626db2d 100644 --- a/tests/ounit_tests/ounit_scc_tests.ml +++ b/tests/ounit_tests/ounit_scc_tests.ml @@ -2,6 +2,13 @@ let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let ( =~ ) = OUnit.assert_equal +module String_hash = Hash.Make (struct + type t = string + + let equal = Ext_string.equal + let hash = Ext_platform_primitives.hash_string +end) + let tiny_test_cases = {| 13 @@ -224,46 +231,46 @@ let read_file file = let test (input : (string * string list) list) = (* string -> int mapping *) - let tbl = Hash_string.create 32 in + let tbl = String_hash.create 32 in let idx = ref 0 in let add x = - if not (Hash_string.mem tbl x) then ( - Hash_string.add tbl x !idx; + if not (String_hash.mem tbl x) then ( + String_hash.add tbl x !idx; incr idx) in input |> List.iter (fun (x, others) -> List.iter add (x :: others)); - let nodes_num = Hash_string.length tbl in + let nodes_num = String_hash.length tbl in let node_array = Array.init nodes_num (fun _ -> Vec_int.empty ()) in input |> List.iter (fun (x, others) -> - let idx = Hash_string.find_exn tbl x in + let idx = String_hash.find_exn tbl x in others |> List.iter (fun y -> - Vec_int.push node_array.(idx) (Hash_string.find_exn tbl y))); + Vec_int.push node_array.(idx) (String_hash.find_exn tbl y))); Ext_scc.graph_check node_array let test2 (input : (string * string list) list) = (* string -> int mapping *) - let tbl = Hash_string.create 32 in + let tbl = String_hash.create 32 in let idx = ref 0 in let add x = - if not (Hash_string.mem tbl x) then ( - Hash_string.add tbl x !idx; + if not (String_hash.mem tbl x) then ( + String_hash.add tbl x !idx; incr idx) in input |> List.iter (fun (x, others) -> List.iter add (x :: others)); - let nodes_num = Hash_string.length tbl in + let nodes_num = String_hash.length tbl in let other_mapping = Array.make nodes_num "" in - Hash_string.iter tbl (fun k v -> other_mapping.(v) <- k); + String_hash.iter tbl (fun k v -> other_mapping.(v) <- k); let node_array = Array.init nodes_num (fun _ -> Vec_int.empty ()) in input |> List.iter (fun (x, others) -> - let idx = Hash_string.find_exn tbl x in + let idx = String_hash.find_exn tbl x in others |> List.iter (fun y -> - Vec_int.push node_array.(idx) (Hash_string.find_exn tbl y))); + Vec_int.push node_array.(idx) (String_hash.find_exn tbl y))); let output = Ext_scc.graph node_array in output |> Int_vec_vec.map_into_array (fun int_vec -> diff --git a/tools.opam b/tools.opam index 202ba62686f..a1657f5a445 100644 --- a/tools.opam +++ b/tools.opam @@ -10,7 +10,6 @@ depends: [ "dune" {>= "3.17"} "ocaml" {>= "5.0.0"} "cmarkit" {>= "0.3.0"} - "cppo" {= "1.8.0"} "analysis" "yojson" {= "3.0.0"} "odoc" {with-doc}