Source file image.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
open Basic_types.Integers
module StrMap = Basic_types.String.Map
module StrTbl = Basic_types.String.Htbl
module AttrMap = Dba.Var.Tag.Attribute.Map
type buffer =
| Zero
| Data of { offset : int; len : int; value : Loader_types.buffer }
let crop_buffer : lo:Z.t -> hi:Z.t -> buffer -> buffer =
fun ~lo ~hi buffer ->
match buffer with
| Zero -> Zero
| Data { offset; value; _ } ->
let lo = Z.to_int lo and hi = Z.to_int hi in
Data { offset = offset + lo; len = hi - lo + 1; value }
let map_content : buffer Zmap.t -> buffer Zmap.t -> buffer Zmap.t =
let stich : buffer Zmap.item -> buffer Zmap.item -> buffer option =
fun (Item { elt = elt0; _ }) (Item { elt = elt1; _ }) ->
match (elt0, elt1) with
| Zero, Zero -> Some Zero
| ( Data { offset = offset0; len = len0; value = value0 },
Data { offset = offset1; len = len1; value = value1 } )
when value0 == value1 && offset0 + len0 = offset1 ->
Some (Data { offset = offset0; len = len0 + len1; value = value0 })
| Zero, Data _ | Data _, Zero | Data _, Data _ -> None
in
fun mapping content ->
Zmap.union_left ~stich ~crop:crop_buffer mapping content
let content_reader :
Virtual_address.t ->
Z.t ->
?endianness:Machine.endianness ->
buffer Zmap.t ->
Virtual_address.t Reader.t =
let offset : Virtual_address.t -> int -> Virtual_address.t =
fun addr n -> Virtual_address.add_int n addr
and get :
buffer Zmap.item_opt ref -> buffer Zmap.t -> Virtual_address.t -> char =
fun cache map addr ->
let idx = Virtual_address.to_bigint addr in
match !cache with
| Item { lo; hi; elt } when Z.leq lo idx && Z.leq idx hi -> (
match elt with
| Zero -> '\x00'
| Data { offset; value; _ } ->
Char.unsafe_chr
(Bigarray.Array1.get value (Z.to_int (Z.sub idx lo) + offset)))
| Item _ | Empty -> (
let last_buffer = Zmap.find_opt idx map in
match last_buffer with
| Empty -> raise Not_found
| Item { elt = Zero; _ } -> '\x00'
| Item { lo; elt = Data { offset; value; _ }; _ } ->
cache := last_buffer;
Char.unsafe_chr
(Bigarray.Array1.get value (Z.to_int (Z.sub idx lo) + offset)))
in
fun start dim ?endianness content ->
Reader.create ~offset
~get:(get (ref Zmap.none))
?endianness ~start
~stop:(Virtual_address.add_bigint dim start)
content
type protection = R | RW | RX | RWX
let map_protection : protection Zmap.t -> protection Zmap.t -> protection Zmap.t
=
let stich : protection Zmap.item -> protection Zmap.item -> protection option
=
fun (Item { elt = elt0; _ }) (Item { elt = elt1; _ }) ->
if elt0 = elt1 then Some elt0 else None
in
fun mapping protection -> Zmap.union_left ~stich mapping protection
let update_append : 'a -> 'a list option -> 'a list option =
fun x list_opt -> Some (x :: Option.value ~default:[] list_opt)
type symbol = { base : Virtual_address.t; name : string; origin : string }
type section = {
base : Virtual_address.t;
name : string;
origin : string;
symbols : symbol Zmap.t;
}
type t = {
content : buffer Zmap.t;
protection : protection Zmap.t;
symbols : (Z.t * string) list AttrMap.t StrMap.t;
layout : section Zmap.t;
}
type layout_cache = {
mutable last_section : section Zmap.item_opt;
mutable last_symbol : symbol Zmap.item_opt;
}
let layout_with_cache :
t -> (Virtual_address.t -> section) * (Virtual_address.t -> symbol) =
let rev_section :
section Zmap.t -> layout_cache -> Virtual_address.t -> section =
fun layout cache addr ->
let idx = Virtual_address.to_bigint addr in
match cache.last_section with
| Item { lo; hi; elt } when Z.leq lo idx && Z.leq idx hi -> elt
| Item _ | Empty -> (
let last_section = Zmap.find_opt idx layout in
match last_section with
| Empty -> raise Not_found
| Item { elt; _ } ->
cache.last_section <- last_section;
elt)
in
let rev_symbol : section Zmap.t -> layout_cache -> Virtual_address.t -> symbol
=
fun layout cache addr ->
let idx = Virtual_address.to_bigint addr in
match cache.last_symbol with
| Item { lo; hi; elt } when Z.leq lo idx && Z.leq idx hi -> elt
| Item _ | Empty -> (
match rev_section layout cache addr with
| { symbols; _ } -> (
let last_symbol = Zmap.find_opt idx symbols in
match last_symbol with
| Empty -> raise Not_found
| Item { elt; _ } ->
cache.last_symbol <- last_symbol;
elt))
in
fun { layout; _ } ->
let cache = { last_section = Zmap.none; last_symbol = Zmap.none } in
(rev_section layout cache, rev_symbol layout cache)
let empty =
{
content = Zmap.empty;
protection = Zmap.empty;
symbols = StrMap.empty;
layout = Zmap.empty;
}
let generic_load : string -> Loader.Img.t -> t =
fun path source ->
let value = Loader.Img.buffer source in
Array.fold_left
(fun ({ symbols; _ } as image) symbol ->
let name = Loader.Symbol.name symbol in
if String.equal name String.empty then image
else
{
image with
symbols =
StrMap.add name
(AttrMap.singleton Value
[
(Virtual_address.to_bigint (Loader.Symbol.value symbol), path);
])
symbols;
})
(Array.fold_left
(fun ({ content; protection; symbols; layout } as image) section ->
if Loader.Section.has_flag Read section then
match (Loader.Section.pos section, Loader.Section.size section) with
| { virt = base; raw = offset }, { virt = size; raw = len } ->
let lo = Virtual_address.to_bigint base in
let hi = Z.add lo (Z.of_int (len - 1)) in
let mapping =
if 0 < len then
Zmap.singleton ~lo ~hi (Data { offset; len; value })
else Zmap.empty
in
let mapping, hi =
if Z.lt (Z.of_int len) size then
let lo = Z.add lo (Z.of_int len)
and hi = Z.add lo (Z.pred size) in
(Zmap.union_left mapping (Zmap.singleton ~lo ~hi Zero), hi)
else (mapping, hi)
in
let content = map_content mapping content in
let mapping =
Zmap.singleton ~lo ~hi
(match
( Loader.Section.has_flag Write section,
Loader.Section.has_flag Exec section )
with
| false, false -> R
| true, false -> RW
| false, true -> RX
| true, true -> RWX)
in
let protection = map_protection mapping protection in
let symbols, layout =
let name = Loader.Section.name section in
if String.equal name String.empty then (symbols, layout)
else
let attributes =
AttrMap.add Value
[ (lo, path) ]
(AttrMap.add Size
[ (size, path) ]
(AttrMap.singleton Last [ (hi, path) ]))
in
let symbols = StrMap.add name attributes symbols in
let mapping =
Zmap.singleton ~lo ~hi
{ base; name; origin = path; symbols = Zmap.empty }
in
let layout = Zmap.union_left mapping layout in
(symbols, layout)
in
{ content; protection; symbols; layout }
else image)
empty
(Loader.Img.sections source))
(Loader.Img.symbols source)
let elf_map_synthetic_symtab :
string -> Loader_elf.Img.t -> Virtual_address.t -> t -> t =
fun path source at image ->
List.fold_left
(fun ({ symbols; layout; _ } as image) (value, name) ->
let value = Virtual_address.to_bigint (Virtual_address.add at value) in
let symbols =
StrMap.update name
(fun attributes ->
Some
(AttrMap.update Plt
(update_append (value, path))
(Option.value ~default:AttrMap.empty attributes)))
symbols
in
let layout =
match Zmap.find value layout with
| Item { lo; hi; elt = { symbols; _ } as section } ->
Zmap.union_left
(Zmap.singleton ~lo ~hi
{
section with
symbols =
Zmap.union_left
(Zmap.singleton ~lo:value ~hi:value
{
base = Virtual_address.of_bigint value;
name = name ^ "@plt";
origin = path;
})
symbols;
})
layout
| exception Not_found -> layout
in
{ image with symbols; layout })
image
(Loader_elf.Utils.synthetic_symtab source)
let elf_map_symtab : string -> Loader_elf.Img.t -> Virtual_address.t -> t -> t =
fun path source at image ->
let at = Virtual_address.to_bigint at in
Array.fold_left
(fun ({ symbols; layout; _ } as image) symbol ->
match Loader_elf.Symbol.header symbol with
| {
sh = SEC { flags; _ };
kind = NOTYPE | FUNC | OBJECT;
name;
value = addr;
size;
_;
}
when (not (String.equal name String.empty))
&& Loader_elf.Shdr.SHF.is flags ALLOC ->
let value = Z.add at (Virtual_address.to_bigint addr) in
let last = Z.add value (Z.of_int (size - 1)) in
let symbols =
StrMap.update name
(fun attributes ->
let attributes =
Option.value ~default:AttrMap.empty attributes
in
let attributes =
AttrMap.update Value (update_append (value, path)) attributes
in
let attributes =
if 0 < size then
AttrMap.update Size
(update_append (Z.of_int size, path))
(AttrMap.update Last
(update_append (last, path))
attributes)
else attributes
in
Some attributes)
symbols
in
let layout =
if 0 < size then
match Zmap.find value layout with
| Item { lo; hi; elt = { symbols; _ } as section } ->
Zmap.union_left
(Zmap.singleton ~lo ~hi
{
section with
symbols =
Zmap.union_left
(Zmap.singleton ~lo:value ~hi:last
{
base = Virtual_address.of_bigint value;
name;
origin = path;
})
symbols;
})
layout
| exception Not_found ->
Logger.fatal "can not find section for symbol %s (%s)" name
(Z.format "%#x" value)
else layout
in
{ image with symbols; layout }
| _ -> image)
(Array.fold_left
(fun ({ symbols; layout; _ } as image) section ->
match Loader_elf.Section.header section with
| { name; addr; size; flags; _ } ->
if String.equal name String.empty || size = 0 then image
else
let lo = Z.add at (Virtual_address.to_bigint addr) in
let size = Z.of_int size
and hi = Z.add lo (Z.of_int (size - 1)) in
let symbols =
StrMap.update name
(fun attributes ->
Some
(AttrMap.update Value
(update_append (lo, path))
(AttrMap.update Size
(update_append (size, path))
(AttrMap.update Last
(update_append (hi, path))
(Option.value ~default:AttrMap.empty attributes)))))
symbols
in
if Loader_elf.Shdr.SHF.is flags ALLOC then
let mapping =
Zmap.singleton ~lo ~hi
{
base = Virtual_address.of_bigint lo;
name;
origin = path;
symbols = Zmap.empty;
}
in
let layout = Zmap.union_left mapping layout in
{ image with symbols; layout }
else { image with symbols })
image
(Loader_elf.Img.sections source))
(Loader_elf.Img.symbols source)
let elf_buildid_path : ?dir:string -> Loader_elf.Img.t -> string option =
fun ?(dir = "/usr/lib/debug/") source ->
let endianness =
match Loader_elf.Img.header source with { ident = { data; _ }; _ } -> data
in
Array.find_map
(fun section ->
match Loader_elf.Section.header section with
| { kind = NOTE; _ } -> (
let cursor =
Reader.of_bigarray ~endianness
(Loader_elf.Img.content source section)
in
match Loader_elf.Note.read cursor with
| { name = "GNU"; kind = 3; offset; size } ->
Reader.set_pos cursor offset;
let build_id = Reader.Read.bytes cursor size in
let idx = String_utils.to_hex (String.sub build_id 0 1)
and basename =
String_utils.to_hex
(String.sub build_id 1 (String.length build_id - 1))
^ ".debug"
in
Some
(Filename.concat dir
(Filename.concat ".build-id" (Filename.concat idx basename)))
| _ -> None)
| _ -> None)
(Loader_elf.Img.sections source)
let elf_debug_locations :
?dir:string -> string -> Loader_elf.Img.t -> string list =
fun ?(dir = "/usr/lib/debug/") path source ->
let other_locations =
let debug = path ^ ".debug"
and basename = Filename.basename path
and dirname = Filename.dirname path in
[
debug;
Filename.concat dirname (Filename.concat ".debug" (basename ^ ".debug"));
Filename.concat dir debug;
]
in
match elf_buildid_path ~dir source with
| None -> other_locations
| Some loc -> loc :: other_locations
let elf_map_symtab_with_debug :
fs:(string -> Loader_types.buffer) ->
string ->
Loader_elf.Img.t ->
Virtual_address.t ->
t ->
t =
fun ~fs path source at image ->
elf_map_synthetic_symtab path source at
(elf_map_symtab path
(Option.value ~default:source
(List.find_map
(fun path ->
Logger.debug "trying to load debug symbols at %s" path;
match fs path with
| exception Not_found -> None
| buf -> Some (Loader_elf.load buf))
(elf_debug_locations path source)))
at image)
let elf_load_segments : Loader_types.buffer -> Loader_elf.Phdr.t array -> t =
fun value segments ->
Array.fold_left
(fun ({ content; protection; _ } as image)
({ flags; offset; vaddr; filesz; memsz; _ } : Loader_elf.Phdr.t) ->
let memsz = Uint64.to_bigint memsz in
if Loader_elf.Phdr.PHF.is flags R && Z.lt Z.zero memsz then
let lo = Virtual_address.to_bigint vaddr in
let hi = Z.add lo (Z.of_int (filesz - 1)) in
let mapping =
if 0 < filesz then
Zmap.singleton ~lo ~hi (Data { offset; len = filesz; value })
else Zmap.empty
in
let mapping, hi =
if Z.lt (Z.of_int filesz) memsz then
let lo = Z.add lo (Z.of_int filesz)
and hi = Z.add lo (Z.pred memsz) in
(Zmap.union_left mapping (Zmap.singleton ~lo ~hi Zero), hi)
else (mapping, hi)
in
let content = map_content mapping content in
let mapping =
Zmap.singleton ~lo ~hi
(match
(Loader_elf.Phdr.PHF.is flags W, Loader_elf.Phdr.PHF.is flags X)
with
| false, false -> R
| true, false -> RW
| false, true -> RX
| true, true -> RWX)
in
let protection = map_protection mapping protection in
{ image with content; protection }
else image)
empty segments
let elf_load_sections : Loader_types.buffer -> Loader_elf.Section.t array -> t =
fun value sections ->
Array.fold_left
(fun ({ content; protection; _ } as image) section ->
match Loader_elf.Section.header section with
| { addr; offset; size; flags; kind; _ } ->
if Loader_elf.Shdr.SHF.is flags ALLOC then
let lo = Virtual_address.to_bigint addr in
let hi = Z.add lo (Z.of_int (size - 1)) in
let mapping =
Zmap.singleton ~lo ~hi
(match kind with
| NOBITS -> Zero
| _ -> Data { offset; len = size; value })
in
let content = map_content mapping content in
let mapping =
Zmap.singleton ~lo ~hi
(match
( Loader_elf.Shdr.SHF.is flags WRITE,
Loader_elf.Shdr.SHF.is flags EXECINSTR )
with
| false, false -> R
| true, false -> RW
| false, true -> RX
| true, true -> RWX)
in
let protection = map_protection mapping protection in
{ image with content; protection }
else image)
empty sections
let elf_load :
fs:(string -> Loader_types.buffer) -> string -> Loader_elf.Img.t -> t =
fun ~fs path source ->
let value = Loader_elf.Img.buffer source in
elf_map_symtab_with_debug ~fs path source Virtual_address.zero
(match Loader_elf.Img.header source with
| { kind = EXEC | DYN; _ } ->
elf_load_segments value (Loader_elf.program_headers source)
| _ -> elf_load_sections value (Loader_elf.Img.sections source))
let elf_revmap_jmprel :
string -> Loader_elf.Img.t -> Virtual_address.t -> t -> t =
fun path source base image ->
let sizeof_symbol, endianness =
match Loader_elf.Img.header source with
| { ident = { kind = `x32; data; _ }; _ } -> (4, data)
| { ident = { kind = `x64; data; _ }; _ } -> (8, data)
in
let isa = Loader_elf.Img.arch source in
List.fold_left
(fun ({ symbols; _ } as image)
{ Loader_elf.Rel.offset; kind; symbol = { name; _ }; addend } ->
if
(not (Loader_elf.Utils.is_jump_slot isa kind))
|| String.equal name String.empty
then image
else
let addend = Option.value ~default:Z.zero addend in
let reader =
content_reader
(Virtual_address.add base offset)
(Z.of_int sizeof_symbol) ~endianness image.content
in
let value =
Z.sub
(Bitvector.value_of (Reader.Read.read reader sizeof_symbol))
addend
in
let symbols =
StrMap.update name
(fun attributes ->
Some
(AttrMap.update Value
(update_append (value, path))
(Option.value ~default:AttrMap.empty attributes)))
symbols
in
Logger.debug ~level:3 "%a %s" Bitvector.pp_hex_or_bin
(Bitvector.create value (8 * sizeof_symbol))
name;
{ image with symbols })
image
(Loader_elf.Utils.jmprel source)
let elf_core_fix_segment_permissions :
Loader_elf.Img.t -> Virtual_address.t -> t -> t =
fun source at image ->
Array.fold_left
(fun ({ protection; _ } as image)
({ flags; vaddr; memsz; _ } : Loader_elf.Phdr.t) ->
let memsz = Uint64.to_bigint memsz in
if Loader_elf.Phdr.PHF.is flags R && Z.lt Z.zero memsz then
let lo = Virtual_address.to_bigint (Virtual_address.add at vaddr) in
let hi = Z.add lo (Z.pred memsz) in
let mapping =
Zmap.singleton ~lo ~hi
(match
(Loader_elf.Phdr.PHF.is flags W, Loader_elf.Phdr.PHF.is flags X)
with
| false, false -> R
| true, false -> RW
| false, true -> RX
| true, true -> RWX)
in
let protection =
map_protection protection
mapping
in
{ image with protection }
else image)
image
(Loader_elf.program_headers source)
let elf_load_core : fs:(string -> Loader_types.buffer) -> Loader_elf.Img.t -> t
=
fun ~fs source ->
let value = Loader_elf.Img.buffer source in
let image = elf_load_segments value (Loader_elf.program_headers source) in
let files = Loader_elf.files source in
let contents = StrTbl.create (Array.length files) and pending = ref [] in
let image =
Array.fold_left
(fun ({ content; _ } as image)
{ Loader_elf.addresses = { lo; hi }; offset; name = fname } ->
let value =
try StrTbl.find contents fname
with Not_found -> (
let value =
try fs fname
with Not_found -> Logger.fatal "Unable to open file %s" fname
in
match Loader.load value with
| ELF source -> (
match Loader_elf.Img.header source with
| { kind = EXEC | DYN; _ } -> (
match
Array.find_opt
(fun ({ offset = fileoff; filesz; _ } :
Loader_elf.Phdr.t) ->
fileoff <= offset && offset < fileoff + filesz)
(Loader_elf.program_headers source)
with
| None -> value
| Some { offset = fileoff; vaddr; _ } ->
let base =
Virtual_address.create
(Virtual_address.diff
(Virtual_address.add_int (fileoff - offset) lo)
vaddr)
in
Logger.debug "%a :: %a-%a %08x %s" Virtual_address.pp
base Virtual_address.pp lo Virtual_address.pp hi
offset fname;
StrTbl.add contents fname value;
pending := (fname, source, base) :: !pending;
value)
| _ -> value)
| Raw _ | PE _ | TI83 _ -> value)
in
let mapping =
Zmap.singleton
~lo:(Virtual_address.to_bigint lo)
~hi:(Z.pred (Virtual_address.to_bigint hi))
(Data
{
offset;
len =
min
(Virtual_address.diff hi lo)
(Bigarray.Array1.dim value - offset);
value;
})
in
{
image with
content =
map_content content
mapping ;
})
image files
in
List.fold_left
(fun image (fname, source, base) ->
elf_revmap_jmprel fname source base
(elf_map_symtab_with_debug ~fs fname source base
(elf_core_fix_segment_permissions source base image)))
image !pending
let load : fs:(string -> Loader_types.buffer) -> string -> Loader.Img.t -> t =
fun ~fs path source ->
match source with
| ELF img -> (
match Loader_elf.Img.header img with
| { kind = CORE; _ } -> elf_load_core ~fs img
| _ -> elf_load ~fs path img)
| _ -> generic_load path source