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 (* Find in mappings and return first predicate match. *)
  82 let _find_map { mappings = mappings } pred =
  83   let rec loop = function
  84     | [] -> None
  85     | m :: ms ->
  86         match pred m with
  87         | Some n -> Some n
  88         | None -> loop ms
  89   in
  90   loop mappings
  91
  92 (* Array+offset = string? *)
  93 let string_at arr offset str strlen =
  94   let j = ref offset in
  95   let rec loop i =
  96     if i >= strlen then true
  97     else
  98       if Array1.get arr !j <> str.[i] then false
  99       else (
 100         incr j;
 101         loop (i+1)
 102       )
 103   in
 104   loop 0
 105
 106 (* Find in a single file mapping.
 107  * [start] is relative to the mapping and we return an offset relative
 108  * to the mapping.
 109  *)
 110 let _find_in start align str arr =
 111   let strlen = String.length str in
 112   if strlen > 0 then (
 113     let j = ref start in
 114     let e = Array1.dim arr - strlen in
 115     let rec loop () =
 116       if !j <= e then (
 117         if string_at arr !j str strlen then Some !j
 118         else (
 119           j := !j + align;
 120           loop ()
 121         )
 122       )
 123       else None
 124     in
 125     loop ()
 126   )
 127   else Some start
 128
 129 (* Generic find function. *)
 130 let _find t start align str =
 131   _find_map t (
 132     fun { start = mstart; size = msize; arr = arr } ->
 133       if mstart >= start then (
 134         (* Check this mapping from the beginning. *)
 135         match _find_in 0 align str arr with
 136         | Some offset -> Some (mstart +^ Int64.of_int offset)
 137         | None -> None
 138       )
 139       else if mstart < start && start <= mstart+^msize then (
 140         (* Check this mapping from somewhere in the middle. *)
 141         let offset = Int64.to_int (start -^ mstart) in
 142         match _find_in offset align str arr with
 143         | Some offset -> Some (mstart +^ Int64.of_int offset)
 144         | None -> None
 145       )
 146       else None
 147   )
 148
 149 let find t ?(start=0L) str =
 150   _find t start 1 str
 151
 152 let find_align t ?(start=0L) str =
 153   let align = bytes_of_wordsize (get_wordsize t) in
 154   _find t start align str
 155
 156 let rec _find_all t start align str =
 157   match _find t start align str with
 158   | None -> []
 159   | Some offset ->
 160       offset :: _find_all t (offset +^ Int64.of_int align) align str
 161
 162 let find_all t ?(start=0L) str =
 163   _find_all t start 1 str
 164
 165 let find_all_align t ?(start=0L) str =
 166   let align = bytes_of_wordsize (get_wordsize t) in
 167   _find_all t start align str
 168
 169 (* NB: Phantom types in the interface ensure that these pointer functions
 170  * can only be called once endianness and wordsize have both been set.
 171  *)
 172
 173 let rec find_pointer t ?start addr =
 174   find_align t ?start (string_of_addr t addr)
 175
 176 and find_pointer_all t ?start addr =
 177   find_all_align t ?start (string_of_addr t addr)
 178
 179 (*
 180 and string_of_addr t addr =
 181   let bits = bits_of_wordsize (get_wordsize t) in
 182   let e = get_endian t in
 183   let bs = BITSTRING { addr : bits : endian (e) } in
 184   Bitmatch.string_of_bitstring bs
 185 *)
 186 (* XXX bitmatch is missing 'construct_int64_le_unsigned' so we
 187  * have to force this to 32 bits for the moment.
 188  *)
 189 and string_of_addr t addr =
 190   let bits = bits_of_wordsize (get_wordsize t) in
 191   assert (bits = 32);
 192   let e = get_endian t in
 193   let bs = BITSTRING { Int64.to_int32 addr : 32 : endian (e) } in
 194   Bitmatch.string_of_bitstring bs
 195
 196 and addr_of_string t str =
 197   let bits = bits_of_wordsize (get_wordsize t) in
 198   let e = get_endian t in
 199   let bs = Bitmatch.bitstring_of_string str in
 200   bitmatch bs with
 201   | { addr : bits : endian (e) } -> addr
 202   | { _ } -> invalid_arg "addr_of_string"
 203
 204 let get_byte { mappings = mappings } addr =
 205   let rec loop = function
 206     | [] -> invalid_arg "get_byte"
 207     | { start = start; size = size; arr = arr } :: _
 208         when start <= addr && addr < start +^ size ->
 209         let offset = Int64.to_int (addr -^ start) in
 210         Char.code (Array1.get arr offset)
 211     | _ :: ms -> loop ms
 212   in
 213   loop mappings
 214
 215 (* Take bytes until a condition is not met.  This is efficient in that
 216  * we stay within the same mapping as long as we can.
 217  *)
 218 let dowhile { mappings = mappings } addr cond =
 219   let rec get_next_mapping addr = function
 220     | [] -> invalid_arg "dowhile"
 221     | { start = start; size = size; arr = arr } :: _
 222         when start <= addr && addr < start +^ size ->
 223         let offset = Int64.to_int (addr -^ start) in
 224         let len = Int64.to_int size - offset in
 225         arr, offset, len
 226     | _ :: ms -> get_next_mapping addr ms
 227   in
 228   let rec loop addr =
 229     let arr, offset, len = get_next_mapping addr mappings in
 230     let rec loop2 i =
 231       if i < len then (
 232         let c = Array1.get arr (offset+i) in
 233         if cond c then loop2 (i+1)
 234       ) else
 235         loop (addr +^ Int64.of_int len)
 236     in
 237     loop2 0
 238   in
 239   loop addr
 240
 241 let get_bytes t addr len =
 242   let str = String.create len in
 243   let i = ref 0 in
 244   try
 245     dowhile t addr (
 246       fun c ->
 247         str.[!i] <- c;
 248         incr i;
 249         !i < len
 250     );
 251     str
 252   with
 253     Invalid_argument _ -> invalid_arg "get_bytes"
 254
 255 let get_string t addr =
 256   let chars = ref [] in
 257   try
 258     dowhile t addr (
 259       fun c ->
 260         if c <> '\000' then (
 261           chars := c :: !chars;
 262           true
 263         ) else false
 264     );
 265     let chars = List.rev !chars in
 266     let len = List.length chars in
 267     let str = String.create len in
 268     let i = ref 0 in
 269     List.iter (fun c -> str.[!i] <- c; incr i) chars;
 270     str
 271   with
 272     Invalid_argument _ -> invalid_arg "get_string"
 273
 274 let is_string t addr =
 275   try dowhile t addr (fun c -> c <> '\000'); true
 276   with Invalid_argument _ -> false
 277
 278 let is_C_identifier t addr =
 279   let i = ref 0 in
 280   let r = ref true in
 281   try
 282     dowhile t addr (
 283       fun c ->
 284         let b =
 285           if !i = 0 then (
 286             c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z'
 287           ) else (
 288             if c = '\000' then false
 289             else (
 290               if c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z' ||
 291                 c >= '0' && c <= '9' then
 292                   true
 293               else (
 294                 r := false;
 295                 false
 296               )
 297             )
 298           ) in
 299         incr i;
 300         b
 301     );
 302     !r
 303   with
 304     Invalid_argument _ -> false
 305
 306 let is_mapped { mappings = mappings } addr =
 307   let rec loop = function
 308     | [] -> false
 309     | { start = start; size = size; arr = arr } :: _
 310         when start <= addr && addr < start +^ size -> true
 311     | _ :: ms -> loop ms
 312   in
 313   loop mappings
 314
 315 let follow_pointer t addr =
 316   let ws = get_wordsize t in
 317   let e = get_endian t in
 318   let bits = bits_of_wordsize ws in
 319   let str = get_bytes t addr (bytes_of_wordsize ws) in
 320   let bs = Bitmatch.bitstring_of_string str in
 321   bitmatch bs with
 322   | { addr : bits : endian (e) } -> addr
 323   | { _ } -> invalid_arg "follow_pointer"
 324
 325 let succ_long t addr =
 326   let ws = get_wordsize t in
 327   addr +^ Int64.of_int (bytes_of_wordsize ws)
 328
 329 let pred_long t addr =
 330   let ws = get_wordsize t in
 331   addr -^ Int64.of_int (bytes_of_wordsize ws)
 332
 333 let align t addr =
 334   let ws = get_wordsize t in
 335   let mask = Int64.of_int (bytes_of_wordsize ws - 1) in
 336   (addr +^ mask) &^ (Int64.lognot mask)