Trremap visualisation (and parse linker flags)
#!/usr/bin/env ocaml | |
#use "topfind" | |
#require "cmdliner" | |
#require "astring" | |
#require "unix" | |
(* based on "Squarified Treemaps" by Mark Bruls, Kees Huizing and Jarke J. van Wijk http://www.win.tue.nl/~vanwijk/stm.pdf *) | |
let width (w, h) = | |
if w <= h then w else h | |
let sum xs = List.fold_left (+.) 0. xs | |
let layoutrow (x, y) (offx, offy) w row = | |
let maxx, maxy = offx +. x, offy +. y in | |
let eles = List.rev row in | |
let sum = sum eles in | |
let height = sum /. w in | |
let off, left, r = if x < y then | |
let coords, fin = | |
List.fold_left (fun (acc, offw) v -> | |
let w = v /. height in | |
(((offw, offy), (w, height)) :: acc, offw +. w)) | |
([], offx) eles | |
in | |
((offx, offy +. height), (maxx -. offx, maxy -. (offy +. height)), List.rev coords) | |
else | |
let coords, fin = | |
List.fold_left (fun (acc, offh) v -> | |
let w = v /. height in | |
(((offx, offh), (height, w)) :: acc, offh +. w)) | |
([], offy) eles | |
in | |
((offx +. height, offy), (maxx -. (offx +. height), maxy -. offy), List.rev coords) | |
in | |
(off, left, r) | |
let minmax r = | |
let sorted = List.sort compare r in | |
match sorted, List.rev sorted with | |
| x::_, y::_ -> (x, y) | |
| _ -> assert false | |
let worst r w = | |
match r with | |
| [] -> infinity | |
| _ -> | |
let smallest, biggest = minmax r | |
and s = sum r | |
and ww = w *. w | |
in | |
let ss = s *. s in | |
let f, g = | |
((ww *. biggest) /. ss), | |
(ss /. (ww *. smallest)) | |
in | |
max f g | |
let rec squarify off left children row w acc = | |
match children with | |
| [] -> | |
let off, rect, row = layoutrow left off w row in | |
List.rev (row :: acc) | |
| c::cs -> | |
let w1, w2 = (worst row w), (worst (c::row) w) in | |
if w1 > w2 then | |
squarify off left cs (c::row) w acc | |
else | |
let off, nrec, row = layoutrow left off w row in | |
let w = width nrec in | |
squarify off nrec children [] w (row :: acc) | |
let square eles rect = | |
let w = width rect in | |
let rows = squarify (0.,0.) rect eles [] w [] in | |
rows | |
let p v ((x,y), (w,h)) = | |
Printf.sprintf "%d %f,%f (%f,%f)" v x y w h | |
let colors = [ "#ECD078" ; "#D95B43" ; "#C02942" ; "#542437" ; "#53777A" ] | |
let c = ref 0 | |
let svg_header = {___|<svg width="1000" height="800" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">|___} | |
and svg_footer = "</svg>" | |
and svg_rect (v, s) ((x, y), (w, h)) = | |
let ti x = int_of_float x in | |
let textx, texty = x +. 10., y +. (h /. 2.) in | |
incr c ; | |
Printf.sprintf "<g><rect x=\"%d\" y=\"%d\" height=\"%d\" width=\"%d\" style=\"stroke:#006000; fill: %s\"/> <text x=\"%d\" y=\"%d\">%s</text><title>%s (%d)</title></g>" | |
(ti x) (ti y) (ti h) (ti w) (List.nth colors (!c mod (List.length colors))) (ti textx) (ti texty) (Filename.basename v) v s | |
let fns x = | |
try | |
let stat = Unix.stat x in | |
stat.Unix.st_size | |
with | |
| _ -> 0 | |
(* pretend to be a linker *) | |
let rec normalise = function | |
| [] -> [] | |
| _::_::".."::".."::xs -> normalise xs | |
| _::".."::xs -> normalise xs | |
| y::ys -> y :: normalise ys | |
let strip s = | |
"/" ^ String.concat "/" (normalise (Astring.String.cuts ~sep:"/" ~empty:false s)) | |
let libs ll x = | |
let name = "lib" ^ x ^ ".a" in | |
let rec find = function | |
| [] -> 0, "none" | |
| l::ls -> | |
let name = Filename.concat l name in | |
match fns name with | |
| 0 -> find ls | |
| x -> (x, name) | |
in | |
find ll | |
let foo o l ll _d _m _t oa = | |
let size = List.map fns oa in | |
Printf.printf "size is %d\n%!" (List.length size) ; | |
let l = List.filter (fun x -> not (x = "pthread" || x = "m" || x = "dl")) l in | |
let ll = List.map strip ll in | |
let lsize, lname = List.split (List.map (libs ll) l) in | |
let names = oa @ lname in | |
let size = size @ lsize in | |
let total = float_of_int (List.fold_left (+) 0 size) in | |
let rect = 1000., 800. in | |
let have = fst rect *. snd rect in | |
let sizes = List.map (fun s -> (have *. float_of_int s) /. total) size in | |
let files = | |
List.sort | |
(fun (_, a) (_, b) -> compare b a) | |
(List.combine (List.combine names size) sizes) | |
in | |
let names, sizes = List.split | |
(List.filter (fun (_, a) -> a > (have *. 0.1) /. total) files) | |
in | |
let rows = square sizes (1000., 800.) in | |
let pieces pp = List.map2 pp names (List.flatten rows) in | |
Printf.printf "%s\n%s\n%s\n" svg_header (String.concat "\n" (pieces svg_rect)) svg_footer | |
open Cmdliner | |
(* -o -L -l *) | |
let o = Arg.(value & opt (some string) None & info ["o"]) | |
let l = Arg.(value & opt_all string [] & info ["l"]) | |
let ll = Arg.(value & opt_all string [] & info ["L"]) | |
(* ld gets some more arguments: -T<script> -m <arch> -d -static -nostdlib *) | |
let d = Arg.(value & flag & info ["d"]) | |
let m = Arg.(value & opt string "" & info ["m"]) | |
let t = Arg.(value & opt string "" & info ["T"]) | |
let oa = Arg.(value & pos_all string [] & info []) | |
let () = | |
let env = try Sys.getenv "EXTRA" with Not_found -> "" in | |
let args = Astring.String.cuts ~sep:" " ~empty:false | |
(String.concat " " (Astring.String.cuts ~sep:"\n" ~empty:false env)) in | |
let args = List.filter (fun x -> not (x = "-static" || x = "-nostdlib" || x = "_build/main.native.o" || x = "\\")) args in | |
let argv = Array.append Sys.argv (Array.of_list args) in | |
match Term.(eval ~argv (pure foo $ o $ l $ ll $ d $ m $ t $ oa, info "bla")) with | |
| `Help | `Version | `Ok _ -> exit 0 | |
| `Error _ -> exit 1 | |
(* use it with ocamlopt: | |
ocamlopt -cc ~/treemap.ml ... > foo-bytes.svg | |
for MirageOS (and esp Xen), once mirage configure ran: | |
setenv EXTRA <all the stuff in the Makefile passed to ld> | |
make | |
copy&paste ocamlbuild invocation, add a -verbose 2 | |
cd _build | |
copy&paste ocamlfind ocamlopt invocation, add -cc ~/treemap.ml to ocamlopt arguments, remove -output-obj > foo-bytes.svg | |
*) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment