File: netshm_array.ml

package info (click to toggle)
ocamlnet 4.1.2-1
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 51,764 kB
  • ctags: 16,446
  • sloc: ml: 148,419; ansic: 10,989; sh: 1,885; makefile: 1,355
file content (144 lines) | stat: -rw-r--r-- 3,047 bytes parent folder | download | duplicates (3)
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
(* $Id$ *)

open Netshm
open Netshm_data

type 'a t =
    { table : shm_table;
      htbl : (int, 'a) Netshm_hashtbl.t;
      (* We use the hash table to store the normal elements. For the
       * length of the array, we use the index (-1) which is mapped
       * to an int instead of 'a. Implemented by bypassing htbl in this
       * case.
       *)
      idx_only_manager : int data_manager;
      idx_len_manager : (int * int) data_manager;
      default_val : 'a;
    }


let shm_table t = t.table

let with_length f t =
  let r = ref None in
  Netshm.read_blocks
    t.table
    (-1l)
    (fun frag_opt ->
       match frag_opt with
	 | Some frag ->
	     let length = Int32.to_int frag.{ 0 } in
	     r := Some (f length);
	     raise Break
	 | None ->
	     assert false
    );
  match !r with
    | None -> 
	assert false
    | Some x ->
	x

let length t = with_length (fun l -> l) t


let get t k = 
  with_length
    (fun length ->
       if k < 0 || k >= length then
	 invalid_arg "Netshm_array.get: index out of bounds";
       try
	 Netshm_hashtbl.find t.htbl k
       with
	 | Not_found -> t.default_val
    )
    t
;;


let set t k x = 
  with_length
    (fun length ->
       if k < 0 || k >= length then
	 invalid_arg "Netshm_array.set: index out of bounds";
       Netshm_hashtbl.replace t.htbl k x
    )
    t

let resize t n = 
  if n < 0 then invalid_arg "Netshm_array.resize";
  with_length
    (fun old_len ->
       (* First remove any element at indexes >= n *)
       if n < old_len then (
	 let l = ref [] in
	 Netshm_hashtbl.iter_keys
	   (fun idx -> 
	      if idx >= n then l := idx :: !l )
	   t.htbl;
	 List.iter
	   (fun idx ->
	      Netshm_hashtbl.remove t.htbl idx
	   )
	   !l
       );

       (* Finally just set the new length field: *)
       Netshm.write_blocks
	 t.table
	 []
	 (-1l)
	 (fun frag_opt ->
	    match frag_opt with
	      | Some frag ->
		  frag.{ 0 } <- Int32.of_int n;
		  raise Break
	      | None ->
		  assert false
	 )
    )
    t


let default_value t = t.default_val

let shm_table t = t.table


let manage ?pagesize ?init defval val_manager lm sd =
  let shm_init =
    match init with
      | Some n -> Some 1000
      | None -> None in
  let idx_manager = Netshm_data.int_manager in
  let htbl = 
    Netshm_hashtbl.manage
      ?pagesize ?init:shm_init idx_manager val_manager lm sd in
  let table = Netshm_hashtbl.shm_table htbl in
  let idx_only_manager =
    left_pair_manager idx_manager in
  let idx_len_manager =
    pair_manager idx_manager Netshm_data.int_manager in
  let t = 
    { table = table;
      htbl = htbl;
      idx_only_manager = idx_only_manager;
      idx_len_manager = idx_len_manager;
      default_val = defval
    } in
  Netshm.group table
    (fun () ->
       if not (Netshm.mem table (-1l)) then
	 let length_field = 
	   Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout 1 in
	 length_field.{ 0 } <- 0l;
	 Netshm.add table (-1l) length_field
    )
    ();
  ( match init with
      | None ->
	  ()
      | Some n ->
	  resize t n
  );
  t