lib/virt_mem_utils.ml

   1 (** Common and utility functions. *)
   2 (* Memory info command for virtual domains.
   3    (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc.
   4    http://libvirt.org/
   5
   6    This program is free software; you can redistribute it and/or modify
   7    it under the terms of the GNU General Public License as published by
   8    the Free Software Foundation; either version 2 of the License, or
   9    (at your option) any later version.
  10
  11    This program is distributed in the hope that it will be useful,
  12    but WITHOUT ANY WARRANTY; without even the implied warranty of
  13    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14    GNU General Public License for more details.
  15
  16    You should have received a copy of the GNU General Public License
  17    along with this program; if not, write to the Free Software
  18    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19
  20    Common & utility functions.
  21  *)
  22
  23 open Printf
  24
  25 let ( +^ ) = Int64.add
  26 let ( -^ ) = Int64.sub
  27 let ( *^ ) = Int64.mul
  28 let ( /^ ) = Int64.div
  29 let ( &^ ) = Int64.logand
  30 let ( |^ ) = Int64.logor
  31
  32 type architecture =
  33   | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
  34
  35 let string_of_architecture = function
  36   | I386 -> "i386"
  37   | X86_64 -> "x86_64"
  38   | IA64 -> "ia64"
  39   | PPC -> "ppc"
  40   | PPC64 -> "ppc64"
  41   | SPARC -> "sparc"
  42   | SPARC64 -> "sparc64"
  43
  44 let architecture_of_string = function
  45   | str when
  46       String.length str = 4 &&
  47       (str.[0] = 'i' || str.[0] = 'I') &&
  48       (str.[1] >= '3' && str.[1] <= '6') &&
  49       str.[2] = '8' && str.[3] = '6' -> I386
  50   | "x86_64" | "X86_64" | "x86-64" | "X86-64" -> X86_64
  51   | "ia64" | "IA64" -> IA64
  52   | "ppc" | "PPC" | "ppc32" | "PPC32" -> PPC
  53   | "ppc64" | "PPC64" -> PPC64
  54   | "sparc" | "SPARC" | "sparc32" | "SPARC32" -> SPARC
  55   | "sparc64" | "SPARC64" -> SPARC64
  56   | str ->
  57       failwith (sprintf "architecture_of_string: %s: unknown architecture"
  58                   str)
  59
  60 let endian_of_architecture = function
  61   | I386 | X86_64 -> Bitstring.LittleEndian
  62   | IA64 -> Bitstring.LittleEndian (* XXX usually? *)
  63   | PPC | PPC64 | SPARC | SPARC64 -> Bitstring.BigEndian
  64
  65 type wordsize =
  66   | W32 | W64
  67
  68 let wordsize_of_architecture = function
  69   | I386 -> W32
  70   | X86_64 -> W64
  71   | IA64 -> W64
  72   | PPC -> W32
  73   | PPC64 -> W64
  74   | SPARC -> W32
  75   | SPARC64 -> W64
  76
  77 let bits_of_wordsize = function
  78   | W32 -> 32 | W64 -> 64
  79 let bytes_of_wordsize = function
  80   | W32 -> 4 | W64 -> 8
  81
  82 (** Returns (count, value) in order of highest frequency occurring in the
  83     list. *)
  84 let frequency xs =
  85   let xs = List.sort compare xs in
  86   let rec loop = function
  87     | [] -> []
  88     | [x] -> [1, x]
  89     | x :: y :: xs when x = y ->
  90         let rest = loop (y :: xs) in
  91         let (count, _), rest = List.hd rest, List.tl rest in
  92         (count+1, y) :: rest
  93     | x :: xs ->
  94         (1, x) :: loop xs
  95   in
  96   let xs = loop xs in
  97   List.rev (List.sort compare xs)
  98
  99 (** Like the Unix uniq(1) command. *)
 100 let rec uniq ?(cmp = Pervasives.compare) = function
 101   | [] -> []
 102   | [x] -> [x]
 103   | x :: y :: xs when cmp x y = 0 ->
 104       uniq (x :: xs)
 105   | x :: y :: xs ->
 106       x :: uniq (y :: xs)
 107
 108 (** Like the Unix pipeline 'sort|uniq'. *)
 109 let sort_uniq ?cmp xs =
 110   let xs = ExtList.List.sort ?cmp xs in
 111   let xs = uniq ?cmp xs in
 112   xs
 113
 114 (** Pad a string to a fixed width (from virt-top, but don't truncate). *)
 115 let pad width str =
 116   let n = String.length str in
 117   if n >= width then str
 118   else (* if n < width then *) str ^ String.make (width-n) ' '
 119
 120 (** General binary tree type.  Data 'a is stored in the leaves and 'b
 121     is stored in the nodes. *)
 122 type ('a,'b) binary_tree =
 123   | Leaf of 'a
 124   | Node of ('a,'b) binary_tree * 'b * ('a,'b) binary_tree
 125
 126 (** Print out the binary tree in graphviz dot format. *)
 127 let print_binary_tree leaf_printer node_printer tree =
 128   (* Assign a unique, fixed label to each node. *)
 129   let label =
 130     let i = ref 0 in
 131     let hash = Hashtbl.create 13 in
 132     fun node ->
 133       try Hashtbl.find hash node
 134       with Not_found ->
 135         let i = incr i; !i in
 136         let label = "n" ^ string_of_int i in
 137         Hashtbl.add hash node label;
 138         label
 139   in
 140   (* Recursively generate the graphviz file. *)
 141   let rec print = function
 142     | (Leaf a as leaf) ->
 143         eprintf "  %s [shape=box, label=\"%s\"];\n"
 144           (label leaf) (leaf_printer a)
 145     | (Node (left,b,right) as node) ->
 146         eprintf "  %s [label=\"%s\"];\n"
 147           (label node) (node_printer b);
 148         eprintf "  %s -> %s [tailport=sw];\n" (label node) (label left);
 149         eprintf "  %s -> %s [tailport=se];\n" (label node) (label right);
 150         print left;
 151         print right;
 152   in
 153   eprintf "/* Use 'dot -Tpng foo.dot > foo.png' to convert to a png file. */\n";
 154   eprintf "digraph G {\n";
 155   print tree;
 156   eprintf "}\n%!"