From 08403bac9f9d4f56f4f9047be572de7958383519 Mon Sep 17 00:00:00 2001 From: octachron Date: Wed, 11 Nov 2015 23:36:55 +0200 Subject: [PATCH 01/31] CCRandom: Add sample_without_replacement --- src/core/CCRandom.ml | 14 ++++++++++++++ src/core/CCRandom.mli | 8 ++++++++ 2 files changed, 22 insertions(+) diff --git a/src/core/CCRandom.ml b/src/core/CCRandom.ml index cc387065..cf53c8eb 100644 --- a/src/core/CCRandom.ml +++ b/src/core/CCRandom.ml @@ -78,6 +78,20 @@ let replicate n g st = if n = 0 then acc else aux (g st :: acc) (n-1) in aux [] n +(* Sample without replacement using rejection sampling. *) +let sample_without_replacement (type elt) ?(compare=compare) k (rng:elt t) st= + let module S = Set.Make(struct type t=elt let compare = compare end) in + let rec aux s k = + if k <= 0 then + S.elements s + else + let x = rng st in + if S.mem x s then + aux s k + else + aux (S.add x s) (k-1) in + aux S.empty k + let list_seq l st = List.map (fun f -> f st) l exception SplitFail diff --git a/src/core/CCRandom.mli b/src/core/CCRandom.mli index e42e1f01..2c1ebcc7 100644 --- a/src/core/CCRandom.mli +++ b/src/core/CCRandom.mli @@ -76,6 +76,14 @@ val replicate : int -> 'a t -> 'a list t (** [replicate n g] makes a list of [n] elements which are all generated randomly using [g] *) +val sample_without_replacement: + ?compare:('a -> 'a -> int) -> int -> 'a t -> 'a list t +(** [sample_without_replacement n g] makes a list of [n] elements which are all + generated randomly using [g] with the added constraint that none of the generated + random values are equal + @since 0.15 + *) + val list_seq : 'a t list -> 'a list t (** Build random lists from lists of random generators @since 0.4 *) From 06f9ca3eee084125c96b15a0cc25c9cdb8ae6695 Mon Sep 17 00:00:00 2001 From: octachron Date: Wed, 11 Nov 2015 23:37:20 +0200 Subject: [PATCH 02/31] CCRandom: Make `split_list` uniform --- src/core/CCRandom.ml | 47 ++++++++++++++++++++++---------------------- 1 file changed, 24 insertions(+), 23 deletions(-) diff --git a/src/core/CCRandom.ml b/src/core/CCRandom.ml index cf53c8eb..709a3e2e 100644 --- a/src/core/CCRandom.ml +++ b/src/core/CCRandom.ml @@ -94,33 +94,34 @@ let sample_without_replacement (type elt) ?(compare=compare) k (rng:elt t) st= let list_seq l st = List.map (fun f -> f st) l -exception SplitFail - -let _split i st = - if i < 2 then raise SplitFail +let split i st = + if i < 2 then None else let j = 1 + Random.State.int st (i-1) in - (j, i-j) + Some (j, i-j) -let split i st = try Some (_split i st) with SplitFail -> None - -(* Partition of an int into [len] integers. We divide-and-conquer on - the expected length, until it reaches 1. *) -let split_list i ~len st = - let rec aux i ~len acc = - if i < len then raise SplitFail - else if len = 1 then i::acc - else - (* split somewhere in the middle *) - let len1, len2 = _split len st in - assert (len = len1+len2); - if i = len - then aux len1 ~len:len1 (aux len2 ~len:len2 acc) - else - let i1, i2 = _split (i-len) st in - aux (i1+len1) ~len:len1 (aux (i2+len2) ~len:len2 acc) +let _diff_list l = + let rec diff_list acc = function + | [a;b] -> Some ( (b - a)::acc ) + | a::( b::_ as r ) -> diff_list ( (b-a)::acc ) r + | [_] | [] -> None in - try Some (aux i ~len []) with SplitFail -> None + diff_list [] l + + +(* Partition of an int into [len] integers uniformly. + We first sample (len-1) points from the set {1,..i-1} without replacement. + We sort these points and add back 0 and i, we have thus + x_0 = 0 < x_1 < x_2 < ... < x_{len-1} < i = x_{len}. + If we define, y_k = x_{k+1} - x_{k} for k in 0..(len-1), then by construction + ∑_k y_k = ∑_k (x_{k+1} - x_k ) = x_{len} - x_0 = i. *) +let split_list i ~len st = + if i >= len then + let xs = sample_without_replacement (len-1) (int_range 1 @@ i-1) st in + let ordered_xs = List.sort compare (i::0::xs) in + _diff_list ordered_xs + else + None let retry ?(max=10) g st = let rec aux n = From 2bb64231098d61e8153321ef9ff8e89964ddd4d8 Mon Sep 17 00:00:00 2001 From: octachron Date: Wed, 11 Nov 2015 23:01:57 +0200 Subject: [PATCH 03/31] CCRandom: add an uniformity test --- src/core/CCRandom.ml | 28 ++++++++++++++++++++++++++++ src/core/CCRandom.mli | 8 ++++++++ 2 files changed, 36 insertions(+) diff --git a/src/core/CCRandom.ml b/src/core/CCRandom.ml index 709a3e2e..a5a37f5c 100644 --- a/src/core/CCRandom.ml +++ b/src/core/CCRandom.ml @@ -192,3 +192,31 @@ let (<*>) f g st = f st (g st) let __default_state = Random.State.make_self_init () let run ?(st=__default_state) g = g st + +let uniformity_test ?(size_hint=10) k rng st = + let histogram = Hashtbl.create size_hint in + let add x = let n = try Hashtbl.find histogram x with Not_found -> 0 in + Hashtbl.replace histogram x (n + 1) in + let () = + for _i = 0 to ( k - 1 ) do + add @@ rng st + done in + let cardinal = float_of_int @@ Hashtbl.length histogram in + let kf = float_of_int k in + (* average number of points assuming an uniform distribution *) + let average = kf /. cardinal in + (* The number of points is a sum of random variables with binomial distribution *) + let p = 1. /. cardinal in + (* The variance of a binomial distribution with average p is *) + let variance = p *. (1. -. p ) in + (* Central limit theorem: a confidence interval of 4σ provides a false positive rate + of 0.00634% *) + let confidence = 4. in + let std = confidence *. ( sqrt @@ kf *. variance ) in + let predicate _key n acc = + acc && abs_float (average -. float_of_int n) < std in + Hashtbl.fold predicate histogram true + +(*$T split_list + run ( uniformity_test 50_000 (split_list 10 ~len:3) ) +*) diff --git a/src/core/CCRandom.mli b/src/core/CCRandom.mli index 2c1ebcc7..be3dcc0a 100644 --- a/src/core/CCRandom.mli +++ b/src/core/CCRandom.mli @@ -153,3 +153,11 @@ val (<*>) : ('a -> 'b) t -> 'a t -> 'b t val run : ?st:state -> 'a t -> 'a (** Using a random state (possibly the one in argument) run a generator *) + +(** {6 Random generator testing } *) + +val uniformity_test : ?size_hint:int -> int -> 'a t -> bool t +(** [uniformity_test k rng] tests the uniformity of the random generator [rng] using + [k] samples. + @since 0.15 +*) From de2a51d62e51c255471d62707cf52fb88e32e8ec Mon Sep 17 00:00:00 2001 From: octachron Date: Thu, 12 Nov 2015 13:41:38 +0200 Subject: [PATCH 04/31] Fix a wasteful sort in sample_without_replacement --- src/core/CCRandom.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/core/CCRandom.ml b/src/core/CCRandom.ml index a5a37f5c..1a54e544 100644 --- a/src/core/CCRandom.ml +++ b/src/core/CCRandom.ml @@ -100,11 +100,11 @@ let split i st = let j = 1 + Random.State.int st (i-1) in Some (j, i-j) -let _diff_list l = +let _diff_list ~last l = let rec diff_list acc = function - | [a;b] -> Some ( (b - a)::acc ) + | [a] -> Some ( (last - a)::acc ) | a::( b::_ as r ) -> diff_list ( (b-a)::acc ) r - | [_] | [] -> None + | [] -> None in diff_list [] l @@ -118,8 +118,7 @@ let _diff_list l = let split_list i ~len st = if i >= len then let xs = sample_without_replacement (len-1) (int_range 1 @@ i-1) st in - let ordered_xs = List.sort compare (i::0::xs) in - _diff_list ordered_xs + _diff_list ( 0::xs ) ~last:i else None From 0a662ef112b2408e0f73fffff2d62d76057cd065 Mon Sep 17 00:00:00 2001 From: octachron Date: Thu, 12 Nov 2015 13:45:57 +0200 Subject: [PATCH 05/31] Exclude uniformity test from the documentation --- src/core/CCRandom.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/CCRandom.mli b/src/core/CCRandom.mli index be3dcc0a..c0b8c604 100644 --- a/src/core/CCRandom.mli +++ b/src/core/CCRandom.mli @@ -154,7 +154,7 @@ val (<*>) : ('a -> 'b) t -> 'a t -> 'b t val run : ?st:state -> 'a t -> 'a (** Using a random state (possibly the one in argument) run a generator *) -(** {6 Random generator testing } *) +(**/**) val uniformity_test : ?size_hint:int -> int -> 'a t -> bool t (** [uniformity_test k rng] tests the uniformity of the random generator [rng] using From cffbc66e6da7a2b33154c4a35c782b98f991f786 Mon Sep 17 00:00:00 2001 From: octachron Date: Fri, 13 Nov 2015 16:35:08 +0200 Subject: [PATCH 06/31] Add octachron as author --- AUTHORS.adoc | 1 + 1 file changed, 1 insertion(+) diff --git a/AUTHORS.adoc b/AUTHORS.adoc index c4772003..b1ee4699 100644 --- a/AUTHORS.adoc +++ b/AUTHORS.adoc @@ -12,3 +12,4 @@ - Emmanuel Surleau (emm) - Guillaume Bury (guigui) - JP Rodi +- octachron (Florian Angeletti) From 3b94aa8a2cc2232a31e692167daade3c728def93 Mon Sep 17 00:00:00 2001 From: octachron Date: Fri, 13 Nov 2015 16:38:05 +0200 Subject: [PATCH 07/31] Fix @since tags in CCRandom.mli --- src/core/CCRandom.mli | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/CCRandom.mli b/src/core/CCRandom.mli index c0b8c604..1909d483 100644 --- a/src/core/CCRandom.mli +++ b/src/core/CCRandom.mli @@ -81,7 +81,7 @@ val sample_without_replacement: (** [sample_without_replacement n g] makes a list of [n] elements which are all generated randomly using [g] with the added constraint that none of the generated random values are equal - @since 0.15 + @since NEXT_RELEASE *) val list_seq : 'a t list -> 'a list t @@ -159,5 +159,5 @@ val run : ?st:state -> 'a t -> 'a val uniformity_test : ?size_hint:int -> int -> 'a t -> bool t (** [uniformity_test k rng] tests the uniformity of the random generator [rng] using [k] samples. - @since 0.15 + @since NEXT_RELEASE *) From ccf605de12e686e58166d470caf311fff3356cd4 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 13 Nov 2015 16:17:40 +0100 Subject: [PATCH 08/31] use qtest's random seed to test `Random.split_list` --- src/core/CCRandom.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/CCRandom.ml b/src/core/CCRandom.ml index 1a54e544..0ece0020 100644 --- a/src/core/CCRandom.ml +++ b/src/core/CCRandom.ml @@ -217,5 +217,5 @@ let uniformity_test ?(size_hint=10) k rng st = Hashtbl.fold predicate histogram true (*$T split_list - run ( uniformity_test 50_000 (split_list 10 ~len:3) ) + run ~st:(Runner.random_state()) ( uniformity_test 50_000 (split_list 10 ~len:3) ) *) From 4d9b1d68ed6e0a7bf54aec06352f882064124a56 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 13 Nov 2015 16:23:49 +0100 Subject: [PATCH 09/31] cleanup; use short-paths --- _tags | 2 +- src/core/CCRandom.ml | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/_tags b/_tags index 233f46bb..a536b979 100644 --- a/_tags +++ b/_tags @@ -5,4 +5,4 @@ : inline(25) or or : inline(15) and not : warn_A, warn(-4), warn(-44) -true: no_alias_deps, safe_string +true: no_alias_deps, safe_string, short_paths diff --git a/src/core/CCRandom.ml b/src/core/CCRandom.ml index 0ece0020..3d762620 100644 --- a/src/core/CCRandom.ml +++ b/src/core/CCRandom.ml @@ -117,7 +117,7 @@ let _diff_list ~last l = ∑_k y_k = ∑_k (x_{k+1} - x_k ) = x_{len} - x_0 = i. *) let split_list i ~len st = if i >= len then - let xs = sample_without_replacement (len-1) (int_range 1 @@ i-1) st in + let xs = sample_without_replacement (len-1) (int_range 1 (i-1)) st in _diff_list ( 0::xs ) ~last:i else None @@ -198,9 +198,9 @@ let uniformity_test ?(size_hint=10) k rng st = Hashtbl.replace histogram x (n + 1) in let () = for _i = 0 to ( k - 1 ) do - add @@ rng st + add (rng st) done in - let cardinal = float_of_int @@ Hashtbl.length histogram in + let cardinal = float_of_int (Hashtbl.length histogram) in let kf = float_of_int k in (* average number of points assuming an uniform distribution *) let average = kf /. cardinal in @@ -211,7 +211,7 @@ let uniformity_test ?(size_hint=10) k rng st = (* Central limit theorem: a confidence interval of 4σ provides a false positive rate of 0.00634% *) let confidence = 4. in - let std = confidence *. ( sqrt @@ kf *. variance ) in + let std = confidence *. (sqrt (kf *. variance)) in let predicate _key n acc = acc && abs_float (average -. float_of_int n) < std in Hashtbl.fold predicate histogram true From eedce686530012351fd04794a5f910ee05df32c6 Mon Sep 17 00:00:00 2001 From: carm Date: Sun, 22 Nov 2015 17:04:24 -0500 Subject: [PATCH 10/31] join / both applicative functions for CCError --- src/core/CCError.ml | 11 +++++++++++ src/core/CCError.mli | 13 ++++++++++++- 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/src/core/CCError.ml b/src/core/CCError.ml index a587ccef..3bc727ee 100644 --- a/src/core/CCError.ml +++ b/src/core/CCError.ml @@ -162,6 +162,17 @@ let (<*>) f x = match f with | `Error s -> fail s | `Ok f -> map f x +let join t = match t with + | `Ok (`Ok o) -> `Ok o + | `Ok (`Error e) -> `Error e + | (`Error _) as e -> e + +let both x y = + match x,y with + | `Ok o, `Ok o' -> `Ok (o, o') + | `Ok _, `Error e -> `Error e + | `Error e, _ -> `Error e + (** {2 Collections} *) let map_l f l = diff --git a/src/core/CCError.mli b/src/core/CCError.mli index 30d9810a..abed8594 100644 --- a/src/core/CCError.mli +++ b/src/core/CCError.mli @@ -141,7 +141,18 @@ val pure : 'a -> ('a, 'err) t val (<*>) : ('a -> 'b, 'err) t -> ('a, 'err) t -> ('b, 'err) t (** [a <*> b] evaluates [a] and [b], and, in case of success, returns [`Ok (a b)]. Otherwise, it fails, and the error of [a] is chosen - over the error of [b] if both fail *) + over the error of [b] if both fail. *) + +val join : (('a, 'err) t, 'err) t -> ('a, 'err) t +(** [join t], in case of success, returns [`Ok o] from [`Ok (`Ok o)]. Otherwise, + it fails with [`Error e] where [e] is the unwrapped error of [t]. + @since NEXT_RELEASE *) + +val both : ('a, 'err) t -> ('b, 'err) t -> (('a * 'b), 'err) t +(** [both a b], in case of success, returns [`Ok (o, o')] with the ok values + of [a] and [b]. Otherwise, it fails, and the error of [a] is chosen over the + error of [b] if both fail. + @since NEXT_RELEASE *) (** {2 Infix} From af2b6caee239df03e6609efeba53471595b44eb7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 22 Nov 2015 23:13:08 +0100 Subject: [PATCH 11/31] minor formatting --- src/core/CCError.mli | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/CCError.mli b/src/core/CCError.mli index abed8594..8a3d9e0d 100644 --- a/src/core/CCError.mli +++ b/src/core/CCError.mli @@ -145,13 +145,13 @@ val (<*>) : ('a -> 'b, 'err) t -> ('a, 'err) t -> ('b, 'err) t val join : (('a, 'err) t, 'err) t -> ('a, 'err) t (** [join t], in case of success, returns [`Ok o] from [`Ok (`Ok o)]. Otherwise, - it fails with [`Error e] where [e] is the unwrapped error of [t]. + it fails with [`Error e] where [e] is the unwrapped error of [t]. @since NEXT_RELEASE *) val both : ('a, 'err) t -> ('b, 'err) t -> (('a * 'b), 'err) t (** [both a b], in case of success, returns [`Ok (o, o')] with the ok values of [a] and [b]. Otherwise, it fails, and the error of [a] is chosen over the - error of [b] if both fail. + error of [b] if both fail. @since NEXT_RELEASE *) (** {2 Infix} From 0ec5545564a1585530af13a0341602c427bbecdf Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 28 Nov 2015 12:09:27 +0100 Subject: [PATCH 12/31] wip: `CCAllocCache`, an allocation cache for short-lived arrays --- _oasis | 2 +- benchs/run_benchs.ml | 66 +++++++++++++++++++++++++++++++++++ doc/intro.txt | 1 + src/data/CCAllocCache.ml | 72 +++++++++++++++++++++++++++++++++++++++ src/data/CCAllocCache.mli | 34 ++++++++++++++++++ 5 files changed, 174 insertions(+), 1 deletion(-) create mode 100644 src/data/CCAllocCache.ml create mode 100644 src/data/CCAllocCache.mli diff --git a/_oasis b/_oasis index d282f26f..2fd334a6 100644 --- a/_oasis +++ b/_oasis @@ -77,7 +77,7 @@ Library "containers_data" CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl, CCMixmap, CCRingBuffer, CCIntMap, CCPersistentArray, CCMixset, CCHashconsedSet, CCGraph, CCHashSet, CCBitField, - CCHashTrie, CCBloom, CCWBTree, CCRAL + CCHashTrie, CCBloom, CCWBTree, CCRAL, CCAllocCache BuildDepends: bytes # BuildDepends: bytes, bisect_ppx FindlibParent: containers diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index 17bcc401..147ea507 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -1032,6 +1032,72 @@ module Thread = struct ) end +module Alloc = struct + module type ALLOC_ARR = sig + type 'a t + val name : string + val create : int -> 'a t + val make : 'a t -> int -> 'a -> 'a array + val free : 'a t -> 'a array -> unit + end + + let dummy = + let module A = struct + type _ t = unit + let name = "dummy" + let create _ = () + let make _ i x = Array.make i x + let free _ _ = () + end in + (module A : ALLOC_ARR) + + let alloc_cache ~buck_size = + let module A = struct + type 'a t = 'a CCAllocCache.Arr.t + let name = Printf.sprintf "alloc_cache(%d)" buck_size + let create n = CCAllocCache.Arr.create ~buck_size n + let make = CCAllocCache.Arr.make + let free = CCAllocCache.Arr.free + end in + (module A : ALLOC_ARR) + + (* repeat [n] times: + - repeat [batch] times: + - allocate [batch] arrays of size from 1 to batch+1 + - free those arrays + *) + let bench1 ~batch n = + let make (module C : ALLOC_ARR) () = + let c = C.create (batch*2) in + let tmp = Array.make (batch * batch) [||] in (* temporary storage *) + for _ = 1 to n do + for j = 0 to batch-1 do + for k = 0 to batch-1 do + tmp.(j*batch + k) <- C.make c (k+1) '_'; + done; + done; + Array.iter (C.free c) tmp (* free the whole array *) + done + in + B.throughputN 3 ~repeat + [ "dummy", make dummy, () + ; "cache(5)", make (alloc_cache ~buck_size:5), () + ; "cache(20)", make (alloc_cache ~buck_size:20), () + ; "cache(50)", make (alloc_cache ~buck_size:50), () + ] + + let () = B.Tree.register ( + "alloc" @>>> + [ "bench1(batch=5)" @>> + app_ints (bench1 ~batch:5) [100; 1_000] + ; "bench1(batch=15)" @>> + app_ints (bench1 ~batch:15) [100; 1_000] + ; "bench1(batch=50)" @>> + app_ints (bench1 ~batch:50) [100; 1_000] + ] + ) +end + let () = try B.Tree.run_global () with Arg.Help msg -> print_endline msg diff --git a/doc/intro.txt b/doc/intro.txt index 8032b938..79b5aee3 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -65,6 +65,7 @@ such as: Various data structures. {!modules: +CCAllocCache CCBitField CCBloom CCBV diff --git a/src/data/CCAllocCache.ml b/src/data/CCAllocCache.ml new file mode 100644 index 00000000..2ddd0301 --- /dev/null +++ b/src/data/CCAllocCache.ml @@ -0,0 +1,72 @@ + +(* This file is free software, part of Logtk. See file "license" for more details. *) + +(** {1 Simple Cache for Allocations} *) + +module Arr = struct + type 'a t = { + caches: 'a array array array; + (* array of buckets, where each bucket is an array of arrays *) + max_buck_size: int; + sizes: int array; (* number of cached arrays in each bucket *) + } + + let create ?(buck_size=16) n = + if n<1 then invalid_arg "AllocCache.Arr.create"; + { max_buck_size=buck_size; + sizes=Array.make n 0; + caches=Array.init n (fun _ -> Array.make buck_size [||]); + } + + let make c i x = + if i=0 then [||] + else if i 0 && n < Array.length c.sizes then ( + let bs = c.sizes.(n) in + if bs < c.max_buck_size then ( + (* store [a] *) + c.caches.(n).(bs) <- a; + c.sizes.(n) <- bs + 1 + ) + ) + + let with_ c i x ~f = + let a = make c i x in + try + let ret = f a in + free c a; + ret + with e -> + free c a; + raise e +end + +(*$inject + let c = Arr.create ~buck_size:2 20 + +*) + +(*$Q + Q.small_int (fun n -> Array.length (Arr.make c n '_') = n) +*) + +(*$T + let a = Arr.make c 1 '_' in Array.length a = 1 + let a = Arr.make c 2 '_' in Array.length a = 2 + let a = Arr.make c 3 '_' in Array.length a = 3 + let a = Arr.make c 4 '_' in Array.length a = 4 +*) + + diff --git a/src/data/CCAllocCache.mli b/src/data/CCAllocCache.mli new file mode 100644 index 00000000..3ad61274 --- /dev/null +++ b/src/data/CCAllocCache.mli @@ -0,0 +1,34 @@ + +(* This file is free software, part of Logtk. See file "license" for more details. *) + +(** {1 Simple Cache for Allocations} + + Be very careful not to use-after-free or double-free. + + {b NOT THREAD SAFE} + + @since NEXT_RELEASE + +*) + +module Arr : sig + type 'a t + (** Cache for 'a arrays *) + + val create: ?buck_size:int -> int -> 'a t + (** [create n] makes a new cache of arrays up to length [n] + @param buck_size number of arrays cached for each array length + @param n maximum size of arrays put in cache *) + + val make : 'a t -> int -> 'a -> 'a array + (** [make cache i x] is like [Array.make i x], + but might return a cached array instead of allocating one. + {b NOTE}: if the array is already allocated then it + will NOT be filled with [x] *) + + val free : 'a t -> 'a array -> unit + (** Return array to the cache. The array's elements will not be GC'd *) + + val with_ : 'a t -> int -> 'a -> f:('a array -> 'b) -> 'b + (** Combines {!make} and {!free} *) +end From 99919ae1d3bde066f9ab211461a84b7e37048f41 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 28 Nov 2015 12:43:50 +0100 Subject: [PATCH 13/31] more cache friendliness --- src/data/CCAllocCache.ml | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/data/CCAllocCache.ml b/src/data/CCAllocCache.ml index 2ddd0301..3d47c8c7 100644 --- a/src/data/CCAllocCache.ml +++ b/src/data/CCAllocCache.ml @@ -5,17 +5,20 @@ module Arr = struct type 'a t = { - caches: 'a array array array; - (* array of buckets, where each bucket is an array of arrays *) + caches: 'a array array; + (* 2-dim array of cached arrays. The 2-dim array is flattened into + one dimension *) max_buck_size: int; - sizes: int array; (* number of cached arrays in each bucket *) + (* number of cached arrays per length *) + sizes: int array; + (* number of cached arrays in each bucket *) } let create ?(buck_size=16) n = if n<1 then invalid_arg "AllocCache.Arr.create"; { max_buck_size=buck_size; sizes=Array.make n 0; - caches=Array.init n (fun _ -> Array.make buck_size [||]); + caches=Array.make (n * buck_size) [||]; } let make c i x = @@ -25,7 +28,7 @@ module Arr = struct if bs = 0 then Array.make i x else ( (* remove last array *) - let ret = c.caches.(i).(bs-1) in + let ret = c.caches.(i * c.max_buck_size + bs-1) in c.sizes.(i) <- bs - 1; ret ) @@ -37,7 +40,7 @@ module Arr = struct let bs = c.sizes.(n) in if bs < c.max_buck_size then ( (* store [a] *) - c.caches.(n).(bs) <- a; + c.caches.(n * c.max_buck_size + bs) <- a; c.sizes.(n) <- bs + 1 ) ) From 191953feafdc731e6e0d476f517708c7d65219c9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 30 Nov 2015 12:33:59 +0100 Subject: [PATCH 14/31] add `CCMap.{keys,values}` --- src/core/CCMap.ml | 14 ++++++++++++++ src/core/CCMap.mli | 8 ++++++++ 2 files changed, 22 insertions(+) diff --git a/src/core/CCMap.ml b/src/core/CCMap.ml index 0fdc6e9e..d9b752bb 100644 --- a/src/core/CCMap.ml +++ b/src/core/CCMap.ml @@ -53,6 +53,14 @@ module type S = sig val add_list : 'a t -> (key * 'a) list -> 'a t (** @since 0.14 *) + val keys : _ t -> key sequence + (** Iterate on keys only + @since NEXT_RELEASE *) + + val values : 'a t -> 'a sequence + (** Iterate on values only + @since NEXT_RELEASE *) + val to_list : 'a t -> (key * 'a) list val pp : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string -> @@ -88,6 +96,12 @@ module Make(O : Map.OrderedType) = struct let to_seq m yield = iter (fun k v -> yield (k,v)) m + let keys m yield = + iter (fun k _ -> yield k) m + + let values m yield = + iter (fun _ v -> yield v) m + let add_list m l = List.fold_left (fun m (k,v) -> add k v m) m l let of_list l = add_list empty l diff --git a/src/core/CCMap.mli b/src/core/CCMap.mli index 51ec28fc..b8353066 100644 --- a/src/core/CCMap.mli +++ b/src/core/CCMap.mli @@ -56,6 +56,14 @@ module type S = sig val add_list : 'a t -> (key * 'a) list -> 'a t (** @since 0.14 *) + val keys : _ t -> key sequence + (** Iterate on keys only + @since NEXT_RELEASE *) + + val values : 'a t -> 'a sequence + (** Iterate on values only + @since NEXT_RELEASE *) + val to_list : 'a t -> (key * 'a) list val pp : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string -> From 95718e38b2092d683698c059c79a638cb6664501 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 1 Dec 2015 22:00:01 +0100 Subject: [PATCH 15/31] opam: depend on ocamlbuild --- opam | 1 + 1 file changed, 1 insertion(+) diff --git a/opam b/opam index 1d961671..acabc0f1 100644 --- a/opam +++ b/opam @@ -28,6 +28,7 @@ depends: [ "ocamlfind" {build} "base-bytes" "cppo" {build} + "ocamlbuild" {build} ] depopts: [ "sequence" "base-bigarray" "base-unix" "base-threads" ] tags: [ "stdlib" "containers" "iterators" "list" "heap" "queue" ] From 1d6cf2c683145b12c70251aa54d76eeb7ab6e891 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 2 Dec 2015 20:59:07 +0100 Subject: [PATCH 16/31] add `CCOrd.option` --- Makefile | 4 +- _tags | 145 ++++++++++ myocamlbuild.ml | 671 +++++++++++++++++++++++++++++++++++++++++++++ src/core/CCOrd.ml | 10 + src/core/CCOrd.mli | 4 + 5 files changed, 832 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 4f0e4731..b1d6c96b 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 9a60866e2fa295c5e33a3fe33b8f3a32) +# DO NOT EDIT (digest: 46f8bd9984975bd4727bed22d0876cd2) SETUP = ./setup.exe @@ -38,7 +38,7 @@ configure: $(SETUP) $(SETUP) -configure $(CONFIGUREFLAGS) setup.exe: setup.ml - ocamlfind ocamlopt -o $@ -linkpkg -package oasis.dynrun $< || ocamlfind ocamlc -o $@ -linkpkg -package oasis.dynrun $< || true + ocamlfind ocamlopt -o $@ $< || ocamlfind ocamlc -o $@ $< || true $(RM) setup.cmi setup.cmo setup.cmx setup.o .PHONY: build doc test all install uninstall reinstall clean distclean configure diff --git a/_tags b/_tags index a536b979..bdf2faa4 100644 --- a/_tags +++ b/_tags @@ -1,4 +1,149 @@ # OASIS_START +# DO NOT EDIT (digest: 0e7b7eeffb179d552ac9c060b7ab3be9) +# Ignore VCS directories, you can use the same kind of rule outside +# OASIS_START/STOP if you want to exclude directories that contains +# useless stuff for the build process +true: annot, bin_annot +<**/.svn>: -traverse +<**/.svn>: not_hygienic +".bzr": -traverse +".bzr": not_hygienic +".hg": -traverse +".hg": not_hygienic +".git": -traverse +".git": not_hygienic +"_darcs": -traverse +"_darcs": not_hygienic +# Library containers +"src/core/containers.cmxs": use_containers +: package(bytes) +# Library containers_io +"src/io/containers_io.cmxs": use_containers_io +: package(bytes) +# Library containers_unix +"src/unix/containers_unix.cmxs": use_containers_unix +: package(bytes) +: package(unix) +# Library containers_sexp +"src/sexp/containers_sexp.cmxs": use_containers_sexp +: package(bytes) +# Library containers_data +"src/data/containers_data.cmxs": use_containers_data +: package(bytes) +# Library containers_iter +"src/iter/containers_iter.cmxs": use_containers_iter +# Library containers_string +"src/string/containers_string.cmxs": use_containers_string +: package(bytes) +# Library containers_advanced +"src/advanced/containers_advanced.cmxs": use_containers_advanced +: package(bytes) +: package(sequence) +: use_containers +# Library containers_bigarray +"src/bigarray/containers_bigarray.cmxs": use_containers_bigarray +: package(bigarray) +: package(bytes) +: use_containers +# Library containers_thread +"src/threads/containers_thread.cmxs": use_containers_thread +: package(bytes) +: package(threads) +: use_containers +# Library containers_top +"src/top/containers_top.cmxs": use_containers_top +: package(bigarray) +: package(bytes) +: package(compiler-libs.common) +: package(unix) +: use_containers +: use_containers_bigarray +: use_containers_data +: use_containers_iter +: use_containers_sexp +: use_containers_string +: use_containers_unix +# Executable run_benchs +: package(benchmark) +: package(bytes) +: package(gen) +: package(hamt) +: package(sequence) +: package(threads) +: use_containers +: use_containers_advanced +: use_containers_data +: use_containers_iter +: use_containers_string +: use_containers_thread +: package(benchmark) +: package(gen) +: package(threads) +: use_containers_advanced +: use_containers_iter +: use_containers_string +: use_containers_thread +# Executable run_bench_hash +: package(bytes) +: use_containers +# Executable run_qtest +: package(QTest2Lib) +: package(bigarray) +: package(bytes) +: package(gen) +: package(oUnit) +: package(sequence) +: package(threads) +: package(unix) +: use_containers +: use_containers_advanced +: use_containers_bigarray +: use_containers_data +: use_containers_io +: use_containers_iter +: use_containers_sexp +: use_containers_string +: use_containers_thread +: use_containers_unix +: package(QTest2Lib) +: package(bigarray) +: package(bytes) +: package(gen) +: package(oUnit) +: package(sequence) +: package(threads) +: package(unix) +: use_containers +: use_containers_advanced +: use_containers_bigarray +: use_containers_data +: use_containers_io +: use_containers_iter +: use_containers_sexp +: use_containers_string +: use_containers_thread +: use_containers_unix +# Executable id_sexp +: package(bytes) +: use_containers_sexp +# Executable mem_measure +"benchs/mem_measure.native": package(bytes) +"benchs/mem_measure.native": package(hamt) +"benchs/mem_measure.native": package(sequence) +"benchs/mem_measure.native": package(unix) +"benchs/mem_measure.native": use_containers +"benchs/mem_measure.native": use_containers_data +: package(bytes) +: package(hamt) +: package(sequence) +: package(unix) +: use_containers +: use_containers_data +# Executable id_sexp2 +: package(bytes) +: use_containers_sexp +: package(bytes) +: use_containers_sexp # OASIS_STOP : thread : thread diff --git a/myocamlbuild.ml b/myocamlbuild.ml index a6f9fc91..b80ef8d1 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,4 +1,675 @@ (* OASIS_START *) +(* DO NOT EDIT (digest: b119194f5742ac2f3cdceac9a223dda7) *) +module OASISGettext = struct +(* # 22 "src/oasis/OASISGettext.ml" *) + + + let ns_ str = + str + + + let s_ str = + str + + + let f_ (str: ('a, 'b, 'c, 'd) format4) = + str + + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + + let init = + [] + + +end + +module OASISExpr = struct +(* # 22 "src/oasis/OASISExpr.ml" *) + + + + + + open OASISGettext + + + type test = string + + + type flag = string + + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + + type 'a choices = (t * 'a) list + + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + + +end + + +# 132 "myocamlbuild.ml" +module BaseEnvLight = struct +(* # 22 "src/base/BaseEnvLight.ml" *) + + + module MapString = Map.Make(String) + + + type t = string MapString.t + + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + + let rec var_expand str env = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = + var_expand (MapString.find name env) env + + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +# 237 "myocamlbuild.ml" +module MyOCamlbuildFindlib = struct +(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) + + + (** OCamlbuild extension, copied from + * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild + * by N. Pouillard and others + * + * Updated on 2009/02/28 + * + * Modified by Sylvain Le Gall + *) + open Ocamlbuild_plugin + + type conf = + { no_automatic_syntax: bool; + } + + (* these functions are not really officially exported *) + let run_and_read = + Ocamlbuild_pack.My_unix.run_and_read + + + let blank_sep_strings = + Ocamlbuild_pack.Lexers.blank_sep_strings + + + let exec_from_conf exec = + let exec = + let env_filename = Pathname.basename BaseEnvLight.default_filename in + let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in + try + BaseEnvLight.var_get exec env + with Not_found -> + Printf.eprintf "W: Cannot get variable %s\n" exec; + exec + in + let fix_win32 str = + if Sys.os_type = "Win32" then begin + let buff = Buffer.create (String.length str) in + (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. + *) + String.iter + (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) + str; + Buffer.contents buff + end else begin + str + end + in + fix_win32 exec + + let split s ch = + let buf = Buffer.create 13 in + let x = ref [] in + let flush () = + x := (Buffer.contents buf) :: !x; + Buffer.clear buf + in + String.iter + (fun c -> + if c = ch then + flush () + else + Buffer.add_char buf c) + s; + flush (); + List.rev !x + + + let split_nl s = split s '\n' + + + let before_space s = + try + String.before s (String.index s ' ') + with Not_found -> s + + (* ocamlfind command *) + let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] + + (* This lists all supported packages. *) + let find_packages () = + List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) + + + (* Mock to list available syntaxes. *) + let find_syntaxes () = ["camlp4o"; "camlp4r"] + + + let well_known_syntax = [ + "camlp4.quotations.o"; + "camlp4.quotations.r"; + "camlp4.exceptiontracer"; + "camlp4.extend"; + "camlp4.foldgenerator"; + "camlp4.listcomprehension"; + "camlp4.locationstripper"; + "camlp4.macro"; + "camlp4.mapgenerator"; + "camlp4.metagenerator"; + "camlp4.profiler"; + "camlp4.tracer" + ] + + + let dispatch conf = + function + | After_options -> + (* By using Before_options one let command line options have an higher + * priority on the contrary using After_options will guarantee to have + * the higher priority override default commands by ocamlfind ones *) + Options.ocamlc := ocamlfind & A"ocamlc"; + Options.ocamlopt := ocamlfind & A"ocamlopt"; + Options.ocamldep := ocamlfind & A"ocamldep"; + Options.ocamldoc := ocamlfind & A"ocamldoc"; + Options.ocamlmktop := ocamlfind & A"ocamlmktop"; + Options.ocamlmklib := ocamlfind & A"ocamlmklib" + + | After_rules -> + + (* When one link an OCaml library/binary/package, one should use + * -linkpkg *) + flag ["ocaml"; "link"; "program"] & A"-linkpkg"; + + if not (conf.no_automatic_syntax) then begin + (* For each ocamlfind package one inject the -package option when + * compiling, computing dependencies, generating documentation and + * linking. *) + List.iter + begin fun pkg -> + let base_args = [A"-package"; A pkg] in + (* TODO: consider how to really choose camlp4o or camlp4r. *) + let syn_args = [A"-syntax"; A "camlp4o"] in + let (args, pargs) = + (* Heuristic to identify syntax extensions: whether they end in + ".syntax"; some might not. + *) + if Filename.check_suffix pkg "syntax" || + List.mem pkg well_known_syntax then + (syn_args @ base_args, syn_args) + else + (base_args, []) + in + flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; + flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; + + (* TODO: Check if this is allowed for OCaml < 3.12.1 *) + flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; + end + (find_packages ()); + end; + + (* Like -package but for extensions syntax. Morover -syntax is useless + * when linking. *) + List.iter begin fun syntax -> + flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & + S[A"-syntax"; A syntax]; + end (find_syntaxes ()); + + (* The default "thread" tag is not compatible with ocamlfind. + * Indeed, the default rules add the "threads.cma" or "threads.cmxa" + * options when using this tag. When using the "-linkpkg" option with + * ocamlfind, this module will then be added twice on the command line. + * + * To solve this, one approach is to add the "-thread" option when using + * the "threads" package using the previous plugin. + *) + flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); + + | _ -> + () +end + +module MyOCamlbuildBase = struct +(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + + (** Base functions for writing myocamlbuild.ml + @author Sylvain Le Gall + *) + + + + + + open Ocamlbuild_plugin + module OC = Ocamlbuild_pack.Ocaml_compiler + + + type dir = string + type file = string + type name = string + type tag = string + + +(* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + + type t = + { + lib_ocaml: (name * dir list * string list) list; + lib_c: (name * dir * file list) list; + flags: (tag list * (spec OASISExpr.choices)) list; + (* Replace the 'dir: include' from _tags by a precise interdepends in + * directory. + *) + includes: (dir * dir list) list; + } + + + let env_filename = + Pathname.basename + BaseEnvLight.default_filename + + + let dispatch_combine lst = + fun e -> + List.iter + (fun dispatch -> dispatch e) + lst + + + let tag_libstubs nm = + "use_lib"^nm^"_stubs" + + + let nm_libstubs nm = + nm^"_stubs" + + + let dispatch t e = + let env = + BaseEnvLight.load + ~filename:env_filename + ~allow_empty:true + () + in + match e with + | Before_options -> + let no_trailing_dot s = + if String.length s >= 1 && s.[0] = '.' then + String.sub s 1 ((String.length s) - 1) + else + s + in + List.iter + (fun (opt, var) -> + try + opt := no_trailing_dot (BaseEnvLight.var_get var env) + with Not_found -> + Printf.eprintf "W: Cannot get variable %s\n" var) + [ + Options.ext_obj, "ext_obj"; + Options.ext_lib, "ext_lib"; + Options.ext_dll, "ext_dll"; + ] + + | After_rules -> + (* Declare OCaml libraries *) + List.iter + (function + | nm, [], intf_modules -> + ocaml_lib nm; + let cmis = + List.map (fun m -> (String.uncapitalize m) ^ ".cmi") + intf_modules in + dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis + | nm, dir :: tl, intf_modules -> + ocaml_lib ~dir:dir (dir^"/"^nm); + List.iter + (fun dir -> + List.iter + (fun str -> + flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) + ["compile"; "infer_interface"; "doc"]) + tl; + let cmis = + List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") + intf_modules in + dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] + cmis) + t.lib_ocaml; + + (* Declare directories dependencies, replace "include" in _tags. *) + List.iter + (fun (dir, include_dirs) -> + Pathname.define_context dir include_dirs) + t.includes; + + (* Declare C libraries *) + List.iter + (fun (lib, dir, headers) -> + (* Handle C part of library *) + flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; + A("-l"^(nm_libstubs lib))]); + + flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] + (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); + + flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); + + (* When ocaml link something that use the C library, then one + need that file to be up to date. + This holds both for programs and for libraries. + *) + dep ["link"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + dep ["compile"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + (* TODO: be more specific about what depends on headers *) + (* Depends on .h files *) + dep ["compile"; "c"] + headers; + + (* Setup search path for lib *) + flag ["link"; "ocaml"; "use_"^lib] + (S[A"-I"; P(dir)]); + ) + t.lib_c; + + (* Add flags *) + List.iter + (fun (tags, cond_specs) -> + let spec = BaseEnvLight.var_choose cond_specs env in + let rec eval_specs = + function + | S lst -> S (List.map eval_specs lst) + | A str -> A (BaseEnvLight.var_expand str env) + | spec -> spec + in + flag tags & (eval_specs spec)) + t.flags + | _ -> + () + + + let dispatch_default conf t = + dispatch_combine + [ + dispatch t; + MyOCamlbuildFindlib.dispatch conf; + ] + + +end + + +# 606 "myocamlbuild.ml" +open Ocamlbuild_plugin;; +let package_default = + { + MyOCamlbuildBase.lib_ocaml = + [ + ("containers", ["src/core"], []); + ("containers_io", ["src/io"], []); + ("containers_unix", ["src/unix"], []); + ("containers_sexp", ["src/sexp"], []); + ("containers_data", ["src/data"], []); + ("containers_iter", ["src/iter"], []); + ("containers_string", ["src/string"], []); + ("containers_advanced", ["src/advanced"], []); + ("containers_bigarray", ["src/bigarray"], []); + ("containers_thread", ["src/threads"], []); + ("containers_top", ["src/top"], []) + ]; + lib_c = []; + flags = []; + includes = + [ + ("src/top", + [ + "src/bigarray"; + "src/core"; + "src/data"; + "src/iter"; + "src/sexp"; + "src/string"; + "src/unix" + ]); + ("src/threads", ["src/core"]); + ("src/bigarray", ["src/core"]); + ("src/advanced", ["src/core"]); + ("qtest", + [ + "src/advanced"; + "src/bigarray"; + "src/core"; + "src/data"; + "src/io"; + "src/iter"; + "src/sexp"; + "src/string"; + "src/threads"; + "src/unix" + ]); + ("examples", ["src/sexp"]); + ("benchs", + [ + "src/advanced"; + "src/core"; + "src/data"; + "src/iter"; + "src/string"; + "src/threads" + ]) + ] + } + ;; + +let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} + +let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; + +# 673 "myocamlbuild.ml" (* OASIS_STOP *) let doc_intro = "doc/intro.txt" diff --git a/src/core/CCOrd.ml b/src/core/CCOrd.ml index 4f2ace2a..f1c974b3 100644 --- a/src/core/CCOrd.ml +++ b/src/core/CCOrd.ml @@ -59,6 +59,16 @@ let () c (ord,x,y) = then ord x y else c +let option c o1 o2 = match o1, o2 with + | None, None -> 0 + | None, Some _ -> -1 + | Some _, None -> 1 + | Some x1, Some x2 -> c x1 x2 + +(*$Q + Q.(option int) (fun o -> option int_ None o <= 0) + *) + let pair o_x o_y (x1,y1) (x2,y2) = let c = o_x x1 x2 in if c = 0 diff --git a/src/core/CCOrd.mli b/src/core/CCOrd.mli index 52dae3b7..39949131 100644 --- a/src/core/CCOrd.mli +++ b/src/core/CCOrd.mli @@ -55,6 +55,10 @@ val () : int -> ('a t * 'a * 'a) -> int (CCBool.compare, true, false)]} *) +val option : 'a t -> 'a option t +(** Comparison of optional values. [None] is smaller than any [Some _]. + @since NEXT_RELEASE *) + val pair : 'a t -> 'b t -> ('a * 'b) t val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t From fdfc106cad46c441564d5e5693093968f294e7e7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 2 Dec 2015 15:31:52 +0100 Subject: [PATCH 17/31] basic ANSI codes for colors in `CCFormat` --- src/core/CCFormat.ml | 31 +++++++++++++++++++++++++++++++ src/core/CCFormat.mli | 24 ++++++++++++++++++++++++ 2 files changed, 55 insertions(+) diff --git a/src/core/CCFormat.ml b/src/core/CCFormat.ml index bdb425d6..58b1636a 100644 --- a/src/core/CCFormat.ml +++ b/src/core/CCFormat.ml @@ -159,3 +159,34 @@ let _with_file_out filename f = let to_file filename format = _with_file_out filename (fun fmt -> Format.fprintf fmt format) + +type color = + [ `Black + | `Red + | `Yellow + | `Green + | `Blue + | `Magenta + | `Cyan + | `White + ] + +let int_of_color_ = function + | `Black -> 0 + | `Red -> 1 + | `Green -> 2 + | `Yellow -> 3 + | `Blue -> 4 + | `Magenta -> 5 + | `Cyan -> 6 + | `White -> 7 + +(* same as [pp], but in color [c] *) +let color_str c out s = + let n = int_of_color_ c in + Format.fprintf out "\x1b[3%dm%s\x1b[0m" n s + +(* same as [pp], but in bold color [c] *) +let bold_str c out s = + let n = int_of_color_ c in + Format.fprintf out "\x1b[3%d;1m%s\x1b[0m" n s diff --git a/src/core/CCFormat.mli b/src/core/CCFormat.mli index bb7279d6..95a53ad6 100644 --- a/src/core/CCFormat.mli +++ b/src/core/CCFormat.mli @@ -66,6 +66,30 @@ val quad : 'a printer -> 'b printer -> 'c printer -> 'd printer -> ('a * 'b * 'c val map : ('a -> 'b) -> 'b printer -> 'a printer +(** {2 ASCII codes} + + Use ANSI escape codes https://en.wikipedia.org/wiki/ANSI_escape_code + to put some colors on the terminal. + We only allow styling of constant strings, because nesting is almost + impossible with ANSI codes (unless we maintain a stack of codes explicitely). + + @since NEXT_RELEASE *) + +type color = + [ `Black + | `Red + | `Yellow + | `Green + | `Blue + | `Magenta + | `Cyan + | `White + ] + +val color_str : color -> string printer + +val bold_str : color -> string printer + (** {2 IO} *) val output : t -> 'a printer -> 'a -> unit From d946b8a159cd9e4f05566922871451ac71656980 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 10 Dec 2015 19:58:15 +0100 Subject: [PATCH 18/31] we need oasis to build (on the dev branch) --- opam | 1 + 1 file changed, 1 insertion(+) diff --git a/opam b/opam index acabc0f1..a3b0dfe8 100644 --- a/opam +++ b/opam @@ -28,6 +28,7 @@ depends: [ "ocamlfind" {build} "base-bytes" "cppo" {build} + "oasis" {build} "ocamlbuild" {build} ] depopts: [ "sequence" "base-bigarray" "base-unix" "base-threads" ] From 24d9213cae2cf8602b47fd73a73e3e364b90a164 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 10 Dec 2015 20:32:06 +0100 Subject: [PATCH 19/31] bugfix: forgot to exporte `{Set.Map}.OrderedType` in `Containers` --- src/core/containers.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/core/containers.ml b/src/core/containers.ml index 1c527b6b..5f5b4b05 100644 --- a/src/core/containers.ml +++ b/src/core/containers.ml @@ -79,7 +79,10 @@ module List = struct include List include CCList end -module Map = CCMap +module Map = struct + module type OrderedType = Map.OrderedType + include CCMap +end module Option = CCOpt module Pair = CCPair module Random = struct @@ -87,7 +90,10 @@ module Random = struct include CCRandom end module Ref = CCRef -module Set = CCSet +module Set = struct + module type OrderedType = Set.OrderedType + include CCSet +end module String = struct include String include CCString From b8e2db95df7acc0b525c5d7fe6fc8ddfa64d5cee Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 11 Dec 2015 17:50:02 +0100 Subject: [PATCH 20/31] oasis stuff --- Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index b1d6c96b..4f0e4731 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 46f8bd9984975bd4727bed22d0876cd2) +# DO NOT EDIT (digest: 9a60866e2fa295c5e33a3fe33b8f3a32) SETUP = ./setup.exe @@ -38,7 +38,7 @@ configure: $(SETUP) $(SETUP) -configure $(CONFIGUREFLAGS) setup.exe: setup.ml - ocamlfind ocamlopt -o $@ $< || ocamlfind ocamlc -o $@ $< || true + ocamlfind ocamlopt -o $@ -linkpkg -package oasis.dynrun $< || ocamlfind ocamlc -o $@ -linkpkg -package oasis.dynrun $< || true $(RM) setup.cmi setup.cmo setup.cmx setup.o .PHONY: build doc test all install uninstall reinstall clean distclean configure From 73cb338ba91642d6f1f7d3d0265d2ab80610627c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 14 Dec 2015 14:48:19 +0100 Subject: [PATCH 21/31] makefile --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 4f0e4731..48d9c2fc 100644 --- a/Makefile +++ b/Makefile @@ -129,7 +129,7 @@ devel: make all watch: - while find src/ -print0 | xargs -0 inotifywait -e delete_self -e modify ; do \ + while find src/ benchs/ -print0 | xargs -0 inotifywait -e delete_self -e modify ; do \ echo "============ at `date` ==========" ; \ make ; \ done From 9cddc2bcf164ca6dafb8267fc6443496b4ddefc1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 14 Dec 2015 14:55:39 +0100 Subject: [PATCH 22/31] some benchmarks for graphs --- benchs/run_benchs.ml | 75 ++++++++++++++++++++++++++++++++++++++++++++ src/data/CCGraph.mli | 1 + 2 files changed, 76 insertions(+) diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index 147ea507..ed1605f2 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -1032,6 +1032,81 @@ module Thread = struct ) end +module Graph = struct + + (* divisors graph *) + let div_children_ i = + (* divisors of [i] that are [>= j] *) + let rec aux j i yield = + if j < i + then ( + if (i mod j = 0) then yield (i,j); + aux (j+1) i yield + ) + in + aux 1 i + + let div_graph_ = {CCGraph. + origin=fst; + dest=snd; + children=div_children_ + } + + module H = Hashtbl.Make(CCInt) + + let dfs_raw n () = + let explored = H.create (n+10) in + let st = Stack.create() in + let res = ref 0 in + Stack.push n st; + while not (Stack.is_empty st) do + let i = Stack.pop st in + if not (H.mem explored i) then ( + H.add explored i (); + incr res; + div_children_ i (fun (_,j) -> Stack.push j st); + ) + done; + !res + + let dfs_ n () = + let tbl = CCGraph.mk_table ~eq:CCInt.equal ~hash:CCInt.hash (n+10) in + CCGraph.Traverse.dfs ~tbl ~graph:div_graph_ + (Sequence.return n) + |> Sequence.fold (fun acc _ -> acc+1) 0 + + let dfs_event n () = + let tbl = CCGraph.mk_table ~eq:CCInt.equal ~hash:CCInt.hash (n+10) in + CCGraph.Traverse.Event.dfs ~tbl ~graph:div_graph_ + (Sequence.return n) + |> Sequence.fold + (fun acc -> function + | `Enter _ -> acc+1 + | `Exit _ + | `Edge _ -> acc) + 0 + + let bench_dfs n = + assert ( + let n1 = dfs_raw n () in + let n2 = dfs_ n () in + let n3 = dfs_event n () in + n1 = n2 && + n2 = n3); + B.throughputN 2 ~repeat + [ "raw", dfs_raw n, () + ; "ccgraph", dfs_ n, () + ; "ccgraph_event", dfs_event n, () + ] + + let () = + B.Tree.register ("graph" @>>> + [ "dfs" @>> + app_ints bench_dfs [100; 1000; 10_000; 50_000; 100_000; 500_000] + ] + ) +end + module Alloc = struct module type ALLOC_ARR = sig type 'a t diff --git a/src/data/CCGraph.mli b/src/data/CCGraph.mli index e59fc5ea..1e37ac25 100644 --- a/src/data/CCGraph.mli +++ b/src/data/CCGraph.mli @@ -273,6 +273,7 @@ val scc : ?tbl:('v, 'v scc_state) table -> in the graph. Uses {{: https://en.wikipedia.org/wiki/Tarjan's_strongly_connected_components_algorithm} Tarjan's algorithm} @param tbl table used to map nodes to some hidden state + @raise Sequence_once if the result is iterated on more than once. *) (** {2 Pretty printing in the DOT (graphviz) format} From ca4f789967311ce25c127ba04bb5a38894f51a5e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 14 Dec 2015 15:13:06 +0100 Subject: [PATCH 23/31] compare persistent hashtables to regular hashtables, too --- benchs/run_benchs.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index ed1605f2..555ca079 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -582,8 +582,9 @@ module Tbl = struct ; "find_string" @>> app_ints bench_find_string [10; 20; 100; 1_000; 10_000] ]); B.Tree.register ("tbl_persistent" @>>> - let l_int = [persistent_hashtbl Int; persistent_hashtbl_ref Int] in - let l_str = [persistent_hashtbl Str; persistent_hashtbl_ref Str] in + (* we also compare to the regular Hashtbl, as a frame of reference *) + let l_int = [persistent_hashtbl Int; persistent_hashtbl_ref Int; hashtbl_make Int ] in + let l_str = [persistent_hashtbl Str; persistent_hashtbl_ref Str; hashtbl_make Str ] in [ "add_int" @>> app_ints (bench_add_to l_int) [10; 100; 1_000; 10_000;] ; "find_int" @>> app_ints (bench_find_to (List.map find_of_mut l_int)) From 3ac1eff2af0f54e5759090b8b5f953c207e1a190 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 14 Dec 2015 17:46:26 +0100 Subject: [PATCH 24/31] add `CCVector.ro_vector` as a convenience alias --- src/core/CCVector.ml | 2 ++ src/core/CCVector.mli | 4 ++++ 2 files changed, 6 insertions(+) diff --git a/src/core/CCVector.ml b/src/core/CCVector.ml index 2bb0d17a..39f53715 100644 --- a/src/core/CCVector.ml +++ b/src/core/CCVector.ml @@ -44,6 +44,8 @@ type ('a,'mut) t = { type 'a vector = ('a, rw) t +type 'a ro_vector = ('a, ro) t + let freeze v = { size=v.size; vec=v.vec; diff --git a/src/core/CCVector.mli b/src/core/CCVector.mli index d4beb99d..2a9986a8 100644 --- a/src/core/CCVector.mli +++ b/src/core/CCVector.mli @@ -37,6 +37,10 @@ type ('a, 'mut) t type 'a vector = ('a, rw) t (** Type synonym: a ['a vector] is mutable. *) +type 'a ro_vector = ('a, ro) t +(** Alias for immutable vectors. + @since NEXT_RELEASE *) + type 'a sequence = ('a -> unit) -> unit type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] type 'a gen = unit -> 'a option From c58d31ed98868fedfd6d45eea4f4243d929b2b17 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 15 Dec 2015 16:49:32 +0100 Subject: [PATCH 25/31] doc --- src/data/CCGraph.mli | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/data/CCGraph.mli b/src/data/CCGraph.mli index 1e37ac25..f8710e82 100644 --- a/src/data/CCGraph.mli +++ b/src/data/CCGraph.mli @@ -271,6 +271,8 @@ val scc : ?tbl:('v, 'v scc_state) table -> (** Strongly connected components reachable from the given vertices. Each component is a list of vertices that are all mutually reachable in the graph. + The components are explored in a topological order (if C1 and C2 are + components, and C1 points to C2, then C2 will be yielded before C1). Uses {{: https://en.wikipedia.org/wiki/Tarjan's_strongly_connected_components_algorithm} Tarjan's algorithm} @param tbl table used to map nodes to some hidden state @raise Sequence_once if the result is iterated on more than once. From 90a611fdfdfe740afe5e862d147282e9a5a11546 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Dec 2015 10:20:39 +0100 Subject: [PATCH 26/31] use tags for color handling in `CCFormat` --- src/core/CCFormat.ml | 134 ++++++++++++++++++++++++++++++++++-------- src/core/CCFormat.mli | 55 ++++++++++++----- 2 files changed, 150 insertions(+), 39 deletions(-) diff --git a/src/core/CCFormat.ml b/src/core/CCFormat.ml index 58b1636a..51ec4613 100644 --- a/src/core/CCFormat.ml +++ b/src/core/CCFormat.ml @@ -122,24 +122,8 @@ let to_string pp x = Format.pp_print_flush fmt (); Buffer.contents buf -let sprintf format = - let buf = Buffer.create 64 in - let fmt = Format.formatter_of_buffer buf in - Format.kfprintf - (fun _fmt -> Format.pp_print_flush fmt (); Buffer.contents buf) - fmt - format - let fprintf = Format.fprintf - -let ksprintf ~f fmt = - let buf = Buffer.create 32 in - let out = Format.formatter_of_buffer buf in - Format.kfprintf - (fun _ -> Format.pp_print_flush out (); f (Buffer.contents buf)) - out fmt - let stdout = Format.std_formatter let stderr = Format.err_formatter @@ -181,12 +165,114 @@ let int_of_color_ = function | `Cyan -> 6 | `White -> 7 -(* same as [pp], but in color [c] *) -let color_str c out s = - let n = int_of_color_ c in - Format.fprintf out "\x1b[3%dm%s\x1b[0m" n s +type style = + [ `FG of color (* foreground *) + | `BG of color (* background *) + | `Bold + | `Reset + ] -(* same as [pp], but in bold color [c] *) -let bold_str c out s = - let n = int_of_color_ c in - Format.fprintf out "\x1b[3%d;1m%s\x1b[0m" n s +let code_of_style : style -> int = function + | `FG c -> 30 + int_of_color_ c + | `BG c -> 40 + int_of_color_ c + | `Bold -> 1 + | `Reset -> 0 + +let ansi_l_to_str_ = function + | [] -> "\x1b[0m" + | [a] -> Format.sprintf "\x1b[%dm" (code_of_style a) + | [a;b] -> Format.sprintf "\x1b[%d;%dm" (code_of_style a) (code_of_style b) + | l -> + let pp_num out c = int out (code_of_style c) in + to_string (list ~start:"\x1b[" ~stop:"m" ~sep:";" pp_num) l + +(* parse a tag *) +let style_of_tag_ s = match String.trim s with + | "reset" -> [`Reset] + | "black" -> [`FG `Black] + | "red" -> [`FG `Red] + | "green" -> [`FG `Green] + | "yellow" -> [`FG `Yellow] + | "blue" -> [`FG `Blue] + | "magenta" -> [`FG `Magenta] + | "cyan" -> [`FG `Cyan] + | "white" -> [`FG `White] + | "Black" -> [`FG `Black] + | "Red" -> [`FG `Red; `Bold] + | "Green" -> [`FG `Green; `Bold] + | "Yellow" -> [`FG `Yellow; `Bold] + | "Blue" -> [`FG `Blue; `Bold] + | "Magenta" -> [`FG `Magenta; `Bold] + | "Cyan" -> [`FG `Cyan; `Bold] + | "White" -> [`FG `White; `Bold] + | s -> failwith ("unknown style: " ^ s) + +let color_enabled = ref false + +(* either prints the tag of [s] or delegate to [or_else] *) +let mark_open_tag ~or_else s = + try + let style = style_of_tag_ s in + if !color_enabled then ansi_l_to_str_ style else "" + with Not_found -> or_else s + +let mark_close_tag ~or_else s = + try + let _ = style_of_tag_ s in (* check if it's indeed about color *) + if !color_enabled then ansi_l_to_str_ [`Reset] else "" + with Not_found -> or_else s + +(* add color handling to formatter [ppf] *) +let set_color_tag_handling ppf = + let open Format in + let functions = pp_get_formatter_tag_functions ppf () in + let functions' = {functions with + mark_open_tag=(mark_open_tag ~or_else:functions.mark_open_tag); + mark_close_tag=(mark_close_tag ~or_else:functions.mark_close_tag); + } in + pp_set_mark_tags ppf true; (* enable tags *) + pp_set_formatter_tag_functions ppf functions' + +let set_color_default = + let first = ref true in + fun b -> + if b && not !color_enabled then ( + color_enabled := true; + if !first then ( + first := false; + set_color_tag_handling stdout; + set_color_tag_handling stderr; + ); + ) else if not b && !color_enabled then color_enabled := false + +(*$R + set_color_default true; + let s = sprintf + "what is your @{favorite color@}? @{blue@}! No, @{red@}! Ahhhhhhh@." + in + assert_equal ~printer:CCFun.id + "what is your \027[37;1mfavorite color\027[0m? \027[34mblue\027[0m! No, \027[31mred\027[0m! Ahhhhhhh\n" + s +*) + +let sprintf format = + let buf = Buffer.create 64 in + let fmt = Format.formatter_of_buffer buf in + if !color_enabled then set_color_tag_handling fmt; + Format.kfprintf + (fun _fmt -> Format.pp_print_flush fmt (); Buffer.contents buf) + fmt + format + +(*$T + sprintf "yolo %s %d" "a b" 42 = "yolo a b 42" + sprintf "%d " 0 = "0 " +*) + +let ksprintf ~f fmt = + let buf = Buffer.create 32 in + let out = Format.formatter_of_buffer buf in + if !color_enabled then set_color_tag_handling out; + Format.kfprintf + (fun _ -> Format.pp_print_flush out (); f (Buffer.contents buf)) + out fmt diff --git a/src/core/CCFormat.mli b/src/core/CCFormat.mli index 95a53ad6..a9550402 100644 --- a/src/core/CCFormat.mli +++ b/src/core/CCFormat.mli @@ -70,25 +70,50 @@ val map : ('a -> 'b) -> 'b printer -> 'a printer Use ANSI escape codes https://en.wikipedia.org/wiki/ANSI_escape_code to put some colors on the terminal. - We only allow styling of constant strings, because nesting is almost - impossible with ANSI codes (unless we maintain a stack of codes explicitely). + This uses {b tags} in format strings to specify the style. Current styles + are the following: + + {ul + {- "reset" resets style} + {- "black" } + {- "red" } + {- "green" } + {- "yellow" } + {- "blue" } + {- "magenta" } + {- "cyan" } + {- "white" } + {- "Black" bold black} + {- "Red" bold red } + {- "Green" bold green } + {- "Yellow" bold yellow } + {- "Blue" bold blue } + {- "Magenta" bold magenta } + {- "Cyan" bold cyan } + {- "White" bold white } + } + + Example: + + {[ + set_color_default true;; + + Format.printf + "what is your @{favorite color@}? @{blue@}! No, @{red@}! Ahhhhhhh@.";; + ]} + + {b status: experimental} @since NEXT_RELEASE *) -type color = - [ `Black - | `Red - | `Yellow - | `Green - | `Blue - | `Magenta - | `Cyan - | `White - ] +val set_color_tag_handling : t -> unit +(** adds functions to support color tags to the given formatter. + @since NEXT_RELEASE *) -val color_str : color -> string printer - -val bold_str : color -> string printer +val set_color_default : bool -> unit +(** [set_color_default b] enables color handling on the standard formatters + (stdout, stderr) if [b = true] as well as on {!sprintf} formatters; + it disables the color handling if [b = false]. *) (** {2 IO} *) From 112dd7da1b7339cb202da6106e9eb28c7d18ea90 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Dec 2015 10:21:27 +0100 Subject: [PATCH 27/31] doc --- src/data/CCAllocCache.mli | 1 + 1 file changed, 1 insertion(+) diff --git a/src/data/CCAllocCache.mli b/src/data/CCAllocCache.mli index 3ad61274..4a54fa8f 100644 --- a/src/data/CCAllocCache.mli +++ b/src/data/CCAllocCache.mli @@ -6,6 +6,7 @@ Be very careful not to use-after-free or double-free. {b NOT THREAD SAFE} + {b status: experimental} @since NEXT_RELEASE From 7e86889f1e808cecbca49bb97c50103a956aef32 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Dec 2015 10:22:30 +0100 Subject: [PATCH 28/31] remove deprecated `CCFloat.sign` --- src/core/CCFloat.ml | 5 ----- src/core/CCFloat.mli | 5 ----- 2 files changed, 10 deletions(-) diff --git a/src/core/CCFloat.ml b/src/core/CCFloat.ml index b73b311b..75336d7f 100644 --- a/src/core/CCFloat.ml +++ b/src/core/CCFloat.ml @@ -71,11 +71,6 @@ type 'a random_gen = Random.State.t -> 'a let pp buf = Printf.bprintf buf "%f" let print fmt = Format.pp_print_float fmt -let sign (a:float) = - if a < 0.0 then -1 - else if a > 0.0 then 1 - else 0 - let fsign a = if is_nan a then nan else if a = 0. then a diff --git a/src/core/CCFloat.mli b/src/core/CCFloat.mli index 7485206d..1cc33188 100644 --- a/src/core/CCFloat.mli +++ b/src/core/CCFloat.mli @@ -76,11 +76,6 @@ val random : t -> t random_gen val random_small : t random_gen val random_range : t -> t -> t random_gen -val sign : t -> int -(** [sign t] is one of [-1, 0, 1], depending on how the float - compares to [0.] - @deprecated since 0.7 use {! fsign} or {!sign_exn} since it's more accurate *) - val fsign : t -> float (** [fsign x] is one of [-1., -0., +0., +1.], or [nan] if [x] is NaN. @since 0.7 *) From 07382c02dd1e34bcea71fdf6e77d246dc15db9e9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Dec 2015 10:26:56 +0100 Subject: [PATCH 29/31] remove deprecated `CCSexpStream` module --- _oasis | 13 +- doc/intro.txt | 1 - examples/id_sexp.ml | 4 +- examples/id_sexp2.ml | 13 - src/sexp/CCSexpStream.ml | 559 -------------------------------------- src/sexp/CCSexpStream.mli | 199 -------------- 6 files changed, 5 insertions(+), 784 deletions(-) delete mode 100644 examples/id_sexp2.ml delete mode 100644 src/sexp/CCSexpStream.ml delete mode 100644 src/sexp/CCSexpStream.mli diff --git a/_oasis b/_oasis index 2fd334a6..feb3094f 100644 --- a/_oasis +++ b/_oasis @@ -66,7 +66,7 @@ Library "containers_unix" Library "containers_sexp" Path: src/sexp - Modules: CCSexp, CCSexpStream, CCSexpM + Modules: CCSexp, CCSexpM BuildDepends: bytes FindlibParent: containers FindlibName: sexp @@ -182,13 +182,6 @@ Test all TestTools: run_qtest Run$: flag(tests) && flag(unix) && flag(advanced) && flag(bigarray) -Executable id_sexp - Path: examples/ - Install: false - CompiledObject: best - MainIs: id_sexp.ml - BuildDepends: containers.sexp - Executable mem_measure Path: benchs/ Install: false @@ -197,11 +190,11 @@ Executable mem_measure Build$: flag(bench) BuildDepends: sequence, unix, containers, containers.data, hamt -Executable id_sexp2 +Executable id_sexp Path: examples/ Install: false CompiledObject: best - MainIs: id_sexp2.ml + MainIs: id_sexp.ml BuildDepends: containers.sexp SourceRepository head diff --git a/doc/intro.txt b/doc/intro.txt index 79b5aee3..b3482bf8 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -106,7 +106,6 @@ the main type ([CCSexp.t]) isn't. {!modules: CCSexp -CCSexpStream CCSexpM } diff --git a/examples/id_sexp.ml b/examples/id_sexp.ml index 1adf3080..90e63c27 100644 --- a/examples/id_sexp.ml +++ b/examples/id_sexp.ml @@ -3,11 +3,11 @@ let () = if Array.length Sys.argv <> 2 then failwith "usage: id_sexp file"; let f = Sys.argv.(1) in - let s = CCSexpStream.L.of_file f in + let s = CCSexpM.parse_file_list f in match s with | `Ok l -> List.iter - (fun s -> Format.printf "@[%a@]@." CCSexpStream.print s) + (fun s -> Format.printf "@[%a@]@." CCSexpM.print s) l | `Error msg -> Format.printf "error: %s@." msg diff --git a/examples/id_sexp2.ml b/examples/id_sexp2.ml deleted file mode 100644 index 90e63c27..00000000 --- a/examples/id_sexp2.ml +++ /dev/null @@ -1,13 +0,0 @@ - - -let () = - if Array.length Sys.argv <> 2 then failwith "usage: id_sexp file"; - let f = Sys.argv.(1) in - let s = CCSexpM.parse_file_list f in - match s with - | `Ok l -> - List.iter - (fun s -> Format.printf "@[%a@]@." CCSexpM.print s) - l - | `Error msg -> - Format.printf "error: %s@." msg diff --git a/src/sexp/CCSexpStream.ml b/src/sexp/CCSexpStream.ml deleted file mode 100644 index 4dc20ad2..00000000 --- a/src/sexp/CCSexpStream.ml +++ /dev/null @@ -1,559 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 S-expressions Parser} *) - -type 'a or_error = [ `Ok of 'a | `Error of string ] -type 'a sequence = ('a -> unit) -> unit -type 'a gen = unit -> 'a option - -type t = [ - | `Atom of string - | `List of t list - ] - -let _with_in filename f = - let ic = open_in filename in - try - let x = f ic in - close_in ic; - x - with e -> - close_in ic; - `Error (Printexc.to_string e) - -let _with_out filename f = - let oc = open_out filename in - try - let x = f oc in - close_out oc; - x - with e -> - close_out oc; - raise e - -(** {2 Serialization (encoding)} *) - -(* shall we escape the string because of one of its chars? *) -let _must_escape s = - try - for i = 0 to String.length s - 1 do - let c = String.unsafe_get s i in - match c with - | ' ' | ';' | ')' | '(' | '"' | '\n' | '\t' -> raise Exit - | _ when Char.code c > 127 -> raise Exit (* non-ascii *) - | _ -> () - done; - false - with Exit -> true - -let rec to_buf b t = match t with - | `Atom s when _must_escape s -> Printf.bprintf b "\"%s\"" (String.escaped s) - | `Atom s -> Buffer.add_string b s - | `List [] -> Buffer.add_string b "()" - | `List [x] -> Printf.bprintf b "(%a)" to_buf x - | `List l -> - Buffer.add_char b '('; - List.iteri - (fun i t' -> (if i > 0 then Buffer.add_char b ' '; to_buf b t')) - l; - Buffer.add_char b ')' - -let to_string t = - let b = Buffer.create 128 in - to_buf b t; - Buffer.contents b - -let rec print fmt t = match t with - | `Atom s when _must_escape s -> Format.fprintf fmt "\"%s\"" (String.escaped s) - | `Atom s -> Format.pp_print_string fmt s - | `List [] -> Format.pp_print_string fmt "()" - | `List [x] -> Format.fprintf fmt "@[(%a)@]" print x - | `List l -> - Format.open_hovbox 2; - Format.pp_print_char fmt '('; - List.iteri - (fun i t' -> (if i > 0 then Format.fprintf fmt "@ "; print fmt t')) - l; - Format.pp_print_char fmt ')'; - Format.close_box () - -let rec print_noindent fmt t = match t with - | `Atom s when _must_escape s -> Format.fprintf fmt "\"%s\"" (String.escaped s) - | `Atom s -> Format.pp_print_string fmt s - | `List [] -> Format.pp_print_string fmt "()" - | `List [x] -> Format.fprintf fmt "(%a)" print_noindent x - | `List l -> - Format.pp_print_char fmt '('; - List.iteri - (fun i t' -> (if i > 0 then Format.pp_print_char fmt ' '; print_noindent fmt t')) - l; - Format.pp_print_char fmt ')' - -let to_chan oc t = - let fmt = Format.formatter_of_out_channel oc in - print fmt t; - Format.pp_print_flush fmt () - -let to_file_seq filename seq = - _with_out filename - (fun oc -> - seq (fun t -> to_chan oc t; output_char oc '\n') - ) - -let to_file filename t = to_file_seq filename (fun k -> k t) - -(** {2 Deserialization (decoding)} *) - -type 'a parse_result = ['a or_error | `End ] -type 'a partial_result = [ 'a parse_result | `Await ] - -module Source = struct - type individual_char = - | NC_yield of char - | NC_end - | NC_await - - type t = unit -> individual_char - type source = t - - module Manual = struct - type t = { - mutable i : int; (* offset *) - mutable stop : bool; - buf : Buffer.t; (* accessible chunk of input *) - } - - let make() = { - i = 0; - stop = false; - buf=Buffer.create 32; - } - - let to_src d () = - if d.i = Buffer.length d.buf - then - if d.stop then NC_end else NC_await - else ( - let c = Buffer.nth d.buf d.i in - d.i <- d.i + 1; - NC_yield c - ) - - let feed d s i len = - if d.stop then failwith "CCSexpStream.Source.Manual.feed: reached EOI"; - Buffer.add_substring d.buf s i len - - let reached_end d = d.stop <- true - end - - let of_string s = - let i = ref 0 in - fun () -> - if !i=String.length s - then NC_end - else ( - let c = String.get s !i in - incr i; - NC_yield c - ) - - let of_chan ?(bufsize=1024) ic = - let buf = Bytes.make bufsize ' ' in - let i = ref 0 in - let n = ref 0 in - let stop = ref false in - let rec next() = - if !stop then NC_end - else if !i = !n - then ( (* refill *) - i := 0; - n := input ic buf 0 bufsize; - if !n = 0 then (stop := true; NC_end) else next() - ) else ( (* yield *) - let c = Bytes.get buf !i in - incr i; - NC_yield c - ) - in next - - let of_gen g = - let s = ref "" in - let i = ref 0 in - let stop = ref false in - let rec next() = - if !stop then NC_end - else if !i = String.length !s - then ( - match g() with - | None -> stop := true; NC_end - | Some buf -> s := buf; i := 0; next () - ) else ( - let c = String.get !s !i in - incr i; - NC_yield c - ) - in next -end - -module Lexer = struct - (** An individual character returned by a source *) - type token = - | Open - | Close - | Atom of string - - type decode_state = - | St_start - | St_atom - | St_quoted - | St_comment - | St_escaped - | St_raw_char1 of int - | St_raw_char2 of int - | St_yield of token - | St_error of string - | St_end - - type t = { - src : Source.t; - atom : Buffer.t; (* atom being parsed *) - mutable st : decode_state; - mutable line : int; - mutable col : int; - } - - let make src = { - src; - st = St_start; - line = 1; - col = 1; - atom = Buffer.create 32; - } - - let of_string s = make (Source.of_string s) - - let of_chan ic = make (Source.of_chan ic) - - let line t = t.line - let col t = t.col - - (* yield [x] with current state [st] *) - let _yield d st x = - d.st <- st; - `Ok x - - let _take_buffer b = - let s = Buffer.contents b in - Buffer.clear b; - s - - (* raise an error *) - let _error d msg = - let b = Buffer.create 32 in - Printf.bprintf b "at %d, %d: " d.line d.col; - Printf.kbprintf - (fun b -> - let msg' = Buffer.contents b in - d.st <- St_error msg'; - `Error msg') - b msg - - let _end d = - d.st <- St_end; - `End - - let _is_digit c = Char.code '0' <= Char.code c && Char.code c <= Char.code '9' - let _digit2i c = Char.code c - Char.code '0' - - (* next token *) - let rec _next d st : token partial_result = - match st with - | St_error msg -> `Error msg - | St_end -> _end d - | St_yield x -> - (* yield the given token, then start a fresh one *) - _yield d St_start x - | _ -> - d.st <- st; - _process_next d st - - (* read and process the next character *) - and _process_next d st = - match d.src () with - | Source.NC_end -> - begin match st with - | St_error _ | St_end | St_yield _ -> assert false - | St_start | St_comment -> _end d - | St_atom -> - let a = _take_buffer d.atom in - _yield d St_end (Atom a) - | St_quoted -> - let a = _take_buffer d.atom in - _yield d St_end (Atom a) - | (St_escaped | St_raw_char1 _ | St_raw_char2 _) -> - _error d "unexpected end of input (escaping)" - end - | Source.NC_await -> `Await - | Source.NC_yield c -> - if c='\n' - then (d.col <- 1; d.line <- d.line + 1) - else (d.col <- d.col + 1); - (* use the next char *) - match st with - | St_error _ | St_end | St_yield _ -> assert false - | St_comment -> - begin match c with - | '\n' -> _next d St_start - | _ -> _next d St_comment - end - | St_start -> - begin match c with - | ' ' | '\t' | '\n' -> _next d St_start - | ';' -> _next d St_comment - | '(' -> _yield d St_start Open - | ')' -> _yield d St_start Close - | '"' -> _next d St_quoted - | _ -> (* read regular atom *) - Buffer.add_char d.atom c; - _next d St_atom - end - | St_atom -> - begin match c with - | ' ' | '\t' | '\n' -> - let a = _take_buffer d.atom in - _yield d St_start (Atom a) - | ';' -> - let a = _take_buffer d.atom in - _yield d St_comment (Atom a) - | ')' -> - let a = _take_buffer d.atom in - _yield d (St_yield Close) (Atom a) - | '(' -> - let a = _take_buffer d.atom in - _yield d (St_yield Open) (Atom a) - | '"' -> _error d "unexpected \" (parsing atom %s)" (Buffer.contents d.atom) - | '\\' -> _error d "unexpected \\" - | _ -> - Buffer.add_char d.atom c; - _next d St_atom - end - | St_quoted -> - (* reading an unquoted atom *) - begin match c with - | '\\' -> _next d St_escaped - | '"' -> - let a = _take_buffer d.atom in - _yield d St_start (Atom a) - | _ -> - Buffer.add_char d.atom c; - _next d St_quoted - end - | St_escaped -> - begin match c with - | 'n' -> Buffer.add_char d.atom '\n'; _next d St_quoted - | 't' -> Buffer.add_char d.atom '\t'; _next d St_quoted - | 'r' -> Buffer.add_char d.atom '\r'; _next d St_quoted - | 'b' -> Buffer.add_char d.atom '\b'; _next d St_quoted - | '"' -> Buffer.add_char d.atom '"'; _next d St_quoted - | '\\' -> Buffer.add_char d.atom '\\'; _next d St_quoted - | _ when _is_digit c -> _next d (St_raw_char1 (_digit2i c)) - | _ -> _error d "unexpected escaped character %c" c - end - | St_raw_char1 i -> - begin match c with - | _ when _is_digit c -> _next d (St_raw_char2 (i*10 + _digit2i c)) - | _ -> _error d "expected digit, got %c" c - end - | St_raw_char2 i -> - begin match c with - | c when _is_digit c -> - (* read an escaped char *) - Buffer.add_char d.atom (Char.chr (i*10+_digit2i c)); - _next d St_quoted - | c -> _error d "expected digit, got %c" c - end - - let next d = _next d d.st -end - -module ParseGen = struct - type 'a t = unit -> 'a parse_result - - let to_list g : 'a list or_error = - let rec aux acc = match g() with - | `Error e -> `Error e - | `Ok x -> aux (x::acc) - | `End -> `Ok (List.rev acc) - in - aux [] - - let head g = match g() with - | `End -> `Error "expected at least one element" - | #or_error as x -> x - - let head_exn g = match g() with - | `Ok x -> x - | `Error msg -> failwith msg - | `End -> failwith "expected at least one element" - - let take n g = - assert (n>=0); - let n = ref n in - fun () -> - if !n = 0 then `End - else ( - decr n; - g() - ) -end - -(* hidden parser state *) -type parser_state = { - ps_d : Lexer.t; - mutable ps_stack : t list list; -} - -let mk_ps src = { - ps_d = Lexer.make src; - ps_stack = []; -} - -let _error ps msg = - let msg' = Printf.sprintf "at %d,%d: %s" (Lexer.line ps.ps_d) (Lexer.col ps.ps_d) msg in - `Error msg' - -(* next token, or await *) -let rec _next ps : t partial_result = - match Lexer.next ps.ps_d with - | `Ok (Lexer.Atom s) -> - _push ps (`Atom s) - | `Ok Lexer.Open -> - ps.ps_stack <- [] :: ps.ps_stack; - _next ps - | `Ok Lexer.Close -> - begin match ps.ps_stack with - | [] -> _error ps "unbalanced ')'" - | l :: stack -> - ps.ps_stack <- stack; - _push ps (`List (List.rev l)) - end - | `Error msg -> `Error msg - | `Await -> `Await - | `End -> `End - -(* push a S-expr on top of the parser stack *) -and _push ps e = match ps.ps_stack with - | [] -> - `Ok e - | l :: tl -> - ps.ps_stack <- (e :: l) :: tl; - _next ps - -(* assume [ps] never needs [`Await] *) -let _never_block ps () = match _next ps with - | `Await -> assert false - | `Ok x -> `Ok x - | `Error e -> `Error e - | `End -> `End - -(* parse from a generator of string slices *) -let parse_gen g : t ParseGen.t = - let ps = mk_ps (Source.of_gen g) in - _never_block ps - -let parse_string s = - let ps = mk_ps (Source.of_string s) in - _never_block ps - -let parse_chan ?bufsize ic = - let ps = mk_ps (Source.of_chan ?bufsize ic) in - _never_block ps - -(** {6 Blocking} *) - -let of_chan ic = - ParseGen.head (parse_chan ic) - -let of_string s = - ParseGen.head (parse_string s) - -let of_file f = - _with_in f of_chan - -module L = struct - let to_buf b l = - List.iter (to_buf b) l - - let to_string l = - let b = Buffer.create 32 in - to_buf b l; - Buffer.contents b - - let to_chan oc l = - let fmt = Format.formatter_of_out_channel oc in - List.iter (Format.fprintf fmt "%a@." print) l; - Format.pp_print_flush fmt () - - let to_file filename l = - _with_out filename (fun oc -> to_chan oc l) - - let of_chan ?bufsize ic = - ParseGen.to_list (parse_chan ?bufsize ic) - - let of_file ?bufsize filename = - _with_in filename - (fun ic -> of_chan ?bufsize ic) - - let of_string s = - ParseGen.to_list (parse_string s) - - let of_gen g = - ParseGen.to_list (parse_gen g) - - exception OhNoes of string - exception StopNaow - - let of_seq seq = - let src = Source.Manual.make () in - let ps = mk_ps (Source.Manual.to_src src) in - let l = ref [] in - (* read as many expressions as possible *) - let rec _nexts () = match _next ps with - | `Ok x -> l := x :: !l; _nexts () - | `Error e -> raise (OhNoes e) - | `End -> raise StopNaow - | `Await -> () - in - try - seq - (fun s -> Source.Manual.feed src s 0 (String.length s); _nexts ()); - Source.Manual.reached_end src; - _nexts (); - `Ok (List.rev !l) - with - | OhNoes msg -> `Error msg - | StopNaow -> `Ok (List.rev !l) -end diff --git a/src/sexp/CCSexpStream.mli b/src/sexp/CCSexpStream.mli deleted file mode 100644 index 2c87e38d..00000000 --- a/src/sexp/CCSexpStream.mli +++ /dev/null @@ -1,199 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 S-expressions Parser} - -@since 0.4 -@deprecated consider using {!CCSexpM} *) - -type 'a or_error = [ `Ok of 'a | `Error of string ] -type 'a sequence = ('a -> unit) -> unit -type 'a gen = unit -> 'a option - -type t = [ - | `Atom of string - | `List of t list - ] - -(** {2 Serialization (encoding)} *) - -val to_buf : Buffer.t -> t -> unit - -val to_string : t -> string - -val to_file : string -> t -> unit - -val to_file_seq : string -> t sequence -> unit -(** Print the given sequence of expressions to a file *) - -val to_chan : out_channel -> t -> unit - -val print : Format.formatter -> t -> unit -(** Pretty-printer nice on human eyes (including indentation) *) - -val print_noindent : Format.formatter -> t -> unit -(** Raw, direct printing as compact as possible *) - -(** {2 Deserialization (decoding)} *) - -type 'a parse_result = ['a or_error | `End ] -type 'a partial_result = [ 'a parse_result | `Await ] - -(** {6 Source of characters} *) -module Source : sig - type individual_char = - | NC_yield of char - | NC_end - | NC_await - (** An individual character returned by a source *) - - type t = unit -> individual_char - (** A source of characters can yield them one by one, or signal the end, - or signal that some external intervention is needed *) - - type source = t - - (** A manual source of individual characters. When it has exhausted its - own input, it asks its caller to provide more or signal that none remains. - This is especially useful when the source of data is monadic IO *) - module Manual : sig - type t - - val make : unit -> t - (** Make a new manual source. It needs to be fed input manually, - using {!feed} *) - - val to_src : t -> source - (** The manual source contains a source! *) - - val feed : t -> string -> int -> int -> unit - (** Feed a chunk of input to the manual source *) - - val reached_end : t -> unit - (** Tell the decoder that end of input has been reached. From now - the source will only yield [NC_end] *) - end - - val of_string : string -> t - (** Use a single string as the source *) - - val of_chan : ?bufsize:int -> in_channel -> t - (** Use a channel as the source *) - - val of_gen : string gen -> t -end - -(** {6 Streaming Lexer} -Splits the input into opening parenthesis, closing ones, and atoms *) - -module Lexer : sig - type t - (** A streaming lexer, that parses atomic chunks of S-expressions (atoms - and delimiters) *) - - val make : Source.t -> t - (** Create a lexer that uses the given source of characters as an input *) - - val of_string : string -> t - - val of_chan : in_channel -> t - - val line : t -> int - val col : t -> int - - (** Obtain next token *) - - type token = - | Open - | Close - | Atom of string - (** An individual S-exp token *) - - val next : t -> token partial_result - (** Obtain the next token, an error, or block/end stream *) -end - -(** {6 Generator with errors} *) -module ParseGen : sig - type 'a t = unit -> 'a parse_result - (** A generator-like structure, but with the possibility of errors. - When called, it can yield a new element, signal the end of stream, - or signal an error. *) - - val to_list : 'a t -> 'a list or_error - - val head : 'a t -> 'a or_error - - val head_exn : 'a t -> 'a - - val take : int -> 'a t -> 'a t -end - -(** {6 Stream Parser} -Returns a lazy stream of S-expressions. *) - -val parse_string : string -> t ParseGen.t -(** Parse a string *) - -val parse_chan : ?bufsize:int -> in_channel -> t ParseGen.t -(** Parse a channel *) - -val parse_gen : string gen -> t ParseGen.t -(** Parse chunks of string *) - -(** {6 Blocking API} -Parse one S-expression from some source. *) - -val of_chan : in_channel -> t or_error -(** Parse a S-expression from the given channel. Can read more data than - necessary, so don't use this if you need finer-grained control (e.g. - to read something else {b after} the S-exp) *) - -val of_string : string -> t or_error - -val of_file : string -> t or_error -(** Open the file and read a S-exp from it *) - -(** {6 Lists of S-exps} *) - -module L : sig - val to_buf : Buffer.t -> t list -> unit - - val to_string : t list -> string - - val to_file : string -> t list -> unit - - val to_chan : out_channel -> t list -> unit - - val of_chan : ?bufsize:int -> in_channel -> t list or_error - - val of_file : ?bufsize:int -> string -> t list or_error - - val of_string : string -> t list or_error - - val of_gen : string gen -> t list or_error - - val of_seq : string sequence -> t list or_error -end From bd6769dcaad6099d6bc9fe554499df1a61ff74a1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Dec 2015 10:27:01 +0100 Subject: [PATCH 30/31] doc --- doc/intro.txt | 1 - 1 file changed, 1 deletion(-) diff --git a/doc/intro.txt b/doc/intro.txt index b3482bf8..338a2596 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -74,7 +74,6 @@ CCFQueue CCFlatHashtbl CCHashSet CCHashTrie -CCImmutArray CCIntMap CCMixmap CCMixset From d569cf59bb44ebaffa895618dd35af7be8aaaed9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Dec 2015 10:34:14 +0100 Subject: [PATCH 31/31] prepare for 0.15 --- CHANGELOG.adoc | 25 ++++++++++++++++++++++++- _oasis | 2 +- src/core/CCError.mli | 4 ++-- src/core/CCFormat.mli | 4 ++-- src/core/CCMap.ml | 4 ++-- src/core/CCMap.mli | 4 ++-- src/core/CCOrd.mli | 2 +- src/core/CCRandom.mli | 4 ++-- src/core/CCVector.mli | 2 +- src/data/CCAllocCache.mli | 2 +- 10 files changed, 38 insertions(+), 15 deletions(-) diff --git a/CHANGELOG.adoc b/CHANGELOG.adoc index 43e557f2..e2ec92c3 100644 --- a/CHANGELOG.adoc +++ b/CHANGELOG.adoc @@ -1,5 +1,28 @@ = Changelog +== 0.15 + +=== breaking changes + +- remove deprecated `CCFloat.sign` +- remove deprecated `CCSexpStream` + +=== other changes + +- basic color handling in `CCFormat`, using tags and ANSI codes +- add `CCVector.ro_vector` as a convenience alias +- add `CCOrd.option` +- add `CCMap.{keys,values}` +- add wip `CCAllocCache`, an allocation cache for short-lived arrays +- add `CCError.{join,both}` applicative functions for CCError +- opam: depend on ocamlbuild +- work on `CCRandom` by octachron: + * add an uniformity test + * Make `split_list` uniform + * Add sample_without_replacement + +- bugfix: forgot to export `{Set.Map}.OrderedType` in `Containers` + == 0.14 === breaking changes @@ -13,7 +36,7 @@ - deprecate `CCVector.rev'`, renamed into `CCVector.rev_in_place` - deprecate `CCVector.flat_map'`, renamed `flat_map_seq` -- add `CCMap.add_{list,seq}` +- add `CCMap.add_{list,seqe` - add `CCSet.add_{list,seq}` - fix small uglyness in `Map.print` and `Set.print` - add `CCFormat.{ksprintf,string_quoted}` diff --git a/_oasis b/_oasis index feb3094f..f0fb6fbc 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.4 Name: containers -Version: 0.14 +Version: 0.15 Homepage: https://github.com/c-cube/ocaml-containers Authors: Simon Cruanes License: BSD-2-clause diff --git a/src/core/CCError.mli b/src/core/CCError.mli index 8a3d9e0d..f7e5fa34 100644 --- a/src/core/CCError.mli +++ b/src/core/CCError.mli @@ -146,13 +146,13 @@ val (<*>) : ('a -> 'b, 'err) t -> ('a, 'err) t -> ('b, 'err) t val join : (('a, 'err) t, 'err) t -> ('a, 'err) t (** [join t], in case of success, returns [`Ok o] from [`Ok (`Ok o)]. Otherwise, it fails with [`Error e] where [e] is the unwrapped error of [t]. - @since NEXT_RELEASE *) + @since 0.15 *) val both : ('a, 'err) t -> ('b, 'err) t -> (('a * 'b), 'err) t (** [both a b], in case of success, returns [`Ok (o, o')] with the ok values of [a] and [b]. Otherwise, it fails, and the error of [a] is chosen over the error of [b] if both fail. - @since NEXT_RELEASE *) + @since 0.15 *) (** {2 Infix} diff --git a/src/core/CCFormat.mli b/src/core/CCFormat.mli index a9550402..8ab2e98f 100644 --- a/src/core/CCFormat.mli +++ b/src/core/CCFormat.mli @@ -104,11 +104,11 @@ val map : ('a -> 'b) -> 'b printer -> 'a printer ]} {b status: experimental} - @since NEXT_RELEASE *) + @since 0.15 *) val set_color_tag_handling : t -> unit (** adds functions to support color tags to the given formatter. - @since NEXT_RELEASE *) + @since 0.15 *) val set_color_default : bool -> unit (** [set_color_default b] enables color handling on the standard formatters diff --git a/src/core/CCMap.ml b/src/core/CCMap.ml index d9b752bb..2dc4a5df 100644 --- a/src/core/CCMap.ml +++ b/src/core/CCMap.ml @@ -55,11 +55,11 @@ module type S = sig val keys : _ t -> key sequence (** Iterate on keys only - @since NEXT_RELEASE *) + @since 0.15 *) val values : 'a t -> 'a sequence (** Iterate on values only - @since NEXT_RELEASE *) + @since 0.15 *) val to_list : 'a t -> (key * 'a) list diff --git a/src/core/CCMap.mli b/src/core/CCMap.mli index b8353066..524e56d2 100644 --- a/src/core/CCMap.mli +++ b/src/core/CCMap.mli @@ -58,11 +58,11 @@ module type S = sig val keys : _ t -> key sequence (** Iterate on keys only - @since NEXT_RELEASE *) + @since 0.15 *) val values : 'a t -> 'a sequence (** Iterate on values only - @since NEXT_RELEASE *) + @since 0.15 *) val to_list : 'a t -> (key * 'a) list diff --git a/src/core/CCOrd.mli b/src/core/CCOrd.mli index 39949131..9c9ed76a 100644 --- a/src/core/CCOrd.mli +++ b/src/core/CCOrd.mli @@ -57,7 +57,7 @@ val () : int -> ('a t * 'a * 'a) -> int val option : 'a t -> 'a option t (** Comparison of optional values. [None] is smaller than any [Some _]. - @since NEXT_RELEASE *) + @since 0.15 *) val pair : 'a t -> 'b t -> ('a * 'b) t diff --git a/src/core/CCRandom.mli b/src/core/CCRandom.mli index 1909d483..c0b8c604 100644 --- a/src/core/CCRandom.mli +++ b/src/core/CCRandom.mli @@ -81,7 +81,7 @@ val sample_without_replacement: (** [sample_without_replacement n g] makes a list of [n] elements which are all generated randomly using [g] with the added constraint that none of the generated random values are equal - @since NEXT_RELEASE + @since 0.15 *) val list_seq : 'a t list -> 'a list t @@ -159,5 +159,5 @@ val run : ?st:state -> 'a t -> 'a val uniformity_test : ?size_hint:int -> int -> 'a t -> bool t (** [uniformity_test k rng] tests the uniformity of the random generator [rng] using [k] samples. - @since NEXT_RELEASE + @since 0.15 *) diff --git a/src/core/CCVector.mli b/src/core/CCVector.mli index 2a9986a8..b2c2a2b5 100644 --- a/src/core/CCVector.mli +++ b/src/core/CCVector.mli @@ -39,7 +39,7 @@ type 'a vector = ('a, rw) t type 'a ro_vector = ('a, ro) t (** Alias for immutable vectors. - @since NEXT_RELEASE *) + @since 0.15 *) type 'a sequence = ('a -> unit) -> unit type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] diff --git a/src/data/CCAllocCache.mli b/src/data/CCAllocCache.mli index 4a54fa8f..d8538a96 100644 --- a/src/data/CCAllocCache.mli +++ b/src/data/CCAllocCache.mli @@ -8,7 +8,7 @@ {b NOT THREAD SAFE} {b status: experimental} - @since NEXT_RELEASE + @since 0.15 *)