1 (* Memory info command for virtual domains.
2 (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc.
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.
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.
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.
19 Functions for making a memory map of a virtual machine from
20 various sources. The memory map will most certainly have holes.
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).
34 mappings : mapping list;
35 wordsize : wordsize option;
36 endian : Bitmatch.endian option;
41 (* Bigarray mmap(2)'d region with byte addressing: *)
42 arr : (char,int8_unsigned_elt,c_layout) Array1.t;
53 let set_wordsize t ws = { t with wordsize = Some ws }
55 let set_endian t e = { t with endian = Some e }
57 let get_wordsize t = Option.get t.wordsize
59 let get_endian t = Option.get t.endian
61 let sort_mappings mappings =
62 let cmp { start = s1 } { start = s2 } = compare s1 s2 in
63 List.sort cmp mappings
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. *)
73 { start = addr; size = Int64.of_int size; arr = arr } :: mappings in
74 let mappings = sort_mappings mappings in
75 { t with mappings = mappings }
81 (* Find in mappings and return first predicate match. *)
82 let _find_map { mappings = mappings } pred =
83 let rec loop = function
92 (* Array+offset = string? *)
93 let string_at arr offset str strlen =
96 if i >= strlen then true
98 if Array1.get arr !j <> str.[i] then false
106 (* Find in a single file mapping.
107 * [start] is relative to the mapping and we return an offset relative
110 let _find_in start align str arr =
111 let strlen = String.length str in
114 let e = Array1.dim arr - strlen in
117 if string_at arr !j str strlen then Some !j
129 (* Generic find function. *)
130 let _find t start align str =
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)
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)
149 let find t ?(start=0L) str =
152 let find_align t ?(start=0L) str =
153 let align = bytes_of_wordsize (get_wordsize t) in
154 _find t start align str
156 let rec _find_all t start align str =
157 match _find t start align str with
160 offset :: _find_all t (offset +^ Int64.of_int align) align str
162 let find_all t ?(start=0L) str =
163 _find_all t start 1 str
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
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.
173 let rec find_pointer t ?start addr =
174 find_align t ?start (string_of_addr t addr)
176 and find_pointer_all t ?start addr =
177 find_all_align t ?start (string_of_addr t addr)
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
186 (* XXX bitmatch is missing 'construct_int64_le_unsigned' so we
187 * have to force this to 32 bits for the moment.
189 and string_of_addr t addr =
190 let bits = bits_of_wordsize (get_wordsize t) in
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
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
201 | { addr : bits : endian (e) } -> addr
202 | { _ } -> invalid_arg "addr_of_string"
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 < size ->
209 let offset = Int64.to_int (addr -^ start) in
210 Char.code (Array1.get arr offset)
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.
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
226 | _ :: ms -> get_next_mapping addr ms
229 let arr, offset, len = get_next_mapping addr mappings in
232 let c = Array1.get arr (offset+i) in
233 if cond c then loop2 (i+1)
235 loop (addr +^ Int64.of_int len)
241 let get_bytes t addr len =
242 let str = String.create len in
253 Invalid_argument _ -> invalid_arg "get_bytes"
255 let get_string t addr =
256 let chars = ref [] in
260 if c <> '\000' then (
261 chars := c :: !chars;
265 let chars = List.rev !chars in
266 let len = List.length chars in
267 let str = String.create len in
269 List.iter (fun c -> str.[!i] <- c; incr i) chars;
272 Invalid_argument _ -> invalid_arg "get_string"
274 let is_string t addr =
275 try dowhile t addr (fun c -> c <> '\000'); true
276 with Invalid_argument _ -> false
278 let is_C_identifier t addr =
286 c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z'
288 if c = '\000' then false
290 if c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z' ||
291 c >= '0' && c <= '9' then
304 Invalid_argument _ -> false
306 let follow_pointer t addr =
307 let ws = get_wordsize t in
308 let e = get_endian t in
309 let bits = bits_of_wordsize ws in
310 let str = get_bytes t addr (bytes_of_wordsize ws) in
311 let bs = Bitmatch.bitstring_of_string str in
313 | { addr : bits : endian (e) } -> addr
314 | { _ } -> invalid_arg "follow_pointer"
316 let succ_long t addr =
317 let ws = get_wordsize t in
318 addr +^ Int64.of_int (bytes_of_wordsize ws)
320 let pred_long t addr =
321 let ws = get_wordsize t in
322 addr -^ Int64.of_int (bytes_of_wordsize ws)