lib/virt_mem_mmap.ml

   1 (* Memory info command for virtual domains.
   2    (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4
   5    This program is free software; you can redistribute it and/or modify
   6    it under the terms of the GNU General Public License as published by
   7    the Free Software Foundation; either version 2 of the License, or
   8    (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful,
  11    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13    GNU General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18
  19    Functions for making a memory map of a virtual machine from
  20    various sources.  The memory map will most certainly have holes.
  21  *)
  22
  23 open Unix
  24 open Bigarray
  25
  26 open Virt_mem_utils
  27
  28 (* Simple implementation at the moment: Store a list of mappings,
  29  * sorted by start address.  We assume that mappings do not overlap.
  30  * We can change the implementation later if we need to.  In most cases
  31  * there will only be a small number of mappings (probably 1).
  32  *)
  33 type ('a,'b) t = {
  34   mappings : mapping list;
  35   wordsize : wordsize option;
  36   endian : Bitmatch.endian option;
  37 }
  38 and mapping = {
  39   start : addr;
  40   size : addr;
  41   (* Bigarray mmap(2)'d region with byte addressing: *)
  42   arr : (char,int8_unsigned_elt,c_layout) Array1.t;
  43 }
  44
  45 and addr = int64
  46
  47 let create () = {
  48   mappings = [];
  49   wordsize = None;
  50   endian = None
  51 }
  52
  53 let set_wordsize t ws = { t with wordsize = Some ws }
  54
  55 let set_endian t e = { t with endian = Some e }
  56
  57 let get_wordsize t = Option.get t.wordsize
  58
  59 let get_endian t = Option.get t.endian
  60
  61 let sort_mappings mappings =
  62   let cmp { start = s1 } { start = s2 } = compare s1 s2 in
  63   List.sort cmp mappings
  64
  65 let add_file ({ mappings = mappings } as t) fd addr =
  66   if addr &^ 7L <> 0L then
  67     invalid_arg "add_file: mapping address must be aligned to 8 bytes";
  68   let size = (fstat fd).st_size in
  69   (* mmap(2) the file using Bigarray module. *)
  70   let arr = Array1.map_file fd char c_layout false size in
  71   (* Create the mapping entry and keep the mappings sorted by start addr. *)
  72   let mappings =
  73     { start = addr; size = Int64.of_int size; arr = arr } :: mappings in
  74   let mappings = sort_mappings mappings in
  75   { t with mappings = mappings }
  76
  77 let of_file fd addr =
  78   let t = create () in
  79   add_file t fd addr
  80
  81 let add_string ({ mappings = mappings } as t) str addr =
  82   if addr &^ 7L <> 0L then
  83     invalid_arg "add_file: mapping address must be aligned to 8 bytes";
  84   let size = String.length str in
  85   (* Copy the string data to a Bigarray. *)
  86   let arr = Array1.create char c_layout size in
  87   for i = 0 to size-1 do
  88     Array1.set arr i (String.unsafe_get str i)
  89   done;
  90   (* Create the mapping entry and keep the mappings sorted by start addr. *)
  91   let mappings =
  92     { start = addr; size = Int64.of_int size; arr = arr } :: mappings in
  93   let mappings = sort_mappings mappings in
  94   { t with mappings = mappings }
  95
  96 let of_string str addr =
  97   let t = create () in
  98   add_string t str addr
  99
 100 (* Find in mappings and return first predicate match. *)
 101 let _find_map { mappings = mappings } pred =
 102   let rec loop = function
 103     | [] -> None
 104     | m :: ms ->
 105         match pred m with
 106         | Some n -> Some n
 107         | None -> loop ms
 108   in
 109   loop mappings
 110
 111 (* The following functions are actually written in C
 112  * because memmem(3) is likely to be much faster than anything
 113  * we could write in OCaml.
 114  *
 115  * Also OCaml bigarrays are specifically designed to be accessed
 116  * easily from C:
 117  *   http://caml.inria.fr/pub/docs/manual-ocaml/manual043.html
 118  *)
 119 (*
 120 (* Array+offset = string? *)
 121 let string_at arr offset str strlen =
 122   let j = ref offset in
 123   let rec loop i =
 124     if i >= strlen then true
 125     else
 126       if Array1.get arr !j <> str.[i] then false
 127       else (
 128         incr j;
 129         loop (i+1)
 130       )
 131   in
 132   loop 0
 133
 134 (* Find in a single file mapping.
 135  * [start] is relative to the mapping and we return an offset relative
 136  * to the mapping.
 137  *)
 138 let _find_in start align str arr =
 139   let strlen = String.length str in
 140   if strlen > 0 then (
 141     let j = ref start in
 142     let e = Array1.dim arr - strlen in
 143     let rec loop () =
 144       if !j <= e then (
 145         if string_at arr !j str strlen then Some !j
 146         else (
 147           j := !j + align;
 148           loop ()
 149         )
 150       )
 151       else None
 152     in
 153     loop ()
 154   )
 155   else Some start
 156 *)
 157 external _find_in :
 158   int -> int -> string -> (char,int8_unsigned_elt,c_layout) Array1.t ->
 159   int option = "virt_mem_mmap_find_in"
 160
 161 (* Generic find function. *)
 162 let _find t start align str =
 163   _find_map t (
 164     fun { start = mstart; size = msize; arr = arr } ->
 165       if mstart >= start then (
 166         (* Check this mapping from the beginning. *)
 167         match _find_in 0 align str arr with
 168         | Some offset -> Some (mstart +^ Int64.of_int offset)
 169         | None -> None
 170       )
 171       else if mstart < start && start <= mstart+^msize then (
 172         (* Check this mapping from somewhere in the middle. *)
 173         let offset = Int64.to_int (start -^ mstart) in
 174         match _find_in offset align str arr with
 175         | Some offset -> Some (mstart +^ Int64.of_int offset)
 176         | None -> None
 177       )
 178       else None
 179   )
 180
 181 let find t ?(start=0L) str =
 182   _find t start 1 str
 183
 184 let find_align t ?(start=0L) str =
 185   let align = bytes_of_wordsize (get_wordsize t) in
 186   _find t start align str
 187
 188 let rec _find_all t start align str =
 189   match _find t start align str with
 190   | None -> []
 191   | Some offset ->
 192       offset :: _find_all t (offset +^ Int64.of_int align) align str
 193
 194 let find_all t ?(start=0L) str =
 195   _find_all t start 1 str
 196
 197 let find_all_align t ?(start=0L) str =
 198   let align = bytes_of_wordsize (get_wordsize t) in
 199   _find_all t start align str
 200
 201 (* NB: Phantom types in the interface ensure that these pointer functions
 202  * can only be called once endianness and wordsize have both been set.
 203  *)
 204
 205 let rec find_pointer t ?start addr =
 206   find_align t ?start (string_of_addr t addr)
 207
 208 and find_pointer_all t ?start addr =
 209   find_all_align t ?start (string_of_addr t addr)
 210
 211 (*
 212 and string_of_addr t addr =
 213   let bits = bits_of_wordsize (get_wordsize t) in
 214   let e = get_endian t in
 215   let bs = BITSTRING { addr : bits : endian (e) } in
 216   Bitmatch.string_of_bitstring bs
 217 *)
 218 (* XXX bitmatch is missing 'construct_int64_le_unsigned' so we
 219  * have to force this to 32 bits for the moment.
 220  *)
 221 and string_of_addr t addr =
 222   let bits = bits_of_wordsize (get_wordsize t) in
 223   assert (bits = 32);
 224   let e = get_endian t in
 225   let bs = BITSTRING { Int64.to_int32 addr : 32 : endian (e) } in
 226   Bitmatch.string_of_bitstring bs
 227
 228 and addr_of_string t str =
 229   let bits = bits_of_wordsize (get_wordsize t) in
 230   let e = get_endian t in
 231   let bs = Bitmatch.bitstring_of_string str in
 232   bitmatch bs with
 233   | { addr : bits : endian (e) } -> addr
 234   | { _ } -> invalid_arg "addr_of_string"
 235
 236 let get_byte { mappings = mappings } addr =
 237   let rec loop = function
 238     | [] -> invalid_arg "get_byte"
 239     | { start = start; size = size; arr = arr } :: _
 240         when start <= addr && addr < start +^ size ->
 241         let offset = Int64.to_int (addr -^ start) in
 242         Char.code (Array1.get arr offset)
 243     | _ :: ms -> loop ms
 244   in
 245   loop mappings
 246
 247 (* Take bytes until a condition is not met.  This is efficient in that
 248  * we stay within the same mapping as long as we can.
 249  *)
 250 let dowhile { mappings = mappings } addr cond =
 251   let rec get_next_mapping addr = function
 252     | [] -> invalid_arg "dowhile"
 253     | { start = start; size = size; arr = arr } :: _
 254         when start <= addr && addr < start +^ size ->
 255         let offset = Int64.to_int (addr -^ start) in
 256         let len = Int64.to_int size - offset in
 257         arr, offset, len
 258     | _ :: ms -> get_next_mapping addr ms
 259   in
 260   let rec loop addr =
 261     let arr, offset, len = get_next_mapping addr mappings in
 262     let rec loop2 i =
 263       if i < len then (
 264         let c = Array1.get arr (offset+i) in
 265         if cond c then loop2 (i+1)
 266       ) else
 267         loop (addr +^ Int64.of_int len)
 268     in
 269     loop2 0
 270   in
 271   loop addr
 272
 273 let get_bytes t addr len =
 274   let str = String.create len in
 275   let i = ref 0 in
 276   try
 277     dowhile t addr (
 278       fun c ->
 279         str.[!i] <- c;
 280         incr i;
 281         !i < len
 282     );
 283     str
 284   with
 285     Invalid_argument _ -> invalid_arg "get_bytes"
 286
 287 let get_int32 t addr =
 288   let e = get_endian t in
 289   let str = get_bytes t addr 4 in
 290   let bs = Bitmatch.bitstring_of_string str in
 291   bitmatch bs with
 292   | { addr : 32 : endian (e) } -> addr
 293   | { _ } -> invalid_arg "follow_pointer"
 294
 295 let get_int64 t addr =
 296   let e = get_endian t in
 297   let str = get_bytes t addr 8 in
 298   let bs = Bitmatch.bitstring_of_string str in
 299   bitmatch bs with
 300   | { addr : 64 : endian (e) } -> addr
 301   | { _ } -> invalid_arg "follow_pointer"
 302
 303 let get_C_int = get_int32
 304
 305 let get_C_long t addr =
 306   let ws = get_wordsize t in
 307   match ws with
 308   | W32 -> Int64.of_int32 (get_int32 t addr)
 309   | W64 -> get_int64 t addr
 310
 311 let get_string t addr =
 312   let chars = ref [] in
 313   try
 314     dowhile t addr (
 315       fun c ->
 316         if c <> '\000' then (
 317           chars := c :: !chars;
 318           true
 319         ) else false
 320     );
 321     let chars = List.rev !chars in
 322     let len = List.length chars in
 323     let str = String.create len in
 324     let i = ref 0 in
 325     List.iter (fun c -> str.[!i] <- c; incr i) chars;
 326     str
 327   with
 328     Invalid_argument _ -> invalid_arg "get_string"
 329
 330 let is_string t addr =
 331   try dowhile t addr (fun c -> c <> '\000'); true
 332   with Invalid_argument _ -> false
 333
 334 let is_C_identifier t addr =
 335   let i = ref 0 in
 336   let r = ref true in
 337   try
 338     dowhile t addr (
 339       fun c ->
 340         let b =
 341           if !i = 0 then (
 342             c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z'
 343           ) else (
 344             if c = '\000' then false
 345             else (
 346               if c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z' ||
 347                 c >= '0' && c <= '9' then
 348                   true
 349               else (
 350                 r := false;
 351                 false
 352               )
 353             )
 354           ) in
 355         incr i;
 356         b
 357     );
 358     !r
 359   with
 360     Invalid_argument _ -> false
 361
 362 let is_mapped { mappings = mappings } addr =
 363   let rec loop = function
 364     | [] -> false
 365     | { start = start; size = size; arr = arr } :: _
 366         when start <= addr && addr < start +^ size -> true
 367     | _ :: ms -> loop ms
 368   in
 369   loop mappings
 370
 371 let follow_pointer t addr =
 372   let ws = get_wordsize t in
 373   let e = get_endian t in
 374   let bits = bits_of_wordsize ws in
 375   let str = get_bytes t addr (bytes_of_wordsize ws) in
 376   let bs = Bitmatch.bitstring_of_string str in
 377   bitmatch bs with
 378   | { addr : bits : endian (e) } -> addr
 379   | { _ } -> invalid_arg "follow_pointer"
 380
 381 let succ_long t addr =
 382   let ws = get_wordsize t in
 383   addr +^ Int64.of_int (bytes_of_wordsize ws)
 384
 385 let pred_long t addr =
 386   let ws = get_wordsize t in
 387   addr -^ Int64.of_int (bytes_of_wordsize ws)
 388
 389 let align t addr =
 390   let ws = get_wordsize t in
 391   let mask = Int64.of_int (bytes_of_wordsize ws - 1) in
 392   (addr +^ mask) &^ (Int64.lognot mask)