summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--byterun/major_gc.c51
-rw-r--r--byterun/major_gc.h5
-rw-r--r--byterun/weak.c74
-rw-r--r--stdlib/weak.ml168
-rw-r--r--test/Makefile2
-rw-r--r--test/Results/weaktest.out1
-rw-r--r--test/weaktest.ml73
7 files changed, 280 insertions, 94 deletions
diff --git a/byterun/major_gc.c b/byterun/major_gc.c
index 18da47721..3c903740a 100644
--- a/byterun/major_gc.c
+++ b/byterun/major_gc.c
@@ -48,12 +48,13 @@ extern char *caml_fl_merge; /* Defined in freelist.c. */
static char *markhp, *chunk, *limit;
-static int gc_subphase; /* Subphase_main, Subphase_weak, Subphase_final */
-#define Subphase_main 10
-#define Subphase_weak 11
-#define Subphase_final 12
+int caml_gc_subphase; /* Subphase_{main,weak1,weak2,final} */
static value *weak_prev;
+#ifdef DEBUG
+static unsigned long major_gc_counter = 0;
+#endif
+
static void realloc_gray_vals (void)
{
value *new;
@@ -111,9 +112,10 @@ static void start_cycle (void)
caml_gc_message (0x01, "Starting new major GC cycle\n", 0);
caml_darken_all_roots();
caml_gc_phase = Phase_mark;
- gc_subphase = Subphase_main;
+ caml_gc_subphase = Subphase_main;
markhp = NULL;
#ifdef DEBUG
+ ++ major_gc_counter;
caml_heap_check ();
#endif
}
@@ -126,6 +128,7 @@ static void mark_slice (intnat work)
mlsize_t size, i;
caml_gc_message (0x40, "Marking %ld words\n", work);
+ caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase);
gray_vals_ptr = gray_vals_cur;
while (work > 0){
if (gray_vals_ptr > gray_vals){
@@ -187,12 +190,12 @@ static void mark_slice (intnat work)
chunk = caml_heap_start;
markhp = chunk;
limit = chunk + Chunk_size (chunk);
- }else if (gc_subphase == Subphase_main){
+ }else if (caml_gc_subphase == Subphase_main){
/* The main marking phase is over. Start removing weak pointers to
dead values. */
- gc_subphase = Subphase_weak;
+ caml_gc_subphase = Subphase_weak1;
weak_prev = &caml_weak_list_head;
- }else if (gc_subphase == Subphase_weak){
+ }else if (caml_gc_subphase == Subphase_weak1){
value cur, curfield;
mlsize_t sz, i;
header_t hd;
@@ -200,10 +203,6 @@ static void mark_slice (intnat work)
cur = *weak_prev;
if (cur != (value) NULL){
hd = Hd_val (cur);
- if (Color_hd (hd) == Caml_white){
- /* The whole array is dead, remove it from the list. */
- *weak_prev = Field (cur, 0);
- }else{
sz = Wosize_hd (hd);
for (i = 1; i < sz; i++){
curfield = Field (cur, i);
@@ -227,18 +226,36 @@ static void mark_slice (intnat work)
}
}
}
+ weak_prev = &Field (cur, 0);
+ work -= Whsize_hd (hd);
+ }else{
+ /* Subphase_weak1 is done. Start removing dead weak arrays. */
+ caml_gc_subphase = Subphase_weak2;
+ weak_prev = &caml_weak_list_head;
+ }
+ }else if (caml_gc_subphase == Subphase_weak2){
+ value cur;
+ header_t hd;
+
+ cur = *weak_prev;
+ if (cur != (value) NULL){
+ hd = Hd_val (cur);
+ if (Color_hd (hd) == Caml_white){
+ /* The whole array is dead, remove it from the list. */
+ *weak_prev = Field (cur, 0);
+ }else{
weak_prev = &Field (cur, 0);
}
- work -= Whsize_hd (hd);
+ work -= 1;
}else{
- /* Subphase_weak is done. Handle finalised values. */
+ /* Subphase_weak2 is done. Handle finalised values. */
gray_vals_cur = gray_vals_ptr;
caml_final_update ();
gray_vals_ptr = gray_vals_cur;
- gc_subphase = Subphase_final;
+ caml_gc_subphase = Subphase_final;
}
}else{
- Assert (gc_subphase == Subphase_final);
+ Assert (caml_gc_subphase == Subphase_final);
/* Initialise the sweep phase. */
gray_vals_cur = gray_vals_ptr;
caml_gc_sweep_hp = caml_heap_start;
@@ -352,7 +369,7 @@ intnat caml_major_collection_slice (intnat howmuch)
if (p < dp) p = dp;
if (p < caml_extra_heap_resources) p = caml_extra_heap_resources;
- caml_gc_message (0x40, "allocated_words = %"
+ caml_gc_message (0x40, "allocated_words = %"
ARCH_INTNAT_PRINTF_FORMAT "u\n",
caml_allocated_words);
caml_gc_message (0x40, "extra_heap_resources = %"
diff --git a/byterun/major_gc.h b/byterun/major_gc.h
index 5607a2675..5e48e3431 100644
--- a/byterun/major_gc.h
+++ b/byterun/major_gc.h
@@ -33,6 +33,7 @@ typedef struct {
#define Chunk_block(c) (((heap_chunk_head *) (c)) [-1]).block
extern int caml_gc_phase;
+extern int caml_gc_subphase;
extern uintnat caml_allocated_words;
extern double caml_extra_heap_resources;
extern uintnat caml_dependent_size, caml_dependent_allocated;
@@ -41,6 +42,10 @@ extern uintnat caml_fl_size_at_phase_change;
#define Phase_mark 0
#define Phase_sweep 1
#define Phase_idle 2
+#define Subphase_main 10
+#define Subphase_weak1 11
+#define Subphase_weak2 12
+#define Subphase_final 13
CAMLextern char *caml_heap_start;
extern uintnat total_heap_size;
diff --git a/byterun/weak.c b/byterun/weak.c
index 1f121af3a..e85468601 100644
--- a/byterun/weak.c
+++ b/byterun/weak.c
@@ -45,6 +45,24 @@ CAMLprim value caml_weak_create (value len)
#define None_val (Val_int(0))
#define Some_tag 0
+static void do_set (value ar, mlsize_t offset, value v)
+{
+ if (Is_block (v) && Is_young (v)){
+ /* modified version of Modify */
+ value old = Field (ar, offset);
+ Field (ar, offset) = v;
+ if (!(Is_block (old) && Is_young (old))){
+ if (caml_weak_ref_table.ptr >= caml_weak_ref_table.limit){
+ CAMLassert (caml_weak_ref_table.ptr == caml_weak_ref_table.limit);
+ caml_realloc_ref_table (&caml_weak_ref_table);
+ }
+ *caml_weak_ref_table.ptr++ = &Field (ar, offset);
+ }
+ }else{
+ Field (ar, offset) = v;
+ }
+}
+
CAMLprim value caml_weak_set (value ar, value n, value el)
{
mlsize_t offset = Long_val (n) + 1;
@@ -53,22 +71,10 @@ CAMLprim value caml_weak_set (value ar, value n, value el)
caml_invalid_argument ("Weak.set");
}
if (el != None_val){
- value v; Assert (Wosize_val (el) == 1);
- v = Field (el, 0);
- if (Is_block (v) && Is_young (v)){
- /* modified version of Modify */
- value old = Field (ar, offset);
- Field (ar, offset) = v;
- if (!(Is_block (old) && Is_young (old))){
- if (caml_weak_ref_table.ptr >= caml_weak_ref_table.limit){
- CAMLassert (caml_weak_ref_table.ptr == caml_weak_ref_table.limit);
- caml_realloc_ref_table (&caml_weak_ref_table);
- }
- *caml_weak_ref_table.ptr++ = &Field (ar, offset);
- }
- }else{
- Field (ar, offset) = v;
- }
+ Assert (Wosize_val (el) == 1);
+ do_set (ar, offset, Field (el, 0));
+ }else{
+ Field (ar, offset) = caml_weak_none;
}
return Val_unit;
}
@@ -149,3 +155,39 @@ CAMLprim value caml_weak_check (value ar, value n)
}
return Val_bool (Field (ar, offset) != caml_weak_none);
}
+
+CAMLprim value caml_weak_blit (value ars, value ofs,
+ value ard, value ofd, value len)
+{
+ mlsize_t offset_s = Long_val (ofs) + 1;
+ mlsize_t offset_d = Long_val (ofd) + 1;
+ mlsize_t length = Long_val (len);
+ long i;
+ Assert (Is_in_heap (ars));
+ Assert (Is_in_heap (ard));
+ if (offset_s < 1 || offset_s + length > Wosize_val (ars)){
+ caml_invalid_argument ("Weak.blit");
+ }
+ if (offset_d < 1 || offset_d + length > Wosize_val (ard)){
+ caml_invalid_argument ("Weak.blit");
+ }
+ if (caml_gc_phase == Phase_mark && caml_gc_subphase == Subphase_weak1){
+ for (i = 0; i < length; i++){
+ value v = Field (ars, offset_s + i);
+ if (v != caml_weak_none && Is_block (v) && Is_in_heap (v)
+ && Is_white_val (v)){
+ Field (ars, offset_s + i) = caml_weak_none;
+ }
+ }
+ }
+ if (offset_d < offset_s){
+ for (i = 0; i < length; i++){
+ do_set (ard, offset_d + i, Field (ars, offset_s + i));
+ }
+ }else{
+ for (i = length - 1; i >= 0; i--){
+ do_set (ard, offset_d + i, Field (ars, offset_s + i));
+ }
+ }
+ return Val_unit;
+}
diff --git a/stdlib/weak.ml b/stdlib/weak.ml
index 317c3729f..bf2899492 100644
--- a/stdlib/weak.ml
+++ b/stdlib/weak.ml
@@ -26,6 +26,7 @@ external set : 'a t -> int -> 'a option -> unit = "caml_weak_set";;
external get: 'a t -> int -> 'a option = "caml_weak_get";;
external get_copy: 'a t -> int -> 'a option = "caml_weak_get_copy";;
external check: 'a t -> int -> bool = "caml_weak_check";;
+external blit: 'a t -> int -> 'a t -> int -> int -> unit = "caml_weak_blit";;
let fill ar ofs len x =
if ofs < 0 || len < 0 || ofs + len > length ar
@@ -37,23 +38,6 @@ let fill ar ofs len x =
end
;;
-let blit ar1 of1 ar2 of2 len =
- if of1 < 0 || of1 + len > length ar1 || of2 < 0 || of2 + len > length ar2
- then raise (Invalid_argument "Weak.blit")
- else begin
- if of2 > of1 then begin
- for i = 0 to len - 1 do
- set ar2 (of2 + i) (get ar1 (of1 + i))
- done
- end else begin
- for i = len - 1 downto 0 do
- set ar2 (of2 + i) (get ar1 (of1 + i))
- done
- end
- end
-;;
-
-
(** Weak hash tables *)
module type S = sig
@@ -83,27 +67,35 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
type t = {
mutable table : data weak_t array;
- mutable totsize : int; (* sum of the bucket sizes *)
- mutable limit : int; (* max ratio totsize/table length *)
+ mutable hashes : int array array;
+ mutable limit : int; (* bucket size limit *)
+ mutable oversize : int; (* number of oversize buckets *)
+ mutable rover : int; (* for internal bookkeeping *)
};;
- let get_index t d = (H.hash d land max_int) mod (Array.length t.table);;
+ let get_index t h = (h land max_int) mod (Array.length t.table);;
+
+ let limit = 7;;
+ let over_limit = 2;;
let create sz =
let sz = if sz < 7 then 7 else sz in
let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in
{
table = Array.create sz emptybucket;
- totsize = 0;
- limit = 3;
+ hashes = Array.create sz [| |];
+ limit = limit;
+ oversize = 0;
+ rover = 0;
};;
let clear t =
for i = 0 to Array.length t.table - 1 do
t.table.(i) <- emptybucket;
+ t.hashes.(i) <- [| |];
done;
- t.totsize <- 0;
- t.limit <- 3;
+ t.limit <- limit;
+ t.oversize <- 0;
;;
let fold f t init =
@@ -126,85 +118,139 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
Array.iter (iter_bucket 0) t.table
;;
+ let rec count_bucket i b accu =
+ if i >= length b then accu else
+ count_bucket (i+1) b (accu + (if check b i then 1 else 0))
+ ;;
+
let count t =
- let rec count_bucket i b accu =
- if i >= length b then accu else
- count_bucket (i+1) b (accu + (if check b i then 1 else 0))
- in
Array.fold_right (count_bucket 0) t.table 0
;;
- let next_sz n = min (3*n/2 + 3) (Sys.max_array_length - 1);;
+ let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length;;
+ let prev_sz n = ((n - 3) * 2 + 2) / 3;;
+
+ let test_shrink_bucket t =
+ let bucket = t.table.(t.rover) in
+ let hbucket = t.hashes.(t.rover) in
+ let len = length bucket in
+ let prev_len = prev_sz len in
+ let live = count_bucket 0 bucket 0 in
+ if live <= prev_len then begin
+ let rec loop i j =
+ if j > prev_len then begin
+ if check bucket i then loop (i + 1) j
+ else if check bucket j then begin
+ blit bucket j bucket i 1;
+ hbucket.(i) <- hbucket.(j);
+ loop (i + 1) (j - 1);
+ end else loop i (j - 1);
+ end;
+ in
+ loop 0 (length bucket - 1);
+ if prev_len = 0 then begin
+ t.table.(t.rover) <- emptybucket;
+ t.hashes.(t.rover) <- [| |];
+ end else begin
+ Obj.truncate (Obj.repr bucket) (prev_len + 1);
+ Obj.truncate (Obj.repr hbucket) prev_len;
+ end;
+ if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1;
+ end;
+ t.rover <- (t.rover + 1) mod (Array.length t.table);
+ ;;
let rec resize t =
let oldlen = Array.length t.table in
let newlen = next_sz oldlen in
if newlen > oldlen then begin
let newt = create newlen in
- newt.limit <- t.limit + 100; (* prevent resizing of newt *)
fold (fun d () -> add newt d) t ();
- (* assert Array.length newt.table = newlen; *)
t.table <- newt.table;
- (* t.limit <- t.limit + 2; -- performance bug *)
+ t.hashes <- newt.hashes;
+ t.limit <- newt.limit;
+ t.oversize <- newt.oversize;
+ t.rover <- t.rover mod Array.length newt.table;
+ end else begin
+ t.limit <- max_int; (* maximum size already reached *)
+ t.oversize <- 0;
end
- and add_aux t d index =
+ and add_aux t d h index =
let bucket = t.table.(index) in
+ let hashes = t.hashes.(index) in
let sz = length bucket in
let rec loop i =
if i >= sz then begin
- let newsz = min (sz + 3) (Sys.max_array_length - 1) in
- if newsz <= sz then failwith "Weak.Make : hash bucket cannot grow more";
+ let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in
+ if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more";
let newbucket = weak_create newsz in
+ let newhashes = Array.make newsz 0 in
blit bucket 0 newbucket 0 sz;
- set newbucket i (Some d);
+ Array.blit hashes 0 newhashes 0 sz;
+ set newbucket sz (Some d);
+ newhashes.(sz) <- h;
t.table.(index) <- newbucket;
- t.totsize <- t.totsize + (newsz - sz);
- if t.totsize > t.limit * Array.length t.table then resize t;
+ t.hashes.(index) <- newhashes;
+ if sz <= t.limit && newsz > t.limit then begin
+ t.oversize <- t.oversize + 1;
+ for i = 0 to over_limit do test_shrink_bucket t done;
+ end;
+ if t.oversize > Array.length t.table / over_limit then resize t;
end else begin
if check bucket i
- then loop (i+1)
- else set bucket i (Some d)
- end
+ then loop (i + 1)
+ else begin
+ set bucket i (Some d);
+ hashes.(i) <- h;
+ end;
+ end;
in
loop 0;
- and add t d = add_aux t d (get_index t d)
+ and add t d =
+ let h = H.hash d in
+ add_aux t d h (get_index t h);
;;
let find_or t d ifnotfound =
- let index = get_index t d in
+ let h = H.hash d in
+ let index = get_index t h in
let bucket = t.table.(index) in
+ let hashes = t.hashes.(index) in
let sz = length bucket in
let rec loop i =
- if i >= sz then ifnotfound index
- else begin
+ if i >= sz then ifnotfound h index
+ else if h = hashes.(i) then begin
match get_copy bucket i with
| Some v when H.equal v d
-> begin match get bucket i with
| Some v -> v
- | None -> loop (i+1)
+ | None -> loop (i + 1)
end
- | _ -> loop (i+1)
- end
+ | _ -> loop (i + 1)
+ end else loop (i + 1)
in
loop 0
;;
- let merge t d = find_or t d (fun index -> add_aux t d index; d);;
+ let merge t d = find_or t d (fun h index -> add_aux t d h index; d);;
- let find t d = find_or t d (fun index -> raise Not_found);;
+ let find t d = find_or t d (fun h index -> raise Not_found);;
let find_shadow t d iffound ifnotfound =
- let index = get_index t d in
+ let h = H.hash d in
+ let index = get_index t h in
let bucket = t.table.(index) in
+ let hashes = t.hashes.(index) in
let sz = length bucket in
let rec loop i =
- if i >= sz then ifnotfound else begin
+ if i >= sz then ifnotfound
+ else if h = hashes.(i) then begin
match get_copy bucket i with
| Some v when H.equal v d -> iffound bucket i
- | _ -> loop (i+1)
- end
+ | _ -> loop (i + 1)
+ end else loop (i + 1)
in
loop 0
;;
@@ -214,20 +260,22 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
let mem t d = find_shadow t d (fun w i -> true) false;;
let find_all t d =
- let index = get_index t d in
+ let h = H.hash d in
+ let index = get_index t h in
let bucket = t.table.(index) in
+ let hashes = t.hashes.(index) in
let sz = length bucket in
let rec loop i accu =
if i >= sz then accu
- else begin
+ else if h = hashes.(i) then begin
match get_copy bucket i with
| Some v when H.equal v d
-> begin match get bucket i with
- | Some v -> loop (i+1) (v::accu)
- | None -> loop (i+1) accu
+ | Some v -> loop (i + 1) (v :: accu)
+ | None -> loop (i + 1) accu
end
- | _ -> loop (i+1) accu
- end
+ | _ -> loop (i + 1) accu
+ end else loop (i + 1) accu
in
loop 0 []
;;
diff --git a/test/Makefile b/test/Makefile
index f8219eeb5..46fb2acb8 100644
--- a/test/Makefile
+++ b/test/Makefile
@@ -28,7 +28,7 @@ CODERUNPARAMS=OCAMLRUNPARAM='o=100'
BYTE_EXE=fib.byt takc.byt taku.byt sieve.byt quicksort.byt quicksort.fast.byt \
fft.byt fft.fast.byt soli.byt soli.fast.byt boyer.byt kb.byt \
nucleic.byt bdd.byt hamming.byt sorts.byt \
- almabench.byt almabench.fast.byt
+ almabench.byt almabench.fast.byt weaktest.byt
CODE_EXE=$(BYTE_EXE:.byt=.out)
diff --git a/test/Results/weaktest.out b/test/Results/weaktest.out
new file mode 100644
index 000000000..2ae28399f
--- /dev/null
+++ b/test/Results/weaktest.out
@@ -0,0 +1 @@
+pass
diff --git a/test/weaktest.ml b/test/weaktest.ml
new file mode 100644
index 000000000..92ab5576d
--- /dev/null
+++ b/test/weaktest.ml
@@ -0,0 +1,73 @@
+(* $Id$ *)
+
+let debug = false;;
+
+open Printf;;
+
+module Hashed = struct
+ type t = string list;;
+ let equal x y =
+ eprintf "equal: %s / %s\n" (List.hd x) (List.hd y);
+ x = y
+ ;;
+ let hash x = Hashtbl.hash (List.hd x);;
+end;;
+
+module HT = Weak.Make (Hashed);;
+
+let tbl = HT.create 7;;
+
+let r = ref [];;
+
+let bunch =
+ if Array.length Sys.argv < 2
+ then 10000
+ else int_of_string Sys.argv.(1)
+;;
+
+Random.init 314;;
+
+let random_string n =
+ let result = String.create n in
+ for i = 0 to n - 1 do
+ result.[i] <- Char.chr (32 + Random.int 95);
+ done;
+ result
+;;
+
+let added = ref 0;;
+let mistakes = ref 0;;
+
+let print_status () =
+ let (len, entries, sumbuck, buckmin, buckmed, buckmax) = HT.stats tbl in
+ if entries > bunch * (!added + 1) then begin
+ if debug then begin
+ printf "\n===================\n";
+ printf "len = %d\n" len;
+ printf "entries = %d\n" entries;
+ printf "sum of bucket sizes = %d\n" sumbuck;
+ printf "min bucket = %d\n" buckmin;
+ printf "med bucket = %d\n" buckmed;
+ printf "max bucket = %d\n" buckmax;
+ printf "GC count = %d\n" (Gc.quick_stat ()).Gc.major_collections;
+ flush stdout;
+ end;
+ incr mistakes;
+ end;
+ added := 0;
+;;
+
+Gc.create_alarm print_status;;
+
+for j = 0 to 99 do
+ r := [];
+ incr added;
+
+ for i = 1 to bunch do
+ let c = random_string 7 in
+ r := c :: !r;
+ HT.add tbl !r;
+ done;
+done;;
+
+if !mistakes < 5 then printf "pass\n" else printf "fail\n";;
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-20 04:00:24 +0000