Source file gpointer.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
(**************************************************************************)
(*                Lablgtk                                                 *)
(*                                                                        *)
(*    This program is free software; you can redistribute it              *)
(*    and/or modify it under the terms of the GNU Library General         *)
(*    Public License as published by the Free Software Foundation         *)
(*    version 2, with the exception described in file COPYING which       *)
(*    comes with the library.                                             *)
(*                                                                        *)
(*    This program is distributed in the hope that it will be useful,     *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of      *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the       *)
(*    GNU Library General Public License for more details.                *)
(*                                                                        *)
(*    You should have received a copy of the GNU Library General          *)
(*    Public License along with this program; if not, write to the        *)
(*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,         *)
(*    Boston, MA 02111-1307  USA                                          *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

(* $Id$ *)

open StdLabels

(* marked pointers *)
type 'a optaddr

let optaddr : 'a option -> 'a optaddr =
  function
      None -> Obj.magic 0
    | Some x -> Obj.magic x

(* boxed pointers *)
type boxed
let boxed_null : boxed = Obj.magic Nativeint.zero

external peek_string : ?pos:int -> ?len:int -> boxed -> string
    = "ml_string_at_pointer"
external peek_int : boxed -> int
    = "ml_int_at_pointer"
external poke_int : boxed -> int -> unit
    = "ml_set_int_at_pointer"
external peek_nativeint : boxed -> nativeint
    = "ml_long_at_pointer"
external poke_nativeint : boxed -> nativeint -> unit
    = "ml_set_long_at_pointer"

type 'a optboxed

let optboxed : 'a option -> 'a optboxed =
  function
      None -> Obj.magic boxed_null
    | Some obj -> Obj.magic obj

let may_box ~f obj : 'a optboxed =
  match obj with
    None -> Obj.magic boxed_null
  | Some obj -> Obj.magic (f obj : 'a)

(* Variant tables *)

type 'a variant_table constraint 'a = [> ]

external decode_variant : 'a variant_table -> int -> 'a
  = "ml_ml_lookup_from_c"
external encode_variant : 'a variant_table -> 'a -> int
  = "ml_ml_lookup_to_c"

let encode_flags tbl l =
  List.fold_left l ~init:0 ~f:(fun acc v -> acc lor (encode_variant tbl v))

let decode_flags tbl c =
  let l = ref [] in
  for i = 30 downto 0 do (* only 31-bits in ocaml usual integers *)
    let d = 1 lsl i in
    if c land d <> 0 then l := decode_variant tbl d :: !l
  done;
  !l

(* Exceptions *)

exception Null
let _ =  Callback.register_exception "null_pointer" Null

(* Stable pointer *)
type 'a stable
external stable_copy : 'a -> 'a stable = "ml_stable_copy"

(* Region pointers *)

type region = { data: Obj.t; path: int array; offset:int; length: int }

let length reg = reg.length

let unsafe_create_region ~path ~get_length data =
  { data = Obj.repr data; path = path; offset = 0; length = get_length data }

let sub ?(pos=0) ?len reg =
  let len = match len with Some x -> x | None -> reg.length - pos in
  if pos < 0 || pos > reg.length || pos + len > reg.length then
    invalid_arg "Gpointer.sub";
  { reg with offset = reg.offset + pos; length = len }

external unsafe_get_byte : region -> pos:int -> int
    = "ml_gpointer_get_char"
external unsafe_set_byte : region -> pos:int -> int -> unit
    = "ml_gpointer_set_char"
external unsafe_blit : src:region -> dst:region -> unit
    ="ml_gpointer_blit"

(* handle with care, if allocation not static *)
external get_addr : region -> nativeint
    = "ml_gpointer_get_addr"

let get_byte reg ~pos =
  if pos >= reg.length then invalid_arg "Gpointer.get_char";
  unsafe_get_byte reg ~pos

let set_byte reg ~pos ch =
  if pos >= reg.length then invalid_arg "Gpointer.set_char";
  unsafe_set_byte reg ~pos ch

let blit ~src ~dst =
  if src.length <> dst.length then invalid_arg "Gpointer.blit";
  unsafe_blit ~src ~dst

(* Making a region from a string is easy *)
let region_of_bytes =
  unsafe_create_region ~path:[||] ~get_length:Bytes.length

let bytes_of_region reg =
  let s = Bytes.create reg.length in
  let reg' = region_of_bytes s in
  unsafe_blit reg reg';
  s

(* Access bigarrays breaking the abstraction... dirty *)
type 'a bigarray = (int, Bigarray.int8_unsigned_elt, 'a) Bigarray.Array1.t
let bigarray_size (arr : 'a bigarray) =
  let size =
    { data = Obj.repr arr; path = [|1+4|]; offset = 0; length = 0 } in
  Nativeint.to_int (get_addr size)
let region_of_bigarray arr =
  unsafe_create_region ~path:[|1|] ~get_length:bigarray_size arr