Create a gist now

Instantly share code, notes, and snippets.

@hannesm /treemap.ml
Last active Jun 11, 2016

What would you like to do?
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