package ecaml
Library for writing Emacs plugin in OCaml
Install
Dune Dependency
Authors
Maintainers
Sources
ecaml-v0.16.0.tar.gz
sha256=d9c6f98e7b0906a7e3d332d1a30fe950b59586b860e4f051348ea854c3ae3434
doc/src/ecaml.nested_profile/profile.ml.html
Source file profile.ml
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516
open! Core open! Async_kernel module Start_location = struct type t = | Line_preceding_profile | End_of_profile_first_line [@@deriving compare, enumerate, sexp_of] let default = End_of_profile_first_line end let start_location = ref Start_location.default let concat = String.concat let approximate_line_length_limit = ref 1_000 let should_profile = ref false let hide_if_less_than = ref (Time_ns.Span.of_int_us 100) let hide_top_level_if_less_than = ref (Time_ns.Span.of_int_ms 10) let never_show_rendering_took = ref false let output_profile = ref print_string let sexp_of_time_ns = ref [%sexp_of: Time_ns.Alternate_sexp.t] let tag_frames_with = ref None module Time_ns = struct include Time_ns let sexp_of_t t = try !sexp_of_time_ns t with | exn -> let backtrace = Backtrace.Exn.most_recent () in [%message "[Profile.sexp_of_time_ns] raised" (exn : exn) (backtrace : Backtrace.t)] ;; end module Clock = struct type t = | Wall | Virtual of { mutable now : Time_ns.t } [@@deriving sexp_of] let create ~now = Virtual { now } let now = function | Wall -> Time_ns.now () | Virtual { now } -> now ;; let advance t ~by = match t with | Wall -> raise_s [%message "[Nested_profile.Clock.advance]"] | Virtual s -> s.now <- Time_ns.add s.now by ;; end let clock = ref Clock.Wall let now () = Clock.now !clock (* We don't support profiling for brief periods when profiler code calls user code, because doing so would be hard and could cause infinite regress, e.g. if that code in turns asks to be profiled. So, we have an internal bool ref, [profiling_is_allowed], that we use to disable profiling when calling user code. *) let profiling_is_allowed = ref true let with_profiling_disallowed f = Ref.set_temporarily profiling_is_allowed false ~f module Elide_in_test = struct type 'a t = 'a let sexp_of_t sexp_of_a a = if am_running_test then [%message "<elided-in-test>"] else sexp_of_a a ;; end module Message : sig type t [@@deriving sexp_of] val create : Sexp.t Lazy.t -> t val am_forcing : unit -> bool val force : t -> Sexp.t end = struct type t = Sexp.t Lazy.t [@@deriving sexp_of] let create t = t let am_forcing_ref = ref false let am_forcing () = !am_forcing_ref let force t = Ref.set_temporarily am_forcing_ref true ~f:(fun () -> force t) end let am_forcing_message = Message.am_forcing module Record = struct type t = { start : Time_ns.t ; stop : Time_ns.t ; message : Message.t ; children : t list ; had_parallel_children : bool ; pending_children : int } let took t = Time_ns.diff t.stop t.start let rec sexp_of_t ({ start = _; stop = _; message; children; had_parallel_children; pending_children } as t) = [%sexp (took t |> Time_ns.Span.to_string_hum : string) , (if had_parallel_children then Some `parallel else None : ([ `parallel ] option[@sexp.option])) , (if pending_children <> 0 then Some (`pending_children pending_children) else None : ([ `pending_children of int ] option[@sexp.option])) , (Message.force message : Sexp.t) , (children : (t list[@sexp.omit_nil]))] ;; let sexp_to_string_on_one_line = let buffer = Buffer.create 0 in let emit string = Buffer.add_string buffer string in let over_the_limit = ref false in let can_emit additional = (not !over_the_limit) && (if Buffer.length buffer + additional > !approximate_line_length_limit then ( over_the_limit := true; emit "..."); not !over_the_limit) in let rec emit_sexp (sexp : Sexp.t) = match sexp with | Atom _ as sexp -> let string = Sexp.to_string sexp in if can_emit (String.length string) then emit string | List sexps -> if can_emit 2 then ( emit "("; (match sexps with | [] -> () | sexp :: sexps -> emit_sexp sexp; List.iter sexps ~f:(fun sexp -> if not !over_the_limit then ( emit " "; emit_sexp sexp))); emit ")") in fun sexp -> Buffer.clear buffer; over_the_limit := false; emit_sexp sexp; Buffer.contents buffer ;; let time_span_as_micros_with_two_digits_of_precision span = let span = span |> Time_ns.Span.to_int_us in let digits = String.length (span |> Int.to_string) in let precision = 2 in let microseconds = if digits <= precision then span else ( let scale = Int.pow 10 (digits - precision) in scale * ((span |> Int.to_float) /. (scale |> Int.to_float) |> Float.iround_nearest_exn)) in concat [ microseconds |> Int.to_string_hum; "us" ] ;; let pad_left string ~total_width = let n = String.length string in if n > total_width then string else concat [ String.make (total_width - n) ' '; string ] ;; let took_width t = String.length (took t |> time_span_as_micros_with_two_digits_of_precision) ;; let rec max_took_width t = Int.max (took_width t) (List.fold t.children ~init:0 ~f:(fun ac child -> Int.max ac (max_took_width child))) ;; let rec insert_gap_frames t = if List.is_empty t.children then t else ( let maybe_add_gap ts ~start ~stop = let gap_took = Time_ns.diff stop start in (* We hide the gap frame if it took less than [!hide_if_less_than], like all other frames. We also hide the gap frame if it took less than 1us, since a gap frame that says 0us would be noise. *) if Time_ns.Span.( < ) gap_took !hide_if_less_than || Time_ns.Span.( < ) gap_took Time_ns.Span.microsecond then ts else { start ; stop ; message = Message.create (lazy [%sexp "gap"]) ; children = [] ; had_parallel_children = false ; pending_children = 0 } :: ts in let last_stop, rev_children = List.fold t.children ~init:(t.start, []) ~f:(fun (last_stop, rev_children) child -> ( child.stop , insert_gap_frames child :: maybe_add_gap rev_children ~start:last_stop ~stop:child.start )) in let rev_children = maybe_add_gap rev_children ~start:last_stop ~stop:t.stop in { t with children = List.rev rev_children }) ;; let to_string_hum t = let rendering_started = now () in let start_location = !start_location in let t = insert_gap_frames t in let took_total_width = max_took_width t in let paren strings = concat [ "("; concat strings; ")" ] in let shift_right = match start_location with | End_of_profile_first_line -> 0 | Line_preceding_profile -> 1 in let start = [%sexp (t.start : Time_ns.t)] |> Sexp.to_string in let rec loop ({ message; children; had_parallel_children; pending_children; _ } as t) ~depth ~parent_took = let took = took t in let percentage = match parent_took with | None -> "" | Some parent_took -> let percentage_int = (if Time_ns.Span.equal parent_took Time_ns.Span.zero then "_" else Time_ns.Span.( // ) took parent_took *. 100. |> Float.iround_nearest_exn |> Int.to_string) |> pad_left ~total_width:3 in concat [ percentage_int; "% " ] in let message = with_profiling_disallowed (fun () -> try Message.force message with | exn -> let backtrace = Backtrace.Exn.most_recent () in [%message "[Profile.profile] message raised" (exn : exn) (backtrace : Backtrace.t)]) in concat [ String.make (shift_right + (3 * depth)) ' ' ; paren [ percentage ; took |> time_span_as_micros_with_two_digits_of_precision |> pad_left ~total_width:took_total_width ; " " ; (if had_parallel_children then "[parallel] " else "") ; (match pending_children with | 0 -> "" | 1 -> "[1 pending child] " | n -> sprintf "[%d pending children] " n) ; message |> sexp_to_string_on_one_line ; (match start_location with | Line_preceding_profile -> "" | End_of_profile_first_line -> if depth = 0 then concat [ " "; start ] else "") ; (if List.is_empty children then "" else concat [ " " ; paren [ "\n" ; concat ~sep:"\n" (List.map children ~f:(loop ~depth:(depth + 1) ~parent_took:(Some took))) ] ]) ] ] in let profile = loop t ~depth:0 ~parent_took:None in let rendering_finished = now () in let rendering_took = Time_ns.diff rendering_finished rendering_started in let rendering_took = if !never_show_rendering_took || Time_ns.Span.( < ) rendering_took !hide_top_level_if_less_than then None else Some (paren [ "rendering_took " ; rendering_took |> time_span_as_micros_with_two_digits_of_precision ]) in match start_location, rendering_took with | End_of_profile_first_line, None -> profile | End_of_profile_first_line, Some r -> paren [ r; "\n "; profile ] | Line_preceding_profile, None -> paren [ start; "\n"; profile ] | Line_preceding_profile, Some r -> paren [ start; "\n "; r; "\n"; profile ] ;; end module Frame = struct type t = { message : Message.t ; start : Time_ns.Alternate_sexp.t Elide_in_test.t ; children : Record.t Queue.t ; parent : t option ; mutable pending_children : int ; mutable max_pending_children : int } [@@deriving sexp_of] let create ~message ~parent = { message = Message.create message ; start = now () ; children = Queue.create () ; parent ; pending_children = 0 ; max_pending_children = 0 } ;; let record t ~stop : Record.t = let { message; start; children; parent = _; pending_children; max_pending_children } = t in { start ; stop ; message ; children = children |> Queue.to_list ; had_parallel_children = max_pending_children > 1 ; pending_children } ;; end module Profile_context = struct let record_profile frame ~stop = let record = Frame.record frame ~stop in match frame.parent with | None -> if Time_ns.Span.( >= ) (Record.took record) !hide_top_level_if_less_than then ( let profile = concat [ record |> Record.to_string_hum; "\n" ] in with_profiling_disallowed (fun () -> try !output_profile profile with | exn -> let backtrace = Backtrace.Exn.most_recent () in eprint_s [%message "[Profile.output_profile] raised" (exn : exn) (backtrace : Backtrace.t)])) | Some parent -> Queue.enqueue parent.children record ;; let backtrace frame = let rec loop (frame : Frame.t) acc = let acc = frame.message :: acc in match frame.parent with | None -> acc | Some parent -> loop parent acc in List.rev (loop frame []) ;; end let maybe_record_frame ?hide_if_less_than:local_hide_if_less_than (frame : Frame.t) ~stop = let took = Time_ns.diff stop frame.start in let hide_if_less_than = Option.value local_hide_if_less_than ~default:!hide_if_less_than in if Time_ns.Span.( >= ) took hide_if_less_than then Profile_context.record_profile frame ~stop ;; let on_async_out_of_order = ref (fun sexp -> !output_profile (Sexp.to_string_hum (force sexp) ^ "\n")) ;; let record_profile ?hide_if_less_than (frame : Frame.t) = if frame.pending_children <> 0 then ( (* Pull this out of the record eagerly so we don't have problems with the lazy expression being evaluated later, where there might be an intervening write to [frame.pending_children]. *) let pending_children = frame.pending_children in !on_async_out_of_order (lazy [%message "Nested [profile Async] exited out-of-order." ~message:(Message.force frame.message : Sexp.t) (pending_children : int)])); maybe_record_frame ?hide_if_less_than frame ~stop:(now ()) ;; module Sync_or_async = struct type _ t = | Sync : _ t | Async : _ Deferred.t t [@@deriving sexp_of] end let profile_context_key = Univ_map.Key.create ~name:"Nested_profile.Profile.Frame" [%sexp_of: Frame.t] ;; let current_profile_context () = Async_kernel_scheduler.find_local profile_context_key let with_profile_context frame ~f = Async_kernel_scheduler.with_local profile_context_key frame ~f ;; let profile (type a) ?hide_if_less_than (sync_or_async : a Sync_or_async.t) (message : Sexp.t Lazy.t) (f : unit -> a) : a = if not (!profiling_is_allowed && !should_profile) then f () else ( let tag = with_profiling_disallowed (fun () -> try Option.bind !tag_frames_with ~f:(fun f -> f ()) with | exn -> let backtrace = Backtrace.Exn.most_recent () in Some [%message "[Profile.tag_frames_with] raised" (exn : exn) (backtrace : Backtrace.t)]) in let message = match tag with | None -> message | Some tag -> lazy (List [ force message; tag ]) in let parent = current_profile_context () in let frame = Frame.create ~message ~parent in let incr_pending_children = match parent with | None -> fun ~by:_ -> () | Some parent -> fun ~by -> parent.pending_children <- parent.pending_children + by; parent.max_pending_children <- Int.max parent.max_pending_children parent.pending_children in incr_pending_children ~by:1; let f () = with_profile_context (Some frame) ~f in match sync_or_async with | Sync -> Exn.protect ~f ~finally:(fun () -> record_profile ?hide_if_less_than frame; incr_pending_children ~by:(-1)) | Async -> Monitor.protect ~run:`Schedule ~rest:`Log f ~finally:(fun () -> record_profile ?hide_if_less_than frame; incr_pending_children ~by:(-1); return ())) ;; let backtrace () = let frame = current_profile_context () in match !should_profile with | false -> None | true -> Some (Option.value_map frame ~f:Profile_context.backtrace ~default:[] |> List.map ~f:Message.force) ;; let disown f = with_profile_context None ~f module Private = struct module Clock = Clock let clock = clock let on_async_out_of_order = on_async_out_of_order let record_frame ~start ~stop ~message = if !profiling_is_allowed && !should_profile then maybe_record_frame { message = Message.create message ; start ; children = Queue.create () ; parent = current_profile_context () ; pending_children = 0 ; max_pending_children = 0 } ~stop ;; end
sectionYPositions = computeSectionYPositions($el), 10)"
x-init="setTimeout(() => sectionYPositions = computeSectionYPositions($el), 10)"
>