212 lines
7.0 KiB
OCaml
212 lines
7.0 KiB
OCaml
(* $Id: iovalue.ml,v 5.15 2012-01-27 16:27:46 ddr Exp $ *)
|
|
(* Copyright (c) 1998-2007 INRIA *)
|
|
|
|
(* Input:
|
|
read inside a value output by output_value (no headers) must
|
|
match OCaml's input_value system (intern.c) *)
|
|
|
|
let sizeof_long = 4
|
|
let sign_extend_shift = (((Sys.word_size / 8) - 1) * 8) - 1
|
|
let sign_extend x = (x lsl sign_extend_shift) asr sign_extend_shift
|
|
let prefix_SMALL_BLOCK = 0x80
|
|
let prefix_SMALL_INT = 0x40
|
|
let prefix_SMALL_STRING = 0x20
|
|
let code_INT8 = 0x0
|
|
let code_INT16 = 0x1
|
|
let code_INT32 = 0x2
|
|
let code_INT64 = 0x3
|
|
let code_BLOCK32 = 0x8
|
|
let code_BLOCK64 = 0x13
|
|
let code_STRING8 = 0x9
|
|
let code_STRING32 = 0xA
|
|
|
|
type 'a in_funs = {
|
|
input_byte : 'a -> int;
|
|
input_binary_int : 'a -> int;
|
|
input : 'a -> bytes -> int -> int -> unit;
|
|
}
|
|
|
|
let input_binary_int64 ifuns ic =
|
|
let rec loop cnt n =
|
|
if cnt = 0 then n else loop (cnt - 1) ((n lsl 8) + ifuns.input_byte ic)
|
|
in
|
|
loop 8 0
|
|
|
|
let rec input_loop ifuns ic =
|
|
let code = ifuns.input_byte ic in
|
|
if code >= prefix_SMALL_INT then
|
|
if code >= prefix_SMALL_BLOCK then
|
|
input_block ifuns ic (code land 0xf) ((code lsr 4) land 0x7)
|
|
else Obj.magic (code land 0x3f)
|
|
else if code >= prefix_SMALL_STRING then (
|
|
let len = code land 0x1F in
|
|
let s = Bytes.create len in
|
|
ifuns.input ic s 0 len;
|
|
Obj.magic s)
|
|
else if code = code_INT8 then Obj.magic (sign_extend (ifuns.input_byte ic))
|
|
else if code = code_INT16 then
|
|
let h = ifuns.input_byte ic in
|
|
Obj.magic ((sign_extend h lsl 8) + ifuns.input_byte ic)
|
|
else if code = code_INT32 then
|
|
let x1 = ifuns.input_byte ic in
|
|
let x2 = ifuns.input_byte ic in
|
|
let x3 = ifuns.input_byte ic in
|
|
let x4 = ifuns.input_byte ic in
|
|
Obj.magic ((sign_extend x1 lsl 24) + (x2 lsl 16) + (x3 lsl 8) + x4)
|
|
else if code = code_INT64 then
|
|
let () = assert (Sys.word_size = 64) in
|
|
Obj.magic (input_binary_int64 ifuns ic)
|
|
else if code = code_BLOCK32 then
|
|
let header = ifuns.input_binary_int ic in
|
|
Obj.magic (input_block ifuns ic (header land 0xff) (header lsr 10))
|
|
else if code = code_BLOCK64 then
|
|
if Sys.word_size = 64 then
|
|
let header = input_binary_int64 ifuns ic in
|
|
Obj.magic (input_block ifuns ic (header land 0xff) (header lsr 10))
|
|
else failwith "input bad code block 64"
|
|
else if code = code_STRING8 then (
|
|
let len = ifuns.input_byte ic in
|
|
let s = Bytes.create len in
|
|
ifuns.input ic s 0 len;
|
|
Obj.magic s)
|
|
else if code = code_STRING32 then (
|
|
let len = ifuns.input_binary_int ic in
|
|
let s = Bytes.create len in
|
|
ifuns.input ic s 0 len;
|
|
Obj.magic s)
|
|
else failwith (Printf.sprintf "input bad code 0x%x" code)
|
|
|
|
and input_block ifuns ic tag size =
|
|
let v =
|
|
if tag = 0 then Obj.magic (Array.make size (Obj.magic 0))
|
|
else Obj.new_block tag size
|
|
in
|
|
for i = 0 to size - 1 do
|
|
let x = input_loop ifuns ic in
|
|
Obj.set_field v i (Obj.magic x)
|
|
done;
|
|
v
|
|
|
|
let in_channel_funs = { input_byte; input_binary_int; input = really_input }
|
|
let input ic = Obj.magic (input_loop in_channel_funs ic)
|
|
|
|
(* Output *)
|
|
|
|
type 'a out_funs = {
|
|
output_byte : 'a -> int -> unit;
|
|
output_binary_int : 'a -> int -> unit;
|
|
output : 'a -> string -> int -> int -> unit;
|
|
}
|
|
|
|
let size_32 = ref 0
|
|
let size_64 = ref 0
|
|
|
|
let output_binary_int64 ofuns oc x =
|
|
for i = 1 to 8 do
|
|
ofuns.output_byte oc ((x lsr (64 - (8 * i))) land 0xFF)
|
|
done
|
|
|
|
let gen_output_block_header ofuns oc tag size =
|
|
let hd = (size lsl 10) + tag in
|
|
if tag < 16 && size < 8 then
|
|
ofuns.output_byte oc (prefix_SMALL_BLOCK + tag + (size lsl 4))
|
|
else if Sys.word_size = 64 && hd >= 1 lsl 32 then (
|
|
ofuns.output_byte oc code_BLOCK64;
|
|
output_binary_int64 ofuns oc hd)
|
|
else (
|
|
ofuns.output_byte oc code_BLOCK32;
|
|
(* hd = size << 10 + tag *)
|
|
ofuns.output_byte oc ((size lsr 14) land 0xFF);
|
|
ofuns.output_byte oc ((size lsr 6) land 0xFF);
|
|
ofuns.output_byte oc ((size lsl 2) land 0xFF);
|
|
ofuns.output_byte oc (((size lsl 10) land 0xFF) + tag));
|
|
if size = 0 then ()
|
|
else (
|
|
size_32 := !size_32 + 1 + size;
|
|
size_64 := !size_64 + 1 + size)
|
|
|
|
let rec output_loop ofuns oc x =
|
|
if Obj.is_int x then
|
|
if Obj.magic x >= 0 && Obj.magic x < 0x40 then
|
|
ofuns.output_byte oc (prefix_SMALL_INT + Obj.magic x)
|
|
else if Obj.magic x >= -128 && Obj.magic x < 128 then (
|
|
ofuns.output_byte oc code_INT8;
|
|
ofuns.output_byte oc (Obj.magic x))
|
|
else if Obj.magic x >= -32768 && Obj.magic x <= 32767 then (
|
|
ofuns.output_byte oc code_INT16;
|
|
ofuns.output_byte oc (Obj.magic x lsr 8);
|
|
ofuns.output_byte oc (Obj.magic x))
|
|
else if Obj.magic x >= -1073741824 && Obj.magic x <= 1073741823 then (
|
|
ofuns.output_byte oc code_INT32;
|
|
ofuns.output_binary_int oc (Obj.magic x))
|
|
else (
|
|
ofuns.output_byte oc code_INT64;
|
|
output_binary_int64 ofuns oc (Obj.magic x))
|
|
else if Obj.tag x = Obj.string_tag then (
|
|
let len = String.length (Obj.magic x) in
|
|
if len < 0x20 then ofuns.output_byte oc (prefix_SMALL_STRING + len)
|
|
else if len < 0x100 then (
|
|
ofuns.output_byte oc code_STRING8;
|
|
ofuns.output_byte oc len)
|
|
else (
|
|
ofuns.output_byte oc code_STRING32;
|
|
ofuns.output_binary_int oc len);
|
|
ofuns.output oc (Obj.magic x) 0 len;
|
|
size_32 := !size_32 + 1 + ((len + 4) / 4);
|
|
size_64 := !size_64 + 1 + ((len + 8) / 8))
|
|
else if Obj.tag x = Obj.double_tag || Obj.tag x = Obj.double_array_tag then
|
|
failwith "Iovalue.output: floats not implemented"
|
|
else if Obj.tag x = Obj.closure_tag then failwith "Iovalue.output <fun>"
|
|
else if Obj.tag x = Obj.abstract_tag then failwith "Iovalue.output <abstract>"
|
|
else if Obj.tag x = Obj.infix_tag then failwith "Iovalue.output: <infix>"
|
|
else if Obj.tag x = Obj.custom_tag then failwith "Iovalue.output: <custom>"
|
|
else if Obj.tag x = Obj.out_of_heap_tag then
|
|
failwith "Iovalue.output: abstract value (outside heap)"
|
|
else (
|
|
gen_output_block_header ofuns oc (Obj.tag x) (Obj.size x);
|
|
(* last case of "for" separated, to make more tail recursive cases
|
|
when last field is itself, to prevent some stacks overflows *)
|
|
if Obj.size x > 0 then (
|
|
for i = 0 to Obj.size x - 2 do
|
|
output_loop ofuns oc (Obj.field x i)
|
|
done;
|
|
output_loop ofuns oc (Obj.field x (Obj.size x - 1))))
|
|
|
|
let out_channel_funs =
|
|
{ output_byte; output_binary_int; output = output_substring }
|
|
|
|
let output oc x = output_loop out_channel_funs oc (Obj.repr x)
|
|
let gen_output ofuns i x = output_loop ofuns i (Obj.repr x)
|
|
|
|
(* Size *)
|
|
|
|
let size_funs =
|
|
{
|
|
output_byte = (fun r _ -> incr r);
|
|
output_binary_int = (fun r _ -> r := !r + 4);
|
|
output = (fun r _ beg len -> r := !r + len - beg);
|
|
}
|
|
|
|
let size = ref 0
|
|
|
|
let size v =
|
|
size := 0;
|
|
gen_output size_funs size v;
|
|
!size
|
|
|
|
let output_value_header_size = 20
|
|
|
|
let array_header_size arr_len =
|
|
if arr_len < 8 then 1
|
|
else if Sys.word_size = 64 && arr_len lsl 10 >= 1 lsl 32 then 9
|
|
else 5
|
|
|
|
let output_array_access oc arr_get arr_len pos =
|
|
let rec loop pos i =
|
|
if i = arr_len then pos
|
|
else (
|
|
output_binary_int oc pos;
|
|
loop (pos + size (arr_get i)) (i + 1))
|
|
in
|
|
loop (pos + output_value_header_size + array_header_size arr_len) 0
|