summaryrefslogtreecommitdiff
path: root/testsuite/tests/regression/pr5233/pr5233.ml
blob: b7fddd7f8bf592646e829d1770055804f6a048b6 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
open Printf;;

(* PR#5233: Create a dangling pointer and use it to access random parts
   of the heap. *)

(* The buggy weak array will end up in smuggle. *)
let smuggle = ref (Weak.create 1);;

(* This will be the weak array (W). *)
let t = ref (Weak.create 1);;

(* Set a finalisation function on W. *)
Gc.finalise (fun w -> smuggle := w) !t;;

(* Free W and run its finalisation function. *)
t := Weak.create 1;;
Gc.full_major ();;

(* smuggle now contains W, whose pointers are not erased, even
   when the contents is deallocated. *)

let size = 1_000_000;;

let check o =
  printf "checking...";
  match o with
  | None -> printf " no value\n";
  | Some s ->
     printf " value found  /  testing...";
     for i = 0 to size - 1 do
       if s.[i] != ' ' then failwith "bad";
     done;
     printf " ok\n";
;;

let f () =
  Weak.set !smuggle 0 (Some (String.make size ' '));

  (* Check the data just to make sure. *)
  check (Weak.get !smuggle 0);

  (* Get a dangling pointer in W. *)
  Gc.full_major ();

  (* Fill the heap with other stuff. *)
  let rec fill n accu = if n = 0 then accu else fill (n-1) (123 :: accu) in
  let _r : int list = fill ((Gc.stat ()).Gc.heap_words / 3) [] in
  Gc.minor ();

  (* Now follow the dangling pointer and exhibit the problem. *)
  check (Weak.get !smuggle 0)

let () = (f [@inlined never]) ()