Simple wrapper around Unix.mmap. Mainly used to work with matrices.

mmap.ml

open Unix
open Hashtbl
open Bigarray
open Bigarray.Array2

module type Params = sig
  type a
  type b
  type c
  val kind : (a,b) Bigarray.kind
  val layout : c Bigarray.layout
end

module Make(P : Params) = struct
  let kind = P.kind
  let layout = P.layout
  let tbl = Hashtbl.create 20

  let determine_dims kind fname = function
    | None, None ->
      invalid_arg "E: mmap: at least on dimension must be given"
    | Some rows, Some cols -> rows,cols
    | r,c ->
      begin
        let open Unix in
        let stt = stat fname in
        let ksize = kind_size_in_bytes kind in
        match r,c with
        | Some r, None -> r, (stt.st_size/(ksize*r))
        | None, Some c -> (stt.st_size/(ksize*c)), c
        | _ -> (-1),(-1) (* це ніколи не спрацює *)
      end


  let create fname rows cols =
    let mfile = openfile fname [O_RDWR; O_CREAT] 0o600 in
    let data =
      array2_of_genarray @@
      Unix.map_file mfile kind layout true [|rows; cols|] in
    Hashtbl.add tbl data mfile; data


  let connect ?rows ?cols fname =
    let rows,cols = determine_dims kind fname (rows,cols) in
    let mfile = openfile fname [O_RDWR] 0o600 in
    let data =
      array2_of_genarray @@
      Unix.map_file mfile kind layout true [|rows; cols|] in
    Hashtbl.add tbl data mfile; data


  let disconnect data =
    try
      let mfile = Hashtbl.find tbl data in
      close mfile;
      Hashtbl.remove tbl data
    with Not_found -> ()

  (** Return list of pairs (Matrix, file_name) *)
  let get_list () = Hashtbl.fold (fun k v r -> (k,v) :: r) tbl
end

module FF64 = struct
  type a = float
  type b = float64_elt
  type c = fortran_layout
  let kind = float64
  let layout = Fortran_layout
end

module CF64 = struct
  type a = float
  type b = float64_elt
  type c = c_layout
  let kind = Float64
  let layout = C_layout
end

module FF32 = struct
  type a = float
  type b = float32_elt
  type c = fortran_layout
  let kind = Float32
  let layout = Fortran_layout
end

module CF32 = struct
  type a = float
  type b = float32_elt
  type c = c_layout
  let kind = Float32
  let layout = C_layout
end

module F64 = Make(FF64)
module F32 = Make(FF32)