Commit 85a8156d authored by POTTIER Francois's avatar POTTIER Francois
Browse files

Cleanup and optimisations in [SparseBitSet].

parent c2928b9c
......@@ -13,19 +13,18 @@
(* This data structure implements sets of integers (of unbounded magnitude). *)
(* A sparse bit set is a list of pairs of integers. The first component of
every pair is an index, while the second component is a bit field. The list
module A =
AtomicBitSet
(* A sparse bit set is a linked list pairs of an index and a bit set. The list
is sorted by order of increasing indices. *)
type t =
| N
| C of int * int * t
| C of int * A.t * t
type element =
int
let word_size =
Sys.word_size - 1
int
let empty =
N
......@@ -36,98 +35,115 @@ let is_empty = function
| C _ ->
false
let rec add base offset s =
match s with
| N ->
(* Insert at end. *)
C (base, A.singleton offset, N)
| C (addr, ss, qs) ->
if base < addr then
(* Insert in front. *)
C (base, A.singleton offset, s)
else if base = addr then
(* Found appropriate cell, update bit field. *)
let ss' = A.add offset ss in
if A.equal ss' ss then s else C (addr, ss', qs)
else
(* Not there yet, continue. *)
let qs' = add base offset qs in
if qs == qs' then s else C (addr, ss, qs')
let add i s =
let ioffset = i mod word_size in
let iaddr = i - ioffset
and imask = 1 lsl ioffset in
let rec add = function
| N ->
(* Insert at end. *)
C (iaddr, imask, N)
| C (addr, ss, qs) as s ->
if iaddr < addr then
(* Insert in front. *)
C (iaddr, imask, s)
else if iaddr = addr then
(* Found appropriate cell, update bit field. *)
let ss' = ss lor imask in
if ss' = ss then
s
else
C (addr, ss', qs)
else
(* Not there yet, continue. *)
let qs' = add qs in
if qs == qs' then
s
else
C (addr, ss, qs')
in
add s
let offset = i mod A.bound in
let base = i - offset in
add base offset s
let singleton i =
add i N
(* This is [add i N], specialised. *)
let offset = i mod A.bound in
let base = i - offset in
C (base, A.singleton offset, N)
let rec remove base offset s =
match s with
| N ->
N
| C (addr, ss, qs) ->
if base < addr then
s
else if base = addr then
(* Found appropriate cell, update bit field. *)
let ss' = A.remove offset ss in
if A.is_empty ss' then
qs
else if A.equal ss' ss then s else C (addr, ss', qs)
else
(* Not there yet, continue. *)
let qs' = remove base offset qs in
if qs == qs' then s else C (addr, ss, qs')
let remove i s =
let ioffset = i mod word_size in
let iaddr = i - ioffset
and imask = 1 lsl ioffset in
let rec remove = function
| N ->
N
| C (addr, ss, qs) as s ->
if iaddr < addr then
s
else if iaddr = addr then
(* Found appropriate cell, update bit field. *)
let ss' = ss land (lnot imask) in
if ss' = 0 then
qs
else if ss' = ss then
s
else
C (addr, ss', qs)
else
(* Not there yet, continue. *)
let qs' = remove qs in
if qs == qs' then
s
else
C (addr, ss, qs')
in
remove s
let offset = i mod A.bound in
let base = i - offset in
remove base offset s
let rec fold f s accu =
let rec mem base offset s =
match s with
| N ->
accu
| C (base, ss, qs) ->
loop f qs base ss accu
false
| C (addr, ss, qs) ->
if base < addr then
false
else if base = addr then
A.mem offset ss
else
mem base offset qs
and loop f qs i ss accu =
if ss = 0 then
fold f qs accu
else
(* One could in principle check whether [ss land 0x3] is zero and if
so move to [i + 2] and [ss lsr 2], and similarly for various sizes.
In practice, this does not seem to make a measurable difference. *)
loop f qs (i + 1) (ss lsr 1) (if ss land 1 = 1 then f i accu else accu)
let mem i s =
let offset = i mod A.bound in
let base = i - offset in
mem base offset s
let iter f s =
fold (fun x () -> f x) s ()
let rec fold f s accu =
match s with
| N ->
accu
| C (addr, ss, qs) ->
let accu =
A.fold (fun offset accu ->
f (addr + offset) accu
) ss accu
in
fold f qs accu
let rec iter f s =
match s with
| N ->
()
| C (addr, ss, qs) ->
A.iter (fun offset ->
f (addr + offset)
) ss;
iter f qs
let is_singleton s =
match s with
| C (_, ss, N) ->
(* Test whether only one bit is set in [ss]. We do this by turning
off the rightmost bit, then comparing to zero. *)
ss land (ss - 1) = 0
A.is_singleton ss
| C (_, _, C _)
| N ->
false
let rec cardinal accu s =
match s with
| C (_, ss, qs) ->
let accu = accu + A.cardinal ss in
cardinal accu qs
| N ->
accu
let cardinal s =
fold (fun _ m -> m + 1) s 0
cardinal 0 s
let elements s =
fold (fun tl hd -> tl :: hd) s []
......@@ -142,15 +158,12 @@ let rec subset s1 s2 =
if addr1 < addr2 then
false
else if addr1 = addr2 then
if (ss1 land ss2) <> ss1 then
false
else
subset qs1 qs2
A.subset ss1 ss2 && subset qs1 qs2
else
subset s1 qs2
let mem i s =
subset (singleton i) s
(* [union] arbitrarily attempts to preserve sharing between its second
argument and its result. *)
let rec union s1 s2 =
match s1, s2 with
......@@ -162,17 +175,14 @@ let rec union s1 s2 =
C (addr1, ss1, union qs1 s2)
else if addr1 > addr2 then
let s = union s1 qs2 in
if s == qs2 then
s2
else
C (addr2, ss2, s)
if s == qs2 then s2 else C (addr2, ss2, s)
else
let ss = ss1 lor ss2 in
let ss = A.union ss1 ss2 in
let s = union qs1 qs2 in
if ss == ss2 && s == qs2 then
s2
else
C (addr1, ss, s)
if A.equal ss ss2 && s == qs2 then s2 else C (addr1, ss, s)
(* [inter] arbitrarily attempts to preserve sharing between its first
argument and its result. *)
let rec inter s1 s2 =
match s1, s2 with
......@@ -185,26 +195,20 @@ let rec inter s1 s2 =
else if addr1 > addr2 then
inter s1 qs2
else
let ss = ss1 land ss2 in
let ss = A.inter ss1 ss2 in
let s = inter qs1 qs2 in
if ss = 0 then
if A.is_empty ss then
s
else
if (ss = ss1) && (s == qs1) then
s1
else
C (addr1, ss, s)
exception Found of int
if A.equal ss ss1 && s == qs1 then s1 else C (addr1, ss, s)
let choose s =
try
iter (fun x ->
raise (Found x)
) s;
raise Not_found
with Found x ->
x
match s with
| N ->
raise Not_found
| C (addr, ss, _) ->
assert (not (A.is_empty ss));
addr + A.choose ss
let rec compare s1 s2 =
match s1, s2 with
......@@ -214,12 +218,16 @@ let rec compare s1 s2 =
| C (addr1, ss1, qs1), C (addr2, ss2, qs2) ->
if addr1 < addr2 then -1
else if addr1 > addr2 then 1
else if ss1 < ss2 then -1
else if ss1 > ss2 then 1
else compare qs1 qs2
else
let c = A.compare ss1 ss2 in
if c <> 0 then c
else compare qs1 qs2
let equal s1 s2 =
compare s1 s2 = 0
(* We could use [compare s1 s2 = 0]. *)
(* Instead, we violate the [AtomicBitSet] abstraction a tiny little bit
and use generic equality. *)
s1 = s2
let rec disjoint s1 s2 =
match s1, s2 with
......@@ -228,10 +236,7 @@ let rec disjoint s1 s2 =
true
| C (addr1, ss1, qs1), C (addr2, ss2, qs2) ->
if addr1 = addr2 then
if (ss1 land ss2) = 0 then
disjoint qs1 qs2
else
false
A.disjoint ss1 ss2 && disjoint qs1 qs2
else if addr1 < addr2 then
disjoint qs1 s2
else
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment