blob: 79e70c2add8acbf50e8bfb80715a1e84de273c78 (
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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
|
(* TEST
* frame_pointers
** native
readonly_files = "fp_backtrace.c stack_realloc_.c"
all_modules = "${readonly_files} stack_realloc.ml"
*)
open Effect
open Effect.Deep
type _ t += E : int -> int t
external fp_backtrace : unit -> unit = "fp_backtrace" [@@noalloc]
external c_fun : unit -> int = "c_fun"
let[@inline never][@local never] f x = x
let[@inline never] consume_stack () =
(* TODO Somehow get a value that would always cause a stack reallocation
* Currently anything above 32 should cause a stack reallocation since a new
* fiber stack size is given by caml_fiber_wsz = 2 * Stack_threshold_words
* and Stack_threshold_words = 32 *)
(* in words *)
let size = 128 in
let allocated = 2 * 2 (* 2 spilled registers *) + 1 (* saved rbp *) in
let count = size / allocated in
let[@inline never] rec gobbler i =
(* Force spilling of x0 and x1 *)
let x0 = Sys.opaque_identity 42 in
let x1 = Sys.opaque_identity 42 in
let _ = f x0 in
let _ = f x1 in
let _ = Sys.opaque_identity x0 in
let _ = Sys.opaque_identity x1 in
let v = if i = 1 then 42 (* dummy *) else gobbler (i - 1) in
v - 1 (* dummy *)
in
ignore (gobbler count)
let[@inline never] callback () =
consume_stack ();
fp_backtrace ();
0
let _ = Callback.register "callback" callback
let[@inline never] f () =
let[@inline never] f_comp () =
let v = perform (E 0) in
let w = c_fun () in
v + w + 1
in
let f_effc (type a) (eff : a t) : ((a, 'b) continuation -> 'b) option =
let[@inline never] f_effc_e v k = continue k (v + 1) in
match eff with
| E v -> Some (f_effc_e v)
| e -> None
in
match_with f_comp ()
{ retc = (fun v -> v);
exnc = (fun e -> raise e);
effc = f_effc }
let () = assert (f () == 3)
|
