1
(* $Id: netmcore_heap.ml 1578 2011-04-12 16:20:49Z gerd $ *)
3
(* Structure of the heaps:
5
Heaps consist of a root block and a list of extension blocks
6
(which is initially empty). Extension blocks are added when no more
7
memory is available in the blocks so far allocated. Extension
8
blocks can also be given back to the pool when they become empty
9
again. Blocks are never changed in size. The blocks are managed
10
with a doubly-linked list.
12
Both allocated memory and free memory in the heap must have
13
"Ocaml structure", i.e. there is always a header preceding the
14
value. The header includes the length and the bits for gabage
17
Free memory is also added to free lists if the memory area
18
consists of at least 2 words (1 word free memory can be first
19
reclaimed by the garabage collector). There are several free lists
20
for different sizes of the free areas.
22
When there is no more available memory, a garbage collection is
23
triggered (see below). If this is also not sufficient, a further
24
extension block is added.
26
Garbage collection is done by marking and sweeping, all in one
27
go. We use only the colors "black" and "white". In the sweep
28
phase also the free lists are completely rebuilt. This makes
29
it possible to merge adjacent free memory, and to reclaim
32
Note that custom values (incl. bigarrays, int32, int64, nativeint)
33
cannot live in heaps, because the GC is not able to figure out which
34
mem regions are used by the custom blocks.
37
(* FIXME: use better locking scheme (r/w locks) *)
39
(* FIXME: flag is_white: whether all values are white. Protect against
40
crashes during the mark phase
46
let enable = ref false
49
let dlog = Netlog.Debug.mk_dlog "Netmcore_heap" Debug.enable
50
let dlogr = Netlog.Debug.mk_dlogr "Netmcore_heap" Debug.enable
53
Netlog.Debug.register_module "Netmcore_heap" Debug.enable
57
{ heap_sem : Netsys_mem.memory;
58
heap_pool : Netmcore.res_id;
59
mutable heap_value : 'a;
61
heap_fl : Obj.t array;
62
mutable heap_roots : Obj.t array;
67
heap_ext is the first extension block (root block). See below for
70
heap_fl: The free lists of unused Ocaml values. This array starts
71
several free lists: heap_fl.(k) is the free list for values with
72
a size of k words (k > 0). heap_fl.(0) is the free list for values
75
The free list pointer references the free Obj.t (which is always
76
preceded by a header). The next element of the free list is in
79
The special value null_obj is used for "None".
81
The values in [heap_roots] are considered as the roots. Values
82
null_obj are ignored in this array. The [heap_roots] array resides
83
in the heap. There is right now no free list providing fast access
84
to unused elements of this array (TBD).
86
Note that the heap_sem bigarray is ok because it is not stored in
87
the value area (bigarrays would be incompatible with our GC).
92
{ mutable ext_prev : int; (* encoded start address *)
93
mutable ext_next : int; (* encoded start address *)
94
ext_addr : nativeint; (* start address of the mem block *)
95
ext_size : int; (* size of the mem block *)
96
mutable ext_start : int; (* offset of value area start *)
97
ext_end : int; (* offset of value area end *)
102
Extension blocks: The first extension block is simply put into the
103
root memory block. The other extension blocks have this format:
104
At the beginning there is the [magic] string, followed by the
105
Ocaml value of the [ext_block] record. The remaining part of the memory
106
block can be used for storing values. This area starts at the
107
offset [ext_start] (relative to the beginning of the mem block), and
108
ends at [ext_end] (i.e. last byte is at [ext_end-1]).
110
ext_prev and ext_next: contain the encoded address of the memory block
111
containing the ext_block we are referring to. The encoding: Shift the
112
address 1 bit to the right, so it fits into an [int] value. The
113
special value [no_ext_block] is used to denote a "none". The special
114
value [root_ext_block] is used to denote the first extension block
115
(remember it does not have a mem block of its own, and is a special
118
ext_addr: this is the address of the mem block containing the
119
ext_block record. ext_size is the size of this mem block in bytes.
121
Note that the ext_addr custom value is ok because it is not stored in
122
the value area (custom values would be incompatible with our GC).
129
mutable alive : bool;
130
mutable pinned : int list;
135
let null_obj = Obj.repr 0
137
let magic = "NETHEAP\n"
140
let min_ext_size = 65536
141
(* min size of an extension block *)
143
let max_ext_block = 256
144
(* max space for ext_block record in bytes *)
147
(* used in ext_prev and ext_next *)
149
let root_ext_block = 1
150
(* used in ext_prev and ext_next *)
153
(* initial number of root values *)
157
match Sys.word_size with
162
let descr_of_heap heap =
163
let addr = heap.heap_ext.ext_addr in
164
Nativeint.to_int(Nativeint.shift_right addr 1)
166
let heap_of_descr pool ptr =
167
let addr = Nativeint.shift_left (Nativeint.of_int ptr) 1 in
169
let size = Netmcore_mempool.size_mem_at_addr pool addr in
170
let mem = Netsys_mem.grab addr size in
171
let u = String.create magic_len in
172
Netsys_mem.blit_memory_to_string mem 0 u 0 magic_len;
173
if u <> magic then raise Not_found;
174
let hoffs_s = String.create 8 in
175
Netsys_mem.blit_memory_to_string mem 8 hoffs_s 0 8;
177
Netnumber.int_of_int8 (Netnumber.HO.read_int8 hoffs_s 0) in
178
Netsys_mem.as_value mem hoffs
181
failwith "Netmcore_heap.heap_of_descr: no heap structure found \
184
let create_mutator heap =
185
{ heap = Obj.magic heap; alive = true; pinned = [] }
188
Netsys_mem.grab ext.ext_addr ext.ext_size
191
let ext_block heap (ptr:int) : ext_block =
192
(* for following ext_prev and ext_next *)
193
if ptr = no_ext_block then
194
failwith "Netmcore_heap.ext_block: null pointer";
195
if ptr = root_ext_block then
198
let nat_ptr = Nativeint.shift_left (Nativeint.of_int ptr) 1 in
199
let mem = Netsys_mem.grab nat_ptr max_ext_block in
200
let u = String.create magic_len in
201
Netsys_mem.blit_memory_to_string mem 0 u 0 magic_len;
203
failwith "Netmcore_heap.ext_block: bad magic";
204
Netsys_mem.as_value mem (magic_len + bytes_per_word)
208
let ptr_to_ext_block heap (ext:ext_block) : int =
209
if ext == heap.heap_ext then
212
Nativeint.to_int (Nativeint.shift_right ext.ext_addr 1)
215
let debug_info heap =
216
let b = Buffer.create 80 in
217
bprintf b "pool = %d\n"
218
(match heap.heap_pool with
221
bprintf b "value = @0x%nx\n"
222
(Netsys_mem.obj_address (Obj.repr heap.heap_value));
223
for k = 0 to Array.length heap.heap_roots - 1 do
224
if heap.heap_roots.(k) != null_obj then
225
bprintf b "root[%d] = @0x%nx\n"
226
k (Netsys_mem.obj_address heap.heap_roots.(k));
228
for k = 0 to Array.length heap.heap_fl - 1 do
229
if heap.heap_fl.(k) != null_obj then
230
bprintf b "fl[%d] = @0x%nx\n"
231
k (Netsys_mem.obj_address heap.heap_fl.(k));
234
let ext = ref (Some heap.heap_ext) in
235
while !ext <> None do
239
if x.ext_next = no_ext_block then
242
Some(ext_block heap x.ext_next) in
243
bprintf b "ext[%d] = @0x%nx, size 0x%x\n"
244
!p x.ext_addr x.ext_size;
247
| None -> assert false
252
let extend_heap heap size =
253
(* Add another extension block to the heap so that a [size] value fits
256
dlogr (fun () -> sprintf "extend_heap size=%d" size);
257
let req_size = size + max_ext_block in
258
(* N.B. choosing max_ext_block high enough is crucial *)
259
let mem_size = max req_size min_ext_size in
260
let mem = Netmcore_mempool.alloc_mem heap.heap_pool mem_size in
262
let mem_real_size = Netmcore_mempool.size_mem heap.heap_pool mem in
263
(* mem_real_size >= mem_size! *)
264
Netsys_mem.blit_string_to_memory magic 0 mem 0 magic_len;
265
let old_next = heap.heap_ext.ext_next in
267
{ ext_prev = ptr_to_ext_block heap heap.heap_ext;
269
ext_addr = Netsys_mem.memory_address mem;
270
ext_size = mem_real_size;
271
ext_start = 0; (* later *)
272
ext_end = mem_real_size;
275
Netsys_mem.init_value mem magic_len ext_orig
276
[Netsys_mem.Copy_bigarray; Netsys_mem.Copy_custom_int;
277
Netsys_mem.Copy_atom] in
279
Netsys_mem.as_value mem voffs in
280
(* If the block is larger than the typical size of 64K, we initialize
281
it so that only the requested value fits exactly
284
if req_size = mem_size then
288
assert(ext.ext_start >= magic_len+n);
289
heap.heap_ext.ext_next <- ptr_to_ext_block heap ext;
290
if old_next <> no_ext_block then
291
(ext_block heap old_next).ext_prev <- ptr_to_ext_block heap ext;
292
dlogr (fun () -> sprintf "extent_heap addr=%nx real_size=%d usable=%d"
293
ext.ext_addr ext.ext_size (ext.ext_end - ext.ext_start));
294
Some(mem, ext.ext_start, ext.ext_end - ext.ext_start)
297
Netmcore_mempool.free_mem heap.heap_pool mem;
300
let shrink_heap heap ext =
301
(* Remove ext from the chaining, and give the mem block back to the pool *)
302
dlogr (fun () -> sprintf "shrink_heap addr=%nx" ext.ext_addr);
303
assert (ext != heap.heap_ext);
304
let mem = Netsys_mem.grab ext.ext_addr ext.ext_size in
305
let u = String.create magic_len in
306
Netsys_mem.blit_memory_to_string mem 0 u 0 magic_len;
308
failwith "Netmcore_heap.shrink_heap";
309
let v = String.make magic_len ' ' in
310
Netsys_mem.blit_string_to_memory v 0 mem 0 magic_len;
311
(* ext is never the first element in the chain *)
312
let prev = ext_block heap ext.ext_prev in
313
prev.ext_next <- ext.ext_next;
314
if ext.ext_next <> no_ext_block then (
315
let next = ext_block heap ext.ext_next in
316
next.ext_prev <- ext.ext_prev
318
Netmcore_mempool.free_mem heap.heap_pool mem;
319
dlog "shrink_heap done"
322
let init_as_block mem offs size =
323
let words = size / bytes_per_word in
325
Netsys_mem.init_header mem offs Obj.string_tag (*block size:*)(words-1)
328
let init_as_atom mem offs =
329
Netsys_mem.init_header mem offs (*tag:*)0 (*block size:*)0
332
let del_in_fl heap (entry:Obj.t) (prev:Obj.t) =
333
let next = Obj.field entry 0 in
334
if prev == null_obj then (
335
(* it must be one of the root pointers *)
336
for k=0 to fl_size-1 do
337
if heap.heap_fl.(k) == entry then
338
heap.heap_fl.(k) <- next
342
Obj.set_field prev 0 next
345
let add_to_fl heap mem offs len =
346
let words = len / bytes_per_word in
347
let k = if words < fl_size then words else 0 in
348
let old_head = heap.heap_fl.(k) in
349
init_as_block mem offs len;
350
let v = Netsys_mem.as_value mem (offs + bytes_per_word) in
351
let o = Obj.repr v in
352
Obj.set_field o 0 old_head;
353
heap.heap_fl.(k) <- o
357
(* Our assumption is that all values have the GC color "white".
359
Mark phase: Iter over all roots. For each root, visit the referenced
360
values, and set all values to the GC color "black" if they are visited
363
Sweep phase: Iter over all extension blocks. Iter over all values
364
in an extension block. "White" values are added to the freelist.
365
"Black" values are changed to "white" again, but remain otherwise
368
The freelists are rebuilt during sweep. We check for the special
369
case that an extension block is completely empty - in this case
370
it is entirely removed.
374
let res = Netmcore.get_resource heap.heap_pool in
375
let (start_addr, end_addr) =
377
| `Posix_shm_preallocated(_,mem) ->
378
let mem_size = Bigarray.Array1.dim mem in
379
let sa = Netsys_mem.memory_address mem in
380
let ea = Nativeint.add sa (Nativeint.of_int mem_size) in
386
sprintf "range: 0x%nx - 0x%nx" start_addr end_addr);
388
let debug_addr = Hashtbl.create 20 in
389
(* For debugging [mark] *)
391
let rec mark (v:Obj.t) =
392
(* FIXME: this recursion can cause stack overflows *)
393
if Obj.is_block v then (
394
let a = Netsys_mem.hdr_address v in
395
(* We do not follow blocks that are outside the shm area. In general,
396
such out-of-shm blocks are likely to be erroneous, though
398
if a >= start_addr && a < end_addr then (
399
if Netsys_mem.color v = Netsys_mem.White then (
400
dlogr (fun () -> sprintf "marking 0x%nx"
401
(Netsys_mem.obj_address v));
402
Netsys_mem.set_color v Netsys_mem.Black;
403
if !Debug.enable then
404
Hashtbl.replace debug_addr (Netsys_mem.obj_address v) ();
405
if Obj.tag v < Obj.no_scan_tag then (
406
let sz = Obj.size v in
407
for k = 0 to sz - 2 do
411
mark (Obj.field v (sz-1)) (* tail-rec *)
415
if !Debug.enable then (
416
if not (Hashtbl.mem debug_addr (Netsys_mem.obj_address v)) then (
417
dlog (sprintf "wrong color at 0x%nx"
418
(Netsys_mem.obj_address v))
423
else dlog "addr out of range"
427
dlogr (fun () -> sprintf "sweep_ext addr=%nx" ext.ext_addr);
428
let mem = Netsys_mem.grab ext.ext_addr ext.ext_size in
429
let offs = ref ext.ext_start in
430
let cur_fl_entry = ref None in
431
let all_free = ref true in
432
let free_size = ref 0 in
434
match !cur_fl_entry with
435
| Some(fl_offs,fl_len) ->
436
free_size := !free_size + fl_len;
437
if fl_len > bytes_per_word then
438
add_to_fl heap mem fl_offs fl_len
440
init_as_atom mem fl_offs;
444
while !offs < ext.ext_end do
445
let v = Netsys_mem.as_value mem (!offs + bytes_per_word) in
446
let sz = Obj.size v in
447
( match Netsys_mem.color v with
448
| Netsys_mem.White ->
449
dlogr (fun () -> sprintf "freeing 0x%nx"
450
(Nativeint.add ext.ext_addr (Nativeint.of_int !offs)));
451
( match !cur_fl_entry with
453
cur_fl_entry := Some(!offs, (sz+1)*bytes_per_word)
454
| Some(fl_offs, fl_len) ->
455
cur_fl_entry := Some(fl_offs,
457
(sz+1)*bytes_per_word)
460
dlogr (fun () -> sprintf "keeping 0x%nx"
461
(Nativeint.add ext.ext_addr (Nativeint.of_int !offs)));
463
Netsys_mem.set_color v Netsys_mem.White;
466
offs := !offs + (sz+1)*bytes_per_word
468
if !all_free && ext != heap.heap_ext then
473
dlogr (fun () -> sprintf "sweep_ext free_size=%d" !free_size);
475
(!free_size, ext.ext_end - ext.ext_start)
479
(* Reset the free lists: *)
480
for k = 0 to fl_size - 1 do
481
heap.heap_fl.(k) <- null_obj
483
(* Iterate over the extension blocks: *)
484
let ext = ref (Some heap.heap_ext) in
485
let free_total = ref 0 in
486
let size_total = ref 0 in
487
while !ext <> None do
490
(* Get the [next] block now, because [x] may be deleted *)
492
if x.ext_next = no_ext_block then
495
Some(ext_block heap x.ext_next) in
496
let (f,s) = sweep_ext x in
497
free_total := !free_total + f;
498
size_total := !size_total + s;
500
| None -> assert false
502
(!free_total, !size_total) in
505
let root = Obj.repr heap.heap_roots in
506
(* root is the only value that is not reset to white color! *)
507
Netsys_mem.set_color root Netsys_mem.White;
511
let (f,s) = sweep() in
516
let do_gc_adjust heap size =
517
(* Do a GC pass and adjust the amount of free mem. If new mem is allocated
518
it should be at least [size]
520
let (free, total) = do_gc heap in
521
if free < total/2 then (
522
let alloc_size0 = max size (total/2 - free) in
523
let alloc_size = ((alloc_size0 - 1) / 8 + 1) * 8 in
524
dlogr (fun () -> sprintf "do_gc_adjust: alloc_size=%d" alloc_size);
525
( match extend_heap heap alloc_size with
526
| Some(mem, offs, len) ->
527
add_to_fl heap mem offs len
534
let find_free_block heap size =
535
(* Find a free block >= [size] in the freelists *)
536
dlogr (fun () -> sprintf "find_free_block size=%d" size);
537
let words = size / bytes_per_word in
538
let k = ref(if words < fl_size then words else 0) in
539
let prev = ref null_obj in
540
let cur = ref heap.heap_fl.( !k ) in
541
let found = ref false in
542
let best = ref null_obj in
543
let best_prev = ref null_obj in
544
let best_size = ref max_int in
545
while not !found && (!cur != null_obj || !k > 0) do
546
if !cur == null_obj then (
548
if !k = fl_size then k := 0;
550
cur := heap.heap_fl.( !k )
552
let n = Obj.size !cur in
553
(* Actually, we have one more word than n because of the value header *)
554
if n+1 >= words && n+1 < !best_size then (
559
if n+1=words then found := true;
561
cur := Obj.field !cur 0
564
if !best != null_obj then (
565
dlog "found free block";
566
let addr = Netsys_mem.hdr_address !best in
567
let byte_size = (Obj.size !best + 1) * bytes_per_word in
568
let mem = Netsys_mem.grab addr byte_size in
569
Some(mem, 0, byte_size, !best, !best_prev)
575
let alloc_in_free_block heap size mem offs len entry prev =
576
(* Take a part of the free block at [mem+offs..mem+offs+len-1] to
577
satisfy the allocation of a block of [size]. [entry] is the
578
entry in the freelist. [prev] is the predecessor in the freelist
582
sprintf "alloc_in_free_block size=%d len=%d" size len);
583
del_in_fl heap entry prev;
584
init_as_block mem offs size;
586
(* The whole block can be used *)
589
(* The block needs to be split *)
590
if len = size + bytes_per_word then (
591
(* The remaining part would only have 1 word. We initialize this word
592
as zero-length block, but it is not entered into a freelist
594
init_as_atom mem (offs+size);
598
(* the remaining part is added to a freelist *)
599
add_to_fl heap mem (offs+size) (len - size);
605
let alloc heap size =
606
(* First search in the freelists *)
607
(* assert: size divisible by word size *)
608
dlogr (fun () -> sprintf "alloc size=%d" size);
609
match find_free_block heap size with
610
| Some(mem, offs, len, obj, prev) ->
611
dlog "alloc: got block from free list";
612
alloc_in_free_block heap size mem offs len obj prev
614
(* Nothing found in the freelists: Do now a GC pass, and try again.
616
( do_gc_adjust heap size;
617
match find_free_block heap size with
618
| Some(mem, offs, len, obj, prev) ->
619
dlog "alloc: got block from free list";
620
alloc_in_free_block heap size mem offs len obj prev
622
(* Still unsuccessful. Add another block and try again *)
623
dlog "alloc: extending heap";
624
( match extend_heap heap size with
625
| Some(mem, offs, len) ->
627
eprintf "mem=%nx offs=%x len=%d\n%!"
628
(Netsys_mem.memory_address mem)
633
init_as_block mem offs size;
637
assert(len <> size + bytes_per_word);
638
init_as_block mem offs size;
639
add_to_fl heap mem (offs+size) (len - size);
644
raise Netmcore_mempool.Out_of_pool_memory
650
(* It is assumed that we already got the lock for the heap *)
652
if not mut.alive then
653
failwith "Netmcore_heap.add: invalid mutator";
654
if Obj.is_int (Obj.repr newval) then
657
let heap = mut.heap in
658
let heap_mem = ext_mem heap.heap_ext in
660
Netsys_mem.init_value
662
[Netsys_mem.Copy_simulate; Netsys_mem.Copy_atom] in
663
assert(size mod bytes_per_word = 0);
664
(* We need [size] bytes to store [newval] *)
665
let (mem, offs) = alloc heap size in
666
(* Do the copy: Note that we need the same flags here as above,
667
except Copy_simulate which is omitted
670
Netsys_mem.init_value
672
[Netsys_mem.Copy_atom] in
673
assert(size = size');
674
(* Return the new value: *)
676
Netsys_mem.as_value mem voffs
680
let add_some mut (x:'a) =
681
(* Very low-level! *)
682
let y_orig = (Some (Obj.magic 0) : 'a option) in
683
let y = add mut y_orig in
684
Obj.set_field (Obj.repr y) 0 (Obj.repr x);
687
let set_tmp_root heap x =
688
if Obj.is_block (Obj.repr x) then (
689
dlog "set_tmp_root: searching for free root element";
690
(* Look for a free entry in the list of roots. There is always a
693
let n = Array.length heap.heap_roots in
694
let found = ref false in
696
while not !found && !k < n-1 do
698
found := heap.heap_roots.( !k ) == null_obj
702
(fun () -> sprintf "set_tmp_root: root element %d" !k);
703
heap.heap_roots.( !k ) <- Obj.repr x;
704
(* If the array of roots is full, reallocate it.
705
At this point we can reallocate, because x is already member of
706
the roots array. (Realloction can trigger the GC!)
710
while not !found && !j < n-1 do
712
found := heap.heap_roots.( !j ) == null_obj
715
dlog "set_tmp_root: reallocation";
716
let r_orig = Array.make (2*n) null_obj in
717
Array.blit heap.heap_roots 0 r_orig 0 n;
718
let mut = create_mutator heap in
719
let r = add mut r_orig in
727
let release_tmp_root heap k =
728
dlog "release_tmp_root: freeing root";
730
heap.heap_roots.(k) <- null_obj
733
let add_uniform_array mut n x_orig =
734
if not mut.alive then
735
failwith "Netmcore_heap.add_uniform_array: invalid mutator";
736
let heap = mut.heap in
737
let heap_mem = ext_mem heap.heap_ext in
738
let x_orig_obj = Obj.repr x_orig in
740
Obj.is_block x_orig_obj && Obj.tag x_orig_obj = Obj.double_tag in
742
Obj.is_block x_orig_obj && Obj.tag x_orig_obj <> Obj.double_tag in
746
Netsys_mem.init_value
748
[Netsys_mem.Copy_simulate; Netsys_mem.Copy_atom])
753
Netsys_mem.init_float_array_bytelen n
755
Netsys_mem.init_array_bytelen n in
756
let t_size = x_size + a_size in
757
(* allocate in one go, so the new value cannot be garbage collected *)
758
let (mem,offs) = alloc heap t_size in
762
Netsys_mem.init_value
764
[Netsys_mem.Copy_atom] in
765
Netsys_mem.as_value mem x_voffs
768
let a_offs = offs + x_size in
771
let (a_voffs, _) = Netsys_mem.init_float_array mem a_offs n in
772
let a = (Netsys_mem.as_value mem a_voffs : _ array) in
773
let a_obj = Obj.repr a in
774
let x_float = (Obj.obj x_orig_obj : float) in
776
Obj.set_double_field a_obj k x_float
781
let (a_voffs, _) = Netsys_mem.init_array mem a_offs n in
782
let a = (Netsys_mem.as_value mem a_voffs : _ array) in
783
let a_obj = Obj.repr a in
784
let x_obj = Obj.repr x in
786
Obj.set_field a_obj k x_obj
793
let add_init_array mut n f =
794
if not mut.alive then
795
failwith "Netmcore_heap.add_init_array: invalid mutator";
797
Obj.magic(add_uniform_array mut 0 0)
800
let a = add_uniform_array mut n x0 in
801
let r = set_tmp_root mut.heap a in
803
Array.unsafe_set a k (add mut (f k))
805
release_tmp_root mut.heap r;
810
let with_lock heap f =
811
dlog "with_lock waiting";
812
let sem = Netsys_posix.as_sem heap.heap_sem 0 in
813
Netsys_posix.sem_wait sem Netsys_posix.SEM_WAIT_BLOCK;
814
dlog "with_lock cont";
817
Netsys_posix.sem_post sem;
818
dlog "with_lock returning";
822
Netsys_posix.sem_post sem;
823
dlog "with_lock exception";
835
(* FIXME: there is a cheaper way of pinning, because we have the
836
heap lock. We could also just gather the roots in a list, and
837
consider this list during GC
839
let k = set_tmp_root mut.heap x in
840
mut.pinned <- k :: mut.pinned
843
let modify heap mutate =
846
let mut = create_mutator (Obj.magic heap) in
849
List.iter (fun k -> release_tmp_root heap k) mut.pinned in
851
let r = mutate mut in
862
if Obj.is_block (Obj.repr x) then
863
Netsys_mem.copy_value [Netsys_mem.Copy_atom] x
868
let with_value_n heap find process =
874
let k_list = List.map (fun x -> set_tmp_root heap x) l in
877
dlog "with_value: process";
879
(* We need the lock again *)
882
List.iter (release_tmp_root heap) k_list
884
dlog "with_value: returning";
887
let with_value heap find process =
891
(function [x] -> process x | _ -> assert false)
893
let with_value_2 heap (find : unit -> ('t1 * 't2)) process =
897
let (x1,x2) = find() in
898
[ Obj.repr x1; Obj.repr x2 ]
901
| [x1; x2] -> process ((Obj.obj x1 : 't1), (Obj.obj x2 : 't2))
905
let with_value_3 heap find process =
909
let (x1,x2,x3) = find() in
910
[ Obj.repr x1; Obj.repr x2; Obj.repr x3 ]
913
| [x1; x2; x3] -> process ((Obj.obj x1), (Obj.obj x2), (Obj.obj x3))
917
let with_value_4 heap find process =
921
let (x1,x2,x3,x4) = find() in
922
[ Obj.repr x1; Obj.repr x2; Obj.repr x3; Obj.repr x4 ]
925
| [x1; x2; x3; x4] ->
926
process ((Obj.obj x1), (Obj.obj x2), (Obj.obj x3), (Obj.obj x4))
930
let with_value_5 heap find process =
934
let (x1,x2,x3,x4,x5) = find() in
935
[ Obj.repr x1; Obj.repr x2; Obj.repr x3; Obj.repr x4; Obj.repr x5 ]
938
| [x1; x2; x3; x4; x5] ->
940
((Obj.obj x1), (Obj.obj x2), (Obj.obj x3), (Obj.obj x4),
951
Bigarray.Array1.create Bigarray.char Bigarray.c_layout bytes_per_word
955
if Obj.is_block (Obj.repr x) then
957
Netsys_mem.init_value
959
[Netsys_mem.Copy_simulate; Netsys_mem.Copy_atom] in
960
n + ((40 + fl_size + n_roots) * bytes_per_word)
961
(* this is just an estimate *)
963
((40 + fl_size + n_roots) * bytes_per_word)
967
let ext = ref (Some heap.heap_ext) in
968
let first = ref true in
969
while !ext <> None do
972
(* Get the [next] block now, because [x] is deleted *)
974
if x.ext_next = no_ext_block then
977
Some(ext_block heap x.ext_next) in
982
| None -> assert false
985
Netsys_mem.grab heap.heap_ext.ext_addr heap.heap_ext.ext_size in
986
Netmcore_mempool.free_mem heap.heap_pool heap_mem
989
let create_sem_mem() =
991
Bigarray.Array1.create
992
Bigarray.char Bigarray.c_layout Netsys_posix.sem_size in
993
ignore(Netsys_posix.sem_init m 0 true 1);
996
let create_heap pool size rootval_orig =
997
if not (Obj.is_block (Obj.repr rootval_orig)) then
998
failwith "Netmcore_heap.create_heap: the root element is not a block";
999
let heap_mem = Netmcore_mempool.alloc_mem pool size in
1002
{ ext_prev = no_ext_block;
1003
ext_next = no_ext_block;
1004
ext_addr = Netsys_mem.memory_address heap_mem;
1005
ext_size = Bigarray.Array1.dim heap_mem;
1006
ext_start = 0; (* fixed later *)
1007
ext_end = Bigarray.Array1.dim heap_mem
1010
{ heap_sem = create_sem_mem();
1012
heap_value = Obj.obj null_obj;
1013
heap_ext = heap_ext_orig;
1014
heap_fl = Array.make fl_size null_obj;
1015
heap_roots = Array.make n_roots null_obj;
1016
(* FIXME: the initial roots array should better be allocated in the
1021
Netsys_mem.blit_string_to_memory magic 0 heap_mem !p magic_len;
1022
p := !p + magic_len;
1026
Netsys_mem.init_value heap_mem !p heap_orig
1027
[Netsys_mem.Copy_bigarray; Netsys_mem.Copy_custom_int;
1028
Netsys_mem.Copy_atom] in
1030
Netnumber.HO.int8_as_string (Netnumber.int8_of_int voffs) in
1031
Netsys_mem.blit_string_to_memory hoffs_s 0 heap_mem p_hoffs 8;
1033
let heap = (Netsys_mem.as_value heap_mem voffs : _ heap) in
1034
heap.heap_ext.ext_start <- !p;
1035
add_to_fl heap heap_mem !p (heap.heap_ext.ext_end - !p);
1036
let mut = create_mutator heap in
1037
let rootval = add mut rootval_orig in
1038
heap.heap_value <- rootval;
1039
heap.heap_roots.(0) <- Obj.repr rootval;
1043
Netmcore_mempool.free_mem pool heap_mem;
added
removed
src/netmulticore/netmcore_heap.ml
