(* $Id: netmcore_heap.ml 1826 2013-01-13 17:57:16Z gerd $ *)
(* Structure of the heaps:
Heaps consist of a root block and a list of extension blocks
(which is initially empty). Extension blocks are added when no more
memory is available in the blocks so far allocated. Extension
blocks can also be given back to the pool when they become empty
again. Blocks are never changed in size. The blocks are managed
with a doubly-linked list.
Both allocated memory and free memory in the heap must have
"Ocaml structure", i.e. there is always a header preceding the
value. The header includes the length and the bits for gabage
collection.
Free memory is also added to free lists if the memory area
consists of at least 2 words (1 word free memory can be first
reclaimed by the garabage collector). There are several free lists
for different sizes of the free areas.
When there is no more available memory, a garbage collection is
triggered (see below). If this is also not sufficient, a further
extension block is added.
Garbage collection is done by marking and sweeping, all in one
go. We use only the colors "black" and "white". In the sweep
phase also the free lists are completely rebuilt. This makes
it possible to merge adjacent free memory, and to reclaim
one word fragments.
Note that custom values (incl. bigarrays, int32, int64, nativeint)
cannot live in heaps, because the GC is not able to figure out which
mem regions are used by the custom blocks.
*)
(* FIXME: use better locking scheme (r/w locks) *)
(* FIXME: flag is_white: whether all values are white. Protect against
crashes during the mark phase
*)
open Printf
module Debug = struct
let enable = ref false
end
let dlog = Netlog.Debug.mk_dlog "Netmcore_heap" Debug.enable
let dlogr = Netlog.Debug.mk_dlogr "Netmcore_heap" Debug.enable
let () =
Netlog.Debug.register_module "Netmcore_heap" Debug.enable
type 'a heap =
{ heap_sem : Netsys_mem.memory;
heap_pool : Netmcore.res_id;
mutable heap_value : 'a;
heap_ext : ext_block;
heap_fl : Obj.t array;
mutable heap_roots : Obj.t array;
}
(* Repr details:
heap_ext is the first extension block (root block). See below for
repr details.
heap_fl: The free lists of unused Ocaml values. This array starts
several free lists: heap_fl.(k) is the free list for values with
a size of k words (k > 0). heap_fl.(0) is the free list for values
of any size.
The free list pointer references the free Obj.t (which is always
preceded by a header). The next element of the free list is in
field 0 of the Obj.t.
The special value null_obj is used for "None".
The values in [heap_roots] are considered as the roots. Values
null_obj are ignored in this array. The [heap_roots] array resides
in the heap. There is right now no free list providing fast access
to unused elements of this array (TBD).
Note that the heap_sem bigarray is ok because it is not stored in
the value area (bigarrays would be incompatible with our GC).
*)
and ext_block =
{ mutable ext_prev : int; (* encoded start address *)
mutable ext_next : int; (* encoded start address *)
ext_addr : nativeint; (* start address of the mem block *)
ext_size : int; (* size of the mem block *)
mutable ext_start : int; (* offset of value area start *)
ext_end : int; (* offset of value area end *)
}
(* Repr details:
Extension blocks: The first extension block is simply put into the
root memory block. The other extension blocks have this format:
At the beginning there is the [magic] string, followed by the
Ocaml value of the [ext_block] record. The remaining part of the memory
block can be used for storing values. This area starts at the
offset [ext_start] (relative to the beginning of the mem block), and
ends at [ext_end] (i.e. last byte is at [ext_end-1]).
ext_prev and ext_next: contain the encoded address of the memory block
containing the ext_block we are referring to. The encoding: Shift the
address 1 bit to the right, so it fits into an [int] value. The
special value [no_ext_block] is used to denote a "none". The special
value [root_ext_block] is used to denote the first extension block
(remember it does not have a mem block of its own, and is a special
case).
ext_addr: this is the address of the mem block containing the
ext_block record. ext_size is the size of this mem block in bytes.
Note that the ext_addr custom value is ok because it is not stored in
the value area (custom values would be incompatible with our GC).
*)
type 'a descr = int
type mutator =
{ heap : Obj.t heap;
mutable alive : bool;
mutable pinned : int list;
}
let fl_size = 64
let null_obj = Obj.repr 0
let magic = "NETHEAP\n"
let magic_len = 8
let min_ext_size = 65536
(* min size of an extension block *)
let max_ext_block = 256
(* max space for ext_block record in bytes *)
let no_ext_block = 0
(* used in ext_prev and ext_next *)
let root_ext_block = 1
(* used in ext_prev and ext_next *)
let n_roots = 20
(* initial number of root values *)
let bytes_per_word =
match Sys.word_size with
| 32 -> 4
| 64 -> 8
| _ -> assert false
let descr_of_heap heap =
let addr = heap.heap_ext.ext_addr in
Nativeint.to_int(Nativeint.shift_right addr 1)
let heap_of_descr pool ptr =
let addr = Nativeint.shift_left (Nativeint.of_int ptr) 1 in
try
let size = Netmcore_mempool.size_mem_at_addr pool addr in
let mem = Netsys_mem.grab addr size in
let u = String.create magic_len in
Netsys_mem.blit_memory_to_string mem 0 u 0 magic_len;
if u <> magic then raise Not_found;
let hoffs_s = String.create 8 in
Netsys_mem.blit_memory_to_string mem 8 hoffs_s 0 8;
let hoffs =
Netnumber.int_of_int8 (Netnumber.HO.read_int8 hoffs_s 0) in
Netsys_mem.as_value mem hoffs
with
| Not_found ->
failwith "Netmcore_heap.heap_of_descr: no heap structure found \
at this address"
let create_mutator heap =
{ heap = Obj.magic heap; alive = true; pinned = [] }
let ext_mem ext =
Netsys_mem.grab ext.ext_addr ext.ext_size
let ext_block heap (ptr:int) : ext_block =
(* for following ext_prev and ext_next *)
if ptr = no_ext_block then
failwith "Netmcore_heap.ext_block: null pointer";
if ptr = root_ext_block then
heap.heap_ext
else (
let nat_ptr = Nativeint.shift_left (Nativeint.of_int ptr) 1 in
let mem = Netsys_mem.grab nat_ptr max_ext_block in
let u = String.create magic_len in
Netsys_mem.blit_memory_to_string mem 0 u 0 magic_len;
if u <> magic then
failwith "Netmcore_heap.ext_block: bad magic";
Netsys_mem.as_value mem (magic_len + bytes_per_word)
)
let ptr_to_ext_block heap (ext:ext_block) : int =
if ext == heap.heap_ext then
root_ext_block
else
Nativeint.to_int (Nativeint.shift_right ext.ext_addr 1)
let debug_info heap =
let b = Buffer.create 80 in
bprintf b "pool = %d\n"
(match heap.heap_pool with
| `Resource id -> id
);
bprintf b "value = @0x%nx\n"
(Netsys_mem.obj_address (Obj.repr heap.heap_value));
for k = 0 to Array.length heap.heap_roots - 1 do
if heap.heap_roots.(k) != null_obj then
bprintf b "root[%d] = @0x%nx\n"
k (Netsys_mem.obj_address heap.heap_roots.(k));
done;
for k = 0 to Array.length heap.heap_fl - 1 do
if heap.heap_fl.(k) != null_obj then
bprintf b "fl[%d] = @0x%nx\n"
k (Netsys_mem.obj_address heap.heap_fl.(k));
done;
let p = ref 0 in
let ext = ref (Some heap.heap_ext) in
while !ext <> None do
match !ext with
| Some x ->
let next =
if x.ext_next = no_ext_block then
None
else
Some(ext_block heap x.ext_next) in
bprintf b "ext[%d] = @0x%nx, size 0x%x\n"
!p x.ext_addr x.ext_size;
incr p;
ext := next;
| None -> assert false
done;
Buffer.contents b
let extend_heap heap size =
(* Add another extension block to the heap so that a [size] value fits
into it
*)
dlogr (fun () -> sprintf "extend_heap size=%d" size);
let req_size = size + max_ext_block in
(* N.B. choosing max_ext_block high enough is crucial *)
let mem_size = max req_size min_ext_size in
let mem = Netmcore_mempool.alloc_mem heap.heap_pool mem_size in
try
let mem_real_size = Netmcore_mempool.size_mem heap.heap_pool mem in
(* mem_real_size >= mem_size! *)
Netsys_mem.blit_string_to_memory magic 0 mem 0 magic_len;
let old_next = heap.heap_ext.ext_next in
let ext_orig =
{ ext_prev = ptr_to_ext_block heap heap.heap_ext;
ext_next = old_next;
ext_addr = Netsys_mem.memory_address mem;
ext_size = mem_real_size;
ext_start = 0; (* later *)
ext_end = mem_real_size;
} in
let (voffs, n) =
Netsys_mem.init_value mem magic_len ext_orig
[Netsys_mem.Copy_bigarray; Netsys_mem.Copy_custom_int;
Netsys_mem.Keep_atom] in
let ext =
Netsys_mem.as_value mem voffs in
(* If the block is larger than the typical size of 64K, we initialize
it so that only the requested value fits exactly
*)
ext.ext_start <-
if req_size = mem_size then
mem_real_size - size
else
magic_len + n;
assert(ext.ext_start >= magic_len+n);
heap.heap_ext.ext_next <- ptr_to_ext_block heap ext;
if old_next <> no_ext_block then
(ext_block heap old_next).ext_prev <- ptr_to_ext_block heap ext;
dlogr (fun () -> sprintf "extent_heap addr=%nx real_size=%d usable=%d"
ext.ext_addr ext.ext_size (ext.ext_end - ext.ext_start));
Some(mem, ext.ext_start, ext.ext_end - ext.ext_start)
with
| error ->
Netmcore_mempool.free_mem heap.heap_pool mem;
raise error
let shrink_heap heap ext =
(* Remove ext from the chaining, and give the mem block back to the pool *)
dlogr (fun () -> sprintf "shrink_heap addr=%nx" ext.ext_addr);
assert (ext != heap.heap_ext);
let mem = Netsys_mem.grab ext.ext_addr ext.ext_size in
let u = String.create magic_len in
Netsys_mem.blit_memory_to_string mem 0 u 0 magic_len;
if u <> magic then
failwith "Netmcore_heap.shrink_heap";
let v = String.make magic_len ' ' in
Netsys_mem.blit_string_to_memory v 0 mem 0 magic_len;
(* ext is never the first element in the chain *)
let prev = ext_block heap ext.ext_prev in
prev.ext_next <- ext.ext_next;
if ext.ext_next <> no_ext_block then (
let next = ext_block heap ext.ext_next in
next.ext_prev <- ext.ext_prev
);
Netmcore_mempool.free_mem heap.heap_pool mem;
dlog "shrink_heap done"
let init_as_block mem offs size =
let words = size / bytes_per_word in
assert(words >= 2);
Netsys_mem.init_header mem offs Obj.string_tag (*block size:*)(words-1)
let init_as_atom mem offs =
Netsys_mem.init_header mem offs (*tag:*)0 (*block size:*)0
let del_in_fl heap (entry:Obj.t) (prev:Obj.t) =
let next = Obj.field entry 0 in
if prev == null_obj then (
(* it must be one of the root pointers *)
for k=0 to fl_size-1 do
if heap.heap_fl.(k) == entry then
heap.heap_fl.(k) <- next
done
)
else
Obj.set_field prev 0 next
let add_to_fl heap mem offs len =
let words = len / bytes_per_word in
let k = if words < fl_size then words else 0 in
let old_head = heap.heap_fl.(k) in
init_as_block mem offs len;
let v = Netsys_mem.as_value mem (offs + bytes_per_word) in
let o = Obj.repr v in
Obj.set_field o 0 old_head;
heap.heap_fl.(k) <- o
let memory_range_of_pool heap =
let res = Netmcore.get_resource heap.heap_pool in
let (start_addr, end_addr) =
match res#repr with
| `Posix_shm_preallocated_sc(_,mem,_) ->
let mem_size = Bigarray.Array1.dim mem in
let sa = Netsys_mem.memory_address mem in
let ea = Nativeint.add sa (Nativeint.of_int mem_size) in
(sa, ea)
| _ ->
assert false in
(start_addr, end_addr)
let do_gc heap =
(* Our assumption is that all values have the GC color "white".
Mark phase: Iter over all roots. For each root, visit the referenced
values, and set all values to the GC color "black" if they are visited
for the first time.
Sweep phase: Iter over all extension blocks. Iter over all values
in an extension block. "White" values are added to the freelist.
"Black" values are changed to "white" again, but remain otherwise
untouched.
The freelists are rebuilt during sweep. We check for the special
case that an extension block is completely empty - in this case
it is entirely removed.
*)
dlog "gc start";
let (start_addr,end_addr) = memory_range_of_pool heap in
dlogr (fun () ->
sprintf "range: 0x%nx - 0x%nx" start_addr end_addr);
let debug_addr = Hashtbl.create 20 in
(* For debugging [mark] *)
let rec mark (v:Obj.t) =
(* FIXME: this recursion can cause stack overflows *)
if Obj.is_block v then (
let a = Netsys_mem.hdr_address v in
(* We do not follow blocks that are outside the shm area. In general,
such out-of-shm blocks are likely to be erroneous, though
*)
if a >= start_addr && a < end_addr then (
if Netsys_mem.color v = Netsys_mem.White then (
dlogr (fun () -> sprintf "marking 0x%nx"
(Netsys_mem.obj_address v));
Netsys_mem.set_color v Netsys_mem.Black;
if !Debug.enable then
Hashtbl.replace debug_addr (Netsys_mem.obj_address v) ();
if Obj.tag v < Obj.no_scan_tag then (
let sz = Obj.size v in
for k = 0 to sz - 2 do
mark (Obj.field v k)
done;
if sz >= 1 then
mark (Obj.field v (sz-1)) (* tail-rec *)
)
)
else (
if !Debug.enable then (
if not (Hashtbl.mem debug_addr (Netsys_mem.obj_address v)) then (
dlog (sprintf "wrong color at 0x%nx"
(Netsys_mem.obj_address v))
)
)
)
)
else dlog "addr out of range"
) in
let sweep_ext ext =
dlogr (fun () -> sprintf "sweep_ext addr=%nx" ext.ext_addr);
let mem = Netsys_mem.grab ext.ext_addr ext.ext_size in
let offs = ref ext.ext_start in
let cur_fl_entry = ref None in
let all_free = ref true in
let free_size = ref 0 in
let push() =
match !cur_fl_entry with
| Some(fl_offs,fl_len) ->
free_size := !free_size + fl_len;
if fl_len > bytes_per_word then
add_to_fl heap mem fl_offs fl_len
else
init_as_atom mem fl_offs;
cur_fl_entry := None
| None -> ()
in
let bigarray_data_size p =
(* Check for bigarrays. Netsys_mem.init_value uses a special
convention for marking the data part of the bigarray: The
data part is started with an _empty_ abstract block, followed
by the size of the data part, and finally followed by the
data part.
*)
if p + bytes_per_word < ext.ext_end then (
let v1 = Netsys_mem.as_value mem (p + bytes_per_word) in
if Obj.tag v1 = Obj.abstract_tag && Obj.size v1 = 0 then (
let data_size_s = String.create bytes_per_word in
Netsys_mem.blit_memory_to_string
mem (p + bytes_per_word) data_size_s 0 bytes_per_word;
let data_size =
match bytes_per_word with
| 4 -> Netnumber.int_of_uint4
(Netnumber.HO.read_uint4 data_size_s 0)
| 8 -> Netnumber.int_of_uint8
(Netnumber.HO.read_uint8 data_size_s 0)
| _ -> assert false in
data_size + 2 (* 2 for the abstract block and the length *)
)
else 0
)
else 0
in
while !offs < ext.ext_end do
let v = Netsys_mem.as_value mem (!offs + bytes_per_word) in
let sz = Obj.size v in
let next_offs = !offs + (sz+1)*bytes_per_word in
let extra_size =
if Obj.tag v = Obj.custom_tag && Netsys_mem.is_bigarray v then
bigarray_data_size next_offs
else
0 in
( match Netsys_mem.color v with
| Netsys_mem.White ->
dlogr (fun () -> sprintf "freeing 0x%nx"
(Nativeint.add ext.ext_addr
(Nativeint.of_int (!offs + bytes_per_word))));
let sz_total = sz + 1 + extra_size in
( match !cur_fl_entry with
| None ->
cur_fl_entry := Some(!offs, sz_total * bytes_per_word)
| Some(fl_offs, fl_len) ->
cur_fl_entry := Some(fl_offs,
fl_len +
sz_total * bytes_per_word)
);
| _ ->
dlogr (fun () -> sprintf "keeping 0x%nx"
(Nativeint.add ext.ext_addr
(Nativeint.of_int (!offs + bytes_per_word))));
all_free := false;
Netsys_mem.set_color v Netsys_mem.White;
push()
);
offs := next_offs + extra_size * bytes_per_word;
done;
if !all_free && ext != heap.heap_ext then
shrink_heap heap ext
else
push();
dlogr (fun () -> sprintf "sweep_ext free_size=%d" !free_size);
(!free_size, ext.ext_end - ext.ext_start)
in
let sweep () =
(* Reset the free lists: *)
for k = 0 to fl_size - 1 do
heap.heap_fl.(k) <- null_obj
done;
(* Iterate over the extension blocks: *)
let ext = ref (Some heap.heap_ext) in
let free_total = ref 0 in
let size_total = ref 0 in
while !ext <> None do
match !ext with
| Some x ->
(* Get the [next] block now, because [x] may be deleted *)
let next =
if x.ext_next = no_ext_block then
None
else
Some(ext_block heap x.ext_next) in
let (f,s) = sweep_ext x in
free_total := !free_total + f;
size_total := !size_total + s;
ext := next
| None -> assert false
done;
(!free_total, !size_total) in
dlog "mark";
let root = Obj.repr heap.heap_roots in
(* root is the only value that is not reset to white color! *)
Netsys_mem.set_color root Netsys_mem.White;
mark root;
dlog "sweep";
let (f,s) = sweep() in
dlog "gc done";
(f, s)
let do_gc_adjust heap size =
(* Do a GC pass and adjust the amount of free mem. If new mem is allocated
it should be at least [size]
*)
let (free, total) = do_gc heap in
if free < total/2 then (
let alloc_size0 = max size (total/2 - free) in
let alloc_size = ((alloc_size0 - 1) / 8 + 1) * 8 in
dlogr (fun () -> sprintf "do_gc_adjust: alloc_size=%d" alloc_size);
( match extend_heap heap alloc_size with
| Some(mem, offs, len) ->
add_to_fl heap mem offs len
| None ->
()
)
)
let find_free_block heap size =
(* Find a free block >= [size] in the freelists *)
dlogr (fun () -> sprintf "find_free_block size=%d" size);
let words = size / bytes_per_word in
let k = ref(if words < fl_size then words else 0) in
let prev = ref null_obj in
let cur = ref heap.heap_fl.( !k ) in
let found = ref false in
let best = ref null_obj in
let best_prev = ref null_obj in
let best_size = ref max_int in
while not !found && (!cur != null_obj || !k > 0) do
if !cur == null_obj then (
incr k;
if !k = fl_size then k := 0;
prev := null_obj;
cur := heap.heap_fl.( !k )
) else (
let n = Obj.size !cur in
(* Actually, we have one more word than n because of the value header *)
if n+1 >= words && n+1 < !best_size then (
best := !cur;
best_prev := !prev;
best_size := n+1;
);
if n+1=words then found := true;
prev := !cur;
cur := Obj.field !cur 0
)
done;
if !best != null_obj then (
dlog "found free block";
let addr = Netsys_mem.hdr_address !best in
let byte_size = (Obj.size !best + 1) * bytes_per_word in
let mem = Netsys_mem.grab addr byte_size in
Some(mem, 0, byte_size, !best, !best_prev)
)
else
None
let alloc_in_free_block heap size mem offs len entry prev =
(* Take a part of the free block at [mem+offs..mem+offs+len-1] to
satisfy the allocation of a block of [size]. [entry] is the
entry in the freelist. [prev] is the predecessor in the freelist
or [null].
*)
dlogr (fun () ->
sprintf "alloc_in_free_block size=%d len=%d" size len);
del_in_fl heap entry prev;
init_as_block mem offs size;
if len = size then
(* The whole block can be used *)
(mem, offs)
else (
(* The block needs to be split *)
if len = size + bytes_per_word then (
(* The remaining part would only have 1 word. We initialize this word
as zero-length block, but it is not entered into a freelist
*)
init_as_atom mem (offs+size);
(mem, offs)
)
else (
(* the remaining part is added to a freelist *)
add_to_fl heap mem (offs+size) (len - size);
(mem, offs)
)
)
let alloc heap size =
(* First search in the freelists *)
(* assert: size divisible by word size *)
dlogr (fun () -> sprintf "alloc size=%d" size);
match find_free_block heap size with
| Some(mem, offs, len, obj, prev) ->
dlog "alloc: got block from free list";
alloc_in_free_block heap size mem offs len obj prev
| None ->
(* Nothing found in the freelists: Do now a GC pass, and try again.
*)
( do_gc_adjust heap size;
match find_free_block heap size with
| Some(mem, offs, len, obj, prev) ->
dlog "alloc: got block from free list";
alloc_in_free_block heap size mem offs len obj prev
| None ->
(* Still unsuccessful. Add another block and try again *)
dlog "alloc: extending heap";
( match extend_heap heap size with
| Some(mem, offs, len) ->
(*
eprintf "mem=%nx offs=%x len=%d\n%!"
(Netsys_mem.memory_address mem)
offs
len;
*)
if len = size then (
init_as_block mem offs size;
(mem,offs)
)
else (
assert(len <> size + bytes_per_word);
init_as_block mem offs size;
add_to_fl heap mem (offs+size) (len - size);
(mem,offs)
)
| None ->
raise Netmcore_mempool.Out_of_pool_memory
)
)
let add mut newval =
(* It is assumed that we already got the lock for the heap *)
dlog "add";
if not mut.alive then
failwith "Netmcore_heap.add: invalid mutator";
if Obj.is_int (Obj.repr newval) then
newval
else (
let heap = mut.heap in
let heap_mem = ext_mem heap.heap_ext in
let _, size =
Netsys_mem.init_value
heap_mem 0 newval
[ Netsys_mem.Copy_simulate; Netsys_mem.Keep_atom;
Netsys_mem.Copy_custom_int; Netsys_mem.Copy_bigarray;
] in
assert(size mod bytes_per_word = 0);
(* We need [size] bytes to store [newval] *)
let (mem, offs) = alloc heap size in
(* Do the copy: Note that we need the same flags here as above,
except Copy_simulate which is omitted
*)
let voffs, size' =
Netsys_mem.init_value
mem offs newval
[Netsys_mem.Keep_atom; Netsys_mem.Copy_custom_int;
Netsys_mem.Copy_bigarray] in
assert(size = size');
(* Return the new value: *)
dlog "add done";
Netsys_mem.as_value mem voffs
)
let add_immutable mut newval =
(* It is assumed that we already got the lock for the heap *)
dlog "add";
if not mut.alive then
failwith "Netmcore_heap.add_immutable: invalid mutator";
if Obj.is_int (Obj.repr newval) then
newval
else (
let heap = mut.heap in
let heap_mem = ext_mem heap.heap_ext in
let (start_addr,end_addr) = memory_range_of_pool heap in
let cc = [ (start_addr,end_addr) ] in
let _, size =
Netsys_mem.init_value
~cc heap_mem 0 newval
[ Netsys_mem.Copy_simulate; Netsys_mem.Keep_atom;
Netsys_mem.Copy_custom_int; Netsys_mem.Copy_bigarray;
Netsys_mem.Copy_conditionally
] in
assert(size mod bytes_per_word = 0);
(* We need [size] bytes to store [newval] *)
let (mem, offs) = alloc heap size in
(* Do the copy: Note that we need the same flags here as above,
except Copy_simulate which is omitted
*)
let voffs, size' =
Netsys_mem.init_value
~cc mem offs newval
[Netsys_mem.Keep_atom; Netsys_mem.Copy_custom_int;
Netsys_mem.Copy_bigarray; Netsys_mem.Copy_conditionally
] in
assert(size = size');
(* Return the new value: *)
dlog "add done";
Netsys_mem.as_value mem voffs
)
let add_string mut length =
(* It is assumed that we already got the lock for the heap *)
dlog "add";
if not mut.alive then
failwith "Netmcore_heap.add_string: invalid mutator";
let heap = mut.heap in
let size = Netsys_mem.init_string_bytelen length in
assert(size mod bytes_per_word = 0);
(* We need [size] bytes to store [newval] *)
let (mem, offs) = alloc heap size in
let voffs, size' = Netsys_mem.init_string mem offs length in
assert(size = size');
(* Return the new value: *)
dlog "add_string done";
Netsys_mem.as_value mem voffs
let add_some mut (x:'a) =
(* Very low-level! *)
let y_orig = (Some (Obj.magic 0) : 'a option) in
let y = add mut y_orig in
Obj.set_field (Obj.repr y) 0 (Obj.repr x);
y
let set_tmp_root heap x =
if Obj.is_block (Obj.repr x) then (
dlog "set_tmp_root: searching for free root element";
(* Look for a free entry in the list of roots. There is always a
free entry
*)
let n = Array.length heap.heap_roots in
let found = ref false in
let k = ref (-1) in
while not !found && !k < n-1 do
incr k;
found := heap.heap_roots.( !k ) == null_obj
done;
assert(!found);
dlogr
(fun () -> sprintf "set_tmp_root: root element %d" !k);
heap.heap_roots.( !k ) <- Obj.repr x;
(* If the array of roots is full, reallocate it.
At this point we can reallocate, because x is already member of
the roots array. (Realloction can trigger the GC!)
*)
let j = ref !k in
found := false;
while not !found && !j < n-1 do
incr j;
found := heap.heap_roots.( !j ) == null_obj
done;
if not !found then (
dlog "set_tmp_root: reallocation";
let r_orig = Array.make (2*n) null_obj in
let mut = create_mutator heap in
let r = add mut r_orig in
Array.blit heap.heap_roots 0 r 0 n;
heap.heap_roots <- r;
);
!k
)
else (-1)
let release_tmp_root heap k =
dlog "release_tmp_root: freeing root";
if k >= 0 then
heap.heap_roots.(k) <- null_obj
let add_uniform_array mut n x_orig =
if not mut.alive then
failwith "Netmcore_heap.add_uniform_array: invalid mutator";
let heap = mut.heap in
let heap_mem = ext_mem heap.heap_ext in
let x_orig_obj = Obj.repr x_orig in
let x_is_float =
Obj.is_block x_orig_obj && Obj.tag x_orig_obj = Obj.double_tag in
let x_is_block =
Obj.is_block x_orig_obj && Obj.tag x_orig_obj <> Obj.double_tag in
let x_size =
if x_is_block then
snd (
Netsys_mem.init_value
heap_mem 0 x_orig
[ Netsys_mem.Copy_simulate; Netsys_mem.Keep_atom;
Netsys_mem.Copy_custom_int; Netsys_mem.Copy_bigarray
])
else
0 in
let a_size =
if x_is_float then
Netsys_mem.init_float_array_bytelen n
else
Netsys_mem.init_array_bytelen n in
let t_size = x_size + a_size in
(* allocate in one go, so the new value cannot be garbage collected *)
let (mem,offs) = alloc heap t_size in
let x =
if x_is_block then (
let x_voffs, _ =
Netsys_mem.init_value
mem offs x_orig
[Netsys_mem.Keep_atom; Netsys_mem.Copy_custom_int;
Netsys_mem.Copy_bigarray
] in
Netsys_mem.as_value mem x_voffs
)
else x_orig in
let a_offs = offs + x_size in
let a =
if x_is_float then (
let (a_voffs, _) = Netsys_mem.init_float_array mem a_offs n in
let a = (Netsys_mem.as_value mem a_voffs : _ array) in
let a_obj = Obj.repr a in
let x_float = (Obj.obj x_orig_obj : float) in
for k = 0 to n-1 do
Obj.set_double_field a_obj k x_float
done;
a
)
else (
let (a_voffs, _) = Netsys_mem.init_array mem a_offs n in
let a = (Netsys_mem.as_value mem a_voffs : _ array) in
let a_obj = Obj.repr a in
let x_obj = Obj.repr x in
for k = 0 to n-1 do
Obj.set_field a_obj k x_obj
done;
a
) in
a
let add_init_array mut n f =
if not mut.alive then
failwith "Netmcore_heap.add_init_array: invalid mutator";
if n=0 then
Obj.magic(add_uniform_array mut 0 0)
else (
let x0 = f 0 in
let a = add_uniform_array mut n x0 in
let r = set_tmp_root mut.heap a in
for k = 1 to n-1 do
Array.unsafe_set a k (add mut (f k))
done;
release_tmp_root mut.heap r;
a
)
let with_lock heap f =
dlog "with_lock waiting";
let c = Netmcore_mempool.sem_container heap.heap_pool in
let sem = Netsys_sem.as_sem c heap.heap_sem 0 in
Netsys_sem.sem_wait sem Netsys_posix.SEM_WAIT_BLOCK;
dlog "with_lock cont";
try
let r = f() in
Netsys_sem.sem_post sem;
dlog "with_lock returning";
r
with
| error ->
Netsys_sem.sem_post sem;
dlog "with_lock exception";
raise error
let gc heap =
with_lock heap
(fun () ->
ignore(do_gc heap)
)
let pin mut x =
(* FIXME: there is a cheaper way of pinning, because we have the
heap lock. We could also just gather the roots in a list, and
consider this list during GC
*)
let k = set_tmp_root mut.heap x in
mut.pinned <- k :: mut.pinned
let modify heap mutate =
with_lock heap
(fun () ->
let mut = create_mutator (Obj.magic heap) in
let finish() =
mut.alive <- false;
List.iter (fun k -> release_tmp_root heap k) mut.pinned in
try
let r = mutate mut in
finish();
r
with
| error ->
finish();
raise error
)
let copy x =
if Obj.is_block (Obj.repr x) then
Netsys_mem.copy_value
[Netsys_mem.Keep_atom; Netsys_mem.Copy_custom_int;
Netsys_mem.Copy_bigarray]
x
else
x
let with_value_n heap find process =
dlog "with_value";
let l, k_list =
with_lock heap
(fun () ->
let l = find() in
let k_list = List.map (fun x -> set_tmp_root heap x) l in
l, k_list
) in
dlog "with_value: process";
let y = process l in
(* We need the lock again *)
with_lock heap
(fun () ->
List.iter (release_tmp_root heap) k_list
);
dlog "with_value: returning";
y
let with_value heap find process =
with_value_n
heap
(fun () -> [find()])
(function [x] -> process x | _ -> assert false)
let with_value_2 heap (find : unit -> ('t1 * 't2)) process =
with_value_n
heap
(fun () ->
let (x1,x2) = find() in
[ Obj.repr x1; Obj.repr x2 ]
)
(function
| [x1; x2] -> process ((Obj.obj x1 : 't1), (Obj.obj x2 : 't2))
| _ -> assert false
)
let with_value_3 heap find process =
with_value_n
heap
(fun () ->
let (x1,x2,x3) = find() in
[ Obj.repr x1; Obj.repr x2; Obj.repr x3 ]
)
(function
| [x1; x2; x3] -> process ((Obj.obj x1), (Obj.obj x2), (Obj.obj x3))
| _ -> assert false
)
let with_value_4 heap find process =
with_value_n
heap
(fun () ->
let (x1,x2,x3,x4) = find() in
[ Obj.repr x1; Obj.repr x2; Obj.repr x3; Obj.repr x4 ]
)
(function
| [x1; x2; x3; x4] ->
process ((Obj.obj x1), (Obj.obj x2), (Obj.obj x3), (Obj.obj x4))
| _ -> assert false
)
let with_value_5 heap find process =
with_value_n
heap
(fun () ->
let (x1,x2,x3,x4,x5) = find() in
[ Obj.repr x1; Obj.repr x2; Obj.repr x3; Obj.repr x4; Obj.repr x5 ]
)
(function
| [x1; x2; x3; x4; x5] ->
process
((Obj.obj x1), (Obj.obj x2), (Obj.obj x3), (Obj.obj x4),
(Obj.obj x5))
| _ -> assert false
)
let root heap =
heap.heap_value
let dummy_mem =
Bigarray.Array1.create Bigarray.char Bigarray.c_layout bytes_per_word
let minimum_size x =
if Obj.is_block (Obj.repr x) then
let (_, n) =
Netsys_mem.init_value
dummy_mem 0 x
[ Netsys_mem.Copy_simulate; Netsys_mem.Keep_atom;
Netsys_mem.Copy_custom_int; Netsys_mem.Copy_bigarray
] in
n + ((40 + fl_size + n_roots) * bytes_per_word)
(* this is just an estimate *)
else
((40 + fl_size + n_roots) * bytes_per_word)
let destroy heap =
let c = Netmcore_mempool.sem_container heap.heap_pool in
let ext = ref (Some heap.heap_ext) in
let first = ref true in
while !ext <> None do
match !ext with
| Some x ->
(* Get the [next] block now, because [x] is deleted *)
let next =
if x.ext_next = no_ext_block then
None
else
Some(ext_block heap x.ext_next) in
if not !first then
shrink_heap heap x;
ext := next;
first := false
| None -> assert false
done;
let sem = Netsys_sem.as_sem c heap.heap_sem 0 in
Netsys_sem.sem_destroy c sem;
let heap_mem =
Netsys_mem.grab heap.heap_ext.ext_addr heap.heap_ext.ext_size in
Netmcore_mempool.free_mem heap.heap_pool heap_mem
let pool heap =
heap.heap_pool
let mut_pool mut =
pool (mut.heap)
let sem_container heap =
Netmcore_mempool.sem_container heap.heap_pool
let mut_sem_container mut =
sem_container (mut.heap)
let create_sem_mem pool_id =
let m =
Bigarray.Array1.create
Bigarray.char Bigarray.c_layout Netsys_sem.sem_size in
let c = Netmcore_mempool.sem_container pool_id in
ignore(Netsys_sem.sem_init c m 0 true 1);
m
let create_heap pool size rootval_orig =
if not (Obj.is_block (Obj.repr rootval_orig)) then
failwith "Netmcore_heap.create_heap: the root element is not a block";
let heap_mem = Netmcore_mempool.alloc_mem pool size in
try
let heap_ext_orig =
{ ext_prev = no_ext_block;
ext_next = no_ext_block;
ext_addr = Netsys_mem.memory_address heap_mem;
ext_size = Bigarray.Array1.dim heap_mem;
ext_start = 0; (* fixed later *)
ext_end = Bigarray.Array1.dim heap_mem
} in
let heap_orig =
{ heap_sem = create_sem_mem pool;
heap_pool = pool;
heap_value = Obj.obj null_obj;
heap_ext = heap_ext_orig;
heap_fl = Array.make fl_size null_obj;
heap_roots = Array.make n_roots null_obj;
(* FIXME: the initial roots array should better be allocated in the
value area
*)
} in
let p = ref 0 in
Netsys_mem.blit_string_to_memory magic 0 heap_mem !p magic_len;
p := !p + magic_len;
let p_hoffs = !p in
p := !p + 8;
let (voffs, n) =
Netsys_mem.init_value heap_mem !p heap_orig
[Netsys_mem.Copy_bigarray; Netsys_mem.Copy_custom_int;
Netsys_mem.Keep_atom] in
let hoffs_s =
Netnumber.HO.int8_as_string (Netnumber.int8_of_int voffs) in
Netsys_mem.blit_string_to_memory hoffs_s 0 heap_mem p_hoffs 8;
p := !p + n;
let heap = (Netsys_mem.as_value heap_mem voffs : _ heap) in
heap.heap_ext.ext_start <- !p;
add_to_fl heap heap_mem !p (heap.heap_ext.ext_end - !p);
let mut = create_mutator heap in
let rootval = add mut rootval_orig in
heap.heap_value <- rootval;
heap.heap_roots.(0) <- Obj.repr rootval;
heap
with
| error ->
Netmcore_mempool.free_mem pool heap_mem;
raise error
