├── .gitignore ├── LICENSE ├── Makefile ├── Readme.md ├── bin ├── dune ├── prof_spacetime.ml └── prof_spacetime.mli ├── dune-project ├── prof_spacetime.opam └── src ├── address.ml ├── address.mli ├── chart.ml ├── chart.mli ├── diff.ml ├── diff.mli ├── dune ├── embed.ml ├── embed.mli ├── print.ml ├── print.mli ├── section.ml ├── section.mli ├── series.ml ├── series.mli ├── serve.ml ├── serve.mli ├── snapshot.ml ├── snapshot.mli ├── table.ml ├── table.mli ├── viewer.ml └── viewer.mli /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | *.install 3 | *.merlin -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Leo White 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | JBUILDER ?= jbuilder 2 | 3 | all: 4 | @$(JBUILDER) build 5 | 6 | clean: 7 | @$(JBUILDER) clean 8 | 9 | .PHONY: all clean 10 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | # Prof_spacetime 2 | 3 | `prof_spacetime` is a viewer for OCaml "spacetime" profiles. 4 | 5 | ## Installation 6 | 7 | The easiest way to install is using OPAM: 8 | 9 | opam install prof_spacetime 10 | 11 | For installing from source see the dependencies and build instructions 12 | in the `opam` file. 13 | 14 | ## Creating a spacetime profile 15 | 16 | To create a spacetime profile from a run of an executable you must build 17 | that executable with a spacetime-enabled OCaml compiler: 18 | 19 | opam switch 4.04.0+spacetime 20 | eval `opam config env` 21 | make foo.exe 22 | 23 | Then run your executable with the `OCAML_SPACETIME_INTERVAL` environment 24 | variable set to an interval in milliseconds between snapshots: 25 | 26 | OCAML_SPACETIME_INTERVAL=100 foo.exe test-data 27 | 28 | this will produce a file with a name like `spacetime-1234` where `1234` 29 | was the pid of the process. 30 | 31 | ## Viewing profiles in the browser 32 | 33 | To view a spacetime profile in the browser use the `serve` command: 34 | 35 | prof_spacetime serve spacetime-1234 36 | 37 | By default, this will serve the profile on `127.0.0.1:8080`. The address 38 | and port can be changed with the `--address` and `--port` options. 39 | 40 | ## Viewing profiles in the terminal 41 | 42 | To view a spacetime profile in the terminal use the `view` command: 43 | 44 | prof_spacetime view spacetime-1234 45 | 46 | ## Preprocessing spacetime profiles 47 | 48 | Processing a spacetime profile can take a while. To avoid redoing this 49 | work each time you want to serve the profile you can use the `process` 50 | command: 51 | 52 | prof_spacetime process spacetime-1234 53 | 54 | which will create a preprocessed version of the profile 55 | `spacetime-1234.p`. This can then be passed to the `serve` or `view` 56 | commands using the `-p` flag: 57 | 58 | prof_spacetime serve -p spacetime-1234.p 59 | 60 | ## Locations for C function calls 61 | 62 | To get locations for C function calls, you should also use the `-e` 63 | option to pass `prof_spacetime` the executable from which the profile was 64 | generated. This works with all commands: 65 | 66 | prof_spacetime serve -e foo.exe spacetime-1234 67 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name prof_spacetime) 3 | (public_name prof_spacetime) 4 | (libraries prof_spacetime_lib cmdliner)) 5 | -------------------------------------------------------------------------------- /bin/prof_spacetime.ml: -------------------------------------------------------------------------------- 1 | open Prof_spacetime_lib 2 | 3 | type command = 4 | | Serve of { address: string; port: int; processed: bool; } 5 | | View of { processed: bool; } 6 | | Print of 7 | { processed: bool; 8 | mode: Print.Mode.t; 9 | inverted: bool; 10 | print_filename: bool; 11 | print_symbol: bool; 12 | print_line_number: bool; } 13 | | Process 14 | | Diff of 15 | { processed: bool 16 | ; reference: string; 17 | } 18 | 19 | let unmarshal_profile file : Spacetime_lib.Series.t = 20 | let ic = open_in_bin file in 21 | match Marshal.from_channel ic with 22 | | data -> close_in ic; data 23 | | exception exn -> close_in ic; raise exn 24 | 25 | let marshal_profile (profile : Spacetime_lib.Series.t) file = 26 | let oc = open_out_bin file in 27 | match Marshal.to_channel oc profile [] with 28 | | data -> close_out oc; data 29 | | exception exn -> close_out oc; raise exn 30 | 31 | let load_series processed executable profile = 32 | if processed then unmarshal_profile profile 33 | else begin 34 | Printf.printf "Processing series...%!"; 35 | let series = Spacetime_lib.Series.create ?executable profile in 36 | Printf.printf "done\n%!"; 37 | series 38 | end 39 | 40 | let main command profile executable = 41 | let processed = 42 | match command with 43 | | Serve { processed; _ } 44 | | View { processed; _ } 45 | | Print { processed; _ } -> processed 46 | | Process -> false 47 | | Diff { processed; _ } -> processed 48 | in 49 | let data = load_series processed executable profile in 50 | match command with 51 | | Serve { address; port; _ } -> 52 | let title = 53 | match executable with 54 | | None -> "Anonymous" 55 | | Some executable -> Filename.basename executable 56 | in 57 | let series = Series.create data in 58 | Serve.serve ~address ~port ~title series 59 | | View _ -> 60 | let series = Series.create data in 61 | Viewer.show series 62 | | Print { mode; inverted; print_filename; 63 | print_symbol; print_line_number; _ } -> 64 | Print.print data 65 | ~mode ~inverted ~print_filename ~print_symbol ~print_line_number 66 | | Process -> 67 | marshal_profile data (profile ^ ".p") 68 | | Diff { reference; _ } -> 69 | let ref_data = load_series processed executable reference in 70 | let series = Series.create data in 71 | Diff.diff (Series.create ref_data) series 72 | 73 | open Cmdliner 74 | 75 | (* Common options *) 76 | 77 | let profile = 78 | let doc = "$(docv) to view" in 79 | Arg.(required & pos 0 (some string) None & info [] ~docv:"PROFILE" ~doc) 80 | 81 | let reference = 82 | let doc = "$(docv) reference" in 83 | Arg.(required & pos 1 (some string) None & info [] ~docv:"REFERNCE" ~doc) 84 | 85 | let executable = 86 | let doc = "Specify the ELF executable that was profiled" in 87 | Arg.(value & opt (some string) None 88 | & info ["e";"executable"] ~docv:"PATH" ~doc) 89 | 90 | let processed = 91 | let doc = "Use an already processed allocation profile" in 92 | Arg.(value & flag & info ["p";"processed"] ~doc) 93 | 94 | (* Serve options *) 95 | 96 | let default_address = "127.0.0.1" 97 | 98 | let serve_address = 99 | let doc = "Use $(docv) as address" in 100 | Arg.(value & opt string default_address 101 | & info ["address"] ~docv:"ADDRESS" ~doc) 102 | 103 | let default_port = 8080 104 | 105 | let serve_port = 106 | let doc = "Use $(docv) as port" in 107 | Arg.(value & opt int default_port & info ["port"] ~docv:"PORT" ~doc) 108 | 109 | let serve_arg = 110 | Term.(pure 111 | (fun address port processed -> 112 | Serve { address; port; processed }) 113 | $ serve_address $ serve_port $ processed) 114 | 115 | let serve_t = 116 | let doc = "Serve allocation profile over HTTP" in 117 | Term.(pure main $ serve_arg $ profile $ executable, info "serve" ~doc) 118 | 119 | (* Print options *) 120 | 121 | let print_filename = 122 | let doc = "print out filename" in 123 | Arg.(value & flag & info ["filename"] ~doc) 124 | 125 | let print_symbol = 126 | let doc = "print out symbol" in 127 | Arg.(value & flag & info ["symbol"] ~doc) 128 | 129 | let print_line_number = 130 | let doc = "print out line_number" in 131 | Arg.(value & flag & info ["line-number"] ~doc) 132 | 133 | type print_mode = 134 | | Words 135 | | Blocks 136 | | Allocations 137 | | Calls 138 | | Indirect_calls 139 | 140 | let print_raw_mode = 141 | let mode = 142 | Arg.enum 143 | [ "words", Words; 144 | "blocks", Blocks; 145 | "allocations", Allocations; 146 | "calls", Calls; 147 | "indirect-calls", Indirect_calls; ] 148 | in 149 | let doc = 150 | "Numbers to output. $(docv) should be one of \ 151 | words, blocks, allocations, calls or indirect-calls" 152 | in 153 | Arg.(value & opt mode Words & info ["mode"] ~docv:"MODE" ~doc) 154 | 155 | let print_raw_index = 156 | let doc = "$(docv) which snapshot to print" in 157 | Arg.(value & pos 1 (some int) None & info [] ~docv:"SNAPSHOT-INDEX" ~doc) 158 | 159 | let print_mode = 160 | let requires mode = 161 | `Error(true, "Mode \"" ^ mode ^ "\" requires a snapshot index") 162 | in 163 | let not_requires mode = 164 | `Error(true, "Mode \"" ^ mode ^ "\" does not require a snapshot index") 165 | in 166 | let convert mode index = 167 | match mode with 168 | | Words -> begin 169 | match index with 170 | | None -> requires "words" 171 | | Some index -> `Ok (Print.Mode.Words { index }) 172 | end 173 | | Blocks -> begin 174 | match index with 175 | | None -> requires "blocks" 176 | | Some index -> `Ok (Print.Mode.Blocks { index }) 177 | end 178 | | Allocations -> begin 179 | match index with 180 | | None -> requires "allocations" 181 | | Some index -> `Ok (Print.Mode.Allocations { index }) 182 | end 183 | | Calls -> begin 184 | match index with 185 | | None -> `Ok Print.Mode.Calls 186 | | Some _ -> not_requires "calls" 187 | end 188 | | Indirect_calls -> begin 189 | match index with 190 | | None -> `Ok Print.Mode.Indirect_calls 191 | | Some _ -> not_requires "indirect-calls" 192 | end 193 | in 194 | Term.(ret (pure convert $ print_raw_mode $ print_raw_index)) 195 | 196 | let inverted = 197 | let doc = "Aggregate traces by their outer-most frame" in 198 | Arg.(value & flag & info ["i";"inverted"] ~doc) 199 | 200 | let print_arg = 201 | Term.(pure 202 | (fun processed mode inverted 203 | print_filename print_symbol print_line_number -> 204 | Print 205 | { processed ; mode ; inverted 206 | ; print_filename ; print_symbol ; print_line_number }) 207 | $ processed $ print_mode $ inverted 208 | $ print_filename $ print_symbol $ print_line_number) 209 | 210 | let print_t = 211 | let doc = "Print data to stdout" in 212 | Term.(pure main $ print_arg $ profile $ executable, info "print" ~doc) 213 | ;; 214 | 215 | let compare_arg = 216 | Term.(pure 217 | (fun processed reference -> Diff { reference; processed }) 218 | $ processed 219 | $ reference) 220 | 221 | let compare_t = 222 | let doc = "Compare two processed profiles" in 223 | Term.(pure main $ compare_arg $ profile $ executable, info "compare" ~doc) 224 | ;; 225 | 226 | (* View options *) 227 | 228 | let view_arg = 229 | Term.(pure 230 | (fun processed -> View { processed; }) 231 | $ processed) 232 | 233 | let view_t = 234 | let doc = "View allocation profile in terminal" in 235 | Term.(pure main $ view_arg $ profile $ executable, info "view" ~doc) 236 | 237 | (* Process options *) 238 | 239 | let process_arg = Term.pure Process 240 | 241 | let process_t = 242 | let doc = "Process allocation profile" in 243 | Term.(pure main $ process_arg $ profile $ executable, info "process" ~doc) 244 | 245 | (* Handle default case *) 246 | 247 | let default = 248 | Term.(pure (`Error(true, "command expected."))) 249 | 250 | let default_t = 251 | let doc = "OCaml spacetime profile viewer" in 252 | Term.(ret default, info "prof-spacetime" ~doc) 253 | 254 | let () = 255 | match Term.eval_choice default_t 256 | [serve_t; view_t; process_t; print_t; compare_t] 257 | with 258 | | `Error _ -> exit 1 259 | | `Ok () -> exit 0 260 | | `Help -> exit 0 261 | | `Version -> exit 0 262 | -------------------------------------------------------------------------------- /bin/prof_spacetime.mli: -------------------------------------------------------------------------------- 1 | (* Intentionally blank *) 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name prof_spacetime) 3 | -------------------------------------------------------------------------------- /prof_spacetime.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "prof_spacetime" 3 | version: "0.3.0+dev" 4 | synopsis: "A viewer for OCaml spacetime profiles" 5 | maintainer: "Leo White " 6 | authors: "Leo White " 7 | license: "MIT" 8 | homepage: "https://github.com/lpw25/prof_spacetime" 9 | bug-reports: "https://github.com/lpw25/prof_spacetime/issues" 10 | depends: [ 11 | "ocaml" 12 | "dune" {build & >= "1.0"} 13 | "cmdliner" 14 | "cohttp" {>= "1.0.0" & < "3.0.0"} 15 | "cohttp-lwt-unix" {< "3.0.0"} 16 | "conduit" 17 | "conduit-lwt-unix" 18 | "yojson" 19 | "lwt" 20 | "lambda-term" 21 | "spacetime_lib" {>= "0.2"} 22 | "stdlib-shims" 23 | ] 24 | build: [ 25 | ["dune" "subst"] {pinned} 26 | ["dune" "build" "-p" name "-j" jobs] 27 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 28 | ] 29 | dev-repo: "git://github.com/lpw25/prof_spacetime" 30 | description: """ 31 | `prof_spacetime` is a viewer for OCaml spacetime profiles. It provides 32 | both terminal and broswer based modes for viewing profiles.""" 33 | -------------------------------------------------------------------------------- /src/address.ml: -------------------------------------------------------------------------------- 1 | 2 | type t = Int64.t 3 | 4 | let of_int64 t = t 5 | 6 | let to_string = Int64.to_string 7 | 8 | let equal = Int64.equal 9 | 10 | let compare = Int64.compare 11 | 12 | let equal_list l1 l2 = 13 | let rec loop l1 l2 = 14 | match l1, l2 with 15 | | [], [] -> true 16 | | t1 :: rest1, t2 :: rest2 -> 17 | equal t1 t2 && loop rest1 rest2 18 | | _ :: _, [] -> false 19 | | [], _ :: _ -> false 20 | in 21 | loop l1 l2 22 | 23 | module Ord = struct 24 | 25 | type t = Int64.t 26 | 27 | let compare = Int64.compare 28 | 29 | end 30 | 31 | module Set = Set.Make(Ord) 32 | 33 | module Map = Map.Make(Ord) 34 | 35 | let pp ppf t = 36 | Format.fprintf ppf "%Li" t 37 | -------------------------------------------------------------------------------- /src/address.mli: -------------------------------------------------------------------------------- 1 | 2 | type t 3 | 4 | val of_int64 : Int64.t -> t 5 | 6 | val to_string : t -> string 7 | 8 | val equal : t -> t -> bool 9 | 10 | val compare : t -> t -> int 11 | 12 | val equal_list : t list -> t list -> bool 13 | 14 | module Set : Set.S with type elt = t 15 | 16 | module Map : Map.S with type key = t 17 | 18 | val pp : Format.formatter -> t -> unit 19 | -------------------------------------------------------------------------------- /src/chart.ml: -------------------------------------------------------------------------------- 1 | 2 | module Mode = struct 3 | 4 | type t = 5 | | Bytes 6 | | Blocks 7 | | Allocations 8 | 9 | let pp ppf = function 10 | | Bytes -> Format.fprintf ppf "Bytes" 11 | | Blocks -> Format.fprintf ppf "Blocks" 12 | | Allocations -> Format.fprintf ppf "Allocations" 13 | 14 | let proj = function 15 | | Bytes -> Section.Allocation.bytes 16 | | Blocks -> Section.Allocation.blocks 17 | | Allocations -> Section.Allocation.allocations 18 | 19 | let equal t1 t2 = 20 | match t1, t2 with 21 | | Bytes, Bytes -> true 22 | | Blocks, Blocks -> true 23 | | Allocations, Allocations -> true 24 | | Bytes, (Blocks | Allocations) -> false 25 | | Blocks, (Bytes | Allocations) -> false 26 | | Allocations, (Bytes | Blocks) -> false 27 | 28 | let all = [Bytes; Blocks; Allocations] 29 | 30 | end 31 | 32 | module Kind = struct 33 | 34 | type t = 35 | | All 36 | | Reduced 37 | 38 | let pp ppf = function 39 | | All -> Format.fprintf ppf "All" 40 | | Reduced -> Format.fprintf ppf "Reduced" 41 | 42 | let equal t1 t2 = 43 | match t1, t2 with 44 | | All, All -> true 45 | | Reduced, Reduced -> true 46 | | All, Reduced -> false 47 | | Reduced, All -> false 48 | 49 | end 50 | 51 | module Direction = struct 52 | 53 | type t = 54 | | Normal 55 | | Inverted 56 | 57 | let pp ppf = function 58 | | Normal -> Format.fprintf ppf "Normal" 59 | | Inverted -> Format.fprintf ppf "Inverted" 60 | 61 | let inverted = function 62 | | Normal -> false 63 | | Inverted -> true 64 | 65 | let equal t1 t2 = 66 | match t1, t2 with 67 | | Normal, Normal -> true 68 | | Inverted, Inverted -> true 69 | | Normal, Inverted -> false 70 | | Inverted, Normal -> false 71 | 72 | end 73 | 74 | module Path = struct 75 | 76 | type t = 77 | { mode : Mode.t; 78 | kind : Kind.t; 79 | direction : Direction.t; 80 | addresses: Address.t list; } 81 | 82 | let create mode kind direction addresses = 83 | { mode; kind; direction; addresses } 84 | 85 | let mode { mode; _ } = mode 86 | 87 | let kind { kind; _ } = kind 88 | 89 | let direction { direction; _ } = direction 90 | 91 | let addresses { addresses; _ } = addresses 92 | 93 | let with_mode t mode = { t with mode } 94 | 95 | let with_kind t kind = { t with kind } 96 | 97 | let with_direction t direction = { t with direction } 98 | 99 | let pp ppf t = 100 | let pp_addresses ppf addresses = 101 | let pp_sep ppf () = 102 | Format.fprintf ppf ";@ " 103 | in 104 | Format.fprintf ppf "[@[<2>%a@]]" 105 | (Format.pp_print_list ~pp_sep Address.pp) addresses 106 | in 107 | Format.fprintf ppf 108 | "@[<2>{@ mode = %a;@ \ 109 | kind = %a;@ \ 110 | direction = %a;@ \ 111 | addresses = %a;@ }@]" 112 | Mode.pp t.mode 113 | Kind.pp t.kind 114 | Direction.pp t.direction 115 | pp_addresses t.addresses 116 | 117 | let equal t1 t2 = 118 | Mode.equal t1.mode t2.mode 119 | && Kind.equal t1.kind t2.kind 120 | && Direction.equal t1.direction t2.direction 121 | && Address.equal_list t1.addresses t2.addresses 122 | 123 | let hash = Hashtbl.hash 124 | 125 | module Hash = struct 126 | 127 | type nonrec t = t 128 | 129 | let equal = equal 130 | let hash = hash 131 | 132 | end 133 | 134 | module Tbl = Hashtbl.Make(Hash) 135 | 136 | end 137 | 138 | module Layer = struct 139 | 140 | module Point = struct 141 | 142 | type t = 143 | { time : float; 144 | value : int; } 145 | 146 | let create ~time ~value = 147 | { time; value } 148 | 149 | let time { time; _ } = time 150 | 151 | let value { value; _ } = value 152 | 153 | let add t ts = 154 | let rec loop t = function 155 | | [] -> [t] 156 | | s :: rest -> 157 | if Stdlib.compare t.time s.time = 0 then 158 | { time = s.time; value = t.value + s.value; } :: rest 159 | else 160 | s :: loop t rest 161 | in 162 | loop t ts 163 | 164 | end 165 | 166 | type t = 167 | { points: Point.t list; 168 | display : string; 169 | foreign : bool; 170 | selection : Path.t option; } 171 | 172 | let create ~points ~display ~foreign ~selection = 173 | { points; display; foreign; selection } 174 | 175 | let points { points; _ } = points 176 | 177 | let display { display; _ } = display 178 | 179 | let foreign { foreign; _ } = foreign 180 | 181 | let selection { selection; _ } = selection 182 | 183 | let unknown path snapshots = 184 | match Path.addresses path, Path.mode path with 185 | | [], Mode.Bytes -> 186 | let points = 187 | List.map 188 | (fun snapshot -> 189 | let time = Snapshot.time snapshot in 190 | let value = 191 | match Snapshot.stats snapshot with 192 | | None -> 0 193 | | Some stats -> 194 | let scanned = Spacetime_lib.Stats.words_scanned stats in 195 | let scanned_profinfo = 196 | Spacetime_lib.Stats.words_scanned_with_profinfo stats 197 | in 198 | let unknown_words = scanned - scanned_profinfo in 199 | let unknown_bytes = 200 | unknown_words * Section.Allocation.word_size 201 | in 202 | unknown_bytes 203 | in 204 | Point.create ~time ~value) 205 | snapshots 206 | in 207 | let display = "Unknown" in 208 | let foreign = false in 209 | let selection = None in 210 | Some { points; display; foreign; selection } 211 | | _, _ -> None 212 | 213 | let reduction_target = 50 214 | 215 | let reduce path layers = 216 | let other_points = ref [] in 217 | let layer_array = Array.make reduction_target None in 218 | let max_array = Array.make reduction_target 0 in 219 | List.iter 220 | (fun layer -> 221 | let max = 222 | List.fold_left 223 | (fun acc point -> 224 | let value = Point.value point in 225 | if value > acc then value 226 | else acc) 227 | 0 layer.points 228 | in 229 | let other = 230 | if max > max_array.(0) then begin 231 | let other = layer_array.(0) in 232 | try 233 | for i = 1 to reduction_target - 1 do 234 | if max > max_array.(i) then begin 235 | max_array.(i-1) <- max_array.(i); 236 | layer_array.(i-1) <- layer_array.(i) 237 | end else begin 238 | max_array.(i-1) <- max; 239 | layer_array.(i-1) <- Some layer; 240 | raise Exit 241 | end 242 | done; 243 | max_array.(reduction_target - 1) <- max; 244 | layer_array.(reduction_target - 1) <- Some layer; 245 | other 246 | with Exit -> other 247 | end else begin 248 | Some layer 249 | end 250 | in 251 | match other with 252 | | None -> () 253 | | Some other -> 254 | List.iter 255 | (fun point -> other_points := Point.add point !other_points) 256 | other.points) 257 | layers; 258 | let layers = 259 | Array.fold_left 260 | (fun acc layer -> 261 | match layer with 262 | | None -> acc 263 | | Some layer -> layer :: acc) 264 | [] layer_array 265 | in 266 | let layers = 267 | match !other_points with 268 | | [] -> layers 269 | | points -> 270 | let others = 271 | let display = "Other" in 272 | let foreign = false in 273 | let path = Path.with_kind path All in 274 | let selection = Some path in 275 | { points; display; foreign; selection } 276 | in 277 | others :: layers 278 | in 279 | layers 280 | 281 | end 282 | 283 | module Frame = struct 284 | 285 | type t = 286 | { path : Path.t; 287 | selected : Address.t option; 288 | display : string option; } 289 | 290 | let path { path; _ } = path 291 | 292 | let selected { selected; _ } = selected 293 | 294 | let display { display; _ } = display 295 | 296 | let initial mode kind direction rest = 297 | let path = Path.create mode kind direction [] in 298 | let selected = 299 | match rest with 300 | | [] -> None 301 | | address :: _ -> Some address 302 | in 303 | let display = None in 304 | { path; selected; display } 305 | 306 | let of_items path items rest = 307 | let selected = 308 | match rest with 309 | | [] -> None 310 | | address :: _ -> Some address 311 | in 312 | let rec loop items = 313 | match items with 314 | | [] -> begin 315 | match Path.addresses path with 316 | | [] -> None 317 | | addr :: _ -> Some (Address.to_string addr) 318 | end 319 | | (_, None) :: rest -> loop rest 320 | | (_, Some item) :: _ -> Some (Section.Item.display item) 321 | in 322 | let display = loop items in 323 | { path; selected; display } 324 | 325 | end 326 | 327 | type t = 328 | { path : Path.t; 329 | layers : Layer.t list; 330 | frames : Frame.t list; 331 | max_value : int; 332 | max_time : float; } 333 | 334 | let path { path; _ } = path 335 | 336 | let layers { layers; _ } = layers 337 | 338 | let frames { frames; _ } = frames 339 | 340 | let max_value { max_value; _ } = max_value 341 | 342 | let max_time { max_time; _ } = max_time 343 | 344 | let chart ~series ~path = 345 | let snapshots = Series.snapshots series in 346 | let mode = Path.mode path in 347 | let direction = Path.direction path in 348 | let kind = Path.kind path in 349 | let rec loop frames sections addresses = function 350 | | [] -> frames, sections 351 | | addr :: rest -> begin 352 | let items = 353 | List.map 354 | (fun (time, section) -> 355 | match Section.project section addr with 356 | | None -> time, None 357 | | Some item -> time, Some item) 358 | sections 359 | in 360 | let addresses = addr :: addresses in 361 | let path = Path.create mode kind direction addresses in 362 | let frame = Frame.of_items path items rest in 363 | let frames = frame :: frames in 364 | let sections = 365 | List.map 366 | (fun (time, item) -> 367 | match item with 368 | | None -> time, Section.empty 369 | | Some item -> time, Section.Item.select item) 370 | items 371 | in 372 | loop frames sections addresses rest 373 | end 374 | in 375 | let inverted = Direction.inverted direction in 376 | let initial_sections = 377 | List.map 378 | (fun snapshot -> 379 | let time = Snapshot.time snapshot in 380 | let section = Snapshot.allocation_entries ~inverted snapshot in 381 | time, section) 382 | snapshots 383 | in 384 | let raddresses = List.rev (Path.addresses path) in 385 | let initial_frame = Frame.initial mode kind direction raddresses in 386 | let frames, sections = 387 | loop [initial_frame] initial_sections [] raddresses 388 | in 389 | let proj = Mode.proj mode in 390 | let addresses, max_value, max_time = 391 | List.fold_left 392 | (fun (addresses, max_value, max_time) (time, section) -> 393 | let max_time = if time > max_time then time else max_time in 394 | let addresses, total = 395 | Section.fold 396 | (fun addr item (addresses, total) -> 397 | let addresses = Address.Set.add addr addresses in 398 | let value = proj (Section.Item.value item) in 399 | let total = total + value in 400 | (addresses, total)) 401 | section (addresses, 0) 402 | in 403 | let max_value = if total > max_value then total else max_value in 404 | (addresses, max_value, max_time)) 405 | (Address.Set.empty, 0, 0.0) sections 406 | in 407 | let layers = 408 | Address.Set.fold 409 | (fun addr acc -> 410 | let init = 411 | let points = [] in 412 | let display = Address.to_string addr in 413 | let foreign = false in 414 | let selection = None in 415 | Layer.create ~points ~display ~foreign ~selection 416 | in 417 | let layer = 418 | List.fold_right 419 | (fun (time, section) layer -> 420 | let points = Layer.points layer in 421 | let display = Layer.display layer in 422 | let foreign = Layer.foreign layer in 423 | let selection = Layer.selection layer in 424 | match Section.project section addr with 425 | | None -> 426 | let value = 0 in 427 | let point = Layer.Point.create ~time ~value in 428 | let points = point :: points in 429 | Layer.create ~points ~display ~foreign ~selection 430 | | Some item -> 431 | let value = proj (Section.Item.value item) in 432 | let point = Layer.Point.create ~time ~value in 433 | let points = point :: points in 434 | let display = Section.Item.display item in 435 | let foreign = Section.Item.foreign item in 436 | let selection = 437 | if Section.Item.empty item then selection 438 | else begin 439 | let addresses = Section.Item.path item in 440 | Some (Path.create mode kind direction addresses) 441 | end 442 | in 443 | Layer.create ~points ~display ~foreign ~selection) 444 | sections init 445 | in 446 | layer :: acc) 447 | addresses [] 448 | in 449 | let layers = 450 | match kind with 451 | | Kind.All -> layers 452 | | Kind.Reduced -> Layer.reduce path layers 453 | in 454 | let layers = 455 | match Layer.unknown path snapshots with 456 | | None -> layers 457 | | Some unknown -> unknown :: layers 458 | in 459 | { path; layers; frames; max_value; max_time; } 460 | 461 | module Memo = struct 462 | 463 | type chart = t 464 | 465 | type t = 466 | { series : Series.t; 467 | cache : chart Path.Tbl.t; } 468 | 469 | let create ~series = 470 | let cache = Path.Tbl.create 5 in 471 | { series; cache } 472 | 473 | let chart t ~path = 474 | match Path.Tbl.find t.cache path with 475 | | chart -> chart 476 | | exception Not_found -> 477 | let series = t.series in 478 | let chart = chart ~series ~path in 479 | Path.Tbl.add t.cache path chart; 480 | chart 481 | 482 | end 483 | -------------------------------------------------------------------------------- /src/chart.mli: -------------------------------------------------------------------------------- 1 | module Mode : sig 2 | 3 | type t = 4 | | Bytes 5 | | Blocks 6 | | Allocations 7 | 8 | val equal : t -> t -> bool 9 | 10 | val all : t list 11 | 12 | val pp : Format.formatter -> t -> unit 13 | 14 | end 15 | 16 | module Kind : sig 17 | 18 | type t = 19 | | All 20 | | Reduced 21 | 22 | val equal : t -> t -> bool 23 | 24 | val pp : Format.formatter -> t -> unit 25 | 26 | end 27 | 28 | module Direction : sig 29 | 30 | type t = 31 | | Normal 32 | | Inverted 33 | 34 | val equal : t -> t -> bool 35 | 36 | val pp : Format.formatter -> t -> unit 37 | 38 | end 39 | 40 | module Path : sig 41 | 42 | type t 43 | 44 | val create : Mode.t -> Kind.t -> Direction.t -> Address.t list -> t 45 | 46 | val mode : t -> Mode.t 47 | 48 | val kind : t -> Kind.t 49 | 50 | val direction : t -> Direction.t 51 | 52 | val addresses : t -> Address.t list 53 | 54 | val with_mode : t -> Mode.t -> t 55 | 56 | val with_kind : t -> Kind.t -> t 57 | 58 | val with_direction : t -> Direction.t -> t 59 | 60 | val equal : t -> t -> bool 61 | 62 | val pp : Format.formatter -> t -> unit 63 | 64 | end 65 | 66 | module Frame : sig 67 | 68 | type t 69 | 70 | val path : t -> Path.t 71 | 72 | val selected : t -> Address.t option 73 | 74 | val display : t -> string option 75 | 76 | end 77 | 78 | module Layer : sig 79 | 80 | module Point : sig 81 | 82 | type t 83 | 84 | val time : t -> float 85 | 86 | val value : t -> int 87 | 88 | end 89 | 90 | type t 91 | 92 | val points : t -> Point.t list 93 | 94 | val display : t -> string 95 | 96 | val foreign : t -> bool 97 | 98 | val selection : t -> Path.t option 99 | 100 | end 101 | 102 | type t 103 | 104 | val chart : series:Series.t -> path:Path.t -> t 105 | 106 | val frames : t -> Frame.t list 107 | 108 | val layers : t -> Layer.t list 109 | 110 | val path : t -> Path.t 111 | 112 | val max_value : t -> int 113 | 114 | val max_time : t -> float 115 | 116 | module Memo : sig 117 | 118 | type chart = t 119 | 120 | type t 121 | 122 | val create : series:Series.t -> t 123 | 124 | val chart : t -> path:Path.t -> chart 125 | 126 | end 127 | -------------------------------------------------------------------------------- /src/diff.ml: -------------------------------------------------------------------------------- 1 | 2 | type diff = 3 | { words: int 4 | ; allocations: int 5 | ; blocks: int 6 | } 7 | 8 | let empty_diff = { allocations = 0; words = 0; blocks = 0 } 9 | 10 | module AllocMap = Map.Make(String) 11 | module NameSet = Set.Make(String) 12 | 13 | let get_alloc_map snapshot = 14 | let rec loop snapshot acc = 15 | Section.fold Section.(fun _ item acc -> 16 | let value = Item.value item in 17 | let words = Allocation.words value in 18 | let allocations = Allocation.allocations value in 19 | let blocks = Allocation.blocks value in 20 | try 21 | let display = Item.display item in 22 | let name = String.sub display 0 (String.index display ':') in 23 | let value = 24 | match AllocMap.find name acc with 25 | | exception Not_found -> 26 | { words; allocations; blocks} 27 | | v -> 28 | let words = words + v.words in 29 | let allocations = allocations + v.allocations in 30 | let blocks = blocks + v.blocks in 31 | { words; allocations; blocks} 32 | in 33 | AllocMap.add name value acc 34 | with Not_found -> loop (Item.select item) acc 35 | ) snapshot acc 36 | in 37 | loop snapshot AllocMap.empty 38 | 39 | let get_keys map = 40 | AllocMap.fold (fun k _ acc -> NameSet.add k acc) map NameSet.empty 41 | 42 | let diff_maps map0 map1 = 43 | let keys = NameSet.union (get_keys map0) (get_keys map1) in 44 | let diffs = 45 | NameSet.elements keys 46 | |> List.map (fun key -> 47 | let diff0 = try AllocMap.find key map0 with Not_found -> empty_diff in 48 | let diff1 = try AllocMap.find key map1 with Not_found -> empty_diff in 49 | let diff = 50 | { words = diff0.words - diff1.words 51 | ; allocations = diff0.allocations - diff1.allocations 52 | ; blocks = diff0.blocks - diff1.blocks 53 | } 54 | in 55 | (key, diff)) 56 | |> List.filter (fun (_, { allocations; _ }) -> allocations != 0) 57 | in 58 | let max_length = NameSet.fold (fun n l -> max l (String.length n)) keys 0 in 59 | let padded_string i = 60 | let str = (if i < 0 then "" else "+") ^ string_of_int i in 61 | let len = String.length str in 62 | if len < 14 then (String.make (14 - len) ' ') ^ str else str 63 | in 64 | let pad = String.make (max_length - 4) ' ' in 65 | Printf.printf "File%s Words Allocations Blocks\n" pad; 66 | diffs 67 | |> List.filter (fun (_, d) -> d.words != 0) 68 | |> List.sort (fun (_, a) (_, b) -> a.words - b.words) 69 | |> List.iter (fun (k, { allocations; words; blocks }) -> 70 | Printf.printf "%s%s %s %s %s\n" 71 | k 72 | (String.make (max_length - String.length k) ' ') 73 | (padded_string words) 74 | (padded_string allocations) 75 | (padded_string blocks)) 76 | 77 | let compare_snapshots snapshot0 snapshot1 = 78 | let a0 = Snapshot.allocation_entries ~inverted:false snapshot0 in 79 | let a1 = Snapshot.allocation_entries ~inverted:false snapshot1 in 80 | diff_maps (get_alloc_map a0) (get_alloc_map a1) 81 | 82 | let diff ref data = 83 | match List.rev (Series.snapshots ref), List.rev (Series.snapshots data) with 84 | | snapshot0 :: _, snapshot1 :: _ -> 85 | compare_snapshots snapshot0 snapshot1 86 | | _, _ -> 87 | Printf.eprintf "Empty snaphot!\n" 88 | -------------------------------------------------------------------------------- /src/diff.mli: -------------------------------------------------------------------------------- 1 | 2 | val diff 3 | : Series.t 4 | -> Series.t 5 | -> unit 6 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name prof_spacetime_lib) 3 | (libraries yojson spacetime_lib lwt cohttp-lwt-unix cohttp lambda-term 4 | cmdliner stdlib-shims)) 5 | -------------------------------------------------------------------------------- /src/embed.ml: -------------------------------------------------------------------------------- 1 | 2 | let html = {| 3 | 4 | 5 | Spacetime 6 | 45 | 47 | 48 | 49 | 50 | 51 | 52 | |} 53 | 54 | let js ~title = {| 55 | var title = d3.select("body").append("h1") 56 | .attr("align", "center") 57 | .html(" |} ^ title ^ {| "); 58 | 59 | var mode_widget_vert = 60; 60 | 61 | d3.select("body").append("div") 62 | .attr("align", "center") 63 | .text("Mouse over the graph to show where values were allocated. " + 64 | "Values allocated from non-OCaml code have their mouse-over popup " + 65 | "text in green. Click a portion of the graph to move up the stack.") 66 | 67 | var mode_widget = 68 | d3.select("body") 69 | .append("ul") 70 | .attr("class", "mode"); 71 | 72 | var margin = {top: 100, right: 200, bottom: 100, left: 200}; 73 | 74 | var width = 1280 - margin.left - margin.right; 75 | 76 | var height = 640 - margin.top - margin.bottom; 77 | 78 | var popup_padding = 4; 79 | 80 | var x = d3.scale.linear().range([0, width]); 81 | 82 | var y = d3.scale.linear().range([height, 0]); 83 | 84 | var color1 = d3.scale.category20(); 85 | var color2 = d3.scale.category20c(); 86 | 87 | var fmt = d3.format('.3'); 88 | 89 | var xAxis = d3.svg.axis().scale(x).orient("bottom"); 90 | 91 | xAxis.tickFormat(function (secs) { 92 | return fmt(secs) + 's'; 93 | }); 94 | 95 | var rt2 = Math.sqrt(2); 96 | var ln2 = Math.log(2); 97 | 98 | var byteTickValues = function(start, stop, count) { 99 | 100 | var step0 = Math.abs(stop - start) / Math.max(0, count), 101 | step1 = Math.pow(2, Math.floor(Math.log(step0) / ln2)), 102 | error = step0 / step1; 103 | 104 | if (error >= rt2) step1 *= 2; 105 | 106 | var step = stop < start ? -step1 : step1; 107 | 108 | return d3.range( 109 | Math.ceil(start / step) * step, 110 | Math.floor(stop / step) * step + step / 2, // inclusive 111 | step 112 | ); 113 | }; 114 | 115 | var kb = 1024 116 | var mb = kb * 1024 117 | var gb = mb * 1024 118 | 119 | var byteTickFormat = function (bytes) { 120 | return fmt(bytes) + 'B'; 121 | } 122 | 123 | var kilobyteTickFormat = function (bytes) { 124 | return fmt(bytes / kb) + 'kB'; 125 | } 126 | 127 | var megabyteTickFormat = function (bytes) { 128 | return fmt(bytes / mb) + 'MB'; 129 | } 130 | 131 | var gigabyteTickFormat = function (bytes) { 132 | return fmt(bytes / gb) + 'GB'; 133 | } 134 | 135 | var yAxis = d3.svg.axis().scale(y).orient("left"); 136 | 137 | var area = d3.svg.area() 138 | .x(function(d) { return x(d.time); }) 139 | .y0(function(d) { return y(d.y0); }) 140 | .y1(function(d) { return y(d.y0 + d.y); }); 141 | 142 | var stack = d3.layout.stack() 143 | .values(function(d) { return d.values; }); 144 | 145 | var svg = d3.select("body").append("svg") 146 | .attr("width", width + margin.left + margin.right) 147 | .attr("height", height + margin.top + margin.bottom) 148 | .append("g") 149 | .attr("transform", "translate(" + margin.left + "," + margin.top + ")"); 150 | 151 | svg.append("g") 152 | .attr("transform", "translate(-75, " + height / 2 + ")") 153 | .append("text") 154 | .attr("text-anchor", "middle") 155 | .attr("transform", "rotate(-90)") 156 | .text("Number of words or blocks") 157 | 158 | svg.append("g") 159 | .attr("transform", "translate(" + width / 2 + ", " + (height + 40) + ")") 160 | .append("text") 161 | .attr("text-anchor", "middle") 162 | .text("Time since program start") 163 | 164 | var body = 165 | svg.append("g") 166 | .on("mouseover", function() { 167 | popup.transition().duration(500).style("opacity", 1); 168 | }) 169 | .on("mouseout", function() { 170 | popup.transition().duration(10).style("opacity", 0); 171 | }) 172 | .on("mousemove", function(d) { 173 | var x = d3.event.pageX - margin.left + 5; 174 | var y = d3.event.pageY - margin.top - mode_widget_vert + 5; 175 | popup.attr("transform", "translate(" + x + "," + y + ")"); 176 | }); 177 | 178 | var popup = 179 | svg.append("g") 180 | .attr("id", "popup") 181 | .attr("pointer-events", "none") 182 | .style("opacity", 0); 183 | 184 | popup.append("rect") 185 | .attr("fill", "#000000") 186 | .attr("stroke", "#969696") 187 | .attr("rx", "5") 188 | .attr("ry", "5") 189 | .style("opacity", .6); 190 | 191 | popup.append("text") 192 | .attr("fill", "#FFFFFF"); 193 | 194 | svg.append("g") 195 | .attr("class", "axis") 196 | .attr("id","xaxis") 197 | .attr("transform", "translate(0," + height + ")"); 198 | 199 | svg.append("g") 200 | .attr("class", "axis") 201 | .attr("id","yaxis"); 202 | 203 | d3.select("body").append("h2") 204 | .html("Backtrace (oldest frame first):") 205 | 206 | var frame_widget = d3.select("body").append("ul"); 207 | 208 | function graph(input, dispatch) { 209 | 210 | var modes = 211 | mode_widget.selectAll("li") 212 | .data(input.modes); 213 | 214 | modes.enter().append("li"); 215 | 216 | modes 217 | .text(function (d) { return d.display }) 218 | .attr("class", function (d) { 219 | if (d.selected) { return "mode-sel" } 220 | else { return "mode" } 221 | }) 222 | .on("click", function (d) { 223 | if (!d.selected) { dispatch.select(d.path); } 224 | }); 225 | 226 | modes.exit().remove(); 227 | 228 | color1.domain(input.layers.map(function (layer) 229 | { return layer.index })); 230 | color2.domain(input.layers.map(function (layer) 231 | { return location.index }).reverse()); 232 | 233 | var layers = stack(input.layers); 234 | 235 | var max_time = input.max_time; 236 | var max_y = input.max_y; 237 | 238 | x.domain([0, max_time]); 239 | y.domain([0, max_y]); 240 | 241 | if(input.bytes) { 242 | yAxis.tickValues(byteTickValues(0, max_y, 10)); 243 | if (max_y < kb) { 244 | yAxis.tickFormat(byteTickFormat); 245 | } else if (max_y < mb) { 246 | yAxis.tickFormat(kilobyteTickFormat); 247 | } else if (max_y < gb) { 248 | yAxis.tickFormat(megabyteTickFormat); 249 | } else { 250 | yAxis.tickFormat(gigabyteTickFormat); 251 | } 252 | } else { 253 | yAxis.tickValues(null); 254 | yAxis.tickFormat(null); 255 | yAxis.ticks(10, ",s"); 256 | } 257 | 258 | svg.select("#xaxis").call(xAxis); 259 | svg.select("#yaxis").call(yAxis); 260 | 261 | var layer = 262 | body.selectAll(".layer") 263 | .data(layers); 264 | 265 | layer.enter() 266 | .append("g") 267 | .attr("class", "layer") 268 | .append("path", "#popup") 269 | .attr("class", "area"); 270 | 271 | layer.select("path") 272 | .attr("d", function(d) { return area(d.values); }) 273 | .on("mouseenter", function(d) { 274 | d3.select(this).attr("stroke", "#000000"); 275 | var x = d3.event.pageX - margin.left + 5; 276 | var y = d3.event.pageY - margin.top - mode_widget_vert + 5; 277 | popup.attr("transform", "translate(" + x + "," + y + ")"); 278 | var text = popup.select("text"); 279 | text.text(d.display); 280 | if(d.foreign) { 281 | text.attr("fill", "#66FF00"); 282 | } else { 283 | text.attr("fill", "#FFFFFF"); 284 | } 285 | var box = text.node().getBBox(); 286 | popup.select("rect") 287 | .attr("x", box.x - popup_padding) 288 | .attr("y", box.y - popup_padding) 289 | .attr("width", box.width + popup_padding*2) 290 | .attr("height", box.height + popup_padding*2); 291 | }) 292 | .on("mouseleave", function(d) { 293 | d3.select(this).attr("stroke", "none"); 294 | }) 295 | .on("click", function (d) { dispatch.select(d.path); }) 296 | .attr("fill", function(d) { 297 | if(input.depth % 2 == 0) { 298 | return color1(d.index); 299 | } else { 300 | return color2(d.index); 301 | } 302 | }); 303 | 304 | layer.exit().remove(); 305 | 306 | var frame = 307 | frame_widget.selectAll("li") 308 | .data(input.frames); 309 | 310 | frame.enter() 311 | .append("li") 312 | .style("cursor","pointer") 313 | .style("color","blue") 314 | .style("font","12px sans-serif") 315 | .style("text-decoration","underline"); 316 | 317 | frame.text(function (d) { return d.display;}); 318 | frame.on("click", function (d) { return dispatch.frame(d.path); }); 319 | 320 | frame.exit().remove(); 321 | 322 | } 323 | 324 | var dispatch = d3.dispatch("select", "frame"); 325 | 326 | function fetch(path) { 327 | var xmlhttp = new XMLHttpRequest(); 328 | xmlhttp.onload = function () { 329 | if(xmlhttp.status == 200) { 330 | var state = JSON.parse(xmlhttp.responseText); 331 | graph(state, dispatch); 332 | } 333 | }; 334 | xmlhttp.open("GET", path, true); 335 | xmlhttp.send(); 336 | } 337 | 338 | fetch("initial.json"); 339 | dispatch.on("select", function (path) { if(path != null) fetch(path); }); 340 | dispatch.on("frame", function (path) { fetch(path); }); 341 | |} 342 | -------------------------------------------------------------------------------- /src/embed.mli: -------------------------------------------------------------------------------- 1 | 2 | val html : string 3 | 4 | val js : title:string -> string 5 | -------------------------------------------------------------------------------- /src/print.ml: -------------------------------------------------------------------------------- 1 | open Spacetime_lib 2 | 3 | module Mode = struct 4 | 5 | module Allocation = struct 6 | 7 | type t = 8 | | Words 9 | | Blocks 10 | | Allocations 11 | 12 | end 13 | 14 | module Call = struct 15 | 16 | type t = 17 | | Calls 18 | | Indirect_calls 19 | 20 | end 21 | 22 | type t = 23 | | Words of { index : int } 24 | | Blocks of { index: int } 25 | | Allocations of { index : int } 26 | | Calls 27 | | Indirect_calls 28 | 29 | type allocation_or_call = 30 | | Allocation of int * Allocation.t 31 | | Call of Call.t 32 | 33 | let allocation_or_call = function 34 | | Words { index } -> Allocation(index, Allocation.Words) 35 | | Blocks { index } -> Allocation(index, Allocation.Blocks) 36 | | Allocations { index } -> Allocation(index, Allocation.Allocations) 37 | | Calls -> Call Call.Calls 38 | | Indirect_calls -> Call Call.Indirect_calls 39 | 40 | end 41 | 42 | let filter_opt l = 43 | let rec loop acc = function 44 | | [] -> List.rev acc 45 | | x :: xs -> 46 | let acc = 47 | match x with 48 | | Some x -> x :: acc 49 | | None -> acc 50 | in 51 | loop acc xs 52 | in 53 | loop [] l 54 | 55 | let position_to_string pos 56 | ~address ~symbol ~print_filename ~print_symbol ~print_line_number = 57 | let filename = 58 | if print_filename then Some (Position.filename pos) else None 59 | in 60 | let position = 61 | if print_line_number then begin 62 | let line_number = Position.line_number pos in 63 | let start_char = Position.start_char pos in 64 | let end_char = Position.end_char pos in 65 | let position = 66 | Printf.sprintf "%d,%d-%d" line_number start_char end_char 67 | in 68 | Some position 69 | end else begin 70 | None 71 | end 72 | in 73 | let symbol = 74 | if print_symbol then begin 75 | match symbol with 76 | | None -> Some (Int64.to_string address) 77 | | Some symbol -> Some symbol 78 | end else begin 79 | None 80 | end 81 | in 82 | String.concat "," 83 | (filter_opt [filename; position; symbol]) 84 | 85 | let backtrace_to_string backtrace ~inverted 86 | ~print_filename ~print_symbol ~print_line_number = 87 | let backtrace = 88 | List.concat 89 | (List.map 90 | (fun loc -> 91 | let address = Location.address loc in 92 | let symbol = Location.symbol loc in 93 | let positions = Location.position loc in 94 | List.map 95 | (position_to_string ~address ~symbol 96 | ~print_filename ~print_symbol ~print_line_number) 97 | positions) 98 | backtrace) 99 | in 100 | let backtrace = if inverted then List.rev backtrace else backtrace in 101 | String.concat ";" backtrace 102 | 103 | let print_allocation_entry entry ~mode ~inverted 104 | ~print_filename ~print_symbol ~print_line_number = 105 | let number = 106 | match mode with 107 | | Mode.Allocation.Words -> Allocation_entry.words entry 108 | | Mode.Allocation.Blocks -> Allocation_entry.blocks entry 109 | | Mode.Allocation.Allocations -> Allocation_entry.allocations entry 110 | in 111 | if number > 0 then begin 112 | let backtrace = Allocation_entry.backtrace entry in 113 | let backtrace = 114 | backtrace_to_string backtrace 115 | ~inverted ~print_filename ~print_symbol ~print_line_number 116 | in 117 | try 118 | Printf.printf "%s %d\n" backtrace number 119 | with Sys_error _ -> 120 | close_out_noerr stdout; 121 | exit 2 122 | end 123 | 124 | let print_call_entry entry ~mode ~inverted 125 | ~print_filename ~print_symbol ~print_line_number = 126 | let number = 127 | match mode with 128 | | Mode.Call.Calls -> Call_entry.calls entry 129 | | Mode.Call.Indirect_calls -> 130 | if Call_entry.direct entry then 0 131 | else Call_entry.calls entry 132 | in 133 | if number > 0 then begin 134 | let backtrace = Call_entry.backtrace entry in 135 | let backtrace = 136 | backtrace_to_string backtrace 137 | ~inverted ~print_filename ~print_symbol ~print_line_number 138 | in 139 | try 140 | Printf.printf "%s %d\n" backtrace number 141 | with Sys_error _ -> 142 | close_out_noerr stdout; 143 | exit 2 144 | end 145 | 146 | let print series ~mode ~inverted 147 | ~print_filename ~print_symbol ~print_line_number = 148 | let print_symbol = 149 | if print_filename || print_symbol || print_line_number then 150 | print_symbol 151 | else 152 | true 153 | in 154 | match Mode.allocation_or_call mode with 155 | | Allocation(index, mode) -> 156 | let snapshots = Series.snapshots series in 157 | let num_snapshots = List.length snapshots in 158 | let () = 159 | if index > num_snapshots - 1 then begin 160 | Printf.eprintf 161 | "Snapshot index out of bound, there are only %d in total\n%!" 162 | num_snapshots; 163 | exit 1 164 | end 165 | in 166 | let snapshot = List.nth snapshots index in 167 | let entries = Snapshot.allocation_entries snapshot in 168 | List.iter 169 | (print_allocation_entry ~mode ~inverted 170 | ~print_filename ~print_symbol ~print_line_number) 171 | entries 172 | | Call mode -> 173 | let () = 174 | if not (Series.has_call_counts series) then begin 175 | Printf.eprintf 176 | "Profile does not contain call counts\n%!"; 177 | exit 1 178 | end 179 | in 180 | let entries = Series.call_entries series in 181 | List.iter 182 | (print_call_entry ~mode ~inverted 183 | ~print_filename ~print_symbol ~print_line_number) 184 | entries 185 | 186 | -------------------------------------------------------------------------------- /src/print.mli: -------------------------------------------------------------------------------- 1 | 2 | module Mode : sig 3 | 4 | type t = 5 | | Words of { index : int } 6 | | Blocks of { index : int } 7 | | Allocations of { index : int } 8 | | Calls 9 | | Indirect_calls 10 | 11 | end 12 | 13 | val print 14 | : Spacetime_lib.Series.t 15 | -> mode:Mode.t 16 | -> inverted:bool 17 | -> print_filename:bool 18 | -> print_symbol:bool 19 | -> print_line_number:bool 20 | -> unit 21 | -------------------------------------------------------------------------------- /src/section.ml: -------------------------------------------------------------------------------- 1 | 2 | module Allocation = struct 3 | 4 | type t = 5 | { words : int; 6 | blocks : int; 7 | allocations : int; } 8 | 9 | let create ~words ~blocks ~allocations = 10 | { words; blocks; allocations } 11 | 12 | let words { words; _ } = words 13 | 14 | let byte_size = 8 15 | 16 | let word_size = 17 | Sys.word_size / byte_size 18 | 19 | let bytes { words; _ } = words * word_size 20 | 21 | let blocks { blocks; _ } = blocks 22 | 23 | let allocations { allocations; _ } = allocations 24 | 25 | let zero = 26 | { words = 0; 27 | blocks = 0; 28 | allocations = 0; } 29 | 30 | let sum t1 t2 = 31 | { words = t1.words + t2.words; 32 | blocks = t1.blocks + t2.blocks; 33 | allocations = t1.allocations + t2.allocations; } 34 | 35 | end 36 | 37 | module Call = struct 38 | 39 | type t = 40 | { calls : int; 41 | direct : bool; } 42 | 43 | let create ~calls ~direct = 44 | { calls; direct } 45 | 46 | let calls { calls; _ } = calls 47 | 48 | let direct { direct; _ } = direct 49 | 50 | let zero = 51 | { calls = 0; 52 | direct = true; } 53 | 54 | let sum t1 t2 = 55 | { calls = t1.calls + t2.calls; 56 | direct = t1.direct && t2.direct; } 57 | 58 | end 59 | 60 | 61 | type 'a t = 'a item Address.Map.t 62 | 63 | and 'a item = 64 | { section : 'a t Lazy.t; 65 | empty : bool; 66 | display : string; 67 | foreign : bool; 68 | path : Address.t list; 69 | value : 'a; } 70 | 71 | module Item = struct 72 | 73 | type 'a t = 'a item 74 | 75 | let display { display; _ } = display 76 | 77 | let foreign { foreign; _ } = foreign 78 | 79 | let path { path; _ } = path 80 | 81 | let value { value; _ } = value 82 | 83 | let empty { empty; _ } = empty 84 | 85 | let select t = Lazy.force t.section 86 | 87 | end 88 | 89 | type 'a section = 'a t 90 | 91 | let empty = Address.Map.empty 92 | 93 | let nth depth l = 94 | let rec loop n = function 95 | | [] -> None 96 | | [hd] -> 97 | if n = 0 then Some(hd, true) 98 | else None 99 | | hd :: tl -> 100 | if n = 0 then Some(hd, false) 101 | else loop (n - 1) tl 102 | in 103 | loop depth l 104 | 105 | let display_location loc = 106 | match Spacetime_lib.Location.position loc with 107 | | [] -> begin 108 | match Spacetime_lib.Location.symbol loc with 109 | | Some s -> s 110 | | None -> 111 | Printf.sprintf "0x%Lx" 112 | (Spacetime_lib.Location.address loc) 113 | end 114 | | positions -> begin 115 | let one_pos pos = 116 | let name = Spacetime_lib.Position.filename pos in 117 | let line = string_of_int (Spacetime_lib.Position.line_number pos) in 118 | let first = string_of_int (Spacetime_lib.Position.start_char pos) in 119 | let last = string_of_int (Spacetime_lib.Position.end_char pos) in 120 | if Spacetime_lib.Position.start_char pos < 0 then 121 | String.concat "" 122 | [name; ":"; line; ] 123 | else 124 | String.concat "" 125 | [name; ":"; line; ","; first; "--"; last; ] 126 | in 127 | let pos = 128 | String.concat "; " (List.map one_pos positions) 129 | in 130 | match Spacetime_lib.Location.symbol loc with 131 | | Some symbol -> Printf.sprintf "%s (%s)" pos symbol 132 | | None -> pos 133 | end 134 | 135 | let rec create ~backtrace ~nil ~cons ~inverted ~depth ~path ~entries = 136 | let preindex = 137 | List.fold_left 138 | (fun acc entry -> 139 | let backtrace = backtrace entry in 140 | let backtrace = if inverted then List.rev backtrace else backtrace in 141 | match nth depth backtrace with 142 | | None -> acc 143 | | Some (loc, last) -> 144 | let addr = Address.of_int64 (Spacetime_lib.Location.address loc) in 145 | let entries_acc, loc_acc, value_acc = 146 | try 147 | Address.Map.find addr acc 148 | with Not_found -> [], loc, nil 149 | in 150 | let entries_acc = 151 | if last then entries_acc else entry :: entries_acc 152 | in 153 | let value_acc = cons entry value_acc in 154 | Address.Map.add addr (entries_acc, loc_acc, value_acc) acc) 155 | Address.Map.empty entries 156 | in 157 | Address.Map.fold 158 | (fun addr (entries, loc, value) acc -> 159 | let depth = depth + 1 in 160 | let path = addr :: path in 161 | let empty = 162 | match entries with 163 | | [] -> true 164 | | _ :: _ -> false 165 | in 166 | let section = 167 | lazy (create ~backtrace ~nil ~cons ~inverted ~depth ~path ~entries) 168 | in 169 | let display = display_location loc in 170 | let foreign = Spacetime_lib.Location.foreign loc in 171 | let item = 172 | { section; empty; display; foreign; path; value; } 173 | in 174 | Address.Map.add addr item acc) 175 | preindex Address.Map.empty 176 | 177 | let of_allocation_entries = 178 | let nil = Allocation.zero in 179 | let cons entry t = 180 | let words = Spacetime_lib.Allocation_entry.words entry in 181 | let blocks = Spacetime_lib.Allocation_entry.blocks entry in 182 | let allocations = Spacetime_lib.Allocation_entry.allocations entry in 183 | Allocation.sum t (Allocation.create ~words ~blocks ~allocations) 184 | in 185 | let backtrace = Spacetime_lib.Allocation_entry.backtrace in 186 | let depth = 0 in 187 | let path = [] in 188 | fun ~inverted entries -> 189 | create ~backtrace ~nil ~cons ~inverted ~depth ~path ~entries 190 | 191 | let of_call_entries = 192 | let nil = Call.zero in 193 | let cons entry t = 194 | let calls = Spacetime_lib.Call_entry.calls entry in 195 | let direct = Spacetime_lib.Call_entry.direct entry in 196 | Call.sum t (Call.create ~calls ~direct) 197 | in 198 | let backtrace = Spacetime_lib.Call_entry.backtrace in 199 | let depth = 0 in 200 | let path = [] in 201 | fun ~inverted entries -> 202 | create ~backtrace ~nil ~cons ~inverted ~depth ~path ~entries 203 | 204 | let project t addr = 205 | match Address.Map.find addr t with 206 | | item -> Some item 207 | | exception Not_found -> None 208 | 209 | let select t addr = 210 | match Address.Map.find addr t with 211 | | item -> Item.select item 212 | | exception Not_found -> empty 213 | 214 | let fold f t init = 215 | Address.Map.fold f t init 216 | 217 | let iter f t = 218 | Address.Map.iter f t 219 | -------------------------------------------------------------------------------- /src/section.mli: -------------------------------------------------------------------------------- 1 | 2 | type 'a section 3 | 4 | module Allocation : sig 5 | 6 | type t 7 | 8 | val create : words:int -> blocks:int -> allocations:int -> t 9 | 10 | val words : t -> int 11 | 12 | val bytes : t -> int 13 | 14 | val blocks : t -> int 15 | 16 | val allocations : t -> int 17 | 18 | val zero : t 19 | 20 | val sum : t -> t -> t 21 | 22 | val word_size : int 23 | 24 | end 25 | 26 | module Call : sig 27 | 28 | type t 29 | 30 | val create : calls:int -> direct:bool -> t 31 | 32 | val calls : t -> int 33 | 34 | val direct : t -> bool 35 | 36 | val zero : t 37 | 38 | val sum : t -> t -> t 39 | 40 | end 41 | 42 | module Item : sig 43 | 44 | type 'a t 45 | 46 | val display : 'a t -> string 47 | 48 | val foreign : 'a t -> bool 49 | 50 | val path : 'a t -> Address.t list 51 | 52 | val value : 'a t -> 'a 53 | 54 | val empty : 'a t -> bool 55 | 56 | val select : 'a t -> 'a section 57 | 58 | end 59 | 60 | type 'a t = 'a section 61 | 62 | val empty : 'a t 63 | 64 | val of_allocation_entries : 65 | inverted:bool -> Spacetime_lib.Allocation_entry.t list -> Allocation.t t 66 | 67 | val of_call_entries : 68 | inverted:bool -> Spacetime_lib.Call_entry.t list -> Call.t t 69 | 70 | val project : 'a t -> Address.t -> 'a Item.t option 71 | 72 | val select : 'a t -> Address.t -> 'a t 73 | 74 | val fold : (Address.t -> 'a Item.t -> 'b -> 'b) -> 'a t -> 'b -> 'b 75 | 76 | val iter : (Address.t -> 'a Item.t -> unit) -> 'a t -> unit 77 | -------------------------------------------------------------------------------- /src/series.ml: -------------------------------------------------------------------------------- 1 | 2 | type t = 3 | { snapshots : Snapshot.t list; 4 | has_call_counts : bool; 5 | final_time : float; 6 | call_entries : Section.Call.t Section.t Lazy.t; 7 | inverted_call_entries : Section.Call.t Section.t Lazy.t; } 8 | 9 | let create series = 10 | let snapshots = 11 | List.map Snapshot.create (Spacetime_lib.Series.snapshots series) 12 | in 13 | let has_call_counts = Spacetime_lib.Series.has_call_counts series in 14 | let final_time = Spacetime_lib.Series.final_time series in 15 | let raw_call_entries = Spacetime_lib.Series.call_entries series in 16 | let call_entries = 17 | lazy (Section.of_call_entries ~inverted:false raw_call_entries) 18 | in 19 | let inverted_call_entries = 20 | lazy (Section.of_call_entries ~inverted:true raw_call_entries) 21 | in 22 | { snapshots; has_call_counts; final_time; 23 | call_entries; inverted_call_entries } 24 | 25 | let snapshots { snapshots; _ } = snapshots 26 | 27 | let has_call_counts { has_call_counts; _ } = has_call_counts 28 | 29 | let final_time { final_time; _ } = final_time 30 | 31 | let call_entries t ~inverted = 32 | if inverted then Lazy.force t.inverted_call_entries 33 | else Lazy.force t.call_entries 34 | -------------------------------------------------------------------------------- /src/series.mli: -------------------------------------------------------------------------------- 1 | 2 | type t 3 | 4 | val create : Spacetime_lib.Series.t -> t 5 | 6 | val snapshots : t -> Snapshot.t list 7 | 8 | val has_call_counts : t -> bool 9 | 10 | val final_time : t -> float 11 | 12 | val call_entries : t -> inverted:bool -> Section.Call.t Section.t 13 | -------------------------------------------------------------------------------- /src/serve.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Cohttp 3 | module Server = Cohttp_lwt_unix.Server 4 | 5 | module Url : sig 6 | 7 | type t 8 | 9 | val of_path : Chart.Path.t -> t 10 | 11 | val to_path : t -> Chart.Path.t 12 | 13 | val of_string : string -> t option 14 | 15 | val to_string : t -> string 16 | 17 | end = struct 18 | 19 | type t = Chart.Path.t 20 | 21 | let bytes_mode = "/bytes" 22 | let blocks_mode = "/block" 23 | let allocations_mode = "/alloc" 24 | 25 | let mode_len = 26 | let bytes_len = String.length bytes_mode in 27 | let blocks_len = String.length blocks_mode in 28 | let allocations_len = String.length allocations_mode in 29 | assert (bytes_len = blocks_len); 30 | assert (bytes_len = allocations_len); 31 | bytes_len 32 | 33 | let reduced_kind = "/red" 34 | let all_kind = "/all" 35 | 36 | let kind_len = 37 | let reduced_len = String.length reduced_kind in 38 | let add_len = String.length all_kind in 39 | assert (reduced_len = add_len); 40 | reduced_len 41 | 42 | let default_suffix = "series.json" 43 | 44 | let suffix_len = String.length default_suffix 45 | 46 | let initial_path = "/initial.json" 47 | 48 | let initial = 49 | let mode = Chart.Mode.Bytes in 50 | let kind = Chart.Kind.Reduced in 51 | let direction = Chart.Direction.Normal in 52 | let addresses = [] in 53 | Chart.Path.create mode kind direction addresses 54 | 55 | let () = 56 | let initial_len = String.length initial_path in 57 | assert (initial_len < mode_len + kind_len + suffix_len) 58 | 59 | let split_string s from until = 60 | let rec loop s segments prev n until = 61 | if prev >= until then begin 62 | segments 63 | end else if n >= until then begin 64 | let final = String.sub s prev (until - prev) in 65 | (final :: segments) 66 | end else if s.[n] = '/' then begin 67 | let segments = 68 | if prev >= n then segments 69 | else (String.sub s prev (n - prev)) :: segments 70 | in 71 | loop s segments (n + 1) (n + 1) until 72 | end else begin 73 | loop s segments prev (n + 1) until 74 | end 75 | in 76 | loop s [] from from until 77 | 78 | let of_path p = p 79 | let to_path t = t 80 | 81 | let of_string s = 82 | let len = String.length s in 83 | if len >= (mode_len + kind_len + suffix_len) then begin 84 | let mode = String.sub s 0 mode_len in 85 | let kind = String.sub s mode_len kind_len in 86 | let suffix = String.sub s (len - suffix_len) suffix_len in 87 | try 88 | if suffix = default_suffix then begin 89 | let mode = 90 | if mode = bytes_mode then Some Chart.Mode.Bytes 91 | else if mode = blocks_mode then Some Chart.Mode.Blocks 92 | else if mode = allocations_mode then Some Chart.Mode.Allocations 93 | else None 94 | in 95 | let kind = 96 | if kind = reduced_kind then Some Chart.Kind.Reduced 97 | else if kind = all_kind then Some Chart.Kind.All 98 | else None 99 | in 100 | let direction = Chart.Direction.Normal in 101 | let segments = 102 | split_string s (mode_len + kind_len) (len - suffix_len) 103 | in 104 | let addresses = 105 | List.map 106 | (fun str -> Address.of_int64 (Int64.of_string str)) 107 | segments 108 | in 109 | match mode, kind with 110 | | None, _ -> None 111 | | _, None -> None 112 | | Some mode, Some kind -> 113 | let path = Chart.Path.create mode kind direction addresses in 114 | Some path 115 | end else None 116 | with Failure _ -> None 117 | end else begin 118 | if s = initial_path then Some initial 119 | else None 120 | end 121 | 122 | let to_string t = 123 | let mode = 124 | match Chart.Path.mode t with 125 | | Chart.Mode.Bytes -> bytes_mode 126 | | Chart.Mode.Blocks -> blocks_mode 127 | | Chart.Mode.Allocations -> allocations_mode 128 | in 129 | let kind = 130 | match Chart.Path.kind t with 131 | | Chart.Kind.Reduced -> reduced_kind 132 | | Chart.Kind.All -> all_kind 133 | in 134 | let rec loop = function 135 | | [] -> mode ^ kind 136 | | addr :: rest -> loop rest ^ "/" ^ (Address.to_string addr) 137 | in 138 | let body = loop (Chart.Path.addresses t) in 139 | body ^ "/" ^ default_suffix 140 | 141 | end 142 | 143 | module Json = struct 144 | 145 | let of_modes path = 146 | let modes_json = 147 | List.map 148 | (fun mode -> 149 | let display = 150 | match mode with 151 | | Chart.Mode.Bytes -> "Live bytes" 152 | | Chart.Mode.Blocks -> "Live blocks" 153 | | Chart.Mode.Allocations -> "All allocated words" 154 | in 155 | let selected = Chart.Mode.equal mode (Chart.Path.mode path) in 156 | let url = Url.of_path (Chart.Path.with_mode path mode) in 157 | `Assoc [ "display", `String display; 158 | "selected", `Bool selected; 159 | "path", `String (Url.to_string url); ]) 160 | Chart.Mode.all 161 | in 162 | `List modes_json 163 | 164 | let of_layer index layer = 165 | let display = Chart.Layer.display layer in 166 | let foreign = Chart.Layer.foreign layer in 167 | let path_json = 168 | match Chart.Layer.selection layer with 169 | | None -> `Null 170 | | Some path -> 171 | let url = Url.of_path path in 172 | `String (Url.to_string url) 173 | in 174 | let value_jsons = 175 | List.map 176 | (fun point -> 177 | let time = Chart.Layer.Point.time point in 178 | let y = Chart.Layer.Point.value point in 179 | `Assoc ["time", `Float time; 180 | "y", `Int y]) 181 | (Chart.Layer.points layer) 182 | in 183 | `Assoc [ "index", `Int index; 184 | "display", `String display; 185 | "foreign", `Bool foreign; 186 | "path", path_json; 187 | "values", `List value_jsons; ] 188 | 189 | let of_frames frames = 190 | let jsons = 191 | List.fold_left 192 | (fun acc frame -> 193 | let display = 194 | match Chart.Frame.display frame with 195 | | None -> "(Top of stack)" 196 | | Some display -> display 197 | in 198 | let url = Url.of_path (Chart.Frame.path frame) in 199 | let json = 200 | `Assoc [ "path", `String (Url.to_string url); 201 | "display", `String display; ] 202 | in 203 | json :: acc) 204 | [] frames 205 | in 206 | `List jsons 207 | 208 | let of_chart chart = 209 | let layers = Chart.layers chart in 210 | let frames = Chart.frames chart in 211 | let path = Chart.path chart in 212 | let max_time = Chart.max_time chart in 213 | let max_y = Chart.max_value chart in 214 | let layer_jsons = List.mapi of_layer layers in 215 | let frames_json = of_frames frames in 216 | let depth = List.length frames in 217 | let bytes = 218 | match Chart.Path.mode path with 219 | | Chart.Mode.Bytes -> true 220 | | Chart.Mode.Blocks | Chart.Mode.Allocations -> false 221 | in 222 | let modes_json = of_modes path in 223 | `Assoc [ "layers", `List layer_jsons; 224 | "frames", frames_json; 225 | "depth", `Int depth; 226 | "bytes", `Bool bytes; 227 | "modes", modes_json; 228 | "max_time", `Float max_time; 229 | "max_y", `Int max_y; ] 230 | 231 | end 232 | 233 | (* Workaround for: 234 | 235 | https://github.com/mirage/ocaml-cohttp/issues/511 *) 236 | let () = 237 | Lwt.async_exception_hook := ignore 238 | 239 | let serve ~address ~port ~title series = 240 | let memo = Chart.Memo.create ~series in 241 | let header typ = 242 | let h = Header.init () in 243 | let h = Header.add h "Content-Type" typ in 244 | let h = Header.add h "Server" "prof_spacetime" in 245 | h 246 | in 247 | let header_html = header "text/html; charset=UTF-8" in 248 | let header_js = header "application/javascript; charset=UTF-8" in 249 | let header_json = header "application/json; charset=UTF-8" in 250 | let callback _ req _ = 251 | let uri = Request.uri req in 252 | let path = Uri.path uri in 253 | match path with 254 | | "/" | "/index.html" -> 255 | let headers = header_html in 256 | let status = `OK in 257 | let body = Embed.html in 258 | Server.respond_string ~headers ~status ~body () 259 | | "/graph.js" -> 260 | let headers = header_js in 261 | let status = `OK in 262 | let body = Embed.js ~title in 263 | Server.respond_string ~headers ~status ~body () 264 | | _ -> begin 265 | match Url.of_string path with 266 | | Some url -> 267 | let path = Url.to_path url in 268 | let chart = Chart.Memo.chart memo ~path in 269 | let headers = header_json in 270 | let status = `OK in 271 | let json = Json.of_chart chart in 272 | let body = Yojson.Basic.pretty_to_string ~std:true json in 273 | Server.respond_string ~headers ~status ~body () 274 | | None -> 275 | Server.respond_not_found ~uri () 276 | end 277 | in 278 | let ctx = Conduit_lwt_unix.init ~src:address () in 279 | let mode = `TCP (`Port port) in 280 | let server = Server.make ~callback () in 281 | let body = 282 | ctx >>= fun ctx -> 283 | let ctx = Cohttp_lwt_unix.Net.init ~ctx () in 284 | Server.create ~ctx ~mode server 285 | in 286 | Printf.printf "Serving on http://%s:%d/\n%!" address port; 287 | Lwt_main.run body 288 | -------------------------------------------------------------------------------- /src/serve.mli: -------------------------------------------------------------------------------- 1 | 2 | val serve 3 | : address:string 4 | -> port:int 5 | -> title:string 6 | -> Series.t 7 | -> unit 8 | -------------------------------------------------------------------------------- /src/snapshot.ml: -------------------------------------------------------------------------------- 1 | 2 | type t = { 3 | time : float; 4 | stats : Spacetime_lib.Stats.t option; 5 | allocation_entries: Section.Allocation.t Section.t Lazy.t; 6 | inverted_allocation_entries: Section.Allocation.t Section.t Lazy.t; 7 | } 8 | 9 | let create snapshot = 10 | let time = Spacetime_lib.Snapshot.time snapshot in 11 | let stats = Spacetime_lib.Snapshot.stats snapshot in 12 | let raw_allocation_entries = 13 | Spacetime_lib.Snapshot.allocation_entries snapshot 14 | in 15 | let allocation_entries = 16 | lazy ( 17 | Section.of_allocation_entries ~inverted:false raw_allocation_entries 18 | ) 19 | in 20 | let inverted_allocation_entries = 21 | lazy ( 22 | Section.of_allocation_entries ~inverted:true raw_allocation_entries 23 | ) 24 | in 25 | { time; stats; allocation_entries; inverted_allocation_entries } 26 | 27 | let time t = t.time 28 | 29 | let stats t = t.stats 30 | 31 | let allocation_entries t ~inverted = 32 | if inverted then Lazy.force t.inverted_allocation_entries 33 | else Lazy.force t.allocation_entries 34 | -------------------------------------------------------------------------------- /src/snapshot.mli: -------------------------------------------------------------------------------- 1 | 2 | type t 3 | 4 | val create : Spacetime_lib.Snapshot.t -> t 5 | 6 | val time : t -> float 7 | 8 | val stats : t -> Spacetime_lib.Stats.t option 9 | 10 | val allocation_entries : t -> inverted:bool -> Section.Allocation.t Section.t 11 | -------------------------------------------------------------------------------- /src/table.ml: -------------------------------------------------------------------------------- 1 | 2 | module Mode = struct 3 | 4 | module Call = struct 5 | 6 | type t = 7 | | Calls 8 | | Indirect_calls 9 | 10 | let pp ppf = function 11 | | Calls -> Format.fprintf ppf "Calls" 12 | | Indirect_calls -> Format.fprintf ppf "Indirect_calls" 13 | 14 | let equal t1 t2 = 15 | match t1, t2 with 16 | | Calls, Calls -> true 17 | | Indirect_calls, Indirect_calls -> true 18 | | Calls, Indirect_calls -> false 19 | | Indirect_calls, Calls -> false 20 | 21 | let proj _ = Section.Call.calls 22 | 23 | let filter = function 24 | | Calls -> fun _ -> true 25 | | Indirect_calls -> fun call -> not (Section.Call.direct call) 26 | 27 | end 28 | 29 | module Allocation = struct 30 | 31 | type t = 32 | | Bytes 33 | | Blocks 34 | | Allocations 35 | 36 | let pp ppf = function 37 | | Bytes -> Format.fprintf ppf "Bytes" 38 | | Blocks -> Format.fprintf ppf "Blocks" 39 | | Allocations -> Format.fprintf ppf "Allocations" 40 | 41 | let equal t1 t2 = 42 | match t1, t2 with 43 | | Bytes, Bytes -> true 44 | | Blocks, Blocks -> true 45 | | Allocations, Allocations -> true 46 | | Bytes, (Blocks | Allocations) -> false 47 | | Blocks, (Bytes | Allocations) -> false 48 | | Allocations, (Blocks | Bytes) -> false 49 | 50 | let proj = function 51 | | Bytes -> Section.Allocation.bytes 52 | | Blocks -> Section.Allocation.blocks 53 | | Allocations -> Section.Allocation.allocations 54 | 55 | let filter _ = 56 | fun _ -> true 57 | 58 | end 59 | 60 | type t = 61 | | Allocation of int * Allocation.t 62 | | Call of Call.t 63 | 64 | let pp ppf = function 65 | | Allocation(index, amode) -> 66 | Format.fprintf ppf "Allocation(%i, %a)" 67 | index Allocation.pp amode 68 | | Call cmode -> 69 | Format.fprintf ppf "Call(%a)" 70 | Call.pp cmode 71 | 72 | let equal t1 t2 = 73 | match t1, t2 with 74 | | Allocation(snap1, alloc1), Allocation(snap2, alloc2) -> 75 | snap1 = snap2 && Allocation.equal alloc1 alloc2 76 | | Call call1, Call call2 -> 77 | Call.equal call1 call2 78 | | Allocation _, Call _ -> false 79 | | Call _, Allocation _ -> false 80 | 81 | end 82 | 83 | module Direction = struct 84 | 85 | type t = 86 | | Normal 87 | | Inverted 88 | 89 | let pp ppf = function 90 | | Normal -> Format.fprintf ppf "Normal" 91 | | Inverted -> Format.fprintf ppf "Inverted" 92 | 93 | let inverted = function 94 | | Normal -> false 95 | | Inverted -> true 96 | 97 | let equal t1 t2 = 98 | match t1, t2 with 99 | | Normal, Normal -> true 100 | | Inverted, Inverted -> true 101 | | Normal, Inverted -> false 102 | | Inverted, Normal -> false 103 | 104 | end 105 | 106 | module Path = struct 107 | 108 | type t = 109 | { mode : Mode.t; 110 | direction : Direction.t; 111 | addresses : Address.t list; } 112 | 113 | let create mode direction addresses = 114 | { mode; direction; addresses } 115 | 116 | let mode { mode; _ } = mode 117 | 118 | let direction { direction; _ } = direction 119 | 120 | let addresses { addresses; _ } = addresses 121 | 122 | let with_mode t mode = { t with mode } 123 | 124 | let with_direction t direction = { t with direction } 125 | 126 | let pp ppf t = 127 | let pp_addresses ppf addresses = 128 | let pp_sep ppf () = 129 | Format.fprintf ppf ";@ " 130 | in 131 | Format.fprintf ppf "[@[<2>%a@]]" 132 | (Format.pp_print_list ~pp_sep Address.pp) addresses 133 | in 134 | Format.fprintf ppf 135 | "@[<2>{@ mode = %a;@ \ 136 | direction = %a;@ \ 137 | addresses = %a;@ }@]" 138 | Mode.pp t.mode 139 | Direction.pp t.direction 140 | pp_addresses t.addresses 141 | 142 | let equal t1 t2 = 143 | Mode.equal t1.mode t2.mode 144 | && Direction.equal t1.direction t2.direction 145 | && Address.equal_list t1.addresses t2.addresses 146 | 147 | let hash = Hashtbl.hash 148 | 149 | module Hash = struct 150 | 151 | type nonrec t = t 152 | 153 | let equal = equal 154 | let hash = hash 155 | 156 | end 157 | 158 | module Tbl = Hashtbl.Make(Hash) 159 | 160 | end 161 | 162 | module Row = struct 163 | 164 | type t = 165 | { address : Address.t; 166 | value : int; 167 | percentage : float; 168 | display : string; 169 | selection : Path.t option; } 170 | 171 | let create ~address ~value ~percentage ~display ~selection = 172 | { address; value; percentage; display; selection } 173 | 174 | let address { address; _ } = address 175 | 176 | let value { value; _ } = value 177 | 178 | let percentage { percentage; _ } = percentage 179 | 180 | let display { display; _ } = display 181 | 182 | let selection { selection; _ } = selection 183 | 184 | let dummy = 185 | { address = Address.of_int64 0L; 186 | value = 0; 187 | percentage = 0.0; 188 | display = ""; 189 | selection = None; } 190 | 191 | end 192 | 193 | module Frame = struct 194 | 195 | type t = 196 | { path : Path.t; 197 | selected : Address.t option; 198 | display : string option; } 199 | 200 | let path { path; _ } = path 201 | 202 | let selected { selected; _ } = selected 203 | 204 | let display { display; _ } = display 205 | 206 | let initial mode direction rest = 207 | let path = Path.create mode direction [] in 208 | let selected = 209 | match rest with 210 | | [] -> None 211 | | address :: _ -> Some address 212 | in 213 | let display = None in 214 | { path; selected; display } 215 | 216 | let of_item path item rest = 217 | let selected = 218 | match rest with 219 | | [] -> None 220 | | address :: _ -> Some address 221 | in 222 | let display = 223 | match item with 224 | | None -> begin 225 | match Path.addresses path with 226 | | [] -> None 227 | | addr :: _ -> Some (Address.to_string addr) 228 | end 229 | | Some item -> Some (Section.Item.display item) 230 | in 231 | { path; selected; display } 232 | 233 | end 234 | 235 | type t = 236 | { rows : Row.t array; 237 | frames : Frame.t list; 238 | time : float; 239 | total : int; } 240 | 241 | let of_section frames section time mode direction filter proj = 242 | let size, total = 243 | Section.fold 244 | (fun _ item acc -> 245 | let value = Section.Item.value item in 246 | if not (filter value) then acc 247 | else begin 248 | let (size, total) = acc in 249 | let size = size + 1 in 250 | let value = proj value in 251 | let total = total + value in 252 | (size, total) 253 | end) 254 | section (0, 0) 255 | in 256 | let rows = Array.make size Row.dummy in 257 | let _ = 258 | Section.fold 259 | (fun address item index -> 260 | let value = Section.Item.value item in 261 | if not (filter value) then index 262 | else begin 263 | let value = proj value in 264 | let percentage = 265 | ((float_of_int value) /. (float_of_int total)) *. 100. 266 | in 267 | let display = Section.Item.display item in 268 | let selection = 269 | if Section.Item.empty item then None 270 | else begin 271 | let addresses = Section.Item.path item in 272 | let path = Path.create mode direction addresses in 273 | Some path 274 | end 275 | in 276 | let row = 277 | Row.create ~address ~value ~percentage ~display ~selection 278 | in 279 | Array.set rows index row; 280 | index + 1 281 | end) 282 | section 0 283 | in 284 | Array.sort 285 | (fun row1 row2 -> compare (Row.value row2) (Row.value row1)) 286 | rows; 287 | { rows; frames; time; total } 288 | 289 | let table ~series ~path = 290 | let mode = Path.mode path in 291 | let direction = Path.direction path in 292 | let rec loop frames section addresses = function 293 | | [] -> frames, section 294 | | addr :: rest -> 295 | let item = Section.project section addr in 296 | let addresses = addr :: addresses in 297 | let path = Path.create mode direction addresses in 298 | let frame = Frame.of_item path item rest in 299 | let frames = frame :: frames in 300 | let section = 301 | match item with 302 | | None -> Section.empty 303 | | Some item -> Section.Item.select item 304 | in 305 | loop frames section addresses rest 306 | in 307 | let inverted = Direction.inverted direction in 308 | match mode with 309 | | Allocation(index, amode) -> 310 | let raddresses = List.rev (Path.addresses path) in 311 | let initial_frame = Frame.initial mode direction raddresses in 312 | let snapshots = Series.snapshots series in 313 | let initial_section, time = 314 | if index < List.length snapshots then begin 315 | let snapshot = List.nth snapshots index in 316 | let initial_section = 317 | Snapshot.allocation_entries snapshot ~inverted 318 | in 319 | let time = Snapshot.time snapshot in 320 | initial_section, time 321 | end else begin 322 | Section.empty, 0.0 323 | end 324 | in 325 | let frames, section = 326 | loop [initial_frame] initial_section [] raddresses 327 | in 328 | let filter = Mode.Allocation.filter amode in 329 | let proj = Mode.Allocation.proj amode in 330 | of_section frames section time mode direction filter proj 331 | | Call cmode -> 332 | let raddresses = List.rev (Path.addresses path) in 333 | let initial_frame = Frame.initial mode direction raddresses in 334 | let initial_section = Series.call_entries series ~inverted in 335 | let frames, section = 336 | loop [initial_frame] initial_section [] raddresses 337 | in 338 | let time = Series.final_time series in 339 | let filter = Mode.Call.filter cmode in 340 | let proj = Mode.Call.proj cmode in 341 | of_section frames section time mode direction filter proj 342 | 343 | let row t i = 344 | if i < Array.length t.rows then Some (Array.get t.rows i) 345 | else None 346 | 347 | let size t = Array.length t.rows 348 | 349 | let frames { frames; _ } = frames 350 | 351 | let time { time; _ } = time 352 | 353 | let total { total; _ } = total 354 | 355 | let find p t = 356 | let rec loop rows p i = 357 | if i >= Array.length rows then raise Not_found 358 | else if i < 0 then begin 359 | Printf.eprintf "WTF!\n%!"; 360 | raise Exit 361 | end else begin 362 | if p (Array.get rows i) then i 363 | else loop rows p (i + 1) 364 | end 365 | in 366 | loop t.rows p 0 367 | 368 | module Memo = struct 369 | 370 | type table = t 371 | 372 | type t = 373 | { series : Series.t; 374 | cache : table Path.Tbl.t; } 375 | 376 | let create ~series = 377 | let cache = Path.Tbl.create 5 in 378 | { series; cache } 379 | 380 | let table t ~path = 381 | match Path.Tbl.find t.cache path with 382 | | table -> table 383 | | exception Not_found -> 384 | let series = t.series in 385 | let table = table ~series ~path in 386 | Path.Tbl.add t.cache path table; 387 | table 388 | 389 | end 390 | 391 | -------------------------------------------------------------------------------- /src/table.mli: -------------------------------------------------------------------------------- 1 | 2 | module Mode : sig 3 | 4 | module Call : sig 5 | 6 | type t = 7 | | Calls 8 | | Indirect_calls 9 | 10 | val equal : t -> t -> bool 11 | 12 | val pp : Format.formatter -> t -> unit 13 | 14 | end 15 | 16 | module Allocation : sig 17 | 18 | type t = 19 | | Bytes 20 | | Blocks 21 | | Allocations 22 | 23 | val equal : t -> t -> bool 24 | 25 | val pp : Format.formatter -> t -> unit 26 | 27 | end 28 | 29 | type t = 30 | | Allocation of int * Allocation.t 31 | | Call of Call.t 32 | 33 | val equal : t -> t -> bool 34 | 35 | val pp : Format.formatter -> t -> unit 36 | 37 | end 38 | 39 | module Direction : sig 40 | 41 | type t = 42 | | Normal 43 | | Inverted 44 | 45 | val equal : t -> t -> bool 46 | 47 | val pp : Format.formatter -> t -> unit 48 | 49 | end 50 | 51 | module Path : sig 52 | 53 | type t 54 | 55 | val create : Mode.t -> Direction.t -> Address.t list -> t 56 | 57 | val mode : t -> Mode.t 58 | 59 | val direction : t -> Direction.t 60 | 61 | val addresses : t -> Address.t list 62 | 63 | val with_mode : t -> Mode.t -> t 64 | 65 | val with_direction : t -> Direction.t -> t 66 | 67 | val pp : Format.formatter -> t -> unit 68 | 69 | end 70 | 71 | module Frame : sig 72 | 73 | type t 74 | 75 | val path : t -> Path.t 76 | 77 | val selected : t -> Address.t option 78 | 79 | val display : t -> string option 80 | 81 | end 82 | 83 | module Row : sig 84 | 85 | type t 86 | 87 | val address : t -> Address.t 88 | 89 | val value : t -> int 90 | 91 | val percentage : t -> float 92 | 93 | val display : t -> string 94 | 95 | val selection : t -> Path.t option 96 | 97 | end 98 | 99 | type t 100 | 101 | val table : series:Series.t -> path:Path.t -> t 102 | 103 | val row : t -> int -> Row.t option 104 | 105 | val size : t -> int 106 | 107 | val time : t -> float 108 | 109 | val total : t -> int 110 | 111 | val frames : t -> Frame.t list 112 | 113 | val find : (Row.t -> bool) -> t -> int 114 | 115 | module Memo : sig 116 | 117 | type table = t 118 | 119 | type t 120 | 121 | val create : series:Series.t -> t 122 | 123 | val table : t -> path:Path.t -> table 124 | 125 | end 126 | 127 | -------------------------------------------------------------------------------- /src/viewer.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open LTerm_text 3 | 4 | module State = struct 5 | 6 | type t = 7 | { memo : Table.Memo.t; 8 | has_calls : bool; 9 | no_of_snapshots : int; 10 | snapshot : int; 11 | path : Table.Path.t; 12 | table : Table.t; 13 | no_of_visible_rows : int; 14 | first_visible_row : int; 15 | selected_row : int; } 16 | 17 | let table { table; _ } = table 18 | 19 | let path { path; _ } = path 20 | 21 | let first_visible_row { first_visible_row; _ } = first_visible_row 22 | 23 | let selected_row { selected_row; _ } = selected_row 24 | 25 | let no_of_snapshots { no_of_snapshots; _ } = no_of_snapshots 26 | 27 | let create series = 28 | let memo = Table.Memo.create ~series in 29 | let has_calls = Series.has_call_counts series in 30 | let no_of_snapshots = List.length (Series.snapshots series) in 31 | let snapshot = 0 in 32 | let mode = 33 | if snapshot < no_of_snapshots || not has_calls then 34 | Table.Mode.Allocation(snapshot, Table.Mode.Allocation.Bytes) 35 | else 36 | Table.Mode.Call Table.Mode.Call.Calls 37 | in 38 | let direction = Table.Direction.Normal in 39 | let path = Table.Path.create mode direction [] in 40 | let table = Table.Memo.table memo ~path in 41 | let no_of_visible_rows = 0 in 42 | let first_visible_row = 0 in 43 | let selected_row = 0 in 44 | { memo; has_calls; no_of_snapshots; snapshot; path; table; 45 | no_of_visible_rows; first_visible_row; selected_row; } 46 | 47 | let bound_snapshot t snapshot = 48 | let snapshot = 49 | if snapshot >= t.no_of_snapshots then t.no_of_snapshots - 1 50 | else snapshot 51 | in 52 | let snapshot = 53 | if snapshot < 0 then 0 else snapshot 54 | in 55 | snapshot 56 | 57 | let bound_selected_row t selected_row = 58 | let size = Table.size t.table in 59 | let selected_row = 60 | if selected_row >= size then size - 1 else selected_row 61 | in 62 | let selected_row = 63 | if selected_row < 0 then 0 else selected_row 64 | in 65 | selected_row 66 | 67 | let make_selected_visible t selected_row = 68 | let size = Table.size t.table in 69 | let diff = selected_row - t.first_visible_row in 70 | let first_visible_row = 71 | if diff > t.no_of_visible_rows || diff < 0 then 72 | t.selected_row - (t.no_of_visible_rows / 2) 73 | else 74 | t.first_visible_row 75 | in 76 | if first_visible_row < 0 then 77 | 0 78 | else if t.no_of_visible_rows > size then 79 | 0 80 | else if first_visible_row + t.no_of_visible_rows > size then 81 | size - t.no_of_visible_rows 82 | else 83 | first_visible_row 84 | 85 | let resize t no_of_visible_rows = 86 | let first_visible_row = make_selected_visible t t.selected_row in 87 | { t with no_of_visible_rows; first_visible_row } 88 | 89 | let selected_address t = 90 | match Table.row t.table t.selected_row with 91 | | None -> None 92 | | Some row -> 93 | let address = Table.Row.address row in 94 | Some address 95 | 96 | let update t address snapshot path = 97 | let table = Table.Memo.table t.memo ~path in 98 | let selected_row = 99 | match address with 100 | | None -> 0 101 | | Some address -> begin 102 | match 103 | Table.find 104 | (fun row -> Address.equal (Table.Row.address row) address) 105 | table 106 | with 107 | | index -> index 108 | | exception Not_found -> 0 109 | end 110 | in 111 | let first_visible_row = make_selected_visible t selected_row in 112 | { t with snapshot; path; table; selected_row; first_visible_row } 113 | 114 | let next_mode t = 115 | let mode = Table.Path.mode t.path in 116 | let mode = 117 | match mode with 118 | | Table.Mode.Allocation(_, Table.Mode.Allocation.Bytes) -> 119 | if (t.snapshot < t.no_of_snapshots) then 120 | Table.Mode.Allocation(t.snapshot, Table.Mode.Allocation.Blocks) 121 | else if t.has_calls then 122 | Table.Mode.Call Table.Mode.Call.Calls 123 | else 124 | mode 125 | | Table.Mode.Allocation(_, Table.Mode.Allocation.Blocks) -> 126 | if (t.snapshot < t.no_of_snapshots) then 127 | Table.Mode.Allocation(t.snapshot, Table.Mode.Allocation.Allocations) 128 | else if t.has_calls then 129 | Table.Mode.Call Table.Mode.Call.Calls 130 | else 131 | mode 132 | | Table.Mode.Allocation(_, Table.Mode.Allocation.Allocations) -> 133 | if t.has_calls then 134 | Table.Mode.Call Table.Mode.Call.Calls 135 | else if(t.snapshot < t.no_of_snapshots) then 136 | Table.Mode.Allocation(t.snapshot, Table.Mode.Allocation.Bytes) 137 | else 138 | mode 139 | | Table.Mode.Call Table.Mode.Call.Calls -> 140 | if t.has_calls then 141 | Table.Mode.Call Table.Mode.Call.Indirect_calls 142 | else if(t.snapshot < t.no_of_snapshots) then 143 | Table.Mode.Allocation(t.snapshot, Table.Mode.Allocation.Bytes) 144 | else 145 | mode 146 | | Table.Mode.Call Table.Mode.Call.Indirect_calls -> 147 | if(t.snapshot < t.no_of_snapshots) then 148 | Table.Mode.Allocation(t.snapshot, Table.Mode.Allocation.Bytes) 149 | else if t.has_calls then 150 | Table.Mode.Call Table.Mode.Call.Calls 151 | else 152 | mode 153 | in 154 | let path = Table.Path.with_mode t.path mode in 155 | let address = selected_address t in 156 | update t address t.snapshot path 157 | 158 | let previous_mode t = 159 | let mode = Table.Path.mode t.path in 160 | let mode = 161 | match mode with 162 | | Table.Mode.Allocation(_, Table.Mode.Allocation.Bytes) -> 163 | if t.has_calls then 164 | Table.Mode.Call Table.Mode.Call.Indirect_calls 165 | else if (t.snapshot < t.no_of_snapshots) then 166 | Table.Mode.Allocation 167 | (t.snapshot, Table.Mode.Allocation.Allocations) 168 | else 169 | mode 170 | | Table.Mode.Allocation(_, Table.Mode.Allocation.Blocks) -> 171 | if (t.snapshot < t.no_of_snapshots) then 172 | Table.Mode.Allocation(t.snapshot, Table.Mode.Allocation.Bytes) 173 | else if t.has_calls then 174 | Table.Mode.Call Table.Mode.Call.Indirect_calls 175 | else 176 | mode 177 | | Table.Mode.Allocation(_, Table.Mode.Allocation.Allocations) -> 178 | if (t.snapshot < t.no_of_snapshots) then 179 | Table.Mode.Allocation(t.snapshot, Table.Mode.Allocation.Blocks) 180 | else if t.has_calls then 181 | Table.Mode.Call Table.Mode.Call.Indirect_calls 182 | else 183 | mode 184 | | Table.Mode.Call Table.Mode.Call.Calls -> 185 | if (t.snapshot < t.no_of_snapshots) then 186 | Table.Mode.Allocation 187 | (t.snapshot, Table.Mode.Allocation.Allocations) 188 | else if t.has_calls then 189 | Table.Mode.Call Table.Mode.Call.Indirect_calls 190 | else 191 | mode 192 | | Table.Mode.Call Table.Mode.Call.Indirect_calls -> 193 | if t.has_calls then 194 | Table.Mode.Call Table.Mode.Call.Calls 195 | else if (t.snapshot < t.no_of_snapshots) then 196 | Table.Mode.Allocation 197 | (t.snapshot, Table.Mode.Allocation.Allocations) 198 | else 199 | mode 200 | in 201 | let path = Table.Path.with_mode t.path mode in 202 | let address = selected_address t in 203 | update t address t.snapshot path 204 | 205 | let next_snapshot t = 206 | let snapshot = bound_snapshot t (t.snapshot + 1) in 207 | match Table.Path.mode t.path with 208 | | Table.Mode.Allocation(_, amode) -> 209 | let mode = Table.Mode.Allocation(snapshot, amode) in 210 | let path = Table.Path.with_mode t.path mode in 211 | let address = selected_address t in 212 | update t address snapshot path 213 | | Table.Mode.Call _ -> t 214 | 215 | let previous_snapshot t = 216 | let snapshot = bound_snapshot t (t.snapshot - 1) in 217 | match Table.Path.mode t.path with 218 | | Table.Mode.Allocation(_, amode) -> 219 | let mode = Table.Mode.Allocation(snapshot, amode) in 220 | let path = Table.Path.with_mode t.path mode in 221 | let address = selected_address t in 222 | update t address snapshot path 223 | | Table.Mode.Call _ -> t 224 | 225 | let select t = 226 | match Table.row t.table t.selected_row with 227 | | None -> t 228 | | Some row -> begin 229 | match Table.Row.selection row with 230 | | None -> t 231 | | Some path -> 232 | update t None t.snapshot path 233 | end 234 | 235 | let parent t = 236 | match Table.frames t.table with 237 | | [] | [_] -> t 238 | | _ :: parent :: _ -> 239 | let selected = Table.Frame.selected parent in 240 | let path = Table.Frame.path parent in 241 | update t selected t.snapshot path 242 | 243 | let invert t = 244 | let mode = Table.Path.mode t.path in 245 | let direction = 246 | match Table.Path.direction t.path with 247 | | Table.Direction.Normal -> Table.Direction.Inverted 248 | | Table.Direction.Inverted -> Table.Direction.Normal 249 | in 250 | let path = Table.Path.create mode direction [] in 251 | update t None t.snapshot path 252 | 253 | let next_row t = 254 | let selected_row = bound_selected_row t (t.selected_row + 1) in 255 | let first_visible_row = make_selected_visible t selected_row in 256 | { t with selected_row; first_visible_row } 257 | 258 | let previous_row t = 259 | let selected_row = bound_selected_row t (t.selected_row - 1) in 260 | let first_visible_row = make_selected_visible t selected_row in 261 | { t with selected_row; first_visible_row } 262 | 263 | let next_page t = 264 | let selected_row = 265 | bound_selected_row t (t.selected_row + t.no_of_visible_rows) 266 | in 267 | let first_visible_row = make_selected_visible t selected_row in 268 | { t with selected_row; first_visible_row } 269 | 270 | let previous_page t = 271 | let selected_row = 272 | bound_selected_row t (t.selected_row - t.no_of_visible_rows) 273 | in 274 | let first_visible_row = make_selected_visible t selected_row in 275 | { t with selected_row; first_visible_row } 276 | 277 | end 278 | 279 | let draw_header size ctx state = 280 | let header_bar = 281 | LTerm_style.{ none with foreground = Some white; background = Some blue } 282 | in 283 | let cols = LTerm_geom.cols size in 284 | LTerm_draw.draw_hline ctx 0 0 cols ~style:header_bar LTerm_draw.Blank; 285 | let table = State.table state in 286 | let time = Table.time table in 287 | let total = Table.total table in 288 | let path = State.path state in 289 | let snapshot, desc = 290 | match Table.Path.mode path with 291 | | Table.Mode.Allocation(snapshot, amode) -> 292 | let no_of_snapshots = State.no_of_snapshots state in 293 | let snapshot = 294 | if no_of_snapshots = 0 then 0 else snapshot + 1 295 | in 296 | let snapshot = 297 | Printf.sprintf " (%i/%i)" snapshot no_of_snapshots 298 | in 299 | let desc = 300 | match amode with 301 | | Table.Mode.Allocation.Bytes -> "live bytes" 302 | | Table.Mode.Allocation.Blocks -> "live blocks" 303 | | Table.Mode.Allocation.Allocations -> "allocated words" 304 | in 305 | snapshot, desc 306 | | Table.Mode.Call cmode -> 307 | let snapshot = "" in 308 | let desc = 309 | match cmode with 310 | | Table.Mode.Call.Calls -> "calls" 311 | | Table.Mode.Call.Indirect_calls -> "indirect calls" 312 | in 313 | snapshot, desc 314 | in 315 | let frames = 316 | let frames = Table.frames table in 317 | let frames = 318 | List.fold_right 319 | (fun frame acc -> 320 | match Table.Frame.display frame with 321 | | None -> acc 322 | | Some display -> display :: acc) 323 | frames [] 324 | in 325 | String.concat ";" frames 326 | in 327 | LTerm_draw.draw_styled ctx 0 0 ~style:header_bar 328 | (eval [ LTerm_text.S 329 | (Printf.sprintf "Time %f%s, Total %d %s [%s]" 330 | time snapshot total desc frames)]) 331 | 332 | let draw_row size ctx unit pos selected row = 333 | let value = Table.Row.value row in 334 | let percentage = Table.Row.percentage row in 335 | let display = Table.Row.display row in 336 | let colour = 337 | if percentage > 10. then 338 | LTerm_style.red 339 | else if percentage > 1. then 340 | LTerm_style.green 341 | else 342 | LTerm_style.default 343 | in 344 | let cols = LTerm_geom.cols size in 345 | let display_length = cols - 23 in 346 | let diff = display_length - (String.length display) in 347 | let display = 348 | if diff < 0 then 349 | String.sub display 0 display_length 350 | else 351 | display ^ String.make diff ' ' 352 | in 353 | LTerm_draw.draw_styled ctx (pos + 1) 0 354 | (eval [ LTerm_text.B_reverse selected; 355 | LTerm_text.B_fg colour; 356 | LTerm_text.S (Printf.sprintf " %5.2f%% " percentage); 357 | LTerm_text.E_fg; 358 | LTerm_text.S (Printf.sprintf " %10d" value); 359 | LTerm_text.S unit; 360 | LTerm_text.S " "; 361 | LTerm_text.S display; 362 | LTerm_text.E_reverse; ]) 363 | 364 | let draw ui matrix state = 365 | let size = LTerm_ui.size ui in 366 | let ctx = LTerm_draw.context matrix size in 367 | LTerm_draw.clear ctx; 368 | draw_header size ctx state; 369 | let path = State.path state in 370 | let unit = 371 | match Table.Path.mode path with 372 | | Table.Mode.Allocation(_, Table.Mode.Allocation.Bytes) -> "b" 373 | | Table.Mode.Allocation(_, Table.Mode.Allocation.Blocks) -> "b" 374 | | Table.Mode.Allocation(_, Table.Mode.Allocation.Allocations) -> "w" 375 | | Table.Mode.Call _ -> " " 376 | in 377 | let table = State.table state in 378 | let first_visible_row = State.first_visible_row state in 379 | let selected_row = State.selected_row state in 380 | for pos = 0 to (LTerm_geom.rows size - 1) do 381 | let idx = first_visible_row + pos in 382 | match Table.row table idx with 383 | | None -> () 384 | | Some row -> 385 | let selected = idx = selected_row in 386 | draw_row size ctx unit pos selected row 387 | done 388 | 389 | type response = 390 | | Update of State.t 391 | | Quit 392 | | Ignore 393 | 394 | let process_event state event = 395 | match event with 396 | | LTerm_event.Resize size -> 397 | let rows = (LTerm_geom.rows size) - 1 in 398 | Update (State.resize state rows) 399 | | LTerm_event.Key { code = LTerm_key.Tab; shift = false; _ } -> 400 | Update (State.next_mode state) 401 | | LTerm_event.Key { code = LTerm_key.Tab; shift = true; _ } -> 402 | Update (State.previous_mode state) 403 | | LTerm_event.Key { code = LTerm_key.Left; _ } -> 404 | Update (State.previous_snapshot state) 405 | | LTerm_event.Key { code = LTerm_key.Right; _ } -> 406 | Update (State.next_snapshot state) 407 | | LTerm_event.Key { code = LTerm_key.Up; _ } -> 408 | Update (State.previous_row state) 409 | | LTerm_event.Key { code = LTerm_key.Down; _ } -> 410 | Update (State.next_row state) 411 | | LTerm_event.Key { code = LTerm_key.Prev_page; _ } -> 412 | Update (State.previous_page state) 413 | | LTerm_event.Key { code = LTerm_key.Next_page; _ } -> 414 | Update (State.next_page state) 415 | | LTerm_event.Key { code = LTerm_key.Enter; _ } -> 416 | Update (State.select state) 417 | | LTerm_event.Key { code = LTerm_key.Escape; _ } 418 | | LTerm_event.Key { code = LTerm_key.Backspace; _ } -> 419 | Update (State.parent state) 420 | | LTerm_event.Key { code = LTerm_key.Char c; control; _ } -> 421 | if CamomileLibrary.UChar.char_of c = 'q' then 422 | Quit 423 | else if control && CamomileLibrary.UChar.char_of c = 'c' then 424 | Quit 425 | else if CamomileLibrary.UChar.char_of c = 'i' then 426 | Update (State.invert state) 427 | else 428 | Ignore 429 | | _ -> 430 | Ignore 431 | 432 | let rec event_loop ui state_ref = 433 | LTerm_ui.wait ui >>= fun event -> 434 | match process_event !state_ref event with 435 | | Quit -> 436 | Lwt.return () 437 | | Update state -> 438 | state_ref := state; 439 | LTerm_ui.draw ui; 440 | event_loop ui state_ref 441 | | Ignore -> 442 | event_loop ui state_ref 443 | 444 | let main series = 445 | let state_ref = ref (State.create series) in 446 | Lazy.force LTerm.stdout 447 | >>= fun term -> 448 | LTerm.set_escape_time term 0.2; 449 | LTerm_ui.create term (fun ui matrix -> draw ui matrix !state_ref) 450 | >>= fun ui -> 451 | let size = LTerm_ui.size ui in 452 | let rows = (LTerm_geom.rows size) - 1 in 453 | state_ref := State.resize !state_ref rows; 454 | LTerm_ui.draw ui; 455 | Lwt.finalize 456 | (fun () -> event_loop ui state_ref) 457 | (fun () -> LTerm_ui.quit ui) 458 | 459 | let show series = 460 | Lwt_main.run (main series) 461 | -------------------------------------------------------------------------------- /src/viewer.mli: -------------------------------------------------------------------------------- 1 | 2 | val show : Series.t -> unit 3 | --------------------------------------------------------------------------------