Ajout de flush_all + modifs pour Cash (Bruno Verlyck)
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3872 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
parent
48485d8d8a
commit
2f7123618c
BIN
boot/ocamllex
BIN
boot/ocamllex
Binary file not shown.
|
@ -93,7 +93,7 @@ static value read_debug_info(void)
|
||||||
close(fd);
|
close(fd);
|
||||||
CAMLreturn(Val_false);
|
CAMLreturn(Val_false);
|
||||||
}
|
}
|
||||||
chan = open_descriptor(fd);
|
chan = open_descriptor_in(fd);
|
||||||
num_events = getword(chan);
|
num_events = getword(chan);
|
||||||
events = alloc(num_events, 0);
|
events = alloc(num_events, 0);
|
||||||
for (i = 0; i < num_events; i++) {
|
for (i = 0; i < num_events; i++) {
|
||||||
|
|
|
@ -72,8 +72,8 @@ static void open_connection(void)
|
||||||
if (dbg_socket == -1 ||
|
if (dbg_socket == -1 ||
|
||||||
connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1)
|
connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1)
|
||||||
fatal_error("cannot connect to debugger");
|
fatal_error("cannot connect to debugger");
|
||||||
dbg_in = open_descriptor(dbg_socket);
|
dbg_in = open_descriptor_in(dbg_socket);
|
||||||
dbg_out = open_descriptor(dbg_socket);
|
dbg_out = open_descriptor_out(dbg_socket);
|
||||||
if (!debugger_in_use) putword(dbg_out, -1); /* first connection */
|
if (!debugger_in_use) putword(dbg_out, -1); /* first connection */
|
||||||
putword(dbg_out, getpid());
|
putword(dbg_out, getpid());
|
||||||
flush(dbg_out);
|
flush(dbg_out);
|
||||||
|
|
|
@ -102,7 +102,7 @@ static void intern_cleanup(void)
|
||||||
if (intern_extra_block != NULL) {
|
if (intern_extra_block != NULL) {
|
||||||
/* free newly allocated heap chunk */
|
/* free newly allocated heap chunk */
|
||||||
free_for_heap(intern_extra_block);
|
free_for_heap(intern_extra_block);
|
||||||
} else if (intern_block != NULL) {
|
} else if (intern_block != 0) {
|
||||||
/* restore original header for heap block, otherwise GC is confused */
|
/* restore original header for heap block, otherwise GC is confused */
|
||||||
Hd_val(intern_block) = intern_header;
|
Hd_val(intern_block) = intern_header;
|
||||||
}
|
}
|
||||||
|
@ -286,7 +286,7 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
|
||||||
if (whsize == 0) {
|
if (whsize == 0) {
|
||||||
intern_obj_table = NULL;
|
intern_obj_table = NULL;
|
||||||
intern_extra_block = NULL;
|
intern_extra_block = NULL;
|
||||||
intern_block = NULL;
|
intern_block = 0;
|
||||||
return;
|
return;
|
||||||
}
|
}
|
||||||
wosize = Wosize_whsize(whsize);
|
wosize = Wosize_whsize(whsize);
|
||||||
|
|
80
byterun/io.c
80
byterun/io.c
|
@ -48,13 +48,16 @@ CAMLexport void (*channel_mutex_lock) (struct channel *) = NULL;
|
||||||
CAMLexport void (*channel_mutex_unlock) (struct channel *) = NULL;
|
CAMLexport void (*channel_mutex_unlock) (struct channel *) = NULL;
|
||||||
CAMLexport void (*channel_mutex_unlock_exn) (void) = NULL;
|
CAMLexport void (*channel_mutex_unlock_exn) (void) = NULL;
|
||||||
|
|
||||||
|
/* List of opened channels */
|
||||||
|
CAMLexport struct channel * all_opened_channels = NULL;
|
||||||
|
|
||||||
/* Basic functions over type struct channel *.
|
/* Basic functions over type struct channel *.
|
||||||
These functions can be called directly from C.
|
These functions can be called directly from C.
|
||||||
No locking is performed. */
|
No locking is performed. */
|
||||||
|
|
||||||
/* Functions shared between input and output */
|
/* Functions shared between input and output */
|
||||||
|
|
||||||
CAMLexport struct channel * open_descriptor(int fd)
|
CAMLexport struct channel * open_descriptor_in(int fd)
|
||||||
{
|
{
|
||||||
struct channel * channel;
|
struct channel * channel;
|
||||||
|
|
||||||
|
@ -64,13 +67,39 @@ CAMLexport struct channel * open_descriptor(int fd)
|
||||||
channel->curr = channel->max = channel->buff;
|
channel->curr = channel->max = channel->buff;
|
||||||
channel->end = channel->buff + IO_BUFFER_SIZE;
|
channel->end = channel->buff + IO_BUFFER_SIZE;
|
||||||
channel->mutex = NULL;
|
channel->mutex = NULL;
|
||||||
|
channel->revealed = 0;
|
||||||
|
channel->old_revealed = 0;
|
||||||
|
channel->refcount = 0;
|
||||||
|
channel->next = all_opened_channels;
|
||||||
|
all_opened_channels = channel;
|
||||||
return channel;
|
return channel;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
CAMLexport struct channel * open_descriptor_out(int fd)
|
||||||
|
{
|
||||||
|
struct channel * channel;
|
||||||
|
|
||||||
|
channel = open_descriptor_in(fd);
|
||||||
|
channel->max = NULL;
|
||||||
|
return channel;
|
||||||
|
}
|
||||||
|
|
||||||
|
static void unlink_channel(struct channel *channel)
|
||||||
|
{
|
||||||
|
struct channel ** cp = &all_opened_channels;
|
||||||
|
|
||||||
|
while (*cp != channel && *cp != NULL)
|
||||||
|
cp = &(*cp)->next;
|
||||||
|
if (*cp != NULL)
|
||||||
|
*cp = (*cp)->next;
|
||||||
|
}
|
||||||
|
|
||||||
CAMLexport void close_channel(struct channel *channel)
|
CAMLexport void close_channel(struct channel *channel)
|
||||||
{
|
{
|
||||||
close(channel->fd);
|
close(channel->fd);
|
||||||
|
if (channel->refcount > 0) return;
|
||||||
if (channel_mutex_free != NULL) (*channel_mutex_free)(channel);
|
if (channel_mutex_free != NULL) (*channel_mutex_free)(channel);
|
||||||
|
unlink_channel(channel);
|
||||||
stat_free(channel);
|
stat_free(channel);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -196,7 +225,6 @@ CAMLexport int putblock(struct channel *channel, char *p, long int len)
|
||||||
memmove(channel->buff, channel->buff + written, towrite - written);
|
memmove(channel->buff, channel->buff + written, towrite - written);
|
||||||
channel->offset += written;
|
channel->offset += written;
|
||||||
channel->curr = channel->end - written;
|
channel->curr = channel->end - written;
|
||||||
channel->max = channel->end - written;
|
|
||||||
return free;
|
return free;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
@ -369,10 +397,12 @@ CAMLexport long input_scan_line(struct channel *channel)
|
||||||
objects into a heap-allocated object. Perform locking
|
objects into a heap-allocated object. Perform locking
|
||||||
and unlocking around the I/O operations. */
|
and unlocking around the I/O operations. */
|
||||||
|
|
||||||
static void finalize_channel(value vchan)
|
CAMLexport void finalize_channel(value vchan)
|
||||||
{
|
{
|
||||||
struct channel * chan = Channel(vchan);
|
struct channel * chan = Channel(vchan);
|
||||||
|
if (--chan->refcount > 0) return;
|
||||||
if (channel_mutex_free != NULL) (*channel_mutex_free)(chan);
|
if (channel_mutex_free != NULL) (*channel_mutex_free)(chan);
|
||||||
|
unlink_channel(chan);
|
||||||
stat_free(chan);
|
stat_free(chan);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -392,17 +422,47 @@ static struct custom_operations channel_operations = {
|
||||||
custom_deserialize_default
|
custom_deserialize_default
|
||||||
};
|
};
|
||||||
|
|
||||||
static value alloc_channel(struct channel *chan)
|
CAMLexport value alloc_channel(struct channel *chan)
|
||||||
{
|
{
|
||||||
value res = alloc_custom(&channel_operations, sizeof(struct channel *),
|
value res = alloc_custom(&channel_operations, sizeof(struct channel *),
|
||||||
1, 1000);
|
1, 1000);
|
||||||
Channel(res) = chan;
|
Channel(res) = chan;
|
||||||
|
chan->refcount++;
|
||||||
return res;
|
return res;
|
||||||
}
|
}
|
||||||
|
|
||||||
CAMLprim value caml_open_descriptor(value fd)
|
CAMLprim value caml_open_descriptor_in(value fd)
|
||||||
{
|
{
|
||||||
return alloc_channel(open_descriptor(Int_val(fd)));
|
return alloc_channel(open_descriptor_in(Int_val(fd)));
|
||||||
|
}
|
||||||
|
|
||||||
|
CAMLprim value caml_open_descriptor_out(value fd)
|
||||||
|
{
|
||||||
|
return alloc_channel(open_descriptor_out(Int_val(fd)));
|
||||||
|
}
|
||||||
|
|
||||||
|
#define Pair_tag 0
|
||||||
|
|
||||||
|
CAMLprim value caml_out_channels_list (value unit)
|
||||||
|
{
|
||||||
|
CAMLparam0 ();
|
||||||
|
CAMLlocal3 (res, tail, chan);
|
||||||
|
struct channel * channel;
|
||||||
|
|
||||||
|
res = Val_emptylist;
|
||||||
|
for (channel = all_opened_channels;
|
||||||
|
channel != NULL;
|
||||||
|
channel = channel->next)
|
||||||
|
/* Testing channel->fd >= 0 looks unnecessary, as
|
||||||
|
caml_close_channel changes max when setting fd to -1. */
|
||||||
|
if (channel->max == NULL) {
|
||||||
|
chan = alloc_channel (channel);
|
||||||
|
tail = res;
|
||||||
|
res = alloc_small (2, Pair_tag);
|
||||||
|
Field (res, 0) = chan;
|
||||||
|
Field (res, 1) = tail;
|
||||||
|
}
|
||||||
|
CAMLreturn (res);
|
||||||
}
|
}
|
||||||
|
|
||||||
CAMLprim value channel_descriptor(value vchannel)
|
CAMLprim value channel_descriptor(value vchannel)
|
||||||
|
@ -444,9 +504,7 @@ CAMLprim value caml_flush_partial(value vchannel)
|
||||||
{
|
{
|
||||||
struct channel * channel = Channel(vchannel);
|
struct channel * channel = Channel(vchannel);
|
||||||
int res;
|
int res;
|
||||||
/* Don't fail if channel is closed, this causes problem with flush on
|
|
||||||
stdout and stderr at exit. Revise when "flushall" is implemented. */
|
|
||||||
if (channel->fd == -1) return Val_true;
|
|
||||||
Lock(channel);
|
Lock(channel);
|
||||||
res = flush_partial(channel);
|
res = flush_partial(channel);
|
||||||
Unlock(channel);
|
Unlock(channel);
|
||||||
|
@ -456,9 +514,7 @@ CAMLprim value caml_flush_partial(value vchannel)
|
||||||
CAMLprim value caml_flush(value vchannel)
|
CAMLprim value caml_flush(value vchannel)
|
||||||
{
|
{
|
||||||
struct channel * channel = Channel(vchannel);
|
struct channel * channel = Channel(vchannel);
|
||||||
/* Don't fail if channel is closed, this causes problem with flush on
|
|
||||||
stdout and stderr at exit. Revise when "flushall" is implemented. */
|
|
||||||
if (channel->fd == -1) return Val_unit;
|
|
||||||
Lock(channel);
|
Lock(channel);
|
||||||
flush(channel);
|
flush(channel);
|
||||||
Unlock(channel);
|
Unlock(channel);
|
||||||
|
|
|
@ -32,6 +32,10 @@ struct channel {
|
||||||
char * curr; /* Current position in the buffer */
|
char * curr; /* Current position in the buffer */
|
||||||
char * max; /* Logical end of the buffer (for input) */
|
char * max; /* Logical end of the buffer (for input) */
|
||||||
void * mutex; /* Placeholder for mutex (for systhreads) */
|
void * mutex; /* Placeholder for mutex (for systhreads) */
|
||||||
|
struct channel * next; /* Linear chaining of channels (flush_all) */
|
||||||
|
int revealed; /* For Cash only */
|
||||||
|
int old_revealed; /* For Cash only */
|
||||||
|
int refcount; /* For Cash only */
|
||||||
char buff[IO_BUFFER_SIZE]; /* The buffer itself */
|
char buff[IO_BUFFER_SIZE]; /* The buffer itself */
|
||||||
};
|
};
|
||||||
|
|
||||||
|
@ -54,7 +58,8 @@ struct channel {
|
||||||
? refill(channel) \
|
? refill(channel) \
|
||||||
: (unsigned char) *((channel))->curr++)
|
: (unsigned char) *((channel))->curr++)
|
||||||
|
|
||||||
CAMLextern struct channel * open_descriptor (int);
|
CAMLextern struct channel * open_descriptor_in (int);
|
||||||
|
CAMLextern struct channel * open_descriptor_out (int);
|
||||||
CAMLextern void close_channel (struct channel *);
|
CAMLextern void close_channel (struct channel *);
|
||||||
CAMLextern int channel_binary_mode (struct channel *);
|
CAMLextern int channel_binary_mode (struct channel *);
|
||||||
|
|
||||||
|
|
|
@ -371,7 +371,7 @@ CAMLexport void caml_main(char **argv)
|
||||||
stat_free(req_prims);
|
stat_free(req_prims);
|
||||||
/* Load the globals */
|
/* Load the globals */
|
||||||
seek_section(fd, &trail, "DATA");
|
seek_section(fd, &trail, "DATA");
|
||||||
chan = open_descriptor(fd);
|
chan = open_descriptor_in(fd);
|
||||||
global_data = input_val(chan);
|
global_data = input_val(chan);
|
||||||
close_channel(chan); /* this also closes fd */
|
close_channel(chan); /* this also closes fd */
|
||||||
stat_free(trail.section);
|
stat_free(trail.section);
|
||||||
|
|
|
@ -178,7 +178,7 @@ let string_of_bool b =
|
||||||
let bool_of_string = function
|
let bool_of_string = function
|
||||||
| "true" -> true
|
| "true" -> true
|
||||||
| "false" -> false
|
| "false" -> false
|
||||||
| _ -> invalid_arg "string_of_bool"
|
| _ -> invalid_arg "bool_of_string"
|
||||||
|
|
||||||
let string_of_int n =
|
let string_of_int n =
|
||||||
format_int "%d" n
|
format_int "%d" n
|
||||||
|
@ -202,8 +202,8 @@ let rec (@) l1 l2 =
|
||||||
type in_channel
|
type in_channel
|
||||||
type out_channel
|
type out_channel
|
||||||
|
|
||||||
external open_descriptor_out: int -> out_channel = "caml_open_descriptor"
|
external open_descriptor_out: int -> out_channel = "caml_open_descriptor_out"
|
||||||
external open_descriptor_in: int -> in_channel = "caml_open_descriptor"
|
external open_descriptor_in: int -> in_channel = "caml_open_descriptor_in"
|
||||||
|
|
||||||
let stdin = open_descriptor_in 0
|
let stdin = open_descriptor_in 0
|
||||||
let stdout = open_descriptor_out 1
|
let stdout = open_descriptor_out 1
|
||||||
|
@ -256,6 +256,21 @@ let rec flush oc =
|
||||||
wait_outchan oc (-1); false in
|
wait_outchan oc (-1); false in
|
||||||
if success then () else flush oc
|
if success then () else flush oc
|
||||||
|
|
||||||
|
external out_channels_list : unit -> out_channel list
|
||||||
|
= "caml_out_channels_list"
|
||||||
|
|
||||||
|
let flush_all () =
|
||||||
|
let rec iter = function
|
||||||
|
[] -> ()
|
||||||
|
| a::l ->
|
||||||
|
begin try
|
||||||
|
flush a
|
||||||
|
with Sys_error _ ->
|
||||||
|
() (* ignore channels closed during a preceding flush. *)
|
||||||
|
end;
|
||||||
|
iter l
|
||||||
|
in iter (out_channels ())
|
||||||
|
|
||||||
external unsafe_output_partial : out_channel -> string -> int -> int -> int
|
external unsafe_output_partial : out_channel -> string -> int -> int -> int
|
||||||
= "caml_output_partial"
|
= "caml_output_partial"
|
||||||
|
|
||||||
|
@ -451,7 +466,7 @@ let read_float () = float_of_string(read_line())
|
||||||
|
|
||||||
external sys_exit : int -> 'a = "sys_exit"
|
external sys_exit : int -> 'a = "sys_exit"
|
||||||
|
|
||||||
let exit_function = ref (fun () -> flush stdout; flush stderr)
|
let exit_function = ref flush_all
|
||||||
|
|
||||||
let at_exit f =
|
let at_exit f =
|
||||||
let g = !exit_function in
|
let g = !exit_function in
|
||||||
|
|
|
@ -166,9 +166,9 @@ let write fd buf ofs len =
|
||||||
else unsafe_write fd buf ofs len
|
else unsafe_write fd buf ofs len
|
||||||
|
|
||||||
external in_channel_of_descr : file_descr -> in_channel
|
external in_channel_of_descr : file_descr -> in_channel
|
||||||
= "caml_open_descriptor"
|
= "caml_open_descriptor_in"
|
||||||
external out_channel_of_descr : file_descr -> out_channel
|
external out_channel_of_descr : file_descr -> out_channel
|
||||||
= "caml_open_descriptor"
|
= "caml_open_descriptor_out"
|
||||||
external descr_of_in_channel : in_channel -> file_descr = "channel_descriptor"
|
external descr_of_in_channel : in_channel -> file_descr = "channel_descriptor"
|
||||||
external descr_of_out_channel : out_channel -> file_descr
|
external descr_of_out_channel : out_channel -> file_descr
|
||||||
= "channel_descriptor"
|
= "channel_descriptor"
|
||||||
|
|
|
@ -188,8 +188,8 @@ let write fd buf ofs len =
|
||||||
|
|
||||||
(* Interfacing with the standard input/output library *)
|
(* Interfacing with the standard input/output library *)
|
||||||
|
|
||||||
external open_read_descriptor : int -> in_channel = "caml_open_descriptor"
|
external open_read_descriptor : int -> in_channel = "caml_open_descriptor_in"
|
||||||
external open_write_descriptor : int -> out_channel = "caml_open_descriptor"
|
external open_write_descriptor : int -> out_channel = "caml_open_descriptor_out"
|
||||||
external fd_of_in_channel : in_channel -> int = "channel_descriptor"
|
external fd_of_in_channel : in_channel -> int = "channel_descriptor"
|
||||||
external fd_of_out_channel : out_channel -> int = "channel_descriptor"
|
external fd_of_out_channel : out_channel -> int = "channel_descriptor"
|
||||||
|
|
||||||
|
|
|
@ -188,8 +188,8 @@ let rec (@) l1 l2 =
|
||||||
type in_channel
|
type in_channel
|
||||||
type out_channel
|
type out_channel
|
||||||
|
|
||||||
external open_descriptor_out: int -> out_channel = "caml_open_descriptor"
|
external open_descriptor_out: int -> out_channel = "caml_open_descriptor_out"
|
||||||
external open_descriptor_in: int -> in_channel = "caml_open_descriptor"
|
external open_descriptor_in: int -> in_channel = "caml_open_descriptor_in"
|
||||||
|
|
||||||
let stdin = open_descriptor_in 0
|
let stdin = open_descriptor_in 0
|
||||||
let stdout = open_descriptor_out 1
|
let stdout = open_descriptor_out 1
|
||||||
|
@ -215,6 +215,15 @@ let open_out_bin name =
|
||||||
|
|
||||||
external flush : out_channel -> unit = "caml_flush"
|
external flush : out_channel -> unit = "caml_flush"
|
||||||
|
|
||||||
|
external out_channels_list : unit -> out_channel list
|
||||||
|
= "caml_out_channels_list"
|
||||||
|
|
||||||
|
let flush_all () =
|
||||||
|
let rec iter = function
|
||||||
|
[] -> ()
|
||||||
|
| a::l -> flush a; iter l
|
||||||
|
in iter (out_channels_list ())
|
||||||
|
|
||||||
external unsafe_output : out_channel -> string -> int -> int -> unit
|
external unsafe_output : out_channel -> string -> int -> int -> unit
|
||||||
= "caml_output"
|
= "caml_output"
|
||||||
|
|
||||||
|
@ -345,7 +354,7 @@ external decr: int ref -> unit = "%decr"
|
||||||
|
|
||||||
external sys_exit : int -> 'a = "sys_exit"
|
external sys_exit : int -> 'a = "sys_exit"
|
||||||
|
|
||||||
let exit_function = ref (fun () -> flush stdout; flush stderr)
|
let exit_function = ref flush_all
|
||||||
|
|
||||||
let at_exit f =
|
let at_exit f =
|
||||||
let g = !exit_function in
|
let g = !exit_function in
|
||||||
|
|
|
@ -482,6 +482,8 @@ val flush : out_channel -> unit
|
||||||
performing all pending writes on that channel.
|
performing all pending writes on that channel.
|
||||||
Interactive programs must be careful about flushing standard
|
Interactive programs must be careful about flushing standard
|
||||||
output and standard error at the right time. *)
|
output and standard error at the right time. *)
|
||||||
|
val flush_all : unit -> unit
|
||||||
|
(* Flush all opened output channels. *)
|
||||||
val output_char : out_channel -> char -> unit
|
val output_char : out_channel -> char -> unit
|
||||||
(* Write the character on the given output channel. *)
|
(* Write the character on the given output channel. *)
|
||||||
val output_string : out_channel -> string -> unit
|
val output_string : out_channel -> string -> unit
|
||||||
|
|
Loading…
Reference in New Issue