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}