Trremap visualisation (and parse linker flags)

treemap.ml

#!/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
 *)