From e777400818a1f2a9975643847dc31c67de546c99 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Mon, 29 Sep 2025 18:07:35 +0200 Subject: [PATCH 01/16] Upgrade to ppxlib 0.36 Signed-off-by: Nathan Rebours --- dune-project | 2 +- landmarks-ppx.opam | 2 +- ppx/mapper.ml | 49 +++++++++++++++++++++++++++++++++------------- 3 files changed, 37 insertions(+), 16 deletions(-) diff --git a/dune-project b/dune-project index 4f31a1b..f7b4053 100755 --- a/dune-project +++ b/dune-project @@ -34,7 +34,7 @@ landmarks library.") (depends (ocaml (>= 4.08)) - (ppxlib (>= 0.22)) + (ppxlib (>= 0.36)) (landmarks (= 1.5)) ) ) diff --git a/landmarks-ppx.opam b/landmarks-ppx.opam index bb2ab4c..e7e531a 100644 --- a/landmarks-ppx.opam +++ b/landmarks-ppx.opam @@ -13,7 +13,7 @@ bug-reports: "https://github.com/LexiFi/landmarks/issues" depends: [ "dune" {>= "3.16"} "ocaml" {>= "4.08"} - "ppxlib" {>= "0.22"} + "ppxlib" {>= "0.36"} "landmarks" {= "1.5"} "odoc" {with-doc} ] diff --git a/ppx/mapper.ml b/ppx/mapper.ml index 2456126..bc5fc97 100644 --- a/ppx/mapper.ml +++ b/ppx/mapper.ml @@ -176,26 +176,47 @@ let wrap_landmark ctx landmark loc expr = let rec arity {pexp_desc; _} = match pexp_desc with - | Pexp_fun (a, _, _, e) -> a :: arity e - | Pexp_function cases -> - let max_list l1 l2 = - if List.length l1 < List.length l2 then - l1 - else - l2 - in - Nolabel :: (List.fold_left - (fun acc {pc_rhs; _} -> max_list (arity pc_rhs) acc) - [] cases) + | Pexp_function (params, _, body) -> + List.filter_map + (function + | { pparam_desc = Pparam_val (a, _, _); _ } -> Some a + | { pparam_desc = Pparam_newtype _; _ } -> None ) + params + @ body_arity body | Pexp_newtype (_, e) -> arity e | Pexp_constraint (e, _) -> arity e | Pexp_poly (e, _) -> arity e | _ -> [] -let rec wrap_landmark_method ctx landmark loc ({pexp_desc; _} as expr) = +and body_arity body = + match body with + | Pfunction_body e -> arity e + | Pfunction_cases (cases, _, _) -> + let max_list l1 l2 = if List.length l1 < List.length l2 then l1 else l2 in + Nolabel + :: List.fold_left + (fun acc { pc_rhs; _ } -> max_list (arity pc_rhs) acc) + [] cases + +let rec wrap_landmark_method ctx landmark loc ({ pexp_desc; _ } as expr) = match pexp_desc with - | Pexp_fun (label, def, pat, e) -> - { expr with pexp_desc = Pexp_fun (label, def, pat, wrap_landmark_method ctx landmark loc e)} + | Pexp_function (params, constraint_, Pfunction_body e) -> + let body = wrap_landmark_method ctx landmark loc e in + { expr with + pexp_desc = Pexp_function (params, constraint_, Pfunction_body body) + } + | Pexp_function ((_ :: _ as params), constraint_, Pfunction_cases (c, l, a)) + -> + let function_ = + { expr with + pexp_desc = Pexp_function ([], None, Pfunction_cases (c, l, a)) + ; pexp_loc = l + } + in + let body = wrap_landmark ctx landmark l function_ in + { expr with + pexp_desc = Pexp_function (params, constraint_, Pfunction_body body) + } | Pexp_poly (e, typ) -> { expr with pexp_desc = Pexp_poly (wrap_landmark_method ctx landmark loc e, typ)} | _ -> wrap_landmark ctx landmark loc expr From c99a99d9917f0f65deef5723d17926490c180293 Mon Sep 17 00:00:00 2001 From: hra687261 Date: Mon, 8 Dec 2025 19:32:07 +0100 Subject: [PATCH 02/16] Move common type declarations to `utils.ml` --- src/landmark.ml | 228 +++--------------------------------------------- src/utils.ml | 217 +++++++++++++++++++++++++++++++++++++++++++++ src/utils.mli | 105 ++++++++++++++++++++++ 3 files changed, 333 insertions(+), 217 deletions(-) create mode 100644 src/utils.ml create mode 100644 src/utils.mli diff --git a/src/landmark.ml b/src/landmark.ml index 5996026..33bffea 100644 --- a/src/landmark.ml +++ b/src/landmark.ml @@ -2,6 +2,8 @@ (* See the attached LICENSE file. *) (* Copyright (C) 2000-2025 LexiFi *) +open Utils + external clock: unit -> (Int64.t [@unboxed]) = "caml_highres_clock" "caml_highres_clock_native" [@@noalloc] @@ -17,207 +19,11 @@ let allocated_bytes_major () = Int64.to_int (allocated_bytes_major ()) exception LandmarkFailure of string module Graph = Graph +module Stack = Utils.Stack -module SparseArray = struct - type 'a t = { - mutable keys : int array; - mutable data : 'a array; - mutable size : int; - } - - (* /!\ Dummy cannot be resized. *) - let dummy () = { keys = [||]; data = [||]; size = 0 } - - let make null n = - let n = max n 1 in - { - keys = Array.make n 0; - data = Array.make n null; - size = 0; - } - - let reset sparse_array = sparse_array.size <- 0 - - let get t id = - let {keys; data; size} = t in - let min = ref 0 in - let max = ref (size - 1) in - while !min < !max do - let middle = (!min + !max) / 2 in - if Array.unsafe_get keys middle < id then - min := middle + 1 - else - max := middle - done; - let idx = !min in - if idx = !max && - Array.unsafe_get keys idx = id then - Array.unsafe_get data idx - else - raise Not_found - - let swap a i j = - let t = a.(i) in - a.(i) <- a.(j); - a.(j) <- t - - let values {data; size; _} = - let result = ref [] in - for k = 0 to size-1 do - result := data.(k) :: !result; - done; - List.rev !result - - let bubble {keys; data; size} = - let pos = ref size in - let key = keys.(size) in - while - let p = !pos in - let q = p - 1 in - if key < keys.(q) then begin - swap keys p q; - swap data p q; - pos := q; - q > 0 - end else false - do () done - - let is_full ({keys; size; _}) = Array.length keys = size - - let resize ({keys; data; size} as sparse_array) = - if is_full sparse_array then begin - assert (size > 0); - let new_length = (2 * (size + 1)) - 1 in - sparse_array.keys <- Array.make new_length 0; - sparse_array.data <- Array.make new_length sparse_array.data.(0); - Array.blit keys 0 sparse_array.keys 0 size; - Array.blit data 0 sparse_array.data 0 size; - end - - let set sparse_array id node = - resize sparse_array; - let size = sparse_array.size in - sparse_array.keys.(size) <- id; - sparse_array.data.(size) <- node; - if size > 0 then - bubble sparse_array; - sparse_array.size <- sparse_array.size + 1 -end - -module Stack = struct - module A = struct - type (_, _) kind = - | Array : ('a, 'a array) kind - | Float : (float, floatarray) kind - let empty : type a arr. (a, arr) kind -> arr = function - | Array -> [||] - | Float -> Float.Array.create 0 - let make : type a arr. (a, arr) kind -> int -> a -> arr = fun kind n null -> - match kind with - | Array -> Array.make n null - | Float -> Float.Array.make n null - let length : type a arr. (a, arr) kind -> arr -> int = fun kind arr -> - match kind with - | Array -> Array.length arr - | Float -> Float.Array.length arr - let get : type a arr. (a, arr) kind -> arr -> int -> a = fun kind arr n -> - match kind with - | Array -> Array.get arr n - | Float -> Float.Array.get arr n - let set : type a arr. (a, arr) kind -> arr -> int -> a -> unit = fun kind arr n -> - match kind with - | Array -> Array.set arr n - | Float -> Float.Array.set arr n - let blit : type a arr. (a, arr) kind -> arr -> int -> arr -> int -> int -> unit = fun kind src srcpos dst dstpos n -> - match kind with - | Array -> Array.blit src srcpos dst dstpos n - | Float -> Float.Array.blit src srcpos dst dstpos n - end - type ('a, 'arr) t = { - kind : ('a, 'arr) A.kind; - mutable data : 'arr; - mutable size : int - } - (* /!\ Dummy cannot be resized. *) - let dummy kind = { kind; data = A.empty kind; size = 0 } - let make kind null n = { kind; data = A.make kind (max 1 n) null; size = 0 } - let size {size; _} = size - let resize ({kind; size; data} as stack) = - if size = A.length kind data then begin - assert (size > 0); - let new_length = (2 * (size + 1)) - 1 in - stack.data <- A.make kind new_length (A.get kind data 0); - A.blit kind data 0 stack.data 0 size; - end - - let push stack x = - resize stack; - A.set stack.kind stack.data stack.size x; - stack.size <- stack.size + 1 - - let pop stack = - stack.size <- stack.size - 1; - A.get stack.kind stack.data stack.size - - let to_floatarray {data; size; _} = Float.Array.sub data 0 size -end - -type landmark = { - id: int; - key: landmark_key; - kind : Graph.kind; - name: string; - location: string; - - - mutable last_parent: node; - mutable last_son: node; - mutable last_self: node; -} - -and node = { - landmark: landmark; - - id: int; - - children: node SparseArray.t; - fathers: (node, node array) Stack.t; - - mutable calls: int; - mutable recursive_calls: int; - mutable timestamp: Int64.t; - distrib: (float, floatarray) Stack.t; - floats : floats; -} - -and floats = { - mutable time: float; - mutable allocated_bytes: int; - mutable allocated_bytes_stamp: int; - mutable allocated_bytes_major: int; - mutable allocated_bytes_major_stamp: int; - mutable sys_time: float; - mutable sys_timestamp: float; -} - -and landmark_key = { - key: string; - landmark: landmark; -} - -and counter = landmark - -and sampler = landmark - -let new_floats () = { - time = 0.0; - allocated_bytes = 0; - allocated_bytes_stamp = 0; - allocated_bytes_major = 0; - allocated_bytes_major_stamp = 0; - sys_time = 0.0; - sys_timestamp = 0.0 -} +type landmark = Utils.landmark +type counter = Utils.counter +type sampler = Utils.sampler let rec landmark_root = { kind = Graph.Root; @@ -257,7 +63,6 @@ type profile_format = | JSON | Textual of textual_option -let profiling_ref = ref false let profile_with_debug = ref false let profile_with_allocated_bytes = ref false let profile_with_sys_time = ref false @@ -265,6 +70,7 @@ let profile_output = ref Silent let profile_format = ref (Textual {threshold = 1.0}) let profile_recursive = ref false +let profiling_ref = ref false let profiling () = !profiling_ref (** REGISTERING **) @@ -395,18 +201,6 @@ let clear_cache () = in iter_registered_landmarks reset_landmark -type profiling_state = { - root : node; - nodes: node_info list; - nodes_len: int; - current: node; - cache_miss: int -} -and node_info = { - node: node; - recursive: bool; -} - let profiling_stack = let dummy = {root = dummy_node; current = dummy_node; nodes = [{node = dummy_node; recursive = false}]; cache_miss = 0; nodes_len = 1} @@ -437,7 +231,7 @@ let push_profiling_state () = if !profile_with_debug then Printf.eprintf "[Profiling] Push profiling state ....\n%!"; let state = - let node_info node = + let node_info (node: node) = let recursive = node.landmark.last_self == node in { node; recursive } in @@ -484,7 +278,7 @@ let landmark_failure msg = else raise (LandmarkFailure msg) -let get_entering_node ({id;_} as landmark) = +let get_entering_node ({id;_} as landmark: landmark) = let current_node = !current_node_ref in (* Read the "cache". *) if current_node == landmark.last_parent && landmark.last_son != dummy_node then @@ -552,7 +346,7 @@ let enter landmark = last_self.calls <- last_self.calls + 1 end -let mismatch_recovering landmark current_node = +let mismatch_recovering landmark (current_node: node) = let expected_landmark = current_node.landmark in if expected_landmark != landmark then begin let msg = @@ -647,9 +441,9 @@ let default_options = { } let set_profiling_options {debug; allocated_bytes; sys_time; output; format; recursive} = + profile_with_debug := debug; profile_with_allocated_bytes := allocated_bytes; profile_with_sys_time := sys_time; - profile_with_debug := debug; profile_output := output; profile_format := format; profile_recursive := recursive diff --git a/src/utils.ml b/src/utils.ml new file mode 100644 index 0000000..e6f63e4 --- /dev/null +++ b/src/utils.ml @@ -0,0 +1,217 @@ +(* This file is released under the terms of an MIT-like license. *) +(* See the attached LICENSE file. *) +(* Copyright (C) 2000-2025 LexiFi *) + +module SparseArray = struct + type 'a t = { + mutable keys : int array; + mutable data : 'a array; + mutable size : int; + } + + (* /!\ Dummy cannot be resized. *) + let dummy () = { keys = [||]; data = [||]; size = 0 } + + let make null n = + let n = max n 1 in + { + keys = Array.make n 0; + data = Array.make n null; + size = 0; + } + + let reset sparse_array = sparse_array.size <- 0 + + let get t id = + let {keys; data; size} = t in + let min = ref 0 in + let max = ref (size - 1) in + while !min < !max do + let middle = (!min + !max) / 2 in + if Array.unsafe_get keys middle < id then + min := middle + 1 + else + max := middle + done; + let idx = !min in + if idx = !max && + Array.unsafe_get keys idx = id then + Array.unsafe_get data idx + else + raise Not_found + + let swap a i j = + let t = a.(i) in + a.(i) <- a.(j); + a.(j) <- t + + let values {data; size; _} = + let result = ref [] in + for k = 0 to size-1 do + result := data.(k) :: !result; + done; + List.rev !result + + let bubble {keys; data; size} = + let pos = ref size in + let key = keys.(size) in + while + let p = !pos in + let q = p - 1 in + if key < keys.(q) then begin + swap keys p q; + swap data p q; + pos := q; + q > 0 + end else false + do () done + + let is_full ({keys; size; _}) = Array.length keys = size + + let resize ({keys; data; size} as sparse_array) = + if is_full sparse_array then begin + assert (size > 0); + let new_length = (2 * (size + 1)) - 1 in + sparse_array.keys <- Array.make new_length 0; + sparse_array.data <- Array.make new_length sparse_array.data.(0); + Array.blit keys 0 sparse_array.keys 0 size; + Array.blit data 0 sparse_array.data 0 size; + end + + let set sparse_array id node = + resize sparse_array; + let size = sparse_array.size in + sparse_array.keys.(size) <- id; + sparse_array.data.(size) <- node; + if size > 0 then + bubble sparse_array; + sparse_array.size <- sparse_array.size + 1 +end + +module Stack = struct + module A = struct + type (_, _) kind = + | Array : ('a, 'a array) kind + | Float : (float, floatarray) kind + let empty : type a arr. (a, arr) kind -> arr = function + | Array -> [||] + | Float -> Float.Array.create 0 + let make : type a arr. (a, arr) kind -> int -> a -> arr = fun kind n null -> + match kind with + | Array -> Array.make n null + | Float -> Float.Array.make n null + let length : type a arr. (a, arr) kind -> arr -> int = fun kind arr -> + match kind with + | Array -> Array.length arr + | Float -> Float.Array.length arr + let get : type a arr. (a, arr) kind -> arr -> int -> a = fun kind arr n -> + match kind with + | Array -> Array.get arr n + | Float -> Float.Array.get arr n + let set : type a arr. (a, arr) kind -> arr -> int -> a -> unit = fun kind arr n -> + match kind with + | Array -> Array.set arr n + | Float -> Float.Array.set arr n + let blit : type a arr. (a, arr) kind -> arr -> int -> arr -> int -> int -> unit = fun kind src srcpos dst dstpos n -> + match kind with + | Array -> Array.blit src srcpos dst dstpos n + | Float -> Float.Array.blit src srcpos dst dstpos n + end + type ('a, 'arr) t = { + kind : ('a, 'arr) A.kind; + mutable data : 'arr; + mutable size : int + } + (* /!\ Dummy cannot be resized. *) + let dummy kind = { kind; data = A.empty kind; size = 0 } + let make kind null n = { kind; data = A.make kind (max 1 n) null; size = 0 } + let size {size; _} = size + let resize ({kind; size; data} as stack) = + if size = A.length kind data then begin + assert (size > 0); + let new_length = (2 * (size + 1)) - 1 in + stack.data <- A.make kind new_length (A.get kind data 0); + A.blit kind data 0 stack.data 0 size; + end + + let push stack x = + resize stack; + A.set stack.kind stack.data stack.size x; + stack.size <- stack.size + 1 + + let pop stack = + stack.size <- stack.size - 1; + A.get stack.kind stack.data stack.size + + let to_floatarray {data; size; _} = Float.Array.sub data 0 size +end + +type landmark = { + id: int; + key: landmark_key; + kind : Graph.kind; + name: string; + location: string; + + + mutable last_parent: node; + mutable last_son: node; + mutable last_self: node; +} + +and node = { + landmark: landmark; + + id: int; + + children: node SparseArray.t; + fathers: (node, node array) Stack.t; + + mutable calls: int; + mutable recursive_calls: int; + mutable timestamp: Int64.t; + distrib: (float, floatarray) Stack.t; + floats : floats; +} + +and floats = { + mutable time: float; + mutable allocated_bytes: int; + mutable allocated_bytes_stamp: int; + mutable allocated_bytes_major: int; + mutable allocated_bytes_major_stamp: int; + mutable sys_time: float; + mutable sys_timestamp: float; +} + +and landmark_key = { + key: string; + landmark: landmark; +} + +and counter = landmark + +and sampler = landmark + +let new_floats () = { + time = 0.0; + allocated_bytes = 0; + allocated_bytes_stamp = 0; + allocated_bytes_major = 0; + allocated_bytes_major_stamp = 0; + sys_time = 0.0; + sys_timestamp = 0.0 +} + +type profiling_state = { + root : node; + nodes: node_info list; + nodes_len: int; + current: node; + cache_miss: int +} + +and node_info = { + node: node; + recursive: bool; +} diff --git a/src/utils.mli b/src/utils.mli new file mode 100644 index 0000000..a79bb74 --- /dev/null +++ b/src/utils.mli @@ -0,0 +1,105 @@ +(* This file is released under the terms of an MIT-like license. *) +(* See the attached LICENSE file. *) +(* Copyright (C) 2000-2025 LexiFi *) + +module SparseArray : +sig + type 'a t = { + mutable keys : int array; + mutable data : 'a array; + mutable size : int; + } + val dummy : unit -> 'a t + val make : 'a -> int -> 'a t + val reset : 'a t -> unit + val get : 'a t -> int -> 'a + val swap : 'a array -> int -> int -> unit + val values : 'a t -> 'a list + val bubble : 'a t -> unit + val is_full : 'a t -> bool + val resize : 'a t -> unit + val set : 'a t -> int -> 'a -> unit +end + +module Stack : +sig + module A : + sig + type (_, _) kind = + Array : ('a, 'a array) kind + | Float : (float, floatarray) kind + val empty : ('a, 'arr) kind -> 'arr + val make : ('a, 'arr) kind -> int -> 'a -> 'arr + val length : ('a, 'arr) kind -> 'arr -> int + val get : ('a, 'arr) kind -> 'arr -> int -> 'a + val set : ('a, 'arr) kind -> 'arr -> int -> 'a -> unit + val blit : + ('a, 'arr) kind -> 'arr -> int -> 'arr -> int -> int -> unit + end + type ('a, 'arr) t = { + kind : ('a, 'arr) A.kind; + mutable data : 'arr; + mutable size : int; + } + val dummy : ('a, 'b) A.kind -> ('a, 'b) t + val make : ('a, 'b) A.kind -> 'a -> int -> ('a, 'b) t + val size : ('a, 'b) t -> int + val resize : ('a, 'b) t -> unit + val push : ('a, 'b) t -> 'a -> unit + val pop : ('a, 'b) t -> 'a + val to_floatarray : ('a, floatarray) t -> floatarray +end + +type landmark = { + id : int; + key : landmark_key; + kind : Graph.kind; + name : string; + location : string; + mutable last_parent : node; + mutable last_son : node; + mutable last_self : node; +} + +and node = { + landmark : landmark; + id : int; + children : node SparseArray.t; + fathers : (node, node array) Stack.t; + mutable calls : int; + mutable recursive_calls : int; + mutable timestamp : int64; + distrib : (float, floatarray) Stack.t; + floats : floats; +} + +and floats = { + mutable time : float; + mutable allocated_bytes : int; + mutable allocated_bytes_stamp : int; + mutable allocated_bytes_major : int; + mutable allocated_bytes_major_stamp : int; + mutable sys_time : float; + mutable sys_timestamp : float; +} + +and landmark_key = { key : string; landmark : landmark; } + +and counter = landmark + +and sampler = landmark + +val new_floats : unit -> floats + +type profiling_state = { + root : node; + nodes: node_info list; + nodes_len: int; + current: node; + cache_miss: int +} + +and node_info = { + node: node; + recursive: bool; +} From 3dae4f063f956d191eeaf229fab71fe05e32aba5 Mon Sep 17 00:00:00 2001 From: hra687261 Date: Mon, 8 Dec 2025 21:53:42 +0100 Subject: [PATCH 03/16] Move profiling options to utils.ml --- src/landmark.ml | 22 ++++++++-------------- src/utils.ml | 29 +++++++++++++++++++++++++++++ src/utils.mli | 22 ++++++++++++++++++++++ 3 files changed, 59 insertions(+), 14 deletions(-) diff --git a/src/landmark.ml b/src/landmark.ml index 33bffea..e100ab7 100644 --- a/src/landmark.ml +++ b/src/landmark.ml @@ -52,14 +52,14 @@ and dummy_key = { key = ""; landmark = landmark_root} (** STATE **) -type profile_output = +type profile_output = Utils.profile_output = | Silent | Temporary of string option | Channel of out_channel -type textual_option = {threshold : float} +type textual_option = Utils.textual_option = {threshold : float} -type profile_format = +type profile_format = Utils.profile_format = | JSON | Textual of textual_option @@ -422,23 +422,17 @@ let unsafe_wrap node f x = (** PROFILERS **) -type profiling_options = { +type profiling_options = Utils.profiling_options = { debug : bool; allocated_bytes: bool; sys_time : bool; recursive : bool; - output : profile_output; - format : profile_format + output : Utils.profile_output; + format : Utils.profile_format } -let default_options = { - debug = false; - allocated_bytes = true; - sys_time = false; - recursive = false; - output = Channel stderr; - format = Textual {threshold = 1.0}; -} + +let default_options = default_options let set_profiling_options {debug; allocated_bytes; sys_time; output; format; recursive} = profile_with_debug := debug; diff --git a/src/utils.ml b/src/utils.ml index e6f63e4..a230843 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -203,6 +203,35 @@ let new_floats () = { sys_timestamp = 0.0 } +type profile_output = + | Silent + | Temporary of string option + | Channel of out_channel + +type textual_option = {threshold : float} + +type profile_format = + | JSON + | Textual of textual_option + +type profiling_options = { + debug : bool; + allocated_bytes: bool; + sys_time : bool; + recursive : bool; + output : profile_output; + format : profile_format +} + +let default_options = { + debug = false; + allocated_bytes = true; + sys_time = false; + recursive = false; + output = Channel stderr; + format = Textual {threshold = 1.0}; +} + type profiling_state = { root : node; nodes: node_info list; diff --git a/src/utils.mli b/src/utils.mli index a79bb74..3a77906 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -91,6 +91,28 @@ and sampler = landmark val new_floats : unit -> floats +type profile_output = + | Silent + | Temporary of string option + | Channel of out_channel + +type textual_option = {threshold : float} + +type profile_format = + | JSON + | Textual of textual_option + +type profiling_options = { + debug : bool; + allocated_bytes: bool; + sys_time : bool; + recursive : bool; + output : profile_output; + format : profile_format +} + +val default_options: profiling_options + type profiling_state = { root : node; nodes: node_info list; From fca3b1b9c67cb055e82c55ebc39a448a7bd57e15 Mon Sep 17 00:00:00 2001 From: hra687261 Date: Tue, 9 Dec 2025 13:37:08 +0100 Subject: [PATCH 04/16] Move global references to in landmark.ml to landmark_state.ml --- src/landmark.ml | 270 +++++++++++++------------------------- src/landmark_state.ml | 86 ++++++++++++ src/landmark_state.mli | 5 + src/landmark_state_sig.ml | 36 +++++ src/utils.ml | 52 ++++++++ src/utils.mli | 8 ++ 6 files changed, 280 insertions(+), 177 deletions(-) create mode 100644 src/landmark_state.ml create mode 100644 src/landmark_state.mli create mode 100644 src/landmark_state_sig.ml diff --git a/src/landmark.ml b/src/landmark.ml index e100ab7..0f2eacd 100644 --- a/src/landmark.ml +++ b/src/landmark.ml @@ -3,6 +3,7 @@ (* Copyright (C) 2000-2025 LexiFi *) open Utils +open Landmark_state.Ref external clock: unit -> (Int64.t [@unboxed]) = "caml_highres_clock" "caml_highres_clock_native" [@@noalloc] @@ -25,31 +26,6 @@ type landmark = Utils.landmark type counter = Utils.counter type sampler = Utils.sampler -let rec landmark_root = { - kind = Graph.Root; - id = 0; - name = "ROOT"; - location = __FILE__; - key = { key = ""; landmark = landmark_root}; - last_parent = dummy_node; - last_son = dummy_node; - last_self = dummy_node; -} - -and dummy_node = { - landmark = landmark_root; - id = 0; - children = SparseArray.dummy (); - fathers = Stack.dummy Array; - floats = new_floats (); - calls = 0; - recursive_calls = 0; - distrib = Stack.dummy Float; - timestamp = Int64.zero -} - -and dummy_key = { key = ""; landmark = landmark_root} - (** STATE **) type profile_output = Utils.profile_output = @@ -63,38 +39,21 @@ type profile_format = Utils.profile_format = | JSON | Textual of textual_option -let profile_with_debug = ref false -let profile_with_allocated_bytes = ref false -let profile_with_sys_time = ref false -let profile_output = ref Silent -let profile_format = ref (Textual {threshold = 1.0}) -let profile_recursive = ref false - -let profiling_ref = ref false -let profiling () = !profiling_ref +let profiling = profiling (** REGISTERING **) -let last_landmark_id = ref 1 -module W = Weak.Make(struct - type t = landmark_key - let equal (x : landmark_key) (y : landmark_key) = x.key = y.key - let hash (x : landmark_key) = Hashtbl.hash x.key - end) - -let landmarks_of_key = W.create 17 - let iter_registered_landmarks f = - W.iter (fun {landmark; _} -> f landmark) landmarks_of_key + W.iter (fun {landmark; _} -> f landmark) (get_landmarks_of_key ()) let landmark_of_id user_id = - match W.find_opt landmarks_of_key {dummy_key with key = user_id} with + match W.find_opt (get_landmarks_of_key ()) {dummy_key with key = user_id} with | None -> None | Some {landmark; _} -> Some landmark let new_landmark ~key:key_string ~name ~location ~kind () = - let id = !last_landmark_id in - incr last_landmark_id; + let id = get_last_landmark_id () in + incr_last_landmark_id (); let rec res = { id; @@ -107,33 +66,10 @@ let new_landmark ~key:key_string ~name ~location ~kind () = last_son = dummy_node; } and key = { landmark = res; key = key_string} in - W.add landmarks_of_key key; + add_landmarks_of_key key; res -let node_id_ref = ref 0 -let allocated_nodes = ref [] -let new_node landmark = - if !profile_with_debug then - Printf.eprintf "[Profiling] Allocating new node for %s...\n%!" landmark.name; - let id = !node_id_ref in - incr node_id_ref; - let node = { - landmark; - id; - - fathers = Stack.make Array dummy_node 1; - distrib = Stack.make Float 0.0 0; - children = SparseArray.make dummy_node 7; - - calls = 0; - recursive_calls = 0; - timestamp = Int64.zero; - floats = new_floats (); - } in - allocated_nodes := node :: !allocated_nodes; - node - -let current_root_node = ref (new_node landmark_root) +let new_node = Landmark_state.Ref.new_node let landmark_of_node ({landmark_id = key; name; location; kind; _} : Graph.node) = match landmark_of_id key with @@ -142,7 +78,7 @@ let landmark_of_node ({landmark_id = key; name; location; kind; _} : Graph.node) let register_generic ~id ~name ~location ~kind () = let landmark = new_landmark ~key:id ~name ~location ~kind () in - if !profile_with_debug then + if profile_with_debug () then Printf.eprintf "[Profiling] registering(%s)\n%!" name; landmark @@ -181,17 +117,15 @@ let register_counter name = register_generic Graph.Counter name let register_sampler name = register_generic Graph.Sampler name -let current_node_ref = ref !current_root_node -let cache_miss_ref = ref 0 - let stamp_root () = - !current_root_node.timestamp <- clock (); - if !profile_with_allocated_bytes then begin - !current_root_node.floats.allocated_bytes <- allocated_bytes (); - !current_root_node.floats.allocated_bytes_major <- allocated_bytes_major () + let current_root_node = get_current_root_node () in + current_root_node.timestamp <- clock (); + if profile_with_allocated_bytes () then begin + current_root_node.floats.allocated_bytes <- allocated_bytes (); + current_root_node.floats.allocated_bytes_major <- allocated_bytes_major () end; - if !profile_with_sys_time then - !current_root_node.floats.sys_time <- Sys.time () + if profile_with_sys_time () then + current_root_node.floats.sys_time <- Sys.time () let clear_cache () = let reset_landmark landmark = @@ -201,34 +135,29 @@ let clear_cache () = in iter_registered_landmarks reset_landmark -let profiling_stack = - let dummy = - {root = dummy_node; current = dummy_node; nodes = [{node = dummy_node; recursive = false}]; cache_miss = 0; nodes_len = 1} - in - Stack.make Array dummy 7 - let reset () = - if !profile_with_debug then + if profile_with_debug () then Printf.eprintf "[Profiling] resetting ...\n%!"; (* reset dummy_node *) - let floats = !current_root_node.floats in + let current_root_node = get_current_root_node () in + let floats = current_root_node.floats in floats.time <- 0.0; floats.allocated_bytes <- 0; floats.sys_time <- 0.0; - !current_root_node.calls <- 0; - !current_root_node.recursive_calls <- 0; + current_root_node.calls <- 0; + current_root_node.recursive_calls <- 0; stamp_root (); - SparseArray.reset !current_root_node.children; - allocated_nodes := [!current_root_node]; - current_node_ref := !current_root_node; - cache_miss_ref := 0; + SparseArray.reset current_root_node.children; + set_allocated_nodes [current_root_node]; + set_current_node_ref current_root_node; + set_cache_miss_ref 0; clear_cache (); - node_id_ref := 1 + set_node_id_ref 1 let () = reset () let push_profiling_state () = - if !profile_with_debug then + if profile_with_debug () then Printf.eprintf "[Profiling] Push profiling state ....\n%!"; let state = let node_info (node: node) = @@ -236,55 +165,56 @@ let push_profiling_state () = { node; recursive } in { - root = !current_root_node; - nodes = List.map node_info !allocated_nodes; - nodes_len = !node_id_ref; - current = !current_node_ref; - cache_miss = !cache_miss_ref; + root = get_current_root_node (); + nodes = List.map node_info (get_allocated_nodes ()); + nodes_len = get_node_id_ref (); + current = get_current_node_ref (); + cache_miss = get_cache_miss_ref (); } in clear_cache (); - current_root_node := new_node landmark_root; - current_node_ref := !current_root_node; - cache_miss_ref := 0; - allocated_nodes := [!current_root_node]; - node_id_ref := 1; + set_current_root_node (new_node landmark_root); + set_current_node_ref (get_current_root_node ()); + set_cache_miss_ref 0; + set_allocated_nodes [get_current_root_node ()]; + set_node_id_ref 1; reset (); - Stack.push profiling_stack state + Stack.push (get_profiling_stack ()) state let pop_profiling_state () = + let profiling_stack = get_profiling_stack () in if profiling_stack.size > 0 then let {root; nodes; nodes_len; current; cache_miss} = Stack.pop profiling_stack in - current_root_node := root; - current_node_ref := current; - cache_miss_ref := cache_miss; - allocated_nodes := List.map (fun {node; recursive} -> if recursive then node.landmark.last_self <- node; node) nodes; - node_id_ref := nodes_len + set_current_root_node root; + set_current_node_ref current; + set_cache_miss_ref cache_miss; + set_allocated_nodes (List.map (fun {node; recursive} -> if recursive then node.landmark.last_self <- node; node) nodes); + set_node_id_ref nodes_len let unroll_until node = while - let current_node = !current_node_ref in + let current_node = get_current_node_ref () in current_node != node && Stack.size current_node.fathers > 0 - && (current_node_ref := Stack.pop current_node.fathers; true) + && (set_current_node_ref (Stack.pop current_node.fathers); true) do () done let landmark_failure msg = - unroll_until !current_root_node; - if !current_node_ref != !current_root_node then + unroll_until (get_current_root_node ()); + if get_current_node_ref () != get_current_root_node () then reset (); - if !profile_with_debug then + if profile_with_debug () then (Printf.eprintf "Landmark error: %s\n%!" msg; Stdlib.exit 2) else raise (LandmarkFailure msg) let get_entering_node ({id;_} as landmark: landmark) = - let current_node = !current_node_ref in + let current_node = get_current_node_ref () in (* Read the "cache". *) if current_node == landmark.last_parent && landmark.last_son != dummy_node then landmark.last_son else begin - incr cache_miss_ref; + incr_cache_miss_ref (); (* We fetch the son or create it. *) let children = current_node.children in let son = try @@ -311,7 +241,7 @@ let increment ?(times = 1) counter = node.calls <- node.calls + times let increment ?times counter = - if !profiling_ref then + if profiling () then increment ?times counter let sample sampler x = @@ -320,25 +250,25 @@ let sample sampler x = Stack.push node.distrib x let sample sampler x = - if !profiling_ref then + if profiling () then sample sampler x let enter landmark = - if !profile_with_debug then + if profile_with_debug () then Printf.eprintf "[Profiling] enter%s(%s)\n%!" (if landmark.last_self != dummy_node then " recursive " else "") landmark.name; - if landmark.last_self == dummy_node || !profile_recursive then begin + if landmark.last_self == dummy_node || profile_recursive () then begin let node = get_entering_node landmark in node.calls <- node.calls + 1; - Stack.push node.fathers !current_node_ref; - current_node_ref := node; + Stack.push node.fathers (get_current_node_ref ()); + set_current_node_ref node; landmark.last_self <- node; node.timestamp <- clock (); - if !profile_with_allocated_bytes then begin + if profile_with_allocated_bytes () then begin node.floats.allocated_bytes_stamp <- allocated_bytes (); node.floats.allocated_bytes_major_stamp <- allocated_bytes_major (); end; - if !profile_with_sys_time then + if profile_with_sys_time () then node.floats.sys_timestamp <- Sys.time () end else begin let last_self = landmark.last_self in @@ -356,7 +286,7 @@ let mismatch_recovering landmark (current_node: node) = in Printf.eprintf "Warning: %s\n%!" msg; unroll_until landmark.last_self; - if landmark != !current_node_ref.landmark then begin + if landmark != (get_current_node_ref ()).landmark then begin reset (); landmark_failure ("unable to recover from "^msg) end @@ -366,7 +296,7 @@ let aggregate_stat_for current_node = let floats = current_node.floats in floats.time <- floats.time +. Int64.(to_float (sub (clock ()) current_node.timestamp)); - if !profile_with_allocated_bytes then begin + if profile_with_allocated_bytes () then begin floats.allocated_bytes <- floats.allocated_bytes + (allocated_bytes () - floats.allocated_bytes_stamp); @@ -374,33 +304,33 @@ let aggregate_stat_for current_node = floats.allocated_bytes_major + (allocated_bytes_major () - floats.allocated_bytes_major_stamp) end; - if !profile_with_sys_time then + if profile_with_sys_time () then floats.sys_time <- floats.sys_time +. (Sys.time () -. floats.sys_timestamp) let exit landmark = - if !profile_with_debug then - Printf.eprintf "[Profiling] exit%s(%s)\n%!" (if landmark.last_self != !current_node_ref then " recursive " else "") landmark.name; - let current_node = !current_node_ref in + if profile_with_debug () then + Printf.eprintf "[Profiling] exit%s(%s)\n%!" (if landmark.last_self != get_current_node_ref () then " recursive " else "") landmark.name; + let current_node = get_current_node_ref () in let last_self = landmark.last_self in - if last_self.recursive_calls = 0 || !profile_recursive then begin + if last_self.recursive_calls = 0 || profile_recursive () then begin mismatch_recovering landmark current_node; if Stack.size current_node.fathers = 1 then begin landmark.last_self <- dummy_node; aggregate_stat_for current_node; end; - current_node_ref := get_exiting_node current_node + set_current_node_ref (get_exiting_node current_node) end - else if not !profile_recursive then + else if not (profile_recursive ()) then last_self.recursive_calls <- last_self.recursive_calls - 1 (* These two functions should be inlined. *) let enter landmark = - if !profiling_ref then + if profiling () then enter landmark let exit landmark = - if !profiling_ref then + if profiling () then exit landmark (** HELPERS **) @@ -433,54 +363,40 @@ type profiling_options = Utils.profiling_options = { let default_options = default_options - -let set_profiling_options {debug; allocated_bytes; sys_time; output; format; recursive} = - profile_with_debug := debug; - profile_with_allocated_bytes := allocated_bytes; - profile_with_sys_time := sys_time; - profile_output := output; - profile_format := format; - profile_recursive := recursive - -let profiling_options () = { - debug = !profile_with_debug; - allocated_bytes = !profile_with_allocated_bytes; - sys_time = !profile_with_sys_time; - recursive = !profile_recursive; - output = !profile_output; - format = !profile_format -} +let set_profiling_options = set_profiling_options +let profiling_options = profiling_options let start_profiling ?(profiling_options = default_options) () = - if !profiling_ref then + if profiling () then failwith "In profiling: it is not allowed to nest profilings."; set_profiling_options profiling_options; - if !profile_with_debug then + if profile_with_debug () then Printf.eprintf "[Profiling] Start profiling %s...\n%!" - (match !profile_with_allocated_bytes, !profile_with_sys_time with + (match profile_with_allocated_bytes (), profile_with_sys_time () with | true, true -> "with garbage collection statistics and system time" | true, false -> "with garbage collection statistics" | false, true -> "with system time" | false, false -> ""); - profiling_ref := true + set_profiling true let rec exit_until_root () = - if !current_node_ref != !current_root_node then begin - let landmark = !current_node_ref.landmark in + let current_node_ref = get_current_node_ref () in + if current_node_ref != get_current_root_node () then begin + let landmark = current_node_ref.landmark in exit landmark; exit_until_root (); end let stop_profiling () = - if not !profiling_ref then + if not (profiling ()) then failwith "In profiling: cannot stop since profiling is not on-going"; exit_until_root (); - let current_node = !current_node_ref in - assert (current_node == !current_root_node); + let current_node = get_current_node_ref () in + assert (current_node == get_current_root_node ()); aggregate_stat_for current_node; - if !profile_with_debug then + if profile_with_debug () then Printf.eprintf "[Profiling] Stop profiling.\n%!"; - profiling_ref := false + set_profiling false (** EXPORTING / IMPORTING SLAVE PROFILINGS **) @@ -502,16 +418,16 @@ let export ?(label = "") () = {Graph.landmark_id; id; name; location; calls; time; kind; allocated_bytes; allocated_bytes_major; sys_time; children; distrib = Stack.to_floatarray distrib} in - if !profiling_ref then begin - aggregate_stat_for !current_root_node; + if profiling () then begin + aggregate_stat_for (get_current_root_node ()); stamp_root () end; - let all_nodes = List.rev !allocated_nodes in + let all_nodes = List.rev (get_allocated_nodes ()) in let nodes = array_list_map export_node all_nodes in {Graph.nodes; label; root = 0} let export_and_reset ?label () = - let profiling = !profiling_ref in + let profiling = profiling () in if profiling then stop_profiling (); let res = export ?label () in @@ -552,20 +468,20 @@ and new_branch parent graph (imported : Graph.node) = List.iter (new_branch node graph) (Graph.children graph imported) let merge (graph : Graph.graph) = - if !profile_with_debug then + if profile_with_debug () then Printf.eprintf "[Profiling] merging foreign graph\n%!"; - merge_branch !current_root_node graph (Graph.root graph) + merge_branch (get_current_root_node ()) graph (Graph.root graph) let exit_hook () = - if !profile_with_debug then + if profile_with_debug () then Printf.eprintf "[Profiling] exit_hook\n%!"; - if !profiling_ref then begin + if profiling () then begin stop_profiling (); let label = String.concat " " (Array.to_list Sys.argv) in let cg = export ~label () in - match !profile_output, !profile_format with + match profile_output (), profile_format () with | Silent, _ -> () | Channel out, Textual {threshold} -> Graph.output ~threshold out cg diff --git a/src/landmark_state.ml b/src/landmark_state.ml new file mode 100644 index 0000000..29991a1 --- /dev/null +++ b/src/landmark_state.ml @@ -0,0 +1,86 @@ +(* This file is released under the terms of an MIT-like license. *) +(* See the attached LICENSE file. *) +(* Copyright (C) 2000-2025 LexiFi *) + +open Utils + +module Stack = Utils.Stack + +module Ref = struct + + let profiling_ref = ref false + let profiling () = !profiling_ref + let set_profiling b = profiling_ref := b + + + let last_landmark_id = ref 1 + let get_last_landmark_id () = !last_landmark_id + let incr_last_landmark_id () = incr last_landmark_id + + let landmarks_of_key = W.create 17 + let get_landmarks_of_key () = landmarks_of_key + let add_landmarks_of_key key = W.add landmarks_of_key key + + let node_id_ref = ref 0 + let get_node_id_ref () = !node_id_ref + let set_node_id_ref n = node_id_ref := n + + let allocated_nodes = ref [] + let get_allocated_nodes () = !allocated_nodes + let set_allocated_nodes l = allocated_nodes := l + + let profile_with_debug = ref false + let profile_with_allocated_bytes = ref false + let profile_with_sys_time = ref false + let profile_output = ref Silent + let profile_format = ref (Textual {threshold = 1.0}) + let profile_recursive = ref false + + let set_profiling_options {debug; allocated_bytes; sys_time; output; format; recursive} = + profile_with_debug := debug; + profile_with_allocated_bytes := allocated_bytes; + profile_with_sys_time := sys_time; + profile_output := output; + profile_format := format; + profile_recursive := recursive + + let profiling_options () = { + debug = !profile_with_debug; + allocated_bytes = !profile_with_allocated_bytes; + sys_time = !profile_with_sys_time; + recursive = !profile_recursive; + output = !profile_output; + format = !profile_format + } + + let profile_with_debug () = !profile_with_debug + let profile_with_allocated_bytes () = !profile_with_allocated_bytes + let profile_with_sys_time () = !profile_with_sys_time + let profile_output () = !profile_output + let profile_format () = !profile_format + let profile_recursive () = !profile_recursive + + let new_node landmark = + new_node landmark (profile_with_debug ()) node_id_ref allocated_nodes + + let current_root_node = ref (new_node landmark_root) + let get_current_root_node () = !current_root_node + let set_current_root_node node = current_root_node := node + + let current_node_ref = ref !current_root_node + let get_current_node_ref () = !current_node_ref + let set_current_node_ref node = current_node_ref := node + + let cache_miss_ref = ref 0 + let get_cache_miss_ref () = !cache_miss_ref + let set_cache_miss_ref n = cache_miss_ref := n + + let profiling_stack = + let dummy = + {root = dummy_node; current = dummy_node; nodes = [{node = dummy_node; recursive = false}]; cache_miss = 0; nodes_len = 1} + in + Stack.make Array dummy 7 + let incr_cache_miss_ref () = incr cache_miss_ref + let get_profiling_stack () = profiling_stack + +end diff --git a/src/landmark_state.mli b/src/landmark_state.mli new file mode 100644 index 0000000..a35a4a8 --- /dev/null +++ b/src/landmark_state.mli @@ -0,0 +1,5 @@ +(* This file is released under the terms of an MIT-like license. *) +(* See the attached LICENSE file. *) +(* Copyright (C) 2000-2025 LexiFi *) + +module Ref : Landmark_state_sig.S diff --git a/src/landmark_state_sig.ml b/src/landmark_state_sig.ml new file mode 100644 index 0000000..08bfc3e --- /dev/null +++ b/src/landmark_state_sig.ml @@ -0,0 +1,36 @@ +(* This file is released under the terms of an MIT-like license. *) +(* See the attached LICENSE file. *) +(* Copyright (C) 2000-2025 LexiFi *) + +module type S = +sig + val profiling : unit -> bool + val set_profiling : bool -> unit + val get_last_landmark_id : unit -> int + val incr_last_landmark_id : unit -> unit + val get_landmarks_of_key : unit -> Utils.W.t + val add_landmarks_of_key : Utils.landmark_key -> unit + val get_node_id_ref : unit -> int + val set_node_id_ref : int -> unit + val get_allocated_nodes : unit -> Utils.node list + val set_allocated_nodes : Utils.node list -> unit + val set_profiling_options : Utils.profiling_options -> unit + val profiling_options : unit -> Utils.profiling_options + val profile_with_debug : unit -> bool + val profile_with_allocated_bytes : unit -> bool + val profile_with_sys_time : unit -> bool + val profile_output : unit -> Utils.profile_output + val profile_format : unit -> Utils.profile_format + val profile_recursive : unit -> bool + val new_node : Utils.landmark -> Utils.node + val get_current_root_node : unit -> Utils.node + val set_current_root_node : Utils.node -> unit + val get_current_node_ref : unit -> Utils.node + val set_current_node_ref : Utils.node -> unit + val get_cache_miss_ref : unit -> int + val set_cache_miss_ref : int -> unit + val incr_cache_miss_ref : unit -> unit + val get_profiling_stack : + unit -> + (Utils.profiling_state, Utils.profiling_state array) Utils.Stack.t +end diff --git a/src/utils.ml b/src/utils.ml index a230843..48fdd12 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -193,6 +193,12 @@ and counter = landmark and sampler = landmark +module W = Weak.Make(struct + type t = landmark_key + let equal (x : landmark_key) (y : landmark_key) = x.key = y.key + let hash (x : landmark_key) = Hashtbl.hash x.key + end) + let new_floats () = { time = 0.0; allocated_bytes = 0; @@ -203,6 +209,52 @@ let new_floats () = { sys_timestamp = 0.0 } +let rec landmark_root = { + kind = Graph.Root; + id = 0; + name = "ROOT"; + location = __FILE__; + key = { key = ""; landmark = landmark_root}; + last_parent = dummy_node; + last_son = dummy_node; + last_self = dummy_node; +} + +and dummy_node = { + landmark = landmark_root; + id = 0; + children = SparseArray.dummy (); + fathers = Stack.dummy Array; + floats = new_floats (); + calls = 0; + recursive_calls = 0; + distrib = Stack.dummy Float; + timestamp = Int64.zero +} + +and dummy_key = { key = ""; landmark = landmark_root} + +let new_node landmark profile_with_debug node_id_ref allocated_nodes = + if profile_with_debug then + Printf.eprintf "[Profiling] Allocating new node for %s...\n%!" landmark.name; + let id = !node_id_ref in + incr node_id_ref; + let node = { + landmark; + id; + + fathers = Stack.make Array dummy_node 1; + distrib = Stack.make Float 0.0 0; + children = SparseArray.make dummy_node 7; + + calls = 0; + recursive_calls = 0; + timestamp = Int64.zero; + floats = new_floats (); + } in + allocated_nodes := node :: !allocated_nodes; + node + type profile_output = | Silent | Temporary of string option diff --git a/src/utils.mli b/src/utils.mli index 3a77906..974287e 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -89,8 +89,16 @@ and counter = landmark and sampler = landmark +module W: Weak.S with type data = landmark_key + val new_floats : unit -> floats +val landmark_root : landmark +val dummy_node : node +val dummy_key : landmark_key + +val new_node: counter -> bool -> int ref -> node list ref -> node + type profile_output = | Silent | Temporary of string option From d72c0740bb88f94c0227f5b50467c5826f2e8b13 Mon Sep 17 00:00:00 2001 From: hra687261 Date: Tue, 16 Dec 2025 10:41:41 +0100 Subject: [PATCH 05/16] rename landmark_state to landmark_state_ocaml4, And factorize some code to prepare for landmark_state_ocaml5 --- src/landmark.ml | 157 +++++------------- src/landmark_state.ml | 86 ---------- src/landmark_state_ocaml4.ml | 120 +++++++++++++ ...rk_state.mli => landmark_state_ocaml4.mli} | 2 +- src/landmark_state_sig.ml | 47 +++--- src/utils.ml | 125 ++++++++++---- src/utils.mli | 29 +++- 7 files changed, 308 insertions(+), 258 deletions(-) delete mode 100644 src/landmark_state.ml create mode 100644 src/landmark_state_ocaml4.ml rename src/{landmark_state.mli => landmark_state_ocaml4.mli} (86%) diff --git a/src/landmark.ml b/src/landmark.ml index 0f2eacd..a6ccbed 100644 --- a/src/landmark.ml +++ b/src/landmark.ml @@ -3,20 +3,13 @@ (* Copyright (C) 2000-2025 LexiFi *) open Utils -open Landmark_state.Ref + +module Landmark_state = Landmark_state_ocaml4 +open Landmark_state external clock: unit -> (Int64.t [@unboxed]) = "caml_highres_clock" "caml_highres_clock_native" [@@noalloc] -(* Alternative implementation of Gc.allocated_bytes which does not allocate *) -external allocated_bytes: unit -> (Int64.t [@unboxed]) = - "allocated_bytes" "allocated_bytes_native" [@@noalloc] -external allocated_bytes_major: unit -> (Int64.t [@unboxed]) = - "allocated_bytes_major" "allocated_bytes_major_native" [@@noalloc] - -let allocated_bytes () = Int64.to_int (allocated_bytes ()) -let allocated_bytes_major () = Int64.to_int (allocated_bytes_major ()) - exception LandmarkFailure of string module Graph = Graph @@ -43,17 +36,18 @@ let profiling = profiling (** REGISTERING **) -let iter_registered_landmarks f = - W.iter (fun {landmark; _} -> f landmark) (get_landmarks_of_key ()) +let last_landmark_id = ref 1 let landmark_of_id user_id = + let dummy_key = dummy_key () in match W.find_opt (get_landmarks_of_key ()) {dummy_key with key = user_id} with | None -> None | Some {landmark; _} -> Some landmark let new_landmark ~key:key_string ~name ~location ~kind () = - let id = get_last_landmark_id () in - incr_last_landmark_id (); + let id = !last_landmark_id in + incr last_landmark_id; + let dummy_node = dummy_node () in let rec res = { id; @@ -69,7 +63,7 @@ let new_landmark ~key:key_string ~name ~location ~kind () = add_landmarks_of_key key; res -let new_node = Landmark_state.Ref.new_node +let new_node = Landmark_state.new_node let landmark_of_node ({landmark_id = key; name; location; kind; _} : Graph.node) = match landmark_of_id key with @@ -117,42 +111,8 @@ let register_counter name = register_generic Graph.Counter name let register_sampler name = register_generic Graph.Sampler name -let stamp_root () = - let current_root_node = get_current_root_node () in - current_root_node.timestamp <- clock (); - if profile_with_allocated_bytes () then begin - current_root_node.floats.allocated_bytes <- allocated_bytes (); - current_root_node.floats.allocated_bytes_major <- allocated_bytes_major () - end; - if profile_with_sys_time () then - current_root_node.floats.sys_time <- Sys.time () - -let clear_cache () = - let reset_landmark landmark = - landmark.last_son <- dummy_node; - landmark.last_parent <- dummy_node; - landmark.last_self <- dummy_node; - in - iter_registered_landmarks reset_landmark - let reset () = - if profile_with_debug () then - Printf.eprintf "[Profiling] resetting ...\n%!"; - (* reset dummy_node *) - let current_root_node = get_current_root_node () in - let floats = current_root_node.floats in - floats.time <- 0.0; - floats.allocated_bytes <- 0; - floats.sys_time <- 0.0; - current_root_node.calls <- 0; - current_root_node.recursive_calls <- 0; - stamp_root (); - SparseArray.reset current_root_node.children; - set_allocated_nodes [current_root_node]; - set_current_node_ref current_root_node; - set_cache_miss_ref 0; - clear_cache (); - set_node_id_ref 1 + reset () let () = reset () @@ -173,7 +133,7 @@ let push_profiling_state () = } in clear_cache (); - set_current_root_node (new_node landmark_root); + set_current_root_node (new_node (landmark_root ())); set_current_node_ref (get_current_root_node ()); set_cache_miss_ref 0; set_allocated_nodes [get_current_root_node ()]; @@ -192,12 +152,7 @@ let pop_profiling_state () = set_node_id_ref nodes_len let unroll_until node = - while - let current_node = get_current_node_ref () in - current_node != node - && Stack.size current_node.fathers > 0 - && (set_current_node_ref (Stack.pop current_node.fathers); true) - do () done + unroll_until (get_current_node_ref ()) set_current_node_ref node let landmark_failure msg = unroll_until (get_current_root_node ()); @@ -211,7 +166,7 @@ let landmark_failure msg = let get_entering_node ({id;_} as landmark: landmark) = let current_node = get_current_node_ref () in (* Read the "cache". *) - if current_node == landmark.last_parent && landmark.last_son != dummy_node then + if current_node == landmark.last_parent && landmark.last_son != dummy_node () then landmark.last_son else begin incr_cache_miss_ref (); @@ -245,6 +200,7 @@ let increment ?times counter = increment ?times counter let sample sampler x = + let sampler = get_landmark_body sampler in let node = get_entering_node sampler in node.calls <- node.calls + 1; Stack.push node.distrib x @@ -254,6 +210,8 @@ let sample sampler x = sample sampler x let enter landmark = + let landmark = get_landmark_body landmark in + let dummy_node = dummy_node () in if profile_with_debug () then Printf.eprintf "[Profiling] enter%s(%s)\n%!" (if landmark.last_self != dummy_node then " recursive " else "") landmark.name; @@ -280,9 +238,9 @@ let mismatch_recovering landmark (current_node: node) = let expected_landmark = current_node.landmark in if expected_landmark != landmark then begin let msg = - Printf.sprintf "landmark failure when closing '%s' (%s), expecting '%s' (%s)." - landmark.name landmark.location - expected_landmark.name expected_landmark.location + Printf.sprintf "landmark failure when closing '%s'<%d> (%s), expecting '%s'<%d> (%s)." + landmark.name landmark.id landmark.location + expected_landmark.name landmark.id expected_landmark.location in Printf.eprintf "Warning: %s\n%!" msg; unroll_until landmark.last_self; @@ -292,31 +250,16 @@ let mismatch_recovering landmark (current_node: node) = end end -let aggregate_stat_for current_node = - let floats = current_node.floats in - floats.time <- floats.time - +. Int64.(to_float (sub (clock ()) current_node.timestamp)); - if profile_with_allocated_bytes () then begin - floats.allocated_bytes <- - floats.allocated_bytes - + (allocated_bytes () - floats.allocated_bytes_stamp); - floats.allocated_bytes_major <- - floats.allocated_bytes_major - + (allocated_bytes_major () - floats.allocated_bytes_major_stamp) - end; - if profile_with_sys_time () then - floats.sys_time <- floats.sys_time - +. (Sys.time () -. floats.sys_timestamp) - let exit landmark = + let landmark = get_landmark_body landmark in + let current_node = get_current_node_ref () in if profile_with_debug () then Printf.eprintf "[Profiling] exit%s(%s)\n%!" (if landmark.last_self != get_current_node_ref () then " recursive " else "") landmark.name; - let current_node = get_current_node_ref () in let last_self = landmark.last_self in if last_self.recursive_calls = 0 || profile_recursive () then begin mismatch_recovering landmark current_node; if Stack.size current_node.fathers = 1 then begin - landmark.last_self <- dummy_node; + landmark.last_self <- dummy_node (); aggregate_stat_for current_node; end; set_current_node_ref (get_exiting_node current_node) @@ -400,43 +343,7 @@ let stop_profiling () = (** EXPORTING / IMPORTING SLAVE PROFILINGS **) -let array_list_map f l = - let size = List.length l in - match l with - | [] -> [||] - | hd :: tl -> - let res = Array.make size (f hd) in - List.iteri (fun k x -> res.(k+1) <- f x) tl; res - -let export ?(label = "") () = - let export_node {landmark; id; calls; floats; children; distrib; _} = - let {key = { key = landmark_id; _}; name; location; kind; _} = landmark in - let {time; allocated_bytes; allocated_bytes_major; sys_time; _} = floats in - let children = - List.map (fun ({id;_} : node) -> id) (SparseArray.values children) - in - {Graph.landmark_id; id; name; location; calls; time; kind; - allocated_bytes; allocated_bytes_major; sys_time; children; distrib = Stack.to_floatarray distrib} - in - if profiling () then begin - aggregate_stat_for (get_current_root_node ()); - stamp_root () - end; - let all_nodes = List.rev (get_allocated_nodes ()) in - let nodes = array_list_map export_node all_nodes in - {Graph.nodes; label; root = 0} - -let export_and_reset ?label () = - let profiling = profiling () in - if profiling then - stop_profiling (); - let res = export ?label () in - reset (); - if profiling then - start_profiling (); - res - -let rec merge_branch node graph (imported : Graph.node) = +let rec merge_branch (node:node) graph (imported : Graph.node) = let floats = node.floats in floats.time <- imported.time +. floats.time; floats.sys_time <- imported.sys_time +. floats.sys_time; @@ -467,10 +374,26 @@ and new_branch parent graph (imported : Graph.node) = SparseArray.set parent.children landmark.id node; List.iter (new_branch node graph) (Graph.children graph imported) +let merge_aux node graph = + merge_branch node graph (Graph.root graph) + let merge (graph : Graph.graph) = if profile_with_debug () then Printf.eprintf "[Profiling] merging foreign graph\n%!"; - merge_branch (get_current_root_node ()) graph (Graph.root graph) + merge_aux (get_current_root_node ()) graph + +let export ?(label = "") () = + export ~merge:merge_aux ~label () + +let export_and_reset ?label () = + let profiling = profiling () in + if profiling then + stop_profiling (); + let res = export ?label () in + reset (); + if profiling then + start_profiling (); + res let exit_hook () = if profile_with_debug () then diff --git a/src/landmark_state.ml b/src/landmark_state.ml deleted file mode 100644 index 29991a1..0000000 --- a/src/landmark_state.ml +++ /dev/null @@ -1,86 +0,0 @@ -(* This file is released under the terms of an MIT-like license. *) -(* See the attached LICENSE file. *) -(* Copyright (C) 2000-2025 LexiFi *) - -open Utils - -module Stack = Utils.Stack - -module Ref = struct - - let profiling_ref = ref false - let profiling () = !profiling_ref - let set_profiling b = profiling_ref := b - - - let last_landmark_id = ref 1 - let get_last_landmark_id () = !last_landmark_id - let incr_last_landmark_id () = incr last_landmark_id - - let landmarks_of_key = W.create 17 - let get_landmarks_of_key () = landmarks_of_key - let add_landmarks_of_key key = W.add landmarks_of_key key - - let node_id_ref = ref 0 - let get_node_id_ref () = !node_id_ref - let set_node_id_ref n = node_id_ref := n - - let allocated_nodes = ref [] - let get_allocated_nodes () = !allocated_nodes - let set_allocated_nodes l = allocated_nodes := l - - let profile_with_debug = ref false - let profile_with_allocated_bytes = ref false - let profile_with_sys_time = ref false - let profile_output = ref Silent - let profile_format = ref (Textual {threshold = 1.0}) - let profile_recursive = ref false - - let set_profiling_options {debug; allocated_bytes; sys_time; output; format; recursive} = - profile_with_debug := debug; - profile_with_allocated_bytes := allocated_bytes; - profile_with_sys_time := sys_time; - profile_output := output; - profile_format := format; - profile_recursive := recursive - - let profiling_options () = { - debug = !profile_with_debug; - allocated_bytes = !profile_with_allocated_bytes; - sys_time = !profile_with_sys_time; - recursive = !profile_recursive; - output = !profile_output; - format = !profile_format - } - - let profile_with_debug () = !profile_with_debug - let profile_with_allocated_bytes () = !profile_with_allocated_bytes - let profile_with_sys_time () = !profile_with_sys_time - let profile_output () = !profile_output - let profile_format () = !profile_format - let profile_recursive () = !profile_recursive - - let new_node landmark = - new_node landmark (profile_with_debug ()) node_id_ref allocated_nodes - - let current_root_node = ref (new_node landmark_root) - let get_current_root_node () = !current_root_node - let set_current_root_node node = current_root_node := node - - let current_node_ref = ref !current_root_node - let get_current_node_ref () = !current_node_ref - let set_current_node_ref node = current_node_ref := node - - let cache_miss_ref = ref 0 - let get_cache_miss_ref () = !cache_miss_ref - let set_cache_miss_ref n = cache_miss_ref := n - - let profiling_stack = - let dummy = - {root = dummy_node; current = dummy_node; nodes = [{node = dummy_node; recursive = false}]; cache_miss = 0; nodes_len = 1} - in - Stack.make Array dummy 7 - let incr_cache_miss_ref () = incr cache_miss_ref - let get_profiling_stack () = profiling_stack - -end diff --git a/src/landmark_state_ocaml4.ml b/src/landmark_state_ocaml4.ml new file mode 100644 index 0000000..6ffdb42 --- /dev/null +++ b/src/landmark_state_ocaml4.ml @@ -0,0 +1,120 @@ +(* This file is released under the terms of an MIT-like license. *) +(* See the attached LICENSE file. *) +(* Copyright (C) 2000-2025 LexiFi *) + +open Utils + +module Stack = Utils.Stack + +let rec landmark_root = { + kind = Graph.Root; + id = 0; + name = "ROOT"; + location = __FILE__; + key = { key = ""; landmark = landmark_root}; + last_parent = dummy_node; + last_son = dummy_node; + last_self = dummy_node; +} + +and dummy_node = { + landmark = landmark_root; + id = 0; + children = SparseArray.dummy (); + fathers = Stack.dummy Array; + floats = new_floats (); + calls = 0; + recursive_calls = 0; + distrib = Stack.dummy Float; + timestamp = Int64.zero +} + +and dummy_key = { key = ""; landmark = landmark_root} + +let landmark_root () = landmark_root +let dummy_node () = dummy_node +let dummy_key () = dummy_key + +let profiling_ref = ref false +let profiling () = !profiling_ref +let set_profiling b = profiling_ref := b + +let landmarks_of_key = W.create 17 +let get_landmarks_of_key () = landmarks_of_key +let add_landmarks_of_key key = W.add landmarks_of_key key +let get_landmark_body l = l + +let node_id_ref = ref 0 +let get_node_id_ref () = !node_id_ref +let set_node_id_ref n = node_id_ref := n + +let allocated_nodes = ref [] +let get_allocated_nodes () = !allocated_nodes +let set_allocated_nodes l = allocated_nodes := l + +let get_incr_node_id_ref () = + let id = !node_id_ref in + incr node_id_ref; + id + +let add_allocated_node node = + allocated_nodes := node :: !allocated_nodes + +let new_node landmark = + new_node landmark (dummy_node ()) (profile_with_debug ()) get_incr_node_id_ref add_allocated_node + +let current_root_node = ref (new_node (landmark_root ())) +let get_current_root_node () = !current_root_node +let set_current_root_node node = current_root_node := node + +let current_node_ref = ref !current_root_node +let get_current_node_ref () = !current_node_ref +let set_current_node_ref node = current_node_ref := node + +let cache_miss_ref = ref 0 +let get_cache_miss_ref () = !cache_miss_ref +let set_cache_miss_ref n = cache_miss_ref := n + +let profiling_stack = + let dummy = + {root = dummy_node (); current = dummy_node (); nodes = [{node = dummy_node (); recursive = false}]; cache_miss = 0; nodes_len = 1} + in + Stack.make Array dummy 7 +let incr_cache_miss_ref () = incr cache_miss_ref +let get_profiling_stack () = profiling_stack + +let clear_cache () = + W.iter ( + fun {landmark; _} -> + landmark.last_son <- dummy_node (); + landmark.last_parent <- dummy_node (); + landmark.last_self <- dummy_node (); + ) (get_landmarks_of_key ()) + +let reset () = + if profile_with_debug () then + Printf.eprintf "[Profiling] resetting ...\n%!"; + (* reset dummy_node *) + let current_root_node = get_current_root_node () in + let floats = current_root_node.floats in + floats.time <- 0.0; + floats.allocated_bytes <- 0; + floats.sys_time <- 0.0; + current_root_node.calls <- 0; + current_root_node.recursive_calls <- 0; + stamp_root current_root_node; + SparseArray.reset current_root_node.children; + set_allocated_nodes [current_root_node]; + set_current_node_ref current_root_node; + set_cache_miss_ref 0; + clear_cache (); + set_node_id_ref 1 + +let export ~merge:_ ?(label = "") () = + if profiling () then begin + aggregate_stat_for (get_current_root_node ()); + stamp_root (get_current_root_node ()) + end; + let all_nodes = List.rev (get_allocated_nodes ()) in + let nodes = array_list_map export_node all_nodes in + {Graph.nodes; label; root = 0} diff --git a/src/landmark_state.mli b/src/landmark_state_ocaml4.mli similarity index 86% rename from src/landmark_state.mli rename to src/landmark_state_ocaml4.mli index a35a4a8..617f2f0 100644 --- a/src/landmark_state.mli +++ b/src/landmark_state_ocaml4.mli @@ -2,4 +2,4 @@ (* See the attached LICENSE file. *) (* Copyright (C) 2000-2025 LexiFi *) -module Ref : Landmark_state_sig.S +include Landmark_state_sig.S diff --git a/src/landmark_state_sig.ml b/src/landmark_state_sig.ml index 08bfc3e..3768bb5 100644 --- a/src/landmark_state_sig.ml +++ b/src/landmark_state_sig.ml @@ -2,35 +2,42 @@ (* See the attached LICENSE file. *) (* Copyright (C) 2000-2025 LexiFi *) +open Utils + module type S = sig + val landmark_root : unit -> landmark + val dummy_node : unit -> node + val dummy_key : unit -> landmark_key + val profiling : unit -> bool val set_profiling : bool -> unit - val get_last_landmark_id : unit -> int - val incr_last_landmark_id : unit -> unit - val get_landmarks_of_key : unit -> Utils.W.t - val add_landmarks_of_key : Utils.landmark_key -> unit + + val get_landmarks_of_key : unit -> W.t + val add_landmarks_of_key : landmark_key -> unit + val get_landmark_body: landmark -> landmark + val get_node_id_ref : unit -> int val set_node_id_ref : int -> unit - val get_allocated_nodes : unit -> Utils.node list - val set_allocated_nodes : Utils.node list -> unit - val set_profiling_options : Utils.profiling_options -> unit - val profiling_options : unit -> Utils.profiling_options - val profile_with_debug : unit -> bool - val profile_with_allocated_bytes : unit -> bool - val profile_with_sys_time : unit -> bool - val profile_output : unit -> Utils.profile_output - val profile_format : unit -> Utils.profile_format - val profile_recursive : unit -> bool - val new_node : Utils.landmark -> Utils.node - val get_current_root_node : unit -> Utils.node - val set_current_root_node : Utils.node -> unit - val get_current_node_ref : unit -> Utils.node - val set_current_node_ref : Utils.node -> unit + val get_allocated_nodes : unit -> node list + val set_allocated_nodes : node list -> unit + + val new_node : landmark -> node + + val get_current_root_node : unit -> node + val set_current_root_node : node -> unit + val get_current_node_ref : unit -> node + val set_current_node_ref : node -> unit val get_cache_miss_ref : unit -> int val set_cache_miss_ref : int -> unit + val incr_cache_miss_ref : unit -> unit + val get_profiling_stack : unit -> - (Utils.profiling_state, Utils.profiling_state array) Utils.Stack.t + (profiling_state, profiling_state array) Utils.Stack.t + + val clear_cache : unit -> unit + val reset: unit -> unit + val export : merge:(node -> Graph.graph -> unit) -> ?label:string -> unit -> Graph.graph end diff --git a/src/utils.ml b/src/utils.ml index 48fdd12..0f432db 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -2,6 +2,18 @@ (* See the attached LICENSE file. *) (* Copyright (C) 2000-2025 LexiFi *) +external clock: unit -> (Int64.t [@unboxed]) = + "caml_highres_clock" "caml_highres_clock_native" [@@noalloc] + +(* Alternative implementation of Gc.allocated_bytes which does not allocate *) +external allocated_bytes: unit -> (Int64.t [@unboxed]) = + "allocated_bytes" "allocated_bytes_native" [@@noalloc] +external allocated_bytes_major: unit -> (Int64.t [@unboxed]) = + "allocated_bytes_major" "allocated_bytes_major_native" [@@noalloc] + +let allocated_bytes () = Int64.to_int (allocated_bytes ()) +let allocated_bytes_major () = Int64.to_int (allocated_bytes_major ()) + module SparseArray = struct type 'a t = { mutable keys : int array; @@ -209,36 +221,11 @@ let new_floats () = { sys_timestamp = 0.0 } -let rec landmark_root = { - kind = Graph.Root; - id = 0; - name = "ROOT"; - location = __FILE__; - key = { key = ""; landmark = landmark_root}; - last_parent = dummy_node; - last_son = dummy_node; - last_self = dummy_node; -} - -and dummy_node = { - landmark = landmark_root; - id = 0; - children = SparseArray.dummy (); - fathers = Stack.dummy Array; - floats = new_floats (); - calls = 0; - recursive_calls = 0; - distrib = Stack.dummy Float; - timestamp = Int64.zero -} - -and dummy_key = { key = ""; landmark = landmark_root} - -let new_node landmark profile_with_debug node_id_ref allocated_nodes = +let new_node landmark + dummy_node profile_with_debug get_incr_node_id_ref add_allocated_node = if profile_with_debug then Printf.eprintf "[Profiling] Allocating new node for %s...\n%!" landmark.name; - let id = !node_id_ref in - incr node_id_ref; + let id = get_incr_node_id_ref () in let node = { landmark; id; @@ -252,7 +239,7 @@ let new_node landmark profile_with_debug node_id_ref allocated_nodes = timestamp = Int64.zero; floats = new_floats (); } in - allocated_nodes := node :: !allocated_nodes; + add_allocated_node node; node type profile_output = @@ -284,6 +271,37 @@ let default_options = { format = Textual {threshold = 1.0}; } +let profile_with_debug = ref false +let profile_with_allocated_bytes = ref false +let profile_with_sys_time = ref false +let profile_output = ref Silent +let profile_format = ref (Textual {threshold = 1.0}) +let profile_recursive = ref false + +let set_profiling_options {debug; allocated_bytes; sys_time; output; format; recursive} = + profile_with_debug := debug; + profile_with_allocated_bytes := allocated_bytes; + profile_with_sys_time := sys_time; + profile_output := output; + profile_format := format; + profile_recursive := recursive + +let profiling_options () = { + debug = !profile_with_debug; + allocated_bytes = !profile_with_allocated_bytes; + sys_time = !profile_with_sys_time; + recursive = !profile_recursive; + output = !profile_output; + format = !profile_format +} + +let profile_with_debug () = !profile_with_debug +let profile_with_allocated_bytes () = !profile_with_allocated_bytes +let profile_with_sys_time () = !profile_with_sys_time +let profile_output () = !profile_output +let profile_format () = !profile_format +let profile_recursive () = !profile_recursive + type profiling_state = { root : node; nodes: node_info list; @@ -296,3 +314,52 @@ and node_info = { node: node; recursive: bool; } + +let stamp_root current_root_node = + current_root_node.timestamp <- (clock ()); + if profile_with_allocated_bytes () then begin + current_root_node.floats.allocated_bytes <- allocated_bytes (); + current_root_node.floats.allocated_bytes_major <- allocated_bytes_major () + end; + if profile_with_sys_time () then + current_root_node.floats.sys_time <- Sys.time () + +let aggregate_stat_for current_node = + let floats = current_node.floats in + floats.time <- floats.time + +. Int64.(to_float (sub (clock ()) current_node.timestamp)); + if profile_with_allocated_bytes () then begin + floats.allocated_bytes <- + floats.allocated_bytes + + (allocated_bytes () - floats.allocated_bytes_stamp); + floats.allocated_bytes_major <- + floats.allocated_bytes_major + + (allocated_bytes_major () - floats.allocated_bytes_major_stamp) + end; + if profile_with_sys_time () then + floats.sys_time <- floats.sys_time + +. (Sys.time () -. floats.sys_timestamp) + +let array_list_map f l = + let size = List.length l in + match l with + | [] -> [||] + | hd :: tl -> + let res = Array.make size (f hd) in + List.iteri (fun k x -> res.(k+1) <- f x) tl; res + +let export_node {landmark; id; calls; floats; children; distrib; _} = + let {key = { key = landmark_id; _}; name; location; kind; _} = landmark in + let {time; allocated_bytes; allocated_bytes_major; sys_time; _} = floats in + let children = + List.map (fun ({id;_} : node) -> id) (SparseArray.values children) + in + {Graph.landmark_id; id; name; location; calls; time; kind; + allocated_bytes; allocated_bytes_major; sys_time; children; distrib = Stack.to_floatarray distrib} + +let unroll_until current_node set_current_node node = + while + current_node != node + && Stack.size current_node.fathers > 0 + && (set_current_node (Stack.pop current_node.fathers); true) + do () done diff --git a/src/utils.mli b/src/utils.mli index 974287e..ebc5fb2 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -2,6 +2,12 @@ (* See the attached LICENSE file. *) (* Copyright (C) 2000-2025 LexiFi *) +external clock: unit -> (Int64.t [@unboxed]) = + "caml_highres_clock" "caml_highres_clock_native" [@@noalloc] + +val allocated_bytes: unit -> int +val allocated_bytes_major: unit -> int + module SparseArray : sig type 'a t = { @@ -93,11 +99,8 @@ module W: Weak.S with type data = landmark_key val new_floats : unit -> floats -val landmark_root : landmark -val dummy_node : node -val dummy_key : landmark_key - -val new_node: counter -> bool -> int ref -> node list ref -> node +val new_node: + landmark -> node -> bool -> (unit -> int) -> (node -> unit) -> node type profile_output = | Silent @@ -119,6 +122,15 @@ type profiling_options = { format : profile_format } +val set_profiling_options : profiling_options -> unit +val profiling_options : unit -> profiling_options +val profile_with_debug : unit -> bool +val profile_with_allocated_bytes : unit -> bool +val profile_with_sys_time : unit -> bool +val profile_output : unit -> profile_output +val profile_format : unit -> profile_format +val profile_recursive : unit -> bool + val default_options: profiling_options type profiling_state = { @@ -133,3 +145,10 @@ and node_info = { node: node; recursive: bool; } + +val stamp_root: node -> unit +val aggregate_stat_for: node -> unit +val array_list_map: ('a -> 'b) -> 'a list -> 'b array +val export_node: node -> Graph.node + +val unroll_until: node -> (node -> unit) -> node -> unit From 6a16394cdc0d0471150aa9921d676fb9b9bdfbcb Mon Sep 17 00:00:00 2001 From: hra687261 Date: Tue, 16 Dec 2025 12:27:15 +0100 Subject: [PATCH 06/16] Add landmark_state_ocaml5, a landmark_state compatible with parallelism in ocaml5 --- src/landmark_state_ocaml5.ml | 321 ++++++++++++++++++++++++++++++++++ src/landmark_state_ocaml5.mli | 5 + 2 files changed, 326 insertions(+) create mode 100644 src/landmark_state_ocaml5.ml create mode 100644 src/landmark_state_ocaml5.mli diff --git a/src/landmark_state_ocaml5.ml b/src/landmark_state_ocaml5.ml new file mode 100644 index 0000000..83e28a0 --- /dev/null +++ b/src/landmark_state_ocaml5.ml @@ -0,0 +1,321 @@ +(* This file is released under the terms of an MIT-like license. *) +(* See the attached LICENSE file. *) +(* Copyright (C) 2000-2025 LexiFi *) + +open Utils + +module Stack = Utils.Stack + +let init_dummies () = + let rec landmark_root = { + kind = Graph.Root; + id = 0; + name = "ROOT"; + location = __FILE__; + key = { key = ""; landmark = landmark_root}; + last_parent = dummy_node; + last_son = dummy_node; + last_self = dummy_node; + } + + and dummy_node = { + landmark = landmark_root; + id = 0; + children = SparseArray.dummy (); + fathers = Stack.dummy Array; + floats = new_floats (); + calls = 0; + recursive_calls = 0; + distrib = Stack.dummy Float; + timestamp = Int64.zero + } + + and dummy_key = { key = ""; landmark = landmark_root} + in + landmark_root, dummy_node, dummy_key + +let dummies = Domain.DLS.new_key init_dummies + +let landmark_root () = + let landmark_root, _, _ = Domain.DLS.get dummies in + landmark_root + +let dummy_node () = + let _, dummy_node, _ = Domain.DLS.get dummies in + dummy_node + +let dummy_key () = + let _, _, dummy_key = Domain.DLS.get dummies in + dummy_key + +type nodes = { + mutable node_id_ref: int; + mutable allocated_nodes: node list; +} + +let init_nodes () = { + node_id_ref = 0; + allocated_nodes = []; +} + +let get_incr_node_id_ref nodes () = + let id = nodes.node_id_ref in + nodes.node_id_ref <- id + 1; + id + +let add_allocated_node nodes node = + nodes.allocated_nodes <- node :: nodes.allocated_nodes + +type state = { + nodes: nodes; + + mutable profiling_ref : bool; + landmarks_of_key: W.t; + mutable cache_miss_ref: int; + profiling_stack: (profiling_state, profiling_state array) Stack.t; + + mutable current_root_node : node; + mutable current_node_ref : node; + + mutable child_states : state list; + (* The states of child domains spawned by the main one *) + mutable graph: Graph.graph; + (* Used by child states to store their own graphs *) + + mutable registered: bool; +} + +let clear_cache gls = + let dummy_node = dummy_node () in + W.iter ( + fun {landmark; _} -> + landmark.last_son <- dummy_node; + landmark.last_parent <- dummy_node; + landmark.last_self <- dummy_node; + ) (gls.landmarks_of_key) + +let reset_aux gls = + if profile_with_debug () then + Printf.eprintf "[Profiling] resetting ...\n%!"; + let current_root_node = gls.current_root_node in + let floats = current_root_node.floats in + floats.time <- 0.0; + floats.allocated_bytes <- 0; + floats.sys_time <- 0.0; + current_root_node.calls <- 0; + current_root_node.recursive_calls <- 0; + stamp_root current_root_node; + SparseArray.reset current_root_node.children; + gls.nodes.allocated_nodes <- [current_root_node]; + gls.current_node_ref <- current_root_node; + gls.cache_miss_ref <- 0; + (* TODO: ensure that the dummy node of gls is used *) + clear_cache gls; + gls.nodes.node_id_ref <- 1 + +let init_state () = + let nodes = init_nodes () in + let rootnode = + new_node (landmark_root ()) (dummy_node ()) false + (get_incr_node_id_ref nodes) (add_allocated_node nodes); + in { + nodes; + + profiling_ref = false; + landmarks_of_key = W.create 17; + cache_miss_ref = 0; + profiling_stack = ( + let dummy = + {root = dummy_node (); current = dummy_node (); nodes = [{node = dummy_node (); recursive = false}]; cache_miss = 0; nodes_len = 1} + in + Stack.make Array dummy 7 + ); + + current_root_node = rootnode; + current_node_ref = rootnode; + child_states = []; + graph = {nodes = [||]; label = ""; root = 0 }; + registered = false; + } + +let copy_landmark_cache (w: W.t) = + let w' = W.create 17 in + let dummy_node = dummy_node () in + (* TODO: incorrent since it uses the dummy nodes of the parent domain *) + W.iter ( + fun key -> + W.add w' { + key with + landmark = { + key.landmark with + last_parent = dummy_node; + last_son = dummy_node; + last_self = dummy_node} } + ) w; + w' + +let state = + Domain.DLS.new_key + ~split_from_parent:(fun s -> + let child_state = init_state () in + let child_state = + { child_state with + profiling_ref = s.profiling_ref; + landmarks_of_key = copy_landmark_cache s.landmarks_of_key } + in + s.child_states <- child_state :: s.child_states; + child_state.profiling_ref <- s.profiling_ref; + reset_aux child_state; + child_state + ) + init_state + + +(* Adapted copies of landmark.ml functions *) +let mismatch_recovering st landmark = + let current_node = st.current_node_ref in + let expected_landmark = current_node.landmark in + if expected_landmark != landmark then begin + let msg = + Printf.sprintf "landmark failure when closing '%s'<%d> (%s), expecting '%s'<%d> (%s)." + landmark.name landmark.id landmark.location + expected_landmark.name landmark.id expected_landmark.location + in + Printf.eprintf "Warning: %s\n%!" msg; + unroll_until current_node + (fun node -> st.current_node_ref <- node) + landmark.last_self; + if landmark != st.current_node_ref.landmark then begin + reset_aux st; + failwith ("unable to recover from "^msg) + end + end + +let get_exiting_node st = + if Stack.size st.current_node_ref.fathers = 0 then + failwith "Stack underflow" + else + Stack.pop st.current_node_ref.fathers + +let exit st = + let landmark = (* get_landmark_body *) st.current_node_ref.landmark in + let current_node = st.current_node_ref in + let last_self = landmark.last_self in + if last_self.recursive_calls = 0 || profile_recursive () then begin + mismatch_recovering st landmark; + if Stack.size current_node.fathers = 1 then begin + landmark.last_self <- dummy_node (); + aggregate_stat_for current_node; + end; + st.current_node_ref <- (get_exiting_node st) + end + else if not (profile_recursive ()) then + last_self.recursive_calls <- last_self.recursive_calls - 1 + +let exit_until_root st = + let rec aux () = + if st.current_node_ref != st.current_root_node then begin + exit st; + aux (); + end + in + aux () + +let stop_profiling_aux st = + assert (st.current_node_ref == st.current_root_node); + if st.profiling_ref then ( + exit_until_root st; + assert (st.current_node_ref == st.current_root_node); + aggregate_stat_for st.current_node_ref; + if profile_with_debug () then + Printf.eprintf "[Profiling] Stop profiling.\n%!"; + st.profiling_ref <- false + ) + +let export state label = + if state.profiling_ref then begin + aggregate_stat_for state.current_root_node; + stamp_root state.current_root_node + end; + let all_nodes = List.rev state.nodes.allocated_nodes in + let nodes = array_list_map export_node all_nodes in + {Graph.nodes; label; root = 0} + +let get_state () = + let st = Domain.DLS.get state in + if not st.registered && not (Domain.is_main_domain ()) then ( + Domain.at_exit (fun () -> + stop_profiling_aux st; + st.graph <- export st "" + ); + st.registered <- true; + ); + st + +let profiling () = (get_state ()).profiling_ref +let set_profiling b = (get_state ()).profiling_ref <- b +let get_landmarks_of_key = + let initialized = Domain.DLS.new_key (fun () -> false) in + fun () -> + let landmarks_of_key = (get_state ()).landmarks_of_key in + if not (Domain.DLS.get initialized) then ( + Domain.DLS.set initialized true; + let dummy_node = dummy_node () in + W.iter ( + fun key -> + key.landmark.last_parent <- dummy_node; + key.landmark.last_son <- dummy_node; + key.landmark.last_self <- dummy_node + ) landmarks_of_key + ); + landmarks_of_key + +let add_landmarks_of_key key = W.add (get_state ()).landmarks_of_key key + +let get_landmark_body (l: landmark) = + let dummy_key = dummy_key () in + let { landmark; _ } = + W.find (get_landmarks_of_key ()) { dummy_key with key = l.key.key } + in + landmark + +let get_node_id_ref () = (get_state ()).nodes.node_id_ref +let set_node_id_ref n = (get_state ()).nodes.node_id_ref <- n +let get_allocated_nodes () = (get_state ()).nodes.allocated_nodes +let set_allocated_nodes l = (get_state ()).nodes.allocated_nodes <- l + +let new_node landmark = + let { nodes; _ } = get_state () in + new_node landmark (dummy_node ()) (profile_with_debug ()) + (get_incr_node_id_ref nodes) (add_allocated_node nodes) + + +let get_current_root_node () = (get_state ()).current_root_node +let set_current_root_node (node: node) = + (get_state ()).current_root_node <- node + +let get_current_node_ref () = (get_state ()).current_node_ref +let set_current_node_ref (node: node) = + (get_state ()).current_node_ref <- node + +let get_cache_miss_ref () = (get_state ()).cache_miss_ref +let set_cache_miss_ref n = (get_state ()).cache_miss_ref <- n +let incr_cache_miss_ref () = + let state = get_state () in + state.cache_miss_ref <- state.cache_miss_ref + 1 +let get_profiling_stack () = (get_state ()).profiling_stack + + +let reset () = + reset_aux (get_state ()) + +let clear_cache () = + clear_cache (get_state ()) + +let export ~merge ?(label = "") () = + let state = get_state () in + List.iter ( + fun st -> + merge state.current_root_node st.graph + ) state.child_states; + export state label diff --git a/src/landmark_state_ocaml5.mli b/src/landmark_state_ocaml5.mli new file mode 100644 index 0000000..617f2f0 --- /dev/null +++ b/src/landmark_state_ocaml5.mli @@ -0,0 +1,5 @@ +(* This file is released under the terms of an MIT-like license. *) +(* See the attached LICENSE file. *) +(* Copyright (C) 2000-2025 LexiFi *) + +include Landmark_state_sig.S From ef22c1447bccfa02ddd9b7483cd96048e424c0e4 Mon Sep 17 00:00:00 2001 From: hra687261 Date: Tue, 16 Dec 2025 14:38:20 +0100 Subject: [PATCH 07/16] Choose which landmark_state to use depending on the ocaml version --- src/dune | 17 +++++++++++++++++ src/landmark.ml | 1 - 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/src/dune b/src/dune index d138a06..6b47311 100755 --- a/src/dune +++ b/src/dune @@ -1,6 +1,7 @@ (library (name landmark) (public_name landmarks) + (modules landmark landmark_state graph misc utils) (no_dynlink) (flags (:standard -w +A-30-42-41-40-4-70 -safe-string -strict-sequence)) @@ -10,3 +11,19 @@ (js_of_ocaml (javascript_files utils.js)) (instrumentation.backend (ppx landmarks-ppx))) + +(rule + (targets landmark_state.ml) + (deps landmark_state_ocaml4.ml) + (action + (copy %{deps} %{targets})) + (enabled_if + (< %{ocaml_version} 5.0.0))) + +(rule + (targets landmark_state.ml) + (deps landmark_state_ocaml5.ml) + (action + (copy %{deps} %{targets})) + (enabled_if + (>= %{ocaml_version} 5.0.0))) diff --git a/src/landmark.ml b/src/landmark.ml index a6ccbed..2132433 100644 --- a/src/landmark.ml +++ b/src/landmark.ml @@ -4,7 +4,6 @@ open Utils -module Landmark_state = Landmark_state_ocaml4 open Landmark_state external clock: unit -> (Int64.t [@unboxed]) = From d99696e1f82fe95cf2cdbfdefaf62afda58de221 Mon Sep 17 00:00:00 2001 From: hra687261 Date: Mon, 22 Dec 2025 13:01:18 +0100 Subject: [PATCH 08/16] Remove redundant mli files --- src/dune | 4 ++-- src/landmark_state.mli | 40 ++++++++++++++++++++++++++++++++ src/landmark_state_ocaml4.mli | 5 ---- src/landmark_state_ocaml5.mli | 5 ---- src/landmark_state_sig.ml | 43 ----------------------------------- 5 files changed, 42 insertions(+), 55 deletions(-) create mode 100644 src/landmark_state.mli delete mode 100644 src/landmark_state_ocaml4.mli delete mode 100644 src/landmark_state_ocaml5.mli delete mode 100644 src/landmark_state_sig.ml diff --git a/src/dune b/src/dune index 6b47311..c2da561 100755 --- a/src/dune +++ b/src/dune @@ -16,7 +16,7 @@ (targets landmark_state.ml) (deps landmark_state_ocaml4.ml) (action - (copy %{deps} %{targets})) + (copy# %{deps} %{targets})) (enabled_if (< %{ocaml_version} 5.0.0))) @@ -24,6 +24,6 @@ (targets landmark_state.ml) (deps landmark_state_ocaml5.ml) (action - (copy %{deps} %{targets})) + (copy# %{deps} %{targets})) (enabled_if (>= %{ocaml_version} 5.0.0))) diff --git a/src/landmark_state.mli b/src/landmark_state.mli new file mode 100644 index 0000000..8ee9418 --- /dev/null +++ b/src/landmark_state.mli @@ -0,0 +1,40 @@ +(* This file is released under the terms of an MIT-like license. *) +(* See the attached LICENSE file. *) +(* Copyright (C) 2000-2025 LexiFi *) + +open Utils + +val landmark_root : unit -> landmark +val dummy_node : unit -> node +val dummy_key : unit -> landmark_key + +val profiling : unit -> bool +val set_profiling : bool -> unit + +val get_landmarks_of_key : unit -> W.t +val add_landmarks_of_key : landmark_key -> unit +val get_landmark_body: landmark -> landmark + +val get_node_id_ref : unit -> int +val set_node_id_ref : int -> unit +val get_allocated_nodes : unit -> node list +val set_allocated_nodes : node list -> unit + +val new_node : landmark -> node + +val get_current_root_node : unit -> node +val set_current_root_node : node -> unit +val get_current_node_ref : unit -> node +val set_current_node_ref : node -> unit +val get_cache_miss_ref : unit -> int +val set_cache_miss_ref : int -> unit + +val incr_cache_miss_ref : unit -> unit + +val get_profiling_stack : + unit -> + (profiling_state, profiling_state array) Utils.Stack.t + +val clear_cache : unit -> unit +val reset: unit -> unit +val export : merge:(node -> Graph.graph -> unit) -> ?label:string -> unit -> Graph.graph diff --git a/src/landmark_state_ocaml4.mli b/src/landmark_state_ocaml4.mli deleted file mode 100644 index 617f2f0..0000000 --- a/src/landmark_state_ocaml4.mli +++ /dev/null @@ -1,5 +0,0 @@ -(* This file is released under the terms of an MIT-like license. *) -(* See the attached LICENSE file. *) -(* Copyright (C) 2000-2025 LexiFi *) - -include Landmark_state_sig.S diff --git a/src/landmark_state_ocaml5.mli b/src/landmark_state_ocaml5.mli deleted file mode 100644 index 617f2f0..0000000 --- a/src/landmark_state_ocaml5.mli +++ /dev/null @@ -1,5 +0,0 @@ -(* This file is released under the terms of an MIT-like license. *) -(* See the attached LICENSE file. *) -(* Copyright (C) 2000-2025 LexiFi *) - -include Landmark_state_sig.S diff --git a/src/landmark_state_sig.ml b/src/landmark_state_sig.ml deleted file mode 100644 index 3768bb5..0000000 --- a/src/landmark_state_sig.ml +++ /dev/null @@ -1,43 +0,0 @@ -(* This file is released under the terms of an MIT-like license. *) -(* See the attached LICENSE file. *) -(* Copyright (C) 2000-2025 LexiFi *) - -open Utils - -module type S = -sig - val landmark_root : unit -> landmark - val dummy_node : unit -> node - val dummy_key : unit -> landmark_key - - val profiling : unit -> bool - val set_profiling : bool -> unit - - val get_landmarks_of_key : unit -> W.t - val add_landmarks_of_key : landmark_key -> unit - val get_landmark_body: landmark -> landmark - - val get_node_id_ref : unit -> int - val set_node_id_ref : int -> unit - val get_allocated_nodes : unit -> node list - val set_allocated_nodes : node list -> unit - - val new_node : landmark -> node - - val get_current_root_node : unit -> node - val set_current_root_node : node -> unit - val get_current_node_ref : unit -> node - val set_current_node_ref : node -> unit - val get_cache_miss_ref : unit -> int - val set_cache_miss_ref : int -> unit - - val incr_cache_miss_ref : unit -> unit - - val get_profiling_stack : - unit -> - (profiling_state, profiling_state array) Utils.Stack.t - - val clear_cache : unit -> unit - val reset: unit -> unit - val export : merge:(node -> Graph.graph -> unit) -> ?label:string -> unit -> Graph.graph -end From ee5c91fc4469ad05851cb3ed29ced4443ddf7f8e Mon Sep 17 00:00:00 2001 From: hra687261 Date: Mon, 22 Dec 2025 13:01:55 +0100 Subject: [PATCH 09/16] Recusrive merge the graphs of child states for nested domains --- src/landmark_state_ocaml5.ml | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/landmark_state_ocaml5.ml b/src/landmark_state_ocaml5.ml index 83e28a0..5c4faf2 100644 --- a/src/landmark_state_ocaml5.ml +++ b/src/landmark_state_ocaml5.ml @@ -312,10 +312,14 @@ let reset () = let clear_cache () = clear_cache (get_state ()) -let export ~merge ?(label = "") () = - let state = get_state () in +let rec merge_child_state_graphs ~merge state = List.iter ( fun st -> + merge_child_state_graphs ~merge st; merge state.current_root_node st.graph - ) state.child_states; + ) state.child_states + +let export ~merge ?(label = "") () = + let state = get_state () in + merge_child_state_graphs ~merge state; export state label From cfc017b604f2c41ac0d8841f30a0b55b0d89cbaf Mon Sep 17 00:00:00 2001 From: hra687261 Date: Mon, 5 Jan 2026 10:45:24 +0100 Subject: [PATCH 10/16] Ensure that `landmark_root`, `dummy_node` and `dummy_key` are domain specific in the parallel case Remove duplicate def on `clock` and rename `get_landmark_body` to `get_ds_landmark` --- src/landmark.ml | 11 ++-- src/landmark_state.mli | 2 +- src/landmark_state_ocaml4.ml | 2 +- src/landmark_state_ocaml5.ml | 120 +++++++++++++++++------------------ 4 files changed, 65 insertions(+), 70 deletions(-) diff --git a/src/landmark.ml b/src/landmark.ml index 2132433..b253a7d 100644 --- a/src/landmark.ml +++ b/src/landmark.ml @@ -2,13 +2,10 @@ (* See the attached LICENSE file. *) (* Copyright (C) 2000-2025 LexiFi *) -open Utils +include Utils open Landmark_state -external clock: unit -> (Int64.t [@unboxed]) = - "caml_highres_clock" "caml_highres_clock_native" [@@noalloc] - exception LandmarkFailure of string module Graph = Graph @@ -199,7 +196,7 @@ let increment ?times counter = increment ?times counter let sample sampler x = - let sampler = get_landmark_body sampler in + let sampler = get_ds_landmark sampler in let node = get_entering_node sampler in node.calls <- node.calls + 1; Stack.push node.distrib x @@ -209,7 +206,7 @@ let sample sampler x = sample sampler x let enter landmark = - let landmark = get_landmark_body landmark in + let landmark = get_ds_landmark landmark in let dummy_node = dummy_node () in if profile_with_debug () then Printf.eprintf "[Profiling] enter%s(%s)\n%!" (if landmark.last_self != dummy_node then " recursive " else "") landmark.name; @@ -250,7 +247,7 @@ let mismatch_recovering landmark (current_node: node) = end let exit landmark = - let landmark = get_landmark_body landmark in + let landmark = get_ds_landmark landmark in let current_node = get_current_node_ref () in if profile_with_debug () then Printf.eprintf "[Profiling] exit%s(%s)\n%!" (if landmark.last_self != get_current_node_ref () then " recursive " else "") landmark.name; diff --git a/src/landmark_state.mli b/src/landmark_state.mli index 8ee9418..f075bcc 100644 --- a/src/landmark_state.mli +++ b/src/landmark_state.mli @@ -13,7 +13,7 @@ val set_profiling : bool -> unit val get_landmarks_of_key : unit -> W.t val add_landmarks_of_key : landmark_key -> unit -val get_landmark_body: landmark -> landmark +val get_ds_landmark: landmark -> landmark val get_node_id_ref : unit -> int val set_node_id_ref : int -> unit diff --git a/src/landmark_state_ocaml4.ml b/src/landmark_state_ocaml4.ml index 6ffdb42..fd22e37 100644 --- a/src/landmark_state_ocaml4.ml +++ b/src/landmark_state_ocaml4.ml @@ -42,7 +42,7 @@ let set_profiling b = profiling_ref := b let landmarks_of_key = W.create 17 let get_landmarks_of_key () = landmarks_of_key let add_landmarks_of_key key = W.add landmarks_of_key key -let get_landmark_body l = l +let get_ds_landmark l = l let node_id_ref = ref 0 let get_node_id_ref () = !node_id_ref diff --git a/src/landmark_state_ocaml5.ml b/src/landmark_state_ocaml5.ml index 5c4faf2..732483e 100644 --- a/src/landmark_state_ocaml5.ml +++ b/src/landmark_state_ocaml5.ml @@ -6,48 +6,6 @@ open Utils module Stack = Utils.Stack -let init_dummies () = - let rec landmark_root = { - kind = Graph.Root; - id = 0; - name = "ROOT"; - location = __FILE__; - key = { key = ""; landmark = landmark_root}; - last_parent = dummy_node; - last_son = dummy_node; - last_self = dummy_node; - } - - and dummy_node = { - landmark = landmark_root; - id = 0; - children = SparseArray.dummy (); - fathers = Stack.dummy Array; - floats = new_floats (); - calls = 0; - recursive_calls = 0; - distrib = Stack.dummy Float; - timestamp = Int64.zero - } - - and dummy_key = { key = ""; landmark = landmark_root} - in - landmark_root, dummy_node, dummy_key - -let dummies = Domain.DLS.new_key init_dummies - -let landmark_root () = - let landmark_root, _, _ = Domain.DLS.get dummies in - landmark_root - -let dummy_node () = - let _, dummy_node, _ = Domain.DLS.get dummies in - dummy_node - -let dummy_key () = - let _, _, dummy_key = Domain.DLS.get dummies in - dummy_key - type nodes = { mutable node_id_ref: int; mutable allocated_nodes: node list; @@ -67,6 +25,10 @@ let add_allocated_node nodes node = nodes.allocated_nodes <- node :: nodes.allocated_nodes type state = { + landmark_root: landmark; + dummy_node : node; + dummy_key: landmark_key; + nodes: nodes; mutable profiling_ref : bool; @@ -86,12 +48,11 @@ type state = { } let clear_cache gls = - let dummy_node = dummy_node () in W.iter ( fun {landmark; _} -> - landmark.last_son <- dummy_node; - landmark.last_parent <- dummy_node; - landmark.last_self <- dummy_node; + landmark.last_son <- gls.dummy_node; + landmark.last_parent <- gls.dummy_node; + landmark.last_self <- gls.dummy_node; ) (gls.landmarks_of_key) let reset_aux gls = @@ -109,16 +70,45 @@ let reset_aux gls = gls.nodes.allocated_nodes <- [current_root_node]; gls.current_node_ref <- current_root_node; gls.cache_miss_ref <- 0; - (* TODO: ensure that the dummy node of gls is used *) clear_cache gls; gls.nodes.node_id_ref <- 1 let init_state () = + let rec landmark_root = { + kind = Graph.Root; + id = 0; + name = "ROOT"; + location = __FILE__; + key = { key = ""; landmark = landmark_root}; + last_parent = dummy_node; + last_son = dummy_node; + last_self = dummy_node; + } + + and dummy_node = { + landmark = landmark_root; + id = 0; + children = SparseArray.dummy (); + fathers = Stack.dummy Array; + floats = new_floats (); + calls = 0; + recursive_calls = 0; + distrib = Stack.dummy Float; + timestamp = Int64.zero + } + + and dummy_key = { key = ""; landmark = landmark_root} + in + let nodes = init_nodes () in let rootnode = - new_node (landmark_root ()) (dummy_node ()) false + new_node landmark_root dummy_node false (get_incr_node_id_ref nodes) (add_allocated_node nodes); in { + landmark_root; + dummy_node; + dummy_key; + nodes; profiling_ref = false; @@ -126,7 +116,7 @@ let init_state () = cache_miss_ref = 0; profiling_stack = ( let dummy = - {root = dummy_node (); current = dummy_node (); nodes = [{node = dummy_node (); recursive = false}]; cache_miss = 0; nodes_len = 1} + {root = dummy_node ; current = dummy_node; nodes = [{node = dummy_node; recursive = false}]; cache_miss = 0; nodes_len = 1} in Stack.make Array dummy 7 ); @@ -138,10 +128,8 @@ let init_state () = registered = false; } -let copy_landmark_cache (w: W.t) = +let copy_landmark_cache dummy_node (w: W.t) = let w' = W.create 17 in - let dummy_node = dummy_node () in - (* TODO: incorrent since it uses the dummy nodes of the parent domain *) W.iter ( fun key -> W.add w' { @@ -161,7 +149,7 @@ let state = let child_state = { child_state with profiling_ref = s.profiling_ref; - landmarks_of_key = copy_landmark_cache s.landmarks_of_key } + landmarks_of_key = copy_landmark_cache child_state.dummy_node s.landmarks_of_key } in s.child_states <- child_state :: s.child_states; child_state.profiling_ref <- s.profiling_ref; @@ -198,13 +186,13 @@ let get_exiting_node st = Stack.pop st.current_node_ref.fathers let exit st = - let landmark = (* get_landmark_body *) st.current_node_ref.landmark in + let landmark = (* get_ds_landmark *) st.current_node_ref.landmark in let current_node = st.current_node_ref in let last_self = landmark.last_self in if last_self.recursive_calls = 0 || profile_recursive () then begin mismatch_recovering st landmark; if Stack.size current_node.fathers = 1 then begin - landmark.last_self <- dummy_node (); + landmark.last_self <- st.dummy_node; aggregate_stat_for current_node; end; st.current_node_ref <- (get_exiting_node st) @@ -252,15 +240,25 @@ let get_state () = ); st +let landmark_root () = + (get_state ()).landmark_root + +let dummy_node () = + (get_state ()).dummy_node + +let dummy_key () = + (get_state ()).dummy_key + let profiling () = (get_state ()).profiling_ref let set_profiling b = (get_state ()).profiling_ref <- b let get_landmarks_of_key = let initialized = Domain.DLS.new_key (fun () -> false) in fun () -> - let landmarks_of_key = (get_state ()).landmarks_of_key in + let state = get_state () in + let landmarks_of_key = state.landmarks_of_key in if not (Domain.DLS.get initialized) then ( Domain.DLS.set initialized true; - let dummy_node = dummy_node () in + let dummy_node = state.dummy_node in W.iter ( fun key -> key.landmark.last_parent <- dummy_node; @@ -272,8 +270,8 @@ let get_landmarks_of_key = let add_landmarks_of_key key = W.add (get_state ()).landmarks_of_key key -let get_landmark_body (l: landmark) = - let dummy_key = dummy_key () in +let get_ds_landmark (l: landmark) = + let dummy_key = (get_state ()).dummy_key in let { landmark; _ } = W.find (get_landmarks_of_key ()) { dummy_key with key = l.key.key } in @@ -285,8 +283,8 @@ let get_allocated_nodes () = (get_state ()).nodes.allocated_nodes let set_allocated_nodes l = (get_state ()).nodes.allocated_nodes <- l let new_node landmark = - let { nodes; _ } = get_state () in - new_node landmark (dummy_node ()) (profile_with_debug ()) + let { nodes; dummy_node; _ } = get_state () in + new_node landmark dummy_node (profile_with_debug ()) (get_incr_node_id_ref nodes) (add_allocated_node nodes) From 4635b07b00166cf29f3c2c31e1958c08edb748cf Mon Sep 17 00:00:00 2001 From: hra687261 Date: Mon, 12 Jan 2026 10:39:09 +0100 Subject: [PATCH 11/16] Add `Landmark_state.t` --- src/landmark.ml | 117 +++++++++++++++++++---------------- src/landmark_state.mli | 52 +++++++++------- src/landmark_state_ocaml4.ml | 36 ++++++----- src/landmark_state_ocaml5.ml | 71 +++++++++------------ 4 files changed, 142 insertions(+), 134 deletions(-) diff --git a/src/landmark.ml b/src/landmark.ml index b253a7d..2e3a364 100644 --- a/src/landmark.ml +++ b/src/landmark.ml @@ -28,22 +28,24 @@ type profile_format = Utils.profile_format = | JSON | Textual of textual_option -let profiling = profiling +let profiling () = profiling (get_state ()) (** REGISTERING **) let last_landmark_id = ref 1 let landmark_of_id user_id = - let dummy_key = dummy_key () in - match W.find_opt (get_landmarks_of_key ()) {dummy_key with key = user_id} with + let st = get_state () in + let dummy_key = dummy_key st in + match W.find_opt (get_landmarks_of_key st) {dummy_key with key = user_id} with | None -> None | Some {landmark; _} -> Some landmark let new_landmark ~key:key_string ~name ~location ~kind () = let id = !last_landmark_id in incr last_landmark_id; - let dummy_node = dummy_node () in + let st = get_state () in + let dummy_node = dummy_node st in let rec res = { id; @@ -56,7 +58,7 @@ let new_landmark ~key:key_string ~name ~location ~kind () = last_son = dummy_node; } and key = { landmark = res; key = key_string} in - add_landmarks_of_key key; + add_landmarks_of_key st key; res let new_node = Landmark_state.new_node @@ -108,51 +110,55 @@ let register_counter name = register_generic Graph.Counter name let register_sampler name = register_generic Graph.Sampler name let reset () = - reset () + reset (get_state ()) let () = reset () let push_profiling_state () = if profile_with_debug () then Printf.eprintf "[Profiling] Push profiling state ....\n%!"; - let state = + let st = get_state () in + let profiling_state = let node_info (node: node) = let recursive = node.landmark.last_self == node in { node; recursive } in { - root = get_current_root_node (); - nodes = List.map node_info (get_allocated_nodes ()); - nodes_len = get_node_id_ref (); - current = get_current_node_ref (); - cache_miss = get_cache_miss_ref (); + root = get_current_root_node st; + nodes = List.map node_info (get_allocated_nodes st); + nodes_len = get_node_id_ref st; + current = get_current_node_ref st; + cache_miss = get_cache_miss_ref st; } in - clear_cache (); - set_current_root_node (new_node (landmark_root ())); - set_current_node_ref (get_current_root_node ()); - set_cache_miss_ref 0; - set_allocated_nodes [get_current_root_node ()]; - set_node_id_ref 1; + clear_cache st; + set_current_root_node st (new_node st (landmark_root st)); + set_current_node_ref st (get_current_root_node st); + set_cache_miss_ref st 0; + set_allocated_nodes st [get_current_root_node st]; + set_node_id_ref st 1; reset (); - Stack.push (get_profiling_stack ()) state + Stack.push (get_profiling_stack st) profiling_state let pop_profiling_state () = - let profiling_stack = get_profiling_stack () in + let profiling_stack = get_profiling_stack (get_state ()) in if profiling_stack.size > 0 then + let st = get_state () in let {root; nodes; nodes_len; current; cache_miss} = Stack.pop profiling_stack in - set_current_root_node root; - set_current_node_ref current; - set_cache_miss_ref cache_miss; - set_allocated_nodes (List.map (fun {node; recursive} -> if recursive then node.landmark.last_self <- node; node) nodes); - set_node_id_ref nodes_len + set_current_root_node st root; + set_current_node_ref st current; + set_cache_miss_ref st cache_miss; + set_allocated_nodes st (List.map (fun {node; recursive} -> if recursive then node.landmark.last_self <- node; node) nodes); + set_node_id_ref st nodes_len let unroll_until node = - unroll_until (get_current_node_ref ()) set_current_node_ref node + let st = get_state () in + unroll_until (get_current_node_ref st) (set_current_node_ref st) node let landmark_failure msg = - unroll_until (get_current_root_node ()); - if get_current_node_ref () != get_current_root_node () then + let st = get_state () in + unroll_until (get_current_root_node st); + if get_current_node_ref st != get_current_root_node st then reset (); if profile_with_debug () then (Printf.eprintf "Landmark error: %s\n%!" msg; Stdlib.exit 2) @@ -160,18 +166,19 @@ let landmark_failure msg = raise (LandmarkFailure msg) let get_entering_node ({id;_} as landmark: landmark) = - let current_node = get_current_node_ref () in + let st = get_state () in + let current_node = get_current_node_ref st in (* Read the "cache". *) - if current_node == landmark.last_parent && landmark.last_son != dummy_node () then + if current_node == landmark.last_parent && landmark.last_son != dummy_node st then landmark.last_son else begin - incr_cache_miss_ref (); + incr_cache_miss_ref st; (* We fetch the son or create it. *) let children = current_node.children in let son = try SparseArray.get children id with Not_found -> - let son = new_node landmark in + let son = new_node st landmark in SparseArray.set current_node.children id son; son in @@ -196,7 +203,8 @@ let increment ?times counter = increment ?times counter let sample sampler x = - let sampler = get_ds_landmark sampler in + let st = get_state () in + let sampler = get_ds_landmark st sampler in let node = get_entering_node sampler in node.calls <- node.calls + 1; Stack.push node.distrib x @@ -206,16 +214,17 @@ let sample sampler x = sample sampler x let enter landmark = - let landmark = get_ds_landmark landmark in - let dummy_node = dummy_node () in + let st = get_state () in + let landmark = get_ds_landmark st landmark in + let dummy_node = dummy_node st in if profile_with_debug () then Printf.eprintf "[Profiling] enter%s(%s)\n%!" (if landmark.last_self != dummy_node then " recursive " else "") landmark.name; if landmark.last_self == dummy_node || profile_recursive () then begin let node = get_entering_node landmark in node.calls <- node.calls + 1; - Stack.push node.fathers (get_current_node_ref ()); - set_current_node_ref node; + Stack.push node.fathers (get_current_node_ref st); + set_current_node_ref st node; landmark.last_self <- node; node.timestamp <- clock (); if profile_with_allocated_bytes () then begin @@ -240,25 +249,26 @@ let mismatch_recovering landmark (current_node: node) = in Printf.eprintf "Warning: %s\n%!" msg; unroll_until landmark.last_self; - if landmark != (get_current_node_ref ()).landmark then begin + if landmark != (get_current_node_ref (get_state ())).landmark then begin reset (); landmark_failure ("unable to recover from "^msg) end end let exit landmark = - let landmark = get_ds_landmark landmark in - let current_node = get_current_node_ref () in + let st = get_state () in + let landmark = get_ds_landmark st landmark in + let current_node = get_current_node_ref st in if profile_with_debug () then - Printf.eprintf "[Profiling] exit%s(%s)\n%!" (if landmark.last_self != get_current_node_ref () then " recursive " else "") landmark.name; + Printf.eprintf "[Profiling] exit%s(%s)\n%!" (if landmark.last_self != get_current_node_ref st then " recursive " else "") landmark.name; let last_self = landmark.last_self in if last_self.recursive_calls = 0 || profile_recursive () then begin mismatch_recovering landmark current_node; if Stack.size current_node.fathers = 1 then begin - landmark.last_self <- dummy_node (); + landmark.last_self <- dummy_node st; aggregate_stat_for current_node; end; - set_current_node_ref (get_exiting_node current_node) + set_current_node_ref st (get_exiting_node current_node) end else if not (profile_recursive ()) then last_self.recursive_calls <- last_self.recursive_calls - 1 @@ -316,11 +326,12 @@ let start_profiling ?(profiling_options = default_options) () = | true, false -> "with garbage collection statistics" | false, true -> "with system time" | false, false -> ""); - set_profiling true + set_profiling (get_state ()) true let rec exit_until_root () = - let current_node_ref = get_current_node_ref () in - if current_node_ref != get_current_root_node () then begin +let st = get_state () in + let current_node_ref = get_current_node_ref st in + if current_node_ref != get_current_root_node st then begin let landmark = current_node_ref.landmark in exit landmark; exit_until_root (); @@ -330,12 +341,13 @@ let stop_profiling () = if not (profiling ()) then failwith "In profiling: cannot stop since profiling is not on-going"; exit_until_root (); - let current_node = get_current_node_ref () in - assert (current_node == get_current_root_node ()); + let st = get_state () in + let current_node = get_current_node_ref st in + assert (current_node == get_current_root_node st); aggregate_stat_for current_node; if profile_with_debug () then Printf.eprintf "[Profiling] Stop profiling.\n%!"; - set_profiling false + set_profiling st false (** EXPORTING / IMPORTING SLAVE PROFILINGS **) @@ -359,8 +371,9 @@ let rec merge_branch (node:node) graph (imported : Graph.node) = ) children and new_branch parent graph (imported : Graph.node) = + let st = get_state () in let landmark = landmark_of_node imported in - let node = new_node landmark in + let node = new_node st landmark in node.calls <- imported.calls; let floats = node.floats in floats.time <- imported.time; @@ -376,10 +389,10 @@ let merge_aux node graph = let merge (graph : Graph.graph) = if profile_with_debug () then Printf.eprintf "[Profiling] merging foreign graph\n%!"; - merge_aux (get_current_root_node ()) graph + merge_aux (get_current_root_node (get_state ())) graph let export ?(label = "") () = - export ~merge:merge_aux ~label () + export ~merge:merge_aux ~label (get_state ()) let export_and_reset ?label () = let profiling = profiling () in diff --git a/src/landmark_state.mli b/src/landmark_state.mli index f075bcc..05d0484 100644 --- a/src/landmark_state.mli +++ b/src/landmark_state.mli @@ -4,37 +4,41 @@ open Utils -val landmark_root : unit -> landmark -val dummy_node : unit -> node -val dummy_key : unit -> landmark_key +type t -val profiling : unit -> bool -val set_profiling : bool -> unit +val get_state: unit -> t -val get_landmarks_of_key : unit -> W.t -val add_landmarks_of_key : landmark_key -> unit -val get_ds_landmark: landmark -> landmark +val landmark_root : t -> landmark +val dummy_node : t -> node +val dummy_key : t -> landmark_key -val get_node_id_ref : unit -> int -val set_node_id_ref : int -> unit -val get_allocated_nodes : unit -> node list -val set_allocated_nodes : node list -> unit +val profiling : t -> bool +val set_profiling : t -> bool -> unit -val new_node : landmark -> node +val get_landmarks_of_key : t -> W.t +val add_landmarks_of_key : t -> landmark_key -> unit +val get_ds_landmark: t -> landmark -> landmark -val get_current_root_node : unit -> node -val set_current_root_node : node -> unit -val get_current_node_ref : unit -> node -val set_current_node_ref : node -> unit -val get_cache_miss_ref : unit -> int -val set_cache_miss_ref : int -> unit +val get_node_id_ref : t -> int +val set_node_id_ref : t -> int -> unit +val get_allocated_nodes : t -> node list +val set_allocated_nodes : t -> node list -> unit -val incr_cache_miss_ref : unit -> unit +val new_node : t -> landmark -> node + +val get_current_root_node : t -> node +val set_current_root_node : t -> node -> unit +val get_current_node_ref : t -> node +val set_current_node_ref : t -> node -> unit +val get_cache_miss_ref : t -> int +val set_cache_miss_ref : t -> int -> unit + +val incr_cache_miss_ref : t -> unit val get_profiling_stack : - unit -> + t -> (profiling_state, profiling_state array) Utils.Stack.t -val clear_cache : unit -> unit -val reset: unit -> unit -val export : merge:(node -> Graph.graph -> unit) -> ?label:string -> unit -> Graph.graph +val clear_cache : t -> unit +val reset: t -> unit +val export : merge:(node -> Graph.graph -> unit) -> ?label:string -> t -> Graph.graph diff --git a/src/landmark_state_ocaml4.ml b/src/landmark_state_ocaml4.ml index fd22e37..b08451c 100644 --- a/src/landmark_state_ocaml4.ml +++ b/src/landmark_state_ocaml4.ml @@ -6,6 +6,10 @@ open Utils module Stack = Utils.Stack +type t = unit + +let get_state () = () + let rec landmark_root = { kind = Graph.Root; id = 0; @@ -37,43 +41,43 @@ let dummy_key () = dummy_key let profiling_ref = ref false let profiling () = !profiling_ref -let set_profiling b = profiling_ref := b +let set_profiling () b = profiling_ref := b let landmarks_of_key = W.create 17 let get_landmarks_of_key () = landmarks_of_key -let add_landmarks_of_key key = W.add landmarks_of_key key -let get_ds_landmark l = l +let add_landmarks_of_key () key = W.add landmarks_of_key key +let get_ds_landmark () l = l let node_id_ref = ref 0 let get_node_id_ref () = !node_id_ref -let set_node_id_ref n = node_id_ref := n +let set_node_id_ref () n = node_id_ref := n let allocated_nodes = ref [] let get_allocated_nodes () = !allocated_nodes -let set_allocated_nodes l = allocated_nodes := l +let set_allocated_nodes () l = allocated_nodes := l let get_incr_node_id_ref () = let id = !node_id_ref in incr node_id_ref; id -let add_allocated_node node = +let add_allocated_node () node = allocated_nodes := node :: !allocated_nodes -let new_node landmark = - new_node landmark (dummy_node ()) (profile_with_debug ()) get_incr_node_id_ref add_allocated_node +let new_node () landmark = + new_node landmark (dummy_node ()) (profile_with_debug ()) get_incr_node_id_ref (add_allocated_node ()) -let current_root_node = ref (new_node (landmark_root ())) +let current_root_node = ref (new_node () (landmark_root ())) let get_current_root_node () = !current_root_node -let set_current_root_node node = current_root_node := node +let set_current_root_node () node = current_root_node := node let current_node_ref = ref !current_root_node let get_current_node_ref () = !current_node_ref -let set_current_node_ref node = current_node_ref := node +let set_current_node_ref () node = current_node_ref := node let cache_miss_ref = ref 0 let get_cache_miss_ref () = !cache_miss_ref -let set_cache_miss_ref n = cache_miss_ref := n +let set_cache_miss_ref () n = cache_miss_ref := n let profiling_stack = let dummy = @@ -104,11 +108,11 @@ let reset () = current_root_node.recursive_calls <- 0; stamp_root current_root_node; SparseArray.reset current_root_node.children; - set_allocated_nodes [current_root_node]; - set_current_node_ref current_root_node; - set_cache_miss_ref 0; + set_allocated_nodes () [current_root_node]; + set_current_node_ref () current_root_node; + set_cache_miss_ref () 0; clear_cache (); - set_node_id_ref 1 + set_node_id_ref () 1 let export ~merge:_ ?(label = "") () = if profiling () then begin diff --git a/src/landmark_state_ocaml5.ml b/src/landmark_state_ocaml5.ml index 732483e..e009b58 100644 --- a/src/landmark_state_ocaml5.ml +++ b/src/landmark_state_ocaml5.ml @@ -24,7 +24,7 @@ let get_incr_node_id_ref nodes () = let add_allocated_node nodes node = nodes.allocated_nodes <- node :: nodes.allocated_nodes -type state = { +type t = { landmark_root: landmark; dummy_node : node; dummy_key: landmark_key; @@ -39,7 +39,7 @@ type state = { mutable current_root_node : node; mutable current_node_ref : node; - mutable child_states : state list; + mutable child_states : t list; (* The states of child domains spawned by the main one *) mutable graph: Graph.graph; (* Used by child states to store their own graphs *) @@ -240,21 +240,15 @@ let get_state () = ); st -let landmark_root () = - (get_state ()).landmark_root +let landmark_root st = st.landmark_root +let dummy_node st = st.dummy_node +let dummy_key st = st.dummy_key -let dummy_node () = - (get_state ()).dummy_node - -let dummy_key () = - (get_state ()).dummy_key - -let profiling () = (get_state ()).profiling_ref -let set_profiling b = (get_state ()).profiling_ref <- b +let profiling st = st.profiling_ref +let set_profiling st b = st.profiling_ref <- b let get_landmarks_of_key = let initialized = Domain.DLS.new_key (fun () -> false) in - fun () -> - let state = get_state () in + fun state -> let landmarks_of_key = state.landmarks_of_key in if not (Domain.DLS.get initialized) then ( Domain.DLS.set initialized true; @@ -268,47 +262,41 @@ let get_landmarks_of_key = ); landmarks_of_key -let add_landmarks_of_key key = W.add (get_state ()).landmarks_of_key key +let add_landmarks_of_key st key = W.add st.landmarks_of_key key -let get_ds_landmark (l: landmark) = - let dummy_key = (get_state ()).dummy_key in +let get_ds_landmark st (l: landmark) = let { landmark; _ } = - W.find (get_landmarks_of_key ()) { dummy_key with key = l.key.key } + W.find (get_landmarks_of_key st) { st.dummy_key with key = l.key.key } in landmark -let get_node_id_ref () = (get_state ()).nodes.node_id_ref -let set_node_id_ref n = (get_state ()).nodes.node_id_ref <- n -let get_allocated_nodes () = (get_state ()).nodes.allocated_nodes -let set_allocated_nodes l = (get_state ()).nodes.allocated_nodes <- l +let get_node_id_ref st = st.nodes.node_id_ref +let set_node_id_ref st n = st.nodes.node_id_ref <- n +let get_allocated_nodes st = st.nodes.allocated_nodes +let set_allocated_nodes st l = st.nodes.allocated_nodes <- l -let new_node landmark = - let { nodes; dummy_node; _ } = get_state () in +let new_node { nodes; dummy_node; _ } landmark = new_node landmark dummy_node (profile_with_debug ()) (get_incr_node_id_ref nodes) (add_allocated_node nodes) -let get_current_root_node () = (get_state ()).current_root_node -let set_current_root_node (node: node) = - (get_state ()).current_root_node <- node +let get_current_root_node st = st.current_root_node +let set_current_root_node st (node: node) = + st.current_root_node <- node -let get_current_node_ref () = (get_state ()).current_node_ref -let set_current_node_ref (node: node) = - (get_state ()).current_node_ref <- node +let get_current_node_ref st = st.current_node_ref +let set_current_node_ref st (node: node) = + st.current_node_ref <- node -let get_cache_miss_ref () = (get_state ()).cache_miss_ref -let set_cache_miss_ref n = (get_state ()).cache_miss_ref <- n -let incr_cache_miss_ref () = - let state = get_state () in - state.cache_miss_ref <- state.cache_miss_ref + 1 -let get_profiling_stack () = (get_state ()).profiling_stack +let get_cache_miss_ref st = st.cache_miss_ref +let set_cache_miss_ref st n = st.cache_miss_ref <- n +let incr_cache_miss_ref st = st.cache_miss_ref <- st.cache_miss_ref + 1 +let get_profiling_stack st = st.profiling_stack -let reset () = - reset_aux (get_state ()) +let reset = reset_aux -let clear_cache () = - clear_cache (get_state ()) +let clear_cache = clear_cache let rec merge_child_state_graphs ~merge state = List.iter ( @@ -317,7 +305,6 @@ let rec merge_child_state_graphs ~merge state = merge state.current_root_node st.graph ) state.child_states -let export ~merge ?(label = "") () = - let state = get_state () in +let export ~merge ?(label = "") state = merge_child_state_graphs ~merge state; export state label From b3f53e8a7c86138c6ac3566b3d1c77efc6193b7e Mon Sep 17 00:00:00 2001 From: hra687261 Date: Mon, 12 Jan 2026 10:45:53 +0100 Subject: [PATCH 12/16] Refactoring and cleaning to avoid code duplucation --- src/landmark.ml | 364 +++++++++++++++++++++++++---------- src/landmark_state.mli | 23 ++- src/landmark_state_ocaml4.ml | 113 ++++++----- src/landmark_state_ocaml5.ml | 261 ++++++++----------------- src/utils.ml | 163 +--------------- src/utils.mli | 61 +----- 6 files changed, 421 insertions(+), 564 deletions(-) diff --git a/src/landmark.ml b/src/landmark.ml index 2e3a364..07b9cfe 100644 --- a/src/landmark.ml +++ b/src/landmark.ml @@ -2,52 +2,87 @@ (* See the attached LICENSE file. *) (* Copyright (C) 2000-2025 LexiFi *) -include Utils - +open Utils open Landmark_state +external clock: unit -> (Int64.t [@unboxed]) = + "caml_highres_clock" "caml_highres_clock_native" [@@noalloc] + +(* Alternative implementation of Gc.allocated_bytes which does not allocate *) +external allocated_bytes: unit -> (Int64.t [@unboxed]) = + "allocated_bytes" "allocated_bytes_native" [@@noalloc] +external allocated_bytes_major: unit -> (Int64.t [@unboxed]) = + "allocated_bytes_major" "allocated_bytes_major_native" [@@noalloc] + +let allocated_bytes () = Int64.to_int (allocated_bytes ()) +let allocated_bytes_major () = Int64.to_int (allocated_bytes_major ()) + exception LandmarkFailure of string module Graph = Graph module Stack = Utils.Stack -type landmark = Utils.landmark -type counter = Utils.counter -type sampler = Utils.sampler +type nonrec landmark = landmark + +type landmark_key = { + key: string; + landmark: landmark; +} + +and counter = landmark + +and sampler = landmark (** STATE **) -type profile_output = Utils.profile_output = +type profile_output = | Silent | Temporary of string option | Channel of out_channel -type textual_option = Utils.textual_option = {threshold : float} +type textual_option = {threshold : float} -type profile_format = Utils.profile_format = +type profile_format = | JSON | Textual of textual_option +let profile_with_debug = ref false +let profile_with_allocated_bytes = ref false +let profile_with_sys_time = ref false +let profile_output = ref Silent +let profile_format = ref (Textual {threshold = 1.0}) +let profile_recursive = ref false + let profiling () = profiling (get_state ()) (** REGISTERING **) let last_landmark_id = ref 1 +module W = Weak.Make(struct + type t = landmark_key + let equal (x : landmark_key) (y : landmark_key) = x.key = y.key + let hash (x : landmark_key) = Hashtbl.hash x.key + end) + +let landmarks_of_key = W.create 17 + +let dummy_key st = + { key = ""; landmark = dummy_landmark st} let landmark_of_id user_id = let st = get_state () in let dummy_key = dummy_key st in - match W.find_opt (get_landmarks_of_key st) {dummy_key with key = user_id} with + match W.find_opt landmarks_of_key {dummy_key with key = user_id} with | None -> None | Some {landmark; _} -> Some landmark -let new_landmark ~key:key_string ~name ~location ~kind () = +let new_landmark ~key ~name ~location ~kind () = let id = !last_landmark_id in incr last_landmark_id; let st = get_state () in let dummy_node = dummy_node st in - let rec res = - { + let res = + landmark_of_landmark_body st { id; name; location; @@ -57,11 +92,29 @@ let new_landmark ~key:key_string ~name ~location ~kind () = last_self = dummy_node; last_son = dummy_node; } - and key = { landmark = res; key = key_string} in - add_landmarks_of_key st key; + in + W.add landmarks_of_key { key; landmark = res }; res -let new_node = Landmark_state.new_node +let new_node st landmark = + if !profile_with_debug then + Printf.eprintf "[Profiling] Allocating new node for %s...\n%!" landmark.name; + let id = get_incr_node_id_ref st in + let node = { + landmark; + id; + + fathers = Stack.make Array (dummy_node st) 1; + distrib = Stack.make Float 0.0 0; + children = SparseArray.make (dummy_node st) 7; + + calls = 0; + recursive_calls = 0; + timestamp = Int64.zero; + floats = new_floats (); + } in + set_allocated_nodes st (node :: get_allocated_nodes st); + node let landmark_of_node ({landmark_id = key; name; location; kind; _} : Graph.node) = match landmark_of_id key with @@ -70,7 +123,7 @@ let landmark_of_node ({landmark_id = key; name; location; kind; _} : Graph.node) let register_generic ~id ~name ~location ~kind () = let landmark = new_landmark ~key:id ~name ~location ~kind () in - if profile_with_debug () then + if !profile_with_debug then Printf.eprintf "[Profiling] registering(%s)\n%!" name; landmark @@ -109,13 +162,37 @@ let register_counter name = register_generic Graph.Counter name let register_sampler name = register_generic Graph.Sampler name -let reset () = - reset (get_state ()) +let stamp_root current_root_node = + current_root_node.timestamp <- (clock ()); + if !profile_with_allocated_bytes then begin + current_root_node.floats.allocated_bytes <- allocated_bytes (); + current_root_node.floats.allocated_bytes_major <- allocated_bytes_major () + end; + if !profile_with_sys_time then + current_root_node.floats.sys_time <- Sys.time () + +let reset_st st = + if !profile_with_debug then + Printf.eprintf "[Profiling] resetting ...\n%!"; + let current_root_node = get_current_root_node st in + let floats = current_root_node.floats in + floats.time <- 0.0; + floats.allocated_bytes <- 0; + floats.sys_time <- 0.0; + current_root_node.calls <- 0; + current_root_node.recursive_calls <- 0; + stamp_root current_root_node; + SparseArray.reset current_root_node.children; + set_allocated_nodes st [current_root_node]; + set_current_node_ref st current_root_node; + set_cache_miss_ref st 0; + clear_cache st; + set_node_id_ref st 1 -let () = reset () +let reset () = reset_st (get_state ()) let push_profiling_state () = - if profile_with_debug () then + if !profile_with_debug then Printf.eprintf "[Profiling] Push profiling state ....\n%!"; let st = get_state () in let profiling_state = @@ -131,13 +208,13 @@ let push_profiling_state () = cache_miss = get_cache_miss_ref st; } in - clear_cache st; + (* clear_cache st; *) set_current_root_node st (new_node st (landmark_root st)); set_current_node_ref st (get_current_root_node st); set_cache_miss_ref st 0; set_allocated_nodes st [get_current_root_node st]; set_node_id_ref st 1; - reset (); + (* reset (); *) Stack.push (get_profiling_stack st) profiling_state let pop_profiling_state () = @@ -151,21 +228,25 @@ let pop_profiling_state () = set_allocated_nodes st (List.map (fun {node; recursive} -> if recursive then node.landmark.last_self <- node; node) nodes); set_node_id_ref st nodes_len -let unroll_until node = - let st = get_state () in - unroll_until (get_current_node_ref st) (set_current_node_ref st) node +let unroll_until st node = + while + let current_node = get_current_node_ref st in + current_node != node + && Stack.size current_node.fathers > 0 + && (set_current_node_ref st (Stack.pop current_node.fathers); true) + do () done let landmark_failure msg = let st = get_state () in - unroll_until (get_current_root_node st); + unroll_until st (get_current_root_node st); if get_current_node_ref st != get_current_root_node st then - reset (); - if profile_with_debug () then + reset_st st; + if !profile_with_debug then (Printf.eprintf "Landmark error: %s\n%!" msg; Stdlib.exit 2) else raise (LandmarkFailure msg) -let get_entering_node ({id;_} as landmark: landmark) = +let get_entering_node ({ id; _ } as landmark: landmark_body) = let st = get_state () in let current_node = get_current_node_ref st in (* Read the "cache". *) @@ -188,13 +269,16 @@ let get_entering_node ({id;_} as landmark: landmark) = son end -let get_exiting_node current_node = - if Stack.size current_node.fathers = 0 then +let get_exiting_node st = + let current_node_ref = get_current_node_ref st in + if Stack.size current_node_ref.fathers = 0 then landmark_failure "Stack underflow" else - Stack.pop current_node.fathers + Stack.pop current_node_ref.fathers let increment ?(times = 1) counter = + let st = get_state () in + let counter = get_ds_landmark st counter in let node = get_entering_node counter in node.calls <- node.calls + times @@ -213,25 +297,23 @@ let sample sampler x = if profiling () then sample sampler x -let enter landmark = - let st = get_state () in - let landmark = get_ds_landmark st landmark in +let enter_landmark st landmark = let dummy_node = dummy_node st in - if profile_with_debug () then + if !profile_with_debug then Printf.eprintf "[Profiling] enter%s(%s)\n%!" (if landmark.last_self != dummy_node then " recursive " else "") landmark.name; - if landmark.last_self == dummy_node || profile_recursive () then begin + if landmark.last_self == dummy_node || !profile_recursive then begin let node = get_entering_node landmark in node.calls <- node.calls + 1; Stack.push node.fathers (get_current_node_ref st); set_current_node_ref st node; landmark.last_self <- node; node.timestamp <- clock (); - if profile_with_allocated_bytes () then begin + if !profile_with_allocated_bytes then begin node.floats.allocated_bytes_stamp <- allocated_bytes (); node.floats.allocated_bytes_major_stamp <- allocated_bytes_major (); end; - if profile_with_sys_time () then + if !profile_with_sys_time then node.floats.sys_timestamp <- Sys.time () end else begin let last_self = landmark.last_self in @@ -239,118 +321,194 @@ let enter landmark = last_self.calls <- last_self.calls + 1 end -let mismatch_recovering landmark (current_node: node) = +let mismatch_recovering st (landmark: landmark_body) (current_node: node) = let expected_landmark = current_node.landmark in if expected_landmark != landmark then begin let msg = - Printf.sprintf "landmark failure when closing '%s'<%d> (%s), expecting '%s'<%d> (%s)." - landmark.name landmark.id landmark.location - expected_landmark.name landmark.id expected_landmark.location + Printf.sprintf "landmark failure when closing '%s' (%s), expecting '%s' (%s)." + landmark.name landmark.location + expected_landmark.name expected_landmark.location in Printf.eprintf "Warning: %s\n%!" msg; - unroll_until landmark.last_self; - if landmark != (get_current_node_ref (get_state ())).landmark then begin - reset (); - landmark_failure ("unable to recover from "^msg) + unroll_until st landmark.last_self; + let current_node = get_current_node_ref st in + if landmark != current_node.landmark then begin + reset_st st; + failwith ("unable to recover from "^msg) end end -let exit landmark = - let st = get_state () in - let landmark = get_ds_landmark st landmark in +let aggregate_stat_for current_node = + let floats = current_node.floats in + floats.time <- floats.time + +. Int64.(to_float (sub (clock ()) current_node.timestamp)); + if !profile_with_allocated_bytes then begin + floats.allocated_bytes <- + floats.allocated_bytes + + (allocated_bytes () - floats.allocated_bytes_stamp); + floats.allocated_bytes_major <- + floats.allocated_bytes_major + + (allocated_bytes_major () - floats.allocated_bytes_major_stamp) + end; + if !profile_with_sys_time then + floats.sys_time <- floats.sys_time + +. (Sys.time () -. floats.sys_timestamp) + +let exit_landmark st landmark = let current_node = get_current_node_ref st in - if profile_with_debug () then - Printf.eprintf "[Profiling] exit%s(%s)\n%!" (if landmark.last_self != get_current_node_ref st then " recursive " else "") landmark.name; + if !profile_with_debug then + Printf.eprintf "[Profiling] exit%s(%s)\n%!" (if landmark.last_self != current_node then " recursive " else "") landmark.name; let last_self = landmark.last_self in - if last_self.recursive_calls = 0 || profile_recursive () then begin - mismatch_recovering landmark current_node; + if last_self.recursive_calls = 0 || !profile_recursive then begin + mismatch_recovering st landmark current_node; if Stack.size current_node.fathers = 1 then begin landmark.last_self <- dummy_node st; aggregate_stat_for current_node; end; - set_current_node_ref st (get_exiting_node current_node) + set_current_node_ref st (get_exiting_node st) end - else if not (profile_recursive ()) then + else if not !profile_recursive then last_self.recursive_calls <- last_self.recursive_calls - 1 (* These two functions should be inlined. *) -let enter landmark = +let enter_landmark st landmark = if profiling () then - enter landmark + enter_landmark st landmark -let exit landmark = +let exit_landmark st landmark = if profiling () then - exit landmark + exit_landmark st landmark (** HELPERS **) let wrap node f x = - enter node; + let st = get_state () in + let node = get_ds_landmark st node in + enter_landmark st node; try let res = f x in - exit node; + exit_landmark st node; res with LandmarkFailure _ as e -> raise e - | e -> exit node; raise e + | e -> exit_landmark (get_state ()) node; raise e let unsafe_wrap node f x = - enter node; + let st = get_state () in + let node = get_ds_landmark st node in + enter_landmark st node; let res = f x in - exit node; + exit_landmark (get_state ()) node; res +let exit landmark = + let st = get_state () in + let landmark = get_ds_landmark st landmark in + exit_landmark st landmark + +let enter landmark = + let st = get_state () in + let landmark = get_ds_landmark st landmark in + enter_landmark st landmark + (** PROFILERS **) -type profiling_options = Utils.profiling_options = { +type profiling_options = { debug : bool; allocated_bytes: bool; sys_time : bool; recursive : bool; - output : Utils.profile_output; - format : Utils.profile_format + output : profile_output; + format : profile_format } +let default_options = { + debug = false; + allocated_bytes = true; + sys_time = false; + recursive = false; + output = Channel stderr; + format = Textual {threshold = 1.0}; +} -let default_options = default_options -let set_profiling_options = set_profiling_options -let profiling_options = profiling_options +let set_profiling_options {debug; allocated_bytes; sys_time; output; format; recursive} = + profile_with_allocated_bytes := allocated_bytes; + profile_with_sys_time := sys_time; + profile_with_debug := debug; + profile_output := output; + profile_format := format; + profile_recursive := recursive + +let profiling_options () = { + debug = !profile_with_debug; + allocated_bytes = !profile_with_allocated_bytes; + sys_time = !profile_with_sys_time; + recursive = !profile_recursive; + output = !profile_output; + format = !profile_format +} let start_profiling ?(profiling_options = default_options) () = if profiling () then failwith "In profiling: it is not allowed to nest profilings."; set_profiling_options profiling_options; - if profile_with_debug () then + if !profile_with_debug then Printf.eprintf "[Profiling] Start profiling %s...\n%!" - (match profile_with_allocated_bytes (), profile_with_sys_time () with + (match !profile_with_allocated_bytes, !profile_with_sys_time with | true, true -> "with garbage collection statistics and system time" | true, false -> "with garbage collection statistics" | false, true -> "with system time" | false, false -> ""); set_profiling (get_state ()) true -let rec exit_until_root () = -let st = get_state () in +let rec exit_until_root st = let current_node_ref = get_current_node_ref st in if current_node_ref != get_current_root_node st then begin let landmark = current_node_ref.landmark in - exit landmark; - exit_until_root (); + exit_landmark st landmark; + exit_until_root st; end - -let stop_profiling () = +let stop_profiling_st st = if not (profiling ()) then failwith "In profiling: cannot stop since profiling is not on-going"; - exit_until_root (); - let st = get_state () in + exit_until_root st; let current_node = get_current_node_ref st in - assert (current_node == get_current_root_node st); + assert (current_node == (get_current_root_node st)); aggregate_stat_for current_node; - if profile_with_debug () then + if !profile_with_debug then Printf.eprintf "[Profiling] Stop profiling.\n%!"; set_profiling st false +let stop_profiling () = stop_profiling_st (get_state ()) + (** EXPORTING / IMPORTING SLAVE PROFILINGS **) +let array_list_map f l = + let size = List.length l in + match l with + | [] -> [||] + | hd :: tl -> + let res = Array.make size (f hd) in + List.iteri (fun k x -> res.(k+1) <- f x) tl; res + +let export_aux st label = + let export_node {landmark; id; calls; floats; children; distrib; _} = + let {key = landmark_id; name; location; kind; _} = landmark in + let {time; allocated_bytes; allocated_bytes_major; sys_time; _} = floats in + let children = + List.map (fun ({id;_} : node) -> id) (SparseArray.values children) + in + {Graph.landmark_id; id; name; location; calls; time; kind; + allocated_bytes; allocated_bytes_major; sys_time; children; distrib = Stack.to_floatarray distrib} + in + if profiling () then begin + let root_node = get_current_root_node st in + aggregate_stat_for root_node; + stamp_root root_node + end; + let all_nodes = List.rev (get_allocated_nodes st) in + let nodes = array_list_map export_node all_nodes in + {Graph.nodes; label; root = 0} + let rec merge_branch (node:node) graph (imported : Graph.node) = let floats = node.floats in floats.time <- imported.time +. floats.time; @@ -361,9 +519,11 @@ let rec merge_branch (node:node) graph (imported : Graph.node) = Float.Array.iter (Stack.push node.distrib) imported.distrib; let children = Graph.children graph imported in + let st = get_state () in List.iter (fun (imported_son : Graph.node) -> let landmark = landmark_of_node imported_son in + let landmark = get_ds_landmark st landmark in match SparseArray.get node.children landmark.id with | exception Not_found -> new_branch node graph imported_son @@ -373,6 +533,7 @@ let rec merge_branch (node:node) graph (imported : Graph.node) = and new_branch parent graph (imported : Graph.node) = let st = get_state () in let landmark = landmark_of_node imported in + let landmark = get_ds_landmark st landmark in let node = new_node st landmark in node.calls <- imported.calls; let floats = node.floats in @@ -387,33 +548,34 @@ let merge_aux node graph = merge_branch node graph (Graph.root graph) let merge (graph : Graph.graph) = - if profile_with_debug () then + if !profile_with_debug then Printf.eprintf "[Profiling] merging foreign graph\n%!"; merge_aux (get_current_root_node (get_state ())) graph -let export ?(label = "") () = - export ~merge:merge_aux ~label (get_state ()) - -let export_and_reset ?label () = +let export_and_reset ?(label = "") () = + let st = get_state () in let profiling = profiling () in if profiling then - stop_profiling (); - let res = export ?label () in - reset (); + stop_profiling_st st; + let res = export ~merge:merge_aux ~label st in + reset_st st; if profiling then - start_profiling (); + stop_profiling_st st; res +let export ?(label = "") () = + export ~merge:merge_aux ~label (get_state ()) + let exit_hook () = - if profile_with_debug () then + if !profile_with_debug then Printf.eprintf "[Profiling] exit_hook\n%!"; if profiling () then begin - stop_profiling (); + stop_profiling_st (get_state ()); let label = String.concat " " (Array.to_list Sys.argv) in let cg = export ~label () in - match profile_output (), profile_format () with + match !profile_output, !profile_format with | Silent, _ -> () | Channel out, Textual {threshold} -> Graph.output ~threshold out cg @@ -432,9 +594,6 @@ let exit_hook () = close_out oc end -let () = Stdlib.at_exit exit_hook - - let parse_env_options s = let open Printf in let debug = ref false in @@ -520,7 +679,14 @@ let parse_env_options s = {debug = !debug; allocated_bytes = !allocated_bytes; sys_time = !sys_time; output = !output; format = !format; recursive = !recursive} -let () = match Sys.getenv "OCAML_LANDMARKS" with +let () = + new_node_ref := new_node; + export_ref := export_aux; + reset_state_ref := reset_st; + stop_profiling_ref := stop_profiling_st; + reset (); + Stdlib.at_exit exit_hook; + match Sys.getenv "OCAML_LANDMARKS" with | exception Not_found -> () | str -> try start_profiling ~profiling_options:(parse_env_options str) () diff --git a/src/landmark_state.mli b/src/landmark_state.mli index 05d0484..d8c0041 100644 --- a/src/landmark_state.mli +++ b/src/landmark_state.mli @@ -6,26 +6,32 @@ open Utils type t +type landmark + +val landmark_of_landmark_body: t -> landmark_body -> landmark +val get_ds_landmark: t -> landmark -> landmark_body + +val new_node_ref: (t -> landmark_body -> node) ref +val export_ref: (t -> string -> Graph.graph) ref +val reset_state_ref: (t -> unit) ref +val stop_profiling_ref: (t -> unit) ref +val iter_registered_landmarks: ((landmark -> unit) -> unit) ref + val get_state: unit -> t -val landmark_root : t -> landmark +val dummy_landmark : t -> landmark +val landmark_root : t -> landmark_body val dummy_node : t -> node -val dummy_key : t -> landmark_key val profiling : t -> bool val set_profiling : t -> bool -> unit -val get_landmarks_of_key : t -> W.t -val add_landmarks_of_key : t -> landmark_key -> unit -val get_ds_landmark: t -> landmark -> landmark - val get_node_id_ref : t -> int val set_node_id_ref : t -> int -> unit +val get_incr_node_id_ref : t -> int val get_allocated_nodes : t -> node list val set_allocated_nodes : t -> node list -> unit -val new_node : t -> landmark -> node - val get_current_root_node : t -> node val set_current_root_node : t -> node -> unit val get_current_node_ref : t -> node @@ -40,5 +46,4 @@ val get_profiling_stack : (profiling_state, profiling_state array) Utils.Stack.t val clear_cache : t -> unit -val reset: t -> unit val export : merge:(node -> Graph.graph -> unit) -> ?label:string -> t -> Graph.graph diff --git a/src/landmark_state_ocaml4.ml b/src/landmark_state_ocaml4.ml index b08451c..b896115 100644 --- a/src/landmark_state_ocaml4.ml +++ b/src/landmark_state_ocaml4.ml @@ -6,8 +6,22 @@ open Utils module Stack = Utils.Stack +type landmark = landmark_body + type t = unit +let landmark_of_landmark_body () l = l + +let new_node_ref: (t -> landmark_body -> node) ref = + ref (fun _ _ -> failwith "uninitialized function \"new_node_ref\"") +let export_ref: (t -> string -> Graph.graph) ref = + ref (fun _ -> failwith "uninitialized function \"export_ref\"") +let reset_state_ref: (t -> unit) ref = + ref (fun _ -> failwith "uninitialized function \"reset_state_ref\"") +let stop_profiling_ref: (t -> unit) ref = + ref (fun _ -> failwith "uninitialized function \"stop_profiling_ref\"") +let iter_registered_landmarks: ((landmark -> unit) -> unit) ref = + ref (fun _ -> ()) let get_state () = () let rec landmark_root = { @@ -15,7 +29,7 @@ let rec landmark_root = { id = 0; name = "ROOT"; location = __FILE__; - key = { key = ""; landmark = landmark_root}; + key = ""; last_parent = dummy_node; last_son = dummy_node; last_self = dummy_node; @@ -33,19 +47,22 @@ and dummy_node = { timestamp = Int64.zero } -and dummy_key = { key = ""; landmark = landmark_root} +let dummy_landmark () = landmark_root + +let clear_cache () = + !iter_registered_landmarks ( + fun landmark -> + landmark.last_son <- dummy_node; + landmark.last_parent <- dummy_node; + landmark.last_self <- dummy_node; + ) let landmark_root () = landmark_root let dummy_node () = dummy_node -let dummy_key () = dummy_key let profiling_ref = ref false let profiling () = !profiling_ref let set_profiling () b = profiling_ref := b - -let landmarks_of_key = W.create 17 -let get_landmarks_of_key () = landmarks_of_key -let add_landmarks_of_key () key = W.add landmarks_of_key key let get_ds_landmark () l = l let node_id_ref = ref 0 @@ -61,64 +78,54 @@ let get_incr_node_id_ref () = incr node_id_ref; id -let add_allocated_node () node = - allocated_nodes := node :: !allocated_nodes +let current_root_node = ref (dummy_node ()) +let current_node_ref = ref !current_root_node -let new_node () landmark = - new_node landmark (dummy_node ()) (profile_with_debug ()) get_incr_node_id_ref (add_allocated_node ()) +let get_current_root_node, get_current_node_ref = + let init = ref false in + let set_nodes () = + current_root_node := !new_node_ref () (landmark_root ()); + current_node_ref := !current_root_node; + init := true + in + let get_current_root_node () = + if not !init then ( + set_nodes (); + !current_root_node) + else !current_root_node + in + let get_current_node_ref () = + if not !init + then ( + current_root_node := !new_node_ref () (landmark_root ()); + current_node_ref := !current_root_node; + !current_node_ref + ) + else !current_node_ref + in + get_current_root_node, get_current_node_ref -let current_root_node = ref (new_node () (landmark_root ())) -let get_current_root_node () = !current_root_node -let set_current_root_node () node = current_root_node := node +let set_current_root_node () node = + current_root_node := node -let current_node_ref = ref !current_root_node -let get_current_node_ref () = !current_node_ref -let set_current_node_ref () node = current_node_ref := node +let set_current_node_ref () node = + current_node_ref := node let cache_miss_ref = ref 0 let get_cache_miss_ref () = !cache_miss_ref let set_cache_miss_ref () n = cache_miss_ref := n let profiling_stack = - let dummy = - {root = dummy_node (); current = dummy_node (); nodes = [{node = dummy_node (); recursive = false}]; cache_miss = 0; nodes_len = 1} + let dummy = { + root = dummy_node (); + current = dummy_node (); + nodes = [{node = dummy_node (); recursive = false}]; + cache_miss = 0; + nodes_len = 1} in Stack.make Array dummy 7 let incr_cache_miss_ref () = incr cache_miss_ref let get_profiling_stack () = profiling_stack -let clear_cache () = - W.iter ( - fun {landmark; _} -> - landmark.last_son <- dummy_node (); - landmark.last_parent <- dummy_node (); - landmark.last_self <- dummy_node (); - ) (get_landmarks_of_key ()) - -let reset () = - if profile_with_debug () then - Printf.eprintf "[Profiling] resetting ...\n%!"; - (* reset dummy_node *) - let current_root_node = get_current_root_node () in - let floats = current_root_node.floats in - floats.time <- 0.0; - floats.allocated_bytes <- 0; - floats.sys_time <- 0.0; - current_root_node.calls <- 0; - current_root_node.recursive_calls <- 0; - stamp_root current_root_node; - SparseArray.reset current_root_node.children; - set_allocated_nodes () [current_root_node]; - set_current_node_ref () current_root_node; - set_cache_miss_ref () 0; - clear_cache (); - set_node_id_ref () 1 - let export ~merge:_ ?(label = "") () = - if profiling () then begin - aggregate_stat_for (get_current_root_node ()); - stamp_root (get_current_root_node ()) - end; - let all_nodes = List.rev (get_allocated_nodes ()) in - let nodes = array_list_map export_node all_nodes in - {Graph.nodes; label; root = 0} + !export_ref () label diff --git a/src/landmark_state_ocaml5.ml b/src/landmark_state_ocaml5.ml index e009b58..2061577 100644 --- a/src/landmark_state_ocaml5.ml +++ b/src/landmark_state_ocaml5.ml @@ -6,33 +6,22 @@ open Utils module Stack = Utils.Stack +type landmark = landmark_body Lazy.t Domain.DLS.key +(* _ Lazy.t is used to ensure that the landmark instance of a child domain is + created in runtime of the child domain. *) + type nodes = { mutable node_id_ref: int; mutable allocated_nodes: node list; } -let init_nodes () = { - node_id_ref = 0; - allocated_nodes = []; -} - -let get_incr_node_id_ref nodes () = - let id = nodes.node_id_ref in - nodes.node_id_ref <- id + 1; - id - -let add_allocated_node nodes node = - nodes.allocated_nodes <- node :: nodes.allocated_nodes - type t = { - landmark_root: landmark; + landmark_root: landmark_body; dummy_node : node; - dummy_key: landmark_key; nodes: nodes; mutable profiling_ref : bool; - landmarks_of_key: W.t; mutable cache_miss_ref: int; profiling_stack: (profiling_state, profiling_state array) Stack.t; @@ -47,31 +36,26 @@ type t = { mutable registered: bool; } -let clear_cache gls = - W.iter ( - fun {landmark; _} -> - landmark.last_son <- gls.dummy_node; - landmark.last_parent <- gls.dummy_node; - landmark.last_self <- gls.dummy_node; - ) (gls.landmarks_of_key) +let new_node_ref: (t -> landmark_body -> node) ref = + ref (fun _ _ -> failwith "uninitialized function \"new_node_ref\"") +let export_ref: (t -> string -> Graph.graph) ref = + ref (fun _ -> failwith "uninitialized function \"export_ref\"") +let reset_state_ref: (t -> unit) ref = + ref (fun _ -> failwith "uninitialized function \"reset_state_ref\"") +let stop_profiling_ref: (t -> unit) ref = + ref (fun _ -> failwith "uninitialized function \"stop_profiling_ref\"") +let iter_registered_landmarks: ((landmark -> unit) -> unit) ref = + ref (fun _ -> ()) -let reset_aux gls = - if profile_with_debug () then - Printf.eprintf "[Profiling] resetting ...\n%!"; - let current_root_node = gls.current_root_node in - let floats = current_root_node.floats in - floats.time <- 0.0; - floats.allocated_bytes <- 0; - floats.sys_time <- 0.0; - current_root_node.calls <- 0; - current_root_node.recursive_calls <- 0; - stamp_root current_root_node; - SparseArray.reset current_root_node.children; - gls.nodes.allocated_nodes <- [current_root_node]; - gls.current_node_ref <- current_root_node; - gls.cache_miss_ref <- 0; - clear_cache gls; - gls.nodes.node_id_ref <- 1 +let init_nodes () = { + node_id_ref = 0; + allocated_nodes = []; +} + +let get_incr_node_id_ref st = + let id = st.nodes.node_id_ref in + st.nodes.node_id_ref <- id + 1; + id let init_state () = let rec landmark_root = { @@ -79,12 +63,11 @@ let init_state () = id = 0; name = "ROOT"; location = __FILE__; - key = { key = ""; landmark = landmark_root}; + key = ""; last_parent = dummy_node; last_son = dummy_node; last_self = dummy_node; } - and dummy_node = { landmark = landmark_root; id = 0; @@ -96,51 +79,33 @@ let init_state () = distrib = Stack.dummy Float; timestamp = Int64.zero } - - and dummy_key = { key = ""; landmark = landmark_root} in - let nodes = init_nodes () in - let rootnode = - new_node landmark_root dummy_node false - (get_incr_node_id_ref nodes) (add_allocated_node nodes); - in { + let st = { landmark_root; dummy_node; - dummy_key; - nodes; - profiling_ref = false; - landmarks_of_key = W.create 17; cache_miss_ref = 0; profiling_stack = ( - let dummy = - {root = dummy_node ; current = dummy_node; nodes = [{node = dummy_node; recursive = false}]; cache_miss = 0; nodes_len = 1} + let dummy = { + root = dummy_node; + current = dummy_node; + nodes = [{node = dummy_node; recursive = false}]; + cache_miss = 0; + nodes_len = 1} in - Stack.make Array dummy 7 - ); - - current_root_node = rootnode; - current_node_ref = rootnode; + Stack.make Array dummy 7); child_states = []; graph = {nodes = [||]; label = ""; root = 0 }; registered = false; + (* Temprory *) + current_root_node = dummy_node; + current_node_ref = dummy_node; } - -let copy_landmark_cache dummy_node (w: W.t) = - let w' = W.create 17 in - W.iter ( - fun key -> - W.add w' { - key with - landmark = { - key.landmark with - last_parent = dummy_node; - last_son = dummy_node; - last_self = dummy_node} } - ) w; - w' + in + let root_node = !new_node_ref st landmark_root in + { st with current_root_node = root_node; current_node_ref = root_node } let state = Domain.DLS.new_key @@ -148,138 +113,69 @@ let state = let child_state = init_state () in let child_state = { child_state with - profiling_ref = s.profiling_ref; - landmarks_of_key = copy_landmark_cache child_state.dummy_node s.landmarks_of_key } + profiling_ref = s.profiling_ref } in s.child_states <- child_state :: s.child_states; child_state.profiling_ref <- s.profiling_ref; - reset_aux child_state; + !reset_state_ref child_state; child_state ) init_state - -(* Adapted copies of landmark.ml functions *) -let mismatch_recovering st landmark = - let current_node = st.current_node_ref in - let expected_landmark = current_node.landmark in - if expected_landmark != landmark then begin - let msg = - Printf.sprintf "landmark failure when closing '%s'<%d> (%s), expecting '%s'<%d> (%s)." - landmark.name landmark.id landmark.location - expected_landmark.name landmark.id expected_landmark.location - in - Printf.eprintf "Warning: %s\n%!" msg; - unroll_until current_node - (fun node -> st.current_node_ref <- node) - landmark.last_self; - if landmark != st.current_node_ref.landmark then begin - reset_aux st; - failwith ("unable to recover from "^msg) - end - end - -let get_exiting_node st = - if Stack.size st.current_node_ref.fathers = 0 then - failwith "Stack underflow" - else - Stack.pop st.current_node_ref.fathers - -let exit st = - let landmark = (* get_ds_landmark *) st.current_node_ref.landmark in - let current_node = st.current_node_ref in - let last_self = landmark.last_self in - if last_self.recursive_calls = 0 || profile_recursive () then begin - mismatch_recovering st landmark; - if Stack.size current_node.fathers = 1 then begin - landmark.last_self <- st.dummy_node; - aggregate_stat_for current_node; - end; - st.current_node_ref <- (get_exiting_node st) - end - else if not (profile_recursive ()) then - last_self.recursive_calls <- last_self.recursive_calls - 1 - -let exit_until_root st = - let rec aux () = - if st.current_node_ref != st.current_root_node then begin - exit st; - aux (); - end - in - aux () - -let stop_profiling_aux st = - assert (st.current_node_ref == st.current_root_node); - if st.profiling_ref then ( - exit_until_root st; - assert (st.current_node_ref == st.current_root_node); - aggregate_stat_for st.current_node_ref; - if profile_with_debug () then - Printf.eprintf "[Profiling] Stop profiling.\n%!"; - st.profiling_ref <- false - ) - -let export state label = - if state.profiling_ref then begin - aggregate_stat_for state.current_root_node; - stamp_root state.current_root_node - end; - let all_nodes = List.rev state.nodes.allocated_nodes in - let nodes = array_list_map export_node all_nodes in - {Graph.nodes; label; root = 0} - let get_state () = let st = Domain.DLS.get state in if not st.registered && not (Domain.is_main_domain ()) then ( Domain.at_exit (fun () -> - stop_profiling_aux st; - st.graph <- export st "" + !stop_profiling_ref st; + st.graph <- !export_ref st "" ); st.registered <- true; ); st +let dummy_landmark st = Domain.DLS.new_key (fun () -> lazy st.landmark_root) +(* Only used for search in the weak HashSet, will never be accessed *) + let landmark_root st = st.landmark_root let dummy_node st = st.dummy_node -let dummy_key st = st.dummy_key -let profiling st = st.profiling_ref -let set_profiling st b = st.profiling_ref <- b -let get_landmarks_of_key = - let initialized = Domain.DLS.new_key (fun () -> false) in - fun state -> - let landmarks_of_key = state.landmarks_of_key in - if not (Domain.DLS.get initialized) then ( - Domain.DLS.set initialized true; - let dummy_node = state.dummy_node in - W.iter ( - fun key -> - key.landmark.last_parent <- dummy_node; - key.landmark.last_son <- dummy_node; - key.landmark.last_self <- dummy_node - ) landmarks_of_key - ); - landmarks_of_key +let get_ds_landmark _st (l: landmark) = Lazy.force (Domain.DLS.get l) -let add_landmarks_of_key st key = W.add st.landmarks_of_key key +let landmark_of_landmark_body _st (l: landmark_body): landmark = + Domain.DLS.new_key + ~split_from_parent:( + fun l -> + let { id; name; location; kind; key; _ } = Lazy.force l in + lazy ( + let st = get_state () in { + id; + name; + location; + kind; + key; + last_parent = dummy_node st; + last_self = dummy_node st; + last_son = dummy_node st; + })) + (fun () -> lazy l) -let get_ds_landmark st (l: landmark) = - let { landmark; _ } = - W.find (get_landmarks_of_key st) { st.dummy_key with key = l.key.key } - in - landmark +let clear_cache gls = + !iter_registered_landmarks ( + fun landmark -> + let landmark = get_ds_landmark () landmark in + landmark.last_son <- gls.dummy_node; + landmark.last_parent <- gls.dummy_node; + landmark.last_self <- gls.dummy_node; + ) + +let profiling st = st.profiling_ref +let set_profiling st b = st.profiling_ref <- b let get_node_id_ref st = st.nodes.node_id_ref let set_node_id_ref st n = st.nodes.node_id_ref <- n let get_allocated_nodes st = st.nodes.allocated_nodes let set_allocated_nodes st l = st.nodes.allocated_nodes <- l -let new_node { nodes; dummy_node; _ } landmark = - new_node landmark dummy_node (profile_with_debug ()) - (get_incr_node_id_ref nodes) (add_allocated_node nodes) - - let get_current_root_node st = st.current_root_node let set_current_root_node st (node: node) = st.current_root_node <- node @@ -293,11 +189,6 @@ let set_cache_miss_ref st n = st.cache_miss_ref <- n let incr_cache_miss_ref st = st.cache_miss_ref <- st.cache_miss_ref + 1 let get_profiling_stack st = st.profiling_stack - -let reset = reset_aux - -let clear_cache = clear_cache - let rec merge_child_state_graphs ~merge state = List.iter ( fun st -> @@ -307,4 +198,4 @@ let rec merge_child_state_graphs ~merge state = let export ~merge ?(label = "") state = merge_child_state_graphs ~merge state; - export state label + !export_ref state label diff --git a/src/utils.ml b/src/utils.ml index 0f432db..326141d 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -2,18 +2,6 @@ (* See the attached LICENSE file. *) (* Copyright (C) 2000-2025 LexiFi *) -external clock: unit -> (Int64.t [@unboxed]) = - "caml_highres_clock" "caml_highres_clock_native" [@@noalloc] - -(* Alternative implementation of Gc.allocated_bytes which does not allocate *) -external allocated_bytes: unit -> (Int64.t [@unboxed]) = - "allocated_bytes" "allocated_bytes_native" [@@noalloc] -external allocated_bytes_major: unit -> (Int64.t [@unboxed]) = - "allocated_bytes_major" "allocated_bytes_major_native" [@@noalloc] - -let allocated_bytes () = Int64.to_int (allocated_bytes ()) -let allocated_bytes_major () = Int64.to_int (allocated_bytes_major ()) - module SparseArray = struct type 'a t = { mutable keys : int array; @@ -158,9 +146,9 @@ module Stack = struct let to_floatarray {data; size; _} = Float.Array.sub data 0 size end -type landmark = { +type landmark_body = { id: int; - key: landmark_key; + key: string; kind : Graph.kind; name: string; location: string; @@ -172,7 +160,7 @@ type landmark = { } and node = { - landmark: landmark; + landmark: landmark_body; id: int; @@ -196,21 +184,6 @@ and floats = { mutable sys_timestamp: float; } -and landmark_key = { - key: string; - landmark: landmark; -} - -and counter = landmark - -and sampler = landmark - -module W = Weak.Make(struct - type t = landmark_key - let equal (x : landmark_key) (y : landmark_key) = x.key = y.key - let hash (x : landmark_key) = Hashtbl.hash x.key - end) - let new_floats () = { time = 0.0; allocated_bytes = 0; @@ -221,87 +194,6 @@ let new_floats () = { sys_timestamp = 0.0 } -let new_node landmark - dummy_node profile_with_debug get_incr_node_id_ref add_allocated_node = - if profile_with_debug then - Printf.eprintf "[Profiling] Allocating new node for %s...\n%!" landmark.name; - let id = get_incr_node_id_ref () in - let node = { - landmark; - id; - - fathers = Stack.make Array dummy_node 1; - distrib = Stack.make Float 0.0 0; - children = SparseArray.make dummy_node 7; - - calls = 0; - recursive_calls = 0; - timestamp = Int64.zero; - floats = new_floats (); - } in - add_allocated_node node; - node - -type profile_output = - | Silent - | Temporary of string option - | Channel of out_channel - -type textual_option = {threshold : float} - -type profile_format = - | JSON - | Textual of textual_option - -type profiling_options = { - debug : bool; - allocated_bytes: bool; - sys_time : bool; - recursive : bool; - output : profile_output; - format : profile_format -} - -let default_options = { - debug = false; - allocated_bytes = true; - sys_time = false; - recursive = false; - output = Channel stderr; - format = Textual {threshold = 1.0}; -} - -let profile_with_debug = ref false -let profile_with_allocated_bytes = ref false -let profile_with_sys_time = ref false -let profile_output = ref Silent -let profile_format = ref (Textual {threshold = 1.0}) -let profile_recursive = ref false - -let set_profiling_options {debug; allocated_bytes; sys_time; output; format; recursive} = - profile_with_debug := debug; - profile_with_allocated_bytes := allocated_bytes; - profile_with_sys_time := sys_time; - profile_output := output; - profile_format := format; - profile_recursive := recursive - -let profiling_options () = { - debug = !profile_with_debug; - allocated_bytes = !profile_with_allocated_bytes; - sys_time = !profile_with_sys_time; - recursive = !profile_recursive; - output = !profile_output; - format = !profile_format -} - -let profile_with_debug () = !profile_with_debug -let profile_with_allocated_bytes () = !profile_with_allocated_bytes -let profile_with_sys_time () = !profile_with_sys_time -let profile_output () = !profile_output -let profile_format () = !profile_format -let profile_recursive () = !profile_recursive - type profiling_state = { root : node; nodes: node_info list; @@ -314,52 +206,3 @@ and node_info = { node: node; recursive: bool; } - -let stamp_root current_root_node = - current_root_node.timestamp <- (clock ()); - if profile_with_allocated_bytes () then begin - current_root_node.floats.allocated_bytes <- allocated_bytes (); - current_root_node.floats.allocated_bytes_major <- allocated_bytes_major () - end; - if profile_with_sys_time () then - current_root_node.floats.sys_time <- Sys.time () - -let aggregate_stat_for current_node = - let floats = current_node.floats in - floats.time <- floats.time - +. Int64.(to_float (sub (clock ()) current_node.timestamp)); - if profile_with_allocated_bytes () then begin - floats.allocated_bytes <- - floats.allocated_bytes - + (allocated_bytes () - floats.allocated_bytes_stamp); - floats.allocated_bytes_major <- - floats.allocated_bytes_major - + (allocated_bytes_major () - floats.allocated_bytes_major_stamp) - end; - if profile_with_sys_time () then - floats.sys_time <- floats.sys_time - +. (Sys.time () -. floats.sys_timestamp) - -let array_list_map f l = - let size = List.length l in - match l with - | [] -> [||] - | hd :: tl -> - let res = Array.make size (f hd) in - List.iteri (fun k x -> res.(k+1) <- f x) tl; res - -let export_node {landmark; id; calls; floats; children; distrib; _} = - let {key = { key = landmark_id; _}; name; location; kind; _} = landmark in - let {time; allocated_bytes; allocated_bytes_major; sys_time; _} = floats in - let children = - List.map (fun ({id;_} : node) -> id) (SparseArray.values children) - in - {Graph.landmark_id; id; name; location; calls; time; kind; - allocated_bytes; allocated_bytes_major; sys_time; children; distrib = Stack.to_floatarray distrib} - -let unroll_until current_node set_current_node node = - while - current_node != node - && Stack.size current_node.fathers > 0 - && (set_current_node (Stack.pop current_node.fathers); true) - do () done diff --git a/src/utils.mli b/src/utils.mli index ebc5fb2..afcb8dc 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -2,12 +2,6 @@ (* See the attached LICENSE file. *) (* Copyright (C) 2000-2025 LexiFi *) -external clock: unit -> (Int64.t [@unboxed]) = - "caml_highres_clock" "caml_highres_clock_native" [@@noalloc] - -val allocated_bytes: unit -> int -val allocated_bytes_major: unit -> int - module SparseArray : sig type 'a t = { @@ -56,9 +50,9 @@ sig val to_floatarray : ('a, floatarray) t -> floatarray end -type landmark = { +type landmark_body = { id : int; - key : landmark_key; + key : string; kind : Graph.kind; name : string; location : string; @@ -68,7 +62,7 @@ type landmark = { } and node = { - landmark : landmark; + landmark : landmark_body; id : int; children : node SparseArray.t; fathers : (node, node array) Stack.t; @@ -89,50 +83,8 @@ and floats = { mutable sys_timestamp : float; } -and landmark_key = { key : string; landmark : landmark; } - -and counter = landmark - -and sampler = landmark - -module W: Weak.S with type data = landmark_key - val new_floats : unit -> floats -val new_node: - landmark -> node -> bool -> (unit -> int) -> (node -> unit) -> node - -type profile_output = - | Silent - | Temporary of string option - | Channel of out_channel - -type textual_option = {threshold : float} - -type profile_format = - | JSON - | Textual of textual_option - -type profiling_options = { - debug : bool; - allocated_bytes: bool; - sys_time : bool; - recursive : bool; - output : profile_output; - format : profile_format -} - -val set_profiling_options : profiling_options -> unit -val profiling_options : unit -> profiling_options -val profile_with_debug : unit -> bool -val profile_with_allocated_bytes : unit -> bool -val profile_with_sys_time : unit -> bool -val profile_output : unit -> profile_output -val profile_format : unit -> profile_format -val profile_recursive : unit -> bool - -val default_options: profiling_options - type profiling_state = { root : node; nodes: node_info list; @@ -145,10 +97,3 @@ and node_info = { node: node; recursive: bool; } - -val stamp_root: node -> unit -val aggregate_stat_for: node -> unit -val array_list_map: ('a -> 'b) -> 'a list -> 'b array -val export_node: node -> Graph.node - -val unroll_until: node -> (node -> unit) -> node -> unit From 17be3567a63650090f9cf94654fcc8d99f946e27 Mon Sep 17 00:00:00 2001 From: hra687261 Date: Mon, 12 Jan 2026 14:35:16 +0100 Subject: [PATCH 13/16] upd README --- README.md | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/README.md b/README.md index cc03ff4..0af28ad 100755 --- a/README.md +++ b/README.md @@ -294,6 +294,16 @@ in the landmarks-threads.cm(x)a archive) that prevents non thread-safe functions to execute in all threads but the one which started the profiling. +Instrumenting with domains (on OCaml >= 5) +------------------------------------------ + +*Landmarks* can be used with OCaml domains, but it comes with the following +constraints: + +1) Each domain has to run on its separate physical core, notably for correct + time measures (which can be done using [ocaml-processor](https://github.com/haesbaert/ocaml-processor) or [domainpc](https://github.com/hra687261/domainpc)). +2) Spawned domains have to terminate before the main domain. + Known Issue ----------- From a72376e897918861781d7011506f39142cac72d8 Mon Sep 17 00:00:00 2001 From: hra687261 Date: Wed, 14 Jan 2026 15:03:28 +0100 Subject: [PATCH 14/16] Refactoring to avoid references --- src/landmark.ml | 208 +++++++++++++++++++---------------- src/landmark_state.mli | 21 ++-- src/landmark_state_ocaml4.ml | 56 ++-------- src/landmark_state_ocaml5.ml | 173 ++++++++++++++--------------- 4 files changed, 216 insertions(+), 242 deletions(-) diff --git a/src/landmark.ml b/src/landmark.ml index 07b9cfe..989f5bd 100644 --- a/src/landmark.ml +++ b/src/landmark.ml @@ -53,8 +53,6 @@ let profile_output = ref Silent let profile_format = ref (Textual {threshold = 1.0}) let profile_recursive = ref false -let profiling () = profiling (get_state ()) - (** REGISTERING **) let last_landmark_id = ref 1 @@ -66,20 +64,21 @@ module W = Weak.Make(struct let landmarks_of_key = W.create 17 +let iter_registered_landmarks f = + W.iter (fun {landmark; _} -> f landmark) landmarks_of_key + let dummy_key st = { key = ""; landmark = dummy_landmark st} -let landmark_of_id user_id = - let st = get_state () in +let landmark_of_id st user_id = let dummy_key = dummy_key st in match W.find_opt landmarks_of_key {dummy_key with key = user_id} with | None -> None | Some {landmark; _} -> Some landmark -let new_landmark ~key ~name ~location ~kind () = +let new_landmark st ~key ~name ~location ~kind () = let id = !last_landmark_id in incr last_landmark_id; - let st = get_state () in let dummy_node = dummy_node st in let res = landmark_of_landmark_body st { @@ -116,23 +115,23 @@ let new_node st landmark = set_allocated_nodes st (node :: get_allocated_nodes st); node -let landmark_of_node ({landmark_id = key; name; location; kind; _} : Graph.node) = - match landmark_of_id key with - | None -> new_landmark ~key ~name ~kind ~location () +let landmark_of_node st ({landmark_id = key; name; location; kind; _} : Graph.node) = + match landmark_of_id st key with + | None -> new_landmark st ~key ~name ~kind ~location () | Some landmark -> landmark -let register_generic ~id ~name ~location ~kind () = - let landmark = new_landmark ~key:id ~name ~location ~kind () in +let register_generic st ~id ~name ~location ~kind () = + let landmark = new_landmark st ~key:id ~name ~location ~kind () in if !profile_with_debug then Printf.eprintf "[Profiling] registering(%s)\n%!" name; landmark -let register_generic ~id ~location kind name = - match landmark_of_id id with - | None -> register_generic ~id ~name ~location ~kind () +let register_generic st ~id ~location kind name = + match landmark_of_id st id with + | None -> register_generic st ~id ~name ~location ~kind () | Some lm -> lm -let register_generic ?id ?location kind name = +let register_generic st ?id ?location kind name = let location = match location with | Some name -> name @@ -153,14 +152,7 @@ let register_generic ?id ?location kind name = | Some key -> key | None -> name^"-"^location in - register_generic ~id ~location kind name - -let register ?id ?location name = - register_generic ?id ?location Graph.Normal name - -let register_counter name = register_generic Graph.Counter name - -let register_sampler name = register_generic Graph.Sampler name + register_generic st ~id ~location kind name let stamp_root current_root_node = current_root_node.timestamp <- (clock ()); @@ -171,7 +163,7 @@ let stamp_root current_root_node = if !profile_with_sys_time then current_root_node.floats.sys_time <- Sys.time () -let reset_st st = +let reset_state st = if !profile_with_debug then Printf.eprintf "[Profiling] resetting ...\n%!"; let current_root_node = get_current_root_node st in @@ -186,15 +178,13 @@ let reset_st st = set_allocated_nodes st [current_root_node]; set_current_node_ref st current_root_node; set_cache_miss_ref st 0; - clear_cache st; + clear_cache iter_registered_landmarks st; set_node_id_ref st 1 -let reset () = reset_st (get_state ()) -let push_profiling_state () = +let push_profiling_state st = if !profile_with_debug then Printf.eprintf "[Profiling] Push profiling state ....\n%!"; - let st = get_state () in let profiling_state = let node_info (node: node) = let recursive = node.landmark.last_self == node in @@ -208,19 +198,18 @@ let push_profiling_state () = cache_miss = get_cache_miss_ref st; } in - (* clear_cache st; *) + clear_cache iter_registered_landmarks st; set_current_root_node st (new_node st (landmark_root st)); set_current_node_ref st (get_current_root_node st); set_cache_miss_ref st 0; set_allocated_nodes st [get_current_root_node st]; set_node_id_ref st 1; - (* reset (); *) + reset_state st; Stack.push (get_profiling_stack st) profiling_state -let pop_profiling_state () = - let profiling_stack = get_profiling_stack (get_state ()) in +let pop_profiling_state st = + let profiling_stack = get_profiling_stack st in if profiling_stack.size > 0 then - let st = get_state () in let {root; nodes; nodes_len; current; cache_miss} = Stack.pop profiling_stack in set_current_root_node st root; set_current_node_ref st current; @@ -236,18 +225,16 @@ let unroll_until st node = && (set_current_node_ref st (Stack.pop current_node.fathers); true) do () done -let landmark_failure msg = - let st = get_state () in +let landmark_failure st msg = unroll_until st (get_current_root_node st); if get_current_node_ref st != get_current_root_node st then - reset_st st; + reset_state st; if !profile_with_debug then (Printf.eprintf "Landmark error: %s\n%!" msg; Stdlib.exit 2) else raise (LandmarkFailure msg) -let get_entering_node ({ id; _ } as landmark: landmark_body) = - let st = get_state () in +let get_entering_node st ({ id; _ } as landmark: landmark_body) = let current_node = get_current_node_ref st in (* Read the "cache". *) if current_node == landmark.last_parent && landmark.last_son != dummy_node st then @@ -272,30 +259,28 @@ let get_entering_node ({ id; _ } as landmark: landmark_body) = let get_exiting_node st = let current_node_ref = get_current_node_ref st in if Stack.size current_node_ref.fathers = 0 then - landmark_failure "Stack underflow" + landmark_failure st "Stack underflow" else Stack.pop current_node_ref.fathers -let increment ?(times = 1) counter = - let st = get_state () in +let increment st ?(times = 1) counter = let counter = get_ds_landmark st counter in - let node = get_entering_node counter in + let node = get_entering_node st counter in node.calls <- node.calls + times -let increment ?times counter = - if profiling () then - increment ?times counter +let increment st ?times counter = + if profiling st then + increment st ?times counter -let sample sampler x = - let st = get_state () in +let sample st sampler x = let sampler = get_ds_landmark st sampler in - let node = get_entering_node sampler in + let node = get_entering_node st sampler in node.calls <- node.calls + 1; Stack.push node.distrib x -let sample sampler x = - if profiling () then - sample sampler x +let sample st sampler x = + if profiling st then + sample st sampler x let enter_landmark st landmark = let dummy_node = dummy_node st in @@ -303,7 +288,7 @@ let enter_landmark st landmark = Printf.eprintf "[Profiling] enter%s(%s)\n%!" (if landmark.last_self != dummy_node then " recursive " else "") landmark.name; if landmark.last_self == dummy_node || !profile_recursive then begin - let node = get_entering_node landmark in + let node = get_entering_node st landmark in node.calls <- node.calls + 1; Stack.push node.fathers (get_current_node_ref st); set_current_node_ref st node; @@ -333,7 +318,7 @@ let mismatch_recovering st (landmark: landmark_body) (current_node: node) = unroll_until st landmark.last_self; let current_node = get_current_node_ref st in if landmark != current_node.landmark then begin - reset_st st; + reset_state st; failwith ("unable to recover from "^msg) end end @@ -372,17 +357,16 @@ let exit_landmark st landmark = (* These two functions should be inlined. *) let enter_landmark st landmark = - if profiling () then + if profiling st then enter_landmark st landmark let exit_landmark st landmark = - if profiling () then + if profiling st then exit_landmark st landmark (** HELPERS **) -let wrap node f x = - let st = get_state () in +let wrap st node f x = let node = get_ds_landmark st node in enter_landmark st node; try @@ -390,26 +374,15 @@ let wrap node f x = exit_landmark st node; res with LandmarkFailure _ as e -> raise e - | e -> exit_landmark (get_state ()) node; raise e + | e -> exit_landmark st node; raise e -let unsafe_wrap node f x = - let st = get_state () in +let unsafe_wrap st node f x = let node = get_ds_landmark st node in enter_landmark st node; let res = f x in - exit_landmark (get_state ()) node; + exit_landmark st node; res -let exit landmark = - let st = get_state () in - let landmark = get_ds_landmark st landmark in - exit_landmark st landmark - -let enter landmark = - let st = get_state () in - let landmark = get_ds_landmark st landmark in - enter_landmark st landmark - (** PROFILERS **) type profiling_options = { @@ -447,8 +420,8 @@ let profiling_options () = { format = !profile_format } -let start_profiling ?(profiling_options = default_options) () = - if profiling () then +let start_profiling st ~profiling_options () = + if profiling st then failwith "In profiling: it is not allowed to nest profilings."; set_profiling_options profiling_options; if !profile_with_debug then @@ -458,7 +431,7 @@ let start_profiling ?(profiling_options = default_options) () = | true, false -> "with garbage collection statistics" | false, true -> "with system time" | false, false -> ""); - set_profiling (get_state ()) true + set_profiling st true let rec exit_until_root st = let current_node_ref = get_current_node_ref st in @@ -467,8 +440,9 @@ let rec exit_until_root st = exit_landmark st landmark; exit_until_root st; end + let stop_profiling_st st = - if not (profiling ()) then + if not (profiling st) then failwith "In profiling: cannot stop since profiling is not on-going"; exit_until_root st; let current_node = get_current_node_ref st in @@ -478,8 +452,6 @@ let stop_profiling_st st = Printf.eprintf "[Profiling] Stop profiling.\n%!"; set_profiling st false -let stop_profiling () = stop_profiling_st (get_state ()) - (** EXPORTING / IMPORTING SLAVE PROFILINGS **) let array_list_map f l = @@ -500,7 +472,7 @@ let export_aux st label = {Graph.landmark_id; id; name; location; calls; time; kind; allocated_bytes; allocated_bytes_major; sys_time; children; distrib = Stack.to_floatarray distrib} in - if profiling () then begin + if profiling st then begin let root_node = get_current_root_node st in aggregate_stat_for root_node; stamp_root root_node @@ -509,7 +481,7 @@ let export_aux st label = let nodes = array_list_map export_node all_nodes in {Graph.nodes; label; root = 0} -let rec merge_branch (node:node) graph (imported : Graph.node) = +let rec merge_branch st (node:node) graph (imported : Graph.node) = let floats = node.floats in floats.time <- imported.time +. floats.time; floats.sys_time <- imported.sys_time +. floats.sys_time; @@ -519,20 +491,18 @@ let rec merge_branch (node:node) graph (imported : Graph.node) = Float.Array.iter (Stack.push node.distrib) imported.distrib; let children = Graph.children graph imported in - let st = get_state () in List.iter (fun (imported_son : Graph.node) -> - let landmark = landmark_of_node imported_son in + let landmark = landmark_of_node st imported_son in let landmark = get_ds_landmark st landmark in match SparseArray.get node.children landmark.id with | exception Not_found -> - new_branch node graph imported_son - | son -> merge_branch son graph imported_son + new_branch st node graph imported_son + | son -> merge_branch st son graph imported_son ) children -and new_branch parent graph (imported : Graph.node) = - let st = get_state () in - let landmark = landmark_of_node imported in +and new_branch st parent graph (imported : Graph.node) = + let landmark = landmark_of_node st imported in let landmark = get_ds_landmark st landmark in let node = new_node st landmark in node.calls <- imported.calls; @@ -542,29 +512,77 @@ and new_branch parent graph (imported : Graph.node) = floats.sys_time <- imported.sys_time; Float.Array.iter (Stack.push node.distrib) imported.distrib; SparseArray.set parent.children landmark.id node; - List.iter (new_branch node graph) (Graph.children graph imported) + List.iter (new_branch st node graph) (Graph.children graph imported) + +let merge_aux st node graph = + merge_branch st node graph (Graph.root graph) + +(** API **) + +let get_state = + init ~reset_state ~new_node ~stop_profiling:stop_profiling_st + ~export:export_aux + +let register ?id ?location name = + register_generic ?id ?location (get_state ()) Graph.Normal name + +let landmark_of_id used_id = landmark_of_id (get_state ()) used_id + +let enter landmark = + let st = get_state () in + let landmark = get_ds_landmark st landmark in + enter_landmark st landmark + +let exit landmark = + let st = get_state () in + let landmark = get_ds_landmark st landmark in + exit_landmark st landmark + +let wrap node f x = wrap (get_state ()) node f x + +let unsafe_wrap node f x = unsafe_wrap (get_state ()) node f x + +let register_counter name = register_generic (get_state ()) Graph.Counter name + +let increment ?times counter = increment (get_state ()) ?times counter + +let register_sampler name = register_generic (get_state ()) Graph.Sampler name + +let sample sampler x = sample (get_state ()) sampler x + +let profiling () = profiling (get_state ()) + +let start_profiling ?(profiling_options = default_options) () = + start_profiling (get_state ()) ~profiling_options () + +let stop_profiling () = stop_profiling_st (get_state ()) + +let reset () = reset_state (get_state ()) + +let push_profiling_state () = push_profiling_state (get_state ()) + +let pop_profiling_state () = pop_profiling_state (get_state ()) -let merge_aux node graph = - merge_branch node graph (Graph.root graph) let merge (graph : Graph.graph) = if !profile_with_debug then Printf.eprintf "[Profiling] merging foreign graph\n%!"; - merge_aux (get_current_root_node (get_state ())) graph + let st = get_state () in + merge_aux st (get_current_root_node st) graph let export_and_reset ?(label = "") () = let st = get_state () in let profiling = profiling () in if profiling then stop_profiling_st st; - let res = export ~merge:merge_aux ~label st in - reset_st st; + let res = export ~export:export_aux ~merge:merge_aux ~label st in + reset_state st; if profiling then stop_profiling_st st; res let export ?(label = "") () = - export ~merge:merge_aux ~label (get_state ()) + export ~export:export_aux ~merge:merge_aux ~label (get_state ()) let exit_hook () = if !profile_with_debug then @@ -680,10 +698,6 @@ let parse_env_options s = output = !output; format = !format; recursive = !recursive} let () = - new_node_ref := new_node; - export_ref := export_aux; - reset_state_ref := reset_st; - stop_profiling_ref := stop_profiling_st; reset (); Stdlib.at_exit exit_hook; match Sys.getenv "OCAML_LANDMARKS" with diff --git a/src/landmark_state.mli b/src/landmark_state.mli index d8c0041..2635c93 100644 --- a/src/landmark_state.mli +++ b/src/landmark_state.mli @@ -11,13 +11,13 @@ type landmark val landmark_of_landmark_body: t -> landmark_body -> landmark val get_ds_landmark: t -> landmark -> landmark_body -val new_node_ref: (t -> landmark_body -> node) ref -val export_ref: (t -> string -> Graph.graph) ref -val reset_state_ref: (t -> unit) ref -val stop_profiling_ref: (t -> unit) ref -val iter_registered_landmarks: ((landmark -> unit) -> unit) ref - -val get_state: unit -> t +val init: + reset_state:(t -> unit) -> + new_node:(t -> landmark_body -> node) -> + stop_profiling:(t -> unit) -> + export:(t -> string -> Graph.graph) -> + unit -> + t val dummy_landmark : t -> landmark val landmark_root : t -> landmark_body @@ -45,5 +45,8 @@ val get_profiling_stack : t -> (profiling_state, profiling_state array) Utils.Stack.t -val clear_cache : t -> unit -val export : merge:(node -> Graph.graph -> unit) -> ?label:string -> t -> Graph.graph +val clear_cache : ((landmark -> unit) -> unit) -> t -> unit +val export : + export:(t -> string -> Graph.graph) -> + merge:(t -> node -> Graph.graph -> unit) -> + ?label:string -> t -> Graph.graph diff --git a/src/landmark_state_ocaml4.ml b/src/landmark_state_ocaml4.ml index b896115..9f92ab0 100644 --- a/src/landmark_state_ocaml4.ml +++ b/src/landmark_state_ocaml4.ml @@ -12,18 +12,6 @@ type t = unit let landmark_of_landmark_body () l = l -let new_node_ref: (t -> landmark_body -> node) ref = - ref (fun _ _ -> failwith "uninitialized function \"new_node_ref\"") -let export_ref: (t -> string -> Graph.graph) ref = - ref (fun _ -> failwith "uninitialized function \"export_ref\"") -let reset_state_ref: (t -> unit) ref = - ref (fun _ -> failwith "uninitialized function \"reset_state_ref\"") -let stop_profiling_ref: (t -> unit) ref = - ref (fun _ -> failwith "uninitialized function \"stop_profiling_ref\"") -let iter_registered_landmarks: ((landmark -> unit) -> unit) ref = - ref (fun _ -> ()) -let get_state () = () - let rec landmark_root = { kind = Graph.Root; id = 0; @@ -49,8 +37,8 @@ and dummy_node = { let dummy_landmark () = landmark_root -let clear_cache () = - !iter_registered_landmarks ( +let clear_cache iter_registered_landmarks () = + iter_registered_landmarks ( fun landmark -> landmark.last_son <- dummy_node; landmark.last_parent <- dummy_node; @@ -81,35 +69,15 @@ let get_incr_node_id_ref () = let current_root_node = ref (dummy_node ()) let current_node_ref = ref !current_root_node -let get_current_root_node, get_current_node_ref = - let init = ref false in - let set_nodes () = - current_root_node := !new_node_ref () (landmark_root ()); - current_node_ref := !current_root_node; - init := true - in - let get_current_root_node () = - if not !init then ( - set_nodes (); - !current_root_node) - else !current_root_node - in - let get_current_node_ref () = - if not !init - then ( - current_root_node := !new_node_ref () (landmark_root ()); - current_node_ref := !current_root_node; - !current_node_ref - ) - else !current_node_ref - in - get_current_root_node, get_current_node_ref - -let set_current_root_node () node = - current_root_node := node +let init ~reset_state:_ ~new_node ~stop_profiling:_ ~export:_ = + current_root_node := new_node () (landmark_root ()); + current_node_ref := !current_root_node; + fun () -> () -let set_current_node_ref () node = - current_node_ref := node +let get_current_root_node () = !current_root_node +let get_current_node_ref () = !current_node_ref +let set_current_root_node () node = current_root_node := node +let set_current_node_ref () node = current_node_ref := node let cache_miss_ref = ref 0 let get_cache_miss_ref () = !cache_miss_ref @@ -127,5 +95,5 @@ let profiling_stack = let incr_cache_miss_ref () = incr cache_miss_ref let get_profiling_stack () = profiling_stack -let export ~merge:_ ?(label = "") () = - !export_ref () label +let export ~export ~merge:_ ?(label = "") () = + export () label diff --git a/src/landmark_state_ocaml5.ml b/src/landmark_state_ocaml5.ml index 2061577..0581008 100644 --- a/src/landmark_state_ocaml5.ml +++ b/src/landmark_state_ocaml5.ml @@ -36,17 +36,6 @@ type t = { mutable registered: bool; } -let new_node_ref: (t -> landmark_body -> node) ref = - ref (fun _ _ -> failwith "uninitialized function \"new_node_ref\"") -let export_ref: (t -> string -> Graph.graph) ref = - ref (fun _ -> failwith "uninitialized function \"export_ref\"") -let reset_state_ref: (t -> unit) ref = - ref (fun _ -> failwith "uninitialized function \"reset_state_ref\"") -let stop_profiling_ref: (t -> unit) ref = - ref (fun _ -> failwith "uninitialized function \"stop_profiling_ref\"") -let iter_registered_landmarks: ((landmark -> unit) -> unit) ref = - ref (fun _ -> ()) - let init_nodes () = { node_id_ref = 0; allocated_nodes = []; @@ -57,81 +46,82 @@ let get_incr_node_id_ref st = st.nodes.node_id_ref <- id + 1; id -let init_state () = - let rec landmark_root = { - kind = Graph.Root; - id = 0; - name = "ROOT"; - location = __FILE__; - key = ""; - last_parent = dummy_node; - last_son = dummy_node; - last_self = dummy_node; - } - and dummy_node = { - landmark = landmark_root; - id = 0; - children = SparseArray.dummy (); - fathers = Stack.dummy Array; - floats = new_floats (); - calls = 0; - recursive_calls = 0; - distrib = Stack.dummy Float; - timestamp = Int64.zero - } +let init ~reset_state ~new_node ~stop_profiling ~export = + let init_state () = + let rec landmark_root = { + kind = Graph.Root; + id = 0; + name = "ROOT"; + location = __FILE__; + key = ""; + last_parent = dummy_node; + last_son = dummy_node; + last_self = dummy_node; + } + and dummy_node = { + landmark = landmark_root; + id = 0; + children = SparseArray.dummy (); + fathers = Stack.dummy Array; + floats = new_floats (); + calls = 0; + recursive_calls = 0; + distrib = Stack.dummy Float; + timestamp = Int64.zero + } + in + let nodes = init_nodes () in + let st = { + landmark_root; + dummy_node; + nodes; + profiling_ref = false; + cache_miss_ref = 0; + profiling_stack = ( + let dummy = { + root = dummy_node; + current = dummy_node; + nodes = [{node = dummy_node; recursive = false}]; + cache_miss = 0; + nodes_len = 1} + in + Stack.make Array dummy 7); + child_states = []; + graph = {nodes = [||]; label = ""; root = 0 }; + registered = false; + (* Temprory *) + current_root_node = dummy_node; + current_node_ref = dummy_node; + } + in + let root_node = new_node st landmark_root in + { st with current_root_node = root_node; current_node_ref = root_node } in - let nodes = init_nodes () in - let st = { - landmark_root; - dummy_node; - nodes; - profiling_ref = false; - cache_miss_ref = 0; - profiling_stack = ( - let dummy = { - root = dummy_node; - current = dummy_node; - nodes = [{node = dummy_node; recursive = false}]; - cache_miss = 0; - nodes_len = 1} - in - Stack.make Array dummy 7); - child_states = []; - graph = {nodes = [||]; label = ""; root = 0 }; - registered = false; - (* Temprory *) - current_root_node = dummy_node; - current_node_ref = dummy_node; - } + let state = + Domain.DLS.new_key + ~split_from_parent:(fun s -> + let child_state = init_state () in + let child_state = + { child_state with + profiling_ref = s.profiling_ref } + in + s.child_states <- child_state :: s.child_states; + child_state.profiling_ref <- s.profiling_ref; + reset_state child_state; + child_state + ) + init_state in - let root_node = !new_node_ref st landmark_root in - { st with current_root_node = root_node; current_node_ref = root_node } - -let state = - Domain.DLS.new_key - ~split_from_parent:(fun s -> - let child_state = init_state () in - let child_state = - { child_state with - profiling_ref = s.profiling_ref } - in - s.child_states <- child_state :: s.child_states; - child_state.profiling_ref <- s.profiling_ref; - !reset_state_ref child_state; - child_state - ) - init_state - -let get_state () = - let st = Domain.DLS.get state in - if not st.registered && not (Domain.is_main_domain ()) then ( - Domain.at_exit (fun () -> - !stop_profiling_ref st; - st.graph <- !export_ref st "" - ); - st.registered <- true; - ); - st + fun () -> + let st = Domain.DLS.get state in + if not st.registered && not (Domain.is_main_domain ()) then ( + Domain.at_exit (fun () -> + stop_profiling st; + st.graph <- export st "" + ); + st.registered <- true; + ); + st let dummy_landmark st = Domain.DLS.new_key (fun () -> lazy st.landmark_root) (* Only used for search in the weak HashSet, will never be accessed *) @@ -141,13 +131,12 @@ let dummy_node st = st.dummy_node let get_ds_landmark _st (l: landmark) = Lazy.force (Domain.DLS.get l) -let landmark_of_landmark_body _st (l: landmark_body): landmark = +let landmark_of_landmark_body st (l: landmark_body): landmark = Domain.DLS.new_key ~split_from_parent:( fun l -> let { id; name; location; kind; key; _ } = Lazy.force l in - lazy ( - let st = get_state () in { + lazy ({ id; name; location; @@ -159,8 +148,8 @@ let landmark_of_landmark_body _st (l: landmark_body): landmark = })) (fun () -> lazy l) -let clear_cache gls = - !iter_registered_landmarks ( +let clear_cache iter_registered_landmarks gls: unit = + iter_registered_landmarks ( fun landmark -> let landmark = get_ds_landmark () landmark in landmark.last_son <- gls.dummy_node; @@ -193,9 +182,9 @@ let rec merge_child_state_graphs ~merge state = List.iter ( fun st -> merge_child_state_graphs ~merge st; - merge state.current_root_node st.graph + merge st state.current_root_node st.graph ) state.child_states -let export ~merge ?(label = "") state = +let export ~export ~merge ?(label = "") state = merge_child_state_graphs ~merge state; - !export_ref state label + export state label From 50ec0e5669917faf5c99ba492a0714e62069300c Mon Sep 17 00:00:00 2001 From: hra687261 Date: Wed, 14 Jan 2026 15:08:02 +0100 Subject: [PATCH 15/16] upd README --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 0af28ad..570be3a 100755 --- a/README.md +++ b/README.md @@ -301,7 +301,7 @@ Instrumenting with domains (on OCaml >= 5) constraints: 1) Each domain has to run on its separate physical core, notably for correct - time measures (which can be done using [ocaml-processor](https://github.com/haesbaert/ocaml-processor) or [domainpc](https://github.com/hra687261/domainpc)). + time measures (which can be done using [ocaml-processor](https://github.com/haesbaert/ocaml-processor) or [domainpc](https://github.com/OCamlPro/domainpc)). 2) Spawned domains have to terminate before the main domain. Known Issue From 44a80c1c452510cdb4606da986118c087c6e4232 Mon Sep 17 00:00:00 2001 From: Brandon Stride Date: Fri, 23 Jan 2026 14:14:52 -0500 Subject: [PATCH 16/16] keep constraint on value binding in ppx --- ppx/mapper.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ppx/mapper.ml b/ppx/mapper.ml index bc5fc97..79ddf5b 100644 --- a/ppx/mapper.ml +++ b/ppx/mapper.ml @@ -277,10 +277,10 @@ let translate_value_bindings ctx value_binding auto vbs = in let vbs = List.map (function | (vb, None) -> value_binding vb - | {pvb_pat; pvb_loc; pvb_expr; _}, Some (arity, _, name, loc, attrs) -> + | {pvb_pat; pvb_loc; pvb_expr; pvb_constraint; _}, Some (arity, _, name, loc, attrs) -> (* Remove landmark attribute: *) let vb = - Vb.mk ~attrs ~loc:pvb_loc pvb_pat pvb_expr + Vb.mk ~attrs ~loc:pvb_loc ?value_constraint:pvb_constraint pvb_pat pvb_expr |> value_binding in if arity = [] then