/*
* Sanitycheck "new" keyword.
*/
NODE *
cxx_new(NODE *p)
{
NODE *q = p;
NODE *t1 = bcon(1);
int nw = NM_NEW;
while (p->n_op == LB) {
nw = NM_NWA;
t1 = buildtree(MUL, t1, eve(p->n_right));
p->n_right = bcon(0);
p = p->n_left;
}
if (p->n_op != TYPE)
uerror("new used illegally");
t1 = buildtree(MUL, t1,
xbcon(tsize(p->n_type, p->n_df, p->n_ap)/SZCHAR, NULL, INTPTR));
tfree(q);
return callftn(decoratename(NULL, nw), t1, NULL);
}
CAMLprim value
caml_backpack_mq_getattr(value val_mq)
{
CAMLparam1(val_mq);
CAMLlocal1(val_res);
struct mq_attr attr;
if (mq_getattr(Int_val(val_mq), &attr) == -1)
uerror("mq_getattr", Nothing);
val_res = caml_alloc_tuple(4);
Store_field(val_res, 0,
caml_backpack_unpack_flags(attr.mq_flags, mqueue_flags,
BACKPACK_FLAGS_LEN(mqueue_flags)));
Store_field(val_res, 1, Val_long(attr.mq_maxmsg));
Store_field(val_res, 2, Val_long(attr.mq_msgsize));
Store_field(val_res, 3, Val_long(attr.mq_curmsgs));
CAMLreturn(val_res);
}
/*
* Reference to a struct as a :: name.
*/
NODE *
cxxrstruct(int soru, NODE *attr, NODE *t, char *n)
{
struct symtab *ns, *sp;
ns = pfind(t, spole->sup);
if (ns == NULL)
goto undecl;
tfree(t);
sp = sfind(n, ns);
while (sp != NULL) {
if (sp->sclass == soru)
return mkty(sp->stype, 0, sp->sap);
sp = sfind(n, sp->snext);
}
undecl:
uerror("%s undeclared", n);
return mkty(INT, 0, 0);
}
CAMLprim value unix_lstat(value path)
{
CAMLparam1(path);
int ret;
struct stat buf;
char * p;
p = caml_strdup(String_val(path));
caml_enter_blocking_section();
#ifdef HAS_SYMLINK
ret = lstat(p, &buf);
#else
ret = stat(p, &buf);
#endif
caml_leave_blocking_section();
caml_stat_free(p);
if (ret == -1) uerror("lstat", path);
if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG)
unix_error(EOVERFLOW, "lstat", path);
CAMLreturn(stat_aux(0, &buf));
}
/**
* Attaches a data-structure to its shared-memory FIFO.
*
* @retval 1 Success.
* @retval -1 The data-structure is already attached to a shared-
* memory FIFO. An error message is logged.
* @retval -1 The shared-memory FIFO reference by \e shm couldn't be
* attached. An error message is logged.
*/
int shmfifo_attach(
struct shmhandle* const shm) /**< Pointer to the data-structure. */
{
void* mem;
if (shm->mem)
{
uerror ("attempt to attach already attached mem?\n");
return -1;
}
if ((mem = shmat(shm->sid, 0, 0)) == (void*)-1) {
serror("Couldn't attach to shared-memory: sid=%d", shm->sid);
return -1;
}
shm->mem = mem;
return 1;
}
CAMLprim value netsys_realpath (value name) /* POSIX.1-2001 */
{
#ifdef HAVE_REALPATH
char *name_in_s, *name_out_s;
value name_out;
name_in_s = String_val(name);
name_out_s = realpath(name_in_s, NULL); /* Note: GNU extension! */
if (name_out_s == NULL) {
uerror("realpath", Nothing);
}
else {
name_out = copy_string(name_out_s);
free(name_out_s);
}
return name_out;
#else
invalid_argument("Netsys_posix.realpath not available");
#endif
}
CAMLprim value unix_pipe(value unit)
{
SECURITY_ATTRIBUTES attr;
HANDLE readh, writeh;
value readfd = Val_unit, writefd = Val_unit, res;
attr.nLength = sizeof(attr);
attr.lpSecurityDescriptor = NULL;
attr.bInheritHandle = TRUE;
if (! CreatePipe(&readh, &writeh, &attr, SIZEBUF)) {
win32_maperr(GetLastError());
uerror("pipe", Nothing);
}
Begin_roots2(readfd, writefd)
readfd = win_alloc_handle(readh);
writefd = win_alloc_handle(writeh);
res = caml_alloc_2(0, readfd, writefd);
End_roots();
return res;
}
value
ocaml_shm_open(value v_name, value v_rw, value v_creat, value v_excl, value v_trunc)
{
CAMLparam5(v_name, v_rw, v_creat, v_excl, v_trunc);
char *path;
int fd;
int flags = (Bool_val(v_rw)) ? O_RDWR : O_RDONLY;
if (Bool_val(v_creat)) flags |= O_CREAT;
if (Bool_val(v_excl)) flags |= O_EXCL;
if (Bool_val(v_trunc)) flags |= O_TRUNC;
path = caml_stat_alloc(caml_string_length(v_name)+1);
strcpy(path, String_val(v_name));
enter_blocking_section();
fd = shm_open(path, flags, S_IRUSR | S_IWUSR);
leave_blocking_section();
caml_stat_free(path);
if (fd == -1)
uerror("shm_open", v_name);
CAMLreturn(Val_int(fd));
}
/*
* Print out assembler segment name.
*/
void
setseg(int seg, char *name)
{
switch (seg) {
case PROG: name = ".text"; break;
case DATA:
case LDATA: name = ".data"; break;
case STRNG:
case RDATA: name = ".section .rodata"; break;
case UDATA: break;
case DTORS:
name = ".section .dtors,\"aw\",@progbits";
break;
case CTORS:
name = ".section .ctors,\"aw\",@progbits";
break;
case TLSDATA:
case TLSUDATA:
uerror("FIXME: unsupported segment %d", seg);
break;
case PICRDATA:
name = ".section .data.rel.ro.local,\"aw\",@progbits";
break;
case PICLDATA:
case PICDATA:
name = ".section .data.rel.local,\"aw\",@progbits";
break;
case NMSEG:
printf("\t.section %s,\"aw\",@progbits\n", name);
return;
}
printf("\t%s\n", name);
}
CAMLprim value unix_open(value path, value flags, value perm)
{
int fileaccess, createflags, fileattrib, filecreate, sharemode, cloexec;
SECURITY_ATTRIBUTES attr;
HANDLE h;
fileaccess = convert_flag_list(flags, open_access_flags);
sharemode = FILE_SHARE_READ | FILE_SHARE_WRITE
| convert_flag_list(flags, open_share_flags);
createflags = convert_flag_list(flags, open_create_flags);
if ((createflags & (O_CREAT | O_EXCL)) == (O_CREAT | O_EXCL))
filecreate = CREATE_NEW;
else if ((createflags & (O_CREAT | O_TRUNC)) == (O_CREAT | O_TRUNC))
filecreate = CREATE_ALWAYS;
else if (createflags & O_TRUNC)
filecreate = TRUNCATE_EXISTING;
else if (createflags & O_CREAT)
filecreate = OPEN_ALWAYS;
else
filecreate = OPEN_EXISTING;
if ((createflags & O_CREAT) && (Int_val(perm) & 0200) == 0)
fileattrib = FILE_ATTRIBUTE_READONLY;
else
fileattrib = FILE_ATTRIBUTE_NORMAL;
cloexec = convert_flag_list(flags, open_cloexec_flags);
attr.nLength = sizeof(attr);
attr.lpSecurityDescriptor = NULL;
attr.bInheritHandle = cloexec ? FALSE : TRUE;
h = CreateFile(String_val(path), fileaccess,
sharemode, &attr,
filecreate, fileattrib, NULL);
if (h == INVALID_HANDLE_VALUE) {
win32_maperr(GetLastError());
uerror("open", path);
}
return win_alloc_handle(h);
}
CAMLprim value netsys_mknod (value name, value perm, value nt)
{
#ifdef _WIN32
invalid_argument("Netsys_posix.mknod not available");
#else
mode_t m;
dev_t d;
int e;
m = Long_val(perm) & 07777;
d = 0;
if (Is_block(nt)) {
switch (Tag_val(nt)) {
case 0: /* = S_IFCHR */
m |= S_IFCHR;
d = Long_val(Field(nt,0));
break;
case 1: /* = S_IFBLK */
m |= S_IFBLK;
d = Long_val(Field(nt,0));
break;
}
}
else {
switch (Long_val(nt)) {
case 0: /* = S_IFREG */
m |= S_IFREG; break;
case 1: /* = S_IFIFO */
m |= S_IFIFO; break;
case 2: /* = S_IFSOCK */
m |= S_IFSOCK; break;
}
}
e = mknod(String_val(name), m, d);
if (e < 0) uerror("mknod", Nothing);
return Val_unit;
#endif
}
CAMLprim value core_kernel_time_ns_nanosleep(value v_seconds)
{
struct timespec req = timespec_of_double(Double_val(v_seconds));
struct timespec rem;
int retval;
caml_enter_blocking_section();
retval = nanosleep(&req, &rem);
caml_leave_blocking_section();
if (retval == 0)
return caml_copy_double(0.0);
else if (retval == -1) {
if (errno == EINTR)
return caml_copy_double(timespec_to_double(rem));
else
uerror("nanosleep", Nothing);
}
else
caml_failwith("core_kernel_time_ns_nanosleep: impossible return value from nanosleep(2)");
}
CAMLprim value netsys_posix_openpt(value noctty) /* POSIX.1-2001 */
{
#ifdef HAVE_PTY
int fd;
int flags;
flags = O_RDWR;
if (Bool_val(noctty) != 0) flags |= O_NOCTTY;
#ifdef HAVE_PTY_OPENPT
fd = posix_openpt(flags);
#else
fd = open("/dev/ptmx", flags);
#endif
if (fd == -1) uerror("openpt", Nothing);
return Val_int(fd);
#else
invalid_argument("Netsys_posix.posix_openpt not available");
#endif
}
CAMLprim value unix_sendto_native(value sock, value buff, value ofs, value len,
value flags, value dest)
{
int ret, cv_flags;
long numbytes;
char iobuf[UNIX_BUFFER_SIZE];
union sock_addr_union addr;
socklen_param_type addr_len;
cv_flags = convert_flag_list(flags, msg_flag_table);
get_sockaddr(dest, &addr, &addr_len);
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
enter_blocking_section();
ret = sendto(Int_val(sock), iobuf, (int) numbytes, cv_flags,
&addr.s_gen, addr_len);
leave_blocking_section();
if (ret == -1) uerror("sendto", Nothing);
return Val_int(ret);
}
CAMLprim value unix_accept(value sock)
{
int retcode;
value res;
value a;
union sock_addr_union addr;
socklen_param_type addr_len;
addr_len = sizeof(addr);
enter_blocking_section();
retcode = accept(Int_val(sock), &addr.s_gen, &addr_len);
leave_blocking_section();
if (retcode == -1) uerror("accept", Nothing);
a = alloc_sockaddr(&addr, addr_len, retcode);
Begin_root (a);
res = alloc_small(2, 0);
Field(res, 0) = Val_int(retcode);
Field(res, 1) = a;
End_roots();
return res;
}
CAMLprim value netsys_poll(value s, value nv, value tv) {
#ifdef HAVE_POLL
struct pollfd *p;
int n;
long tmo, r;
p = (*(Poll_mem_val(s)));
n = Int_val(nv);
tmo = Long_val(tv);
enter_blocking_section();
r = poll(p, n, tmo);
leave_blocking_section();
if (r == -1) uerror("poll", Nothing);
return Val_int(r);
#else
invalid_argument("netsys_poll");
#endif
}
CAMLprim value caml_epoll_wait(value epfd,
value maxevents,
value timeout)
{
CAMLparam3(epfd, maxevents, timeout);
CAMLlocal3(res, tmp, vevents);
int imaxevents = Int_val(maxevents);
struct epoll_event events[imaxevents]; // no check of maxevents > 0
int nfd = epoll_wait(Int_val(epfd), events, imaxevents, Int_val(timeout));
if( nfd == -1 ) uerror("epoll_wait", Nothing);
res = caml_alloc_tuple(nfd);
int i;
for (i = 0; i < nfd; i++){
vevents = caml_copy_int32(events[i].events); // it must be before alloc_small! Since alloc_small hates other allocs!
tmp = caml_alloc_small(2, 0);
Field(tmp, 0) = Val_int(events[i].data.fd);
Field(tmp, 1) = vevents;
Store_field(res, i, tmp);
}
CAMLreturn(res);
}
CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen)
{
long ofs, len;
int numbytes, ret;
char iobuf[UNIX_BUFFER_SIZE];
Begin_root (buf);
ofs = Long_val(vofs);
len = Long_val(vlen);
ret = 0;
if (len > 0) {
numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
memmove (iobuf, &Byte(buf, ofs), numbytes);
enter_blocking_section();
ret = write(Int_val(fd), iobuf, numbytes);
leave_blocking_section();
if (ret == -1) uerror("single_write", Nothing);
}
End_roots();
return Val_int(ret);
}
CAMLprim value unix_write(value fd, value buf, value vofs, value vlen)
{
intnat ofs, len, written;
DWORD numbytes, numwritten;
char iobuf[UNIX_BUFFER_SIZE];
DWORD err = 0;
Begin_root (buf);
ofs = Long_val(vofs);
len = Long_val(vlen);
written = 0;
while (len > 0) {
numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
memmove (iobuf, &Byte(buf, ofs), numbytes);
if (Descr_kind_val(fd) == KIND_SOCKET) {
int ret;
SOCKET s = Socket_val(fd);
enter_blocking_section();
ret = send(s, iobuf, numbytes, 0);
if (ret == SOCKET_ERROR) err = WSAGetLastError();
leave_blocking_section();
numwritten = ret;
} else {
HANDLE h = Handle_val(fd);
enter_blocking_section();
if (! WriteFile(h, iobuf, numbytes, &numwritten, NULL))
err = GetLastError();
leave_blocking_section();
}
if (err) {
win32_maperr(err);
uerror("write", Nothing);
}
written += numwritten;
ofs += numwritten;
len -= numwritten;
}
End_roots();
return Val_long(written);
}
CAMLprim value netsys_mem_write(value fdv, value memv, value offv, value lenv)
{
intnat numbytes;
intnat ret;
char *data;
#ifdef _WIN32
DWORD n;
DWORD err = 0;
#endif
numbytes = Long_val(lenv);
data = ((char *) (Bigarray_val(memv)->data)) + Long_val(offv);
#ifdef _WIN32
if (Descr_kind_val(fdv) == KIND_SOCKET) {
SOCKET h = Socket_val(fdv);
enter_blocking_section();
ret = send(h, data, numbytes, 0);
if (ret == SOCKET_ERROR) err = WSAGetLastError();
leave_blocking_section();
ret = n;
} else {
HANDLE h = Handle_val(fdv);
enter_blocking_section();
if (! WriteFile(h, data, numbytes, &n, NULL)) err = GetLastError();
leave_blocking_section();
ret = n;
}
if (err) {
win32_maperr(err);
ret = -1;
}
#else
enter_blocking_section();
ret = write(Int_val(fdv), data, (int) numbytes);
leave_blocking_section();
#endif
if (ret == -1) uerror("mem_write", Nothing);
return Val_long(ret);
}
CAMLprim value unix_send(value sock, value buff, value ofs, value len, value flags)
{
SOCKET s = Socket_val(sock);
int flg = convert_flag_list(flags, msg_flag_table);
int ret;
intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
DWORD err = 0;
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
enter_blocking_section();
ret = send(s, iobuf, (int) numbytes, flg);
if (ret == -1) err = WSAGetLastError();
leave_blocking_section();
if (ret == -1) {
win32_maperr(err);
uerror("send", Nothing);
}
return Val_int(ret);
}
CAMLprim value win_argv(value unit)
{
int n, i;
LPWSTR * l;
CAMLparam0();
CAMLlocal2(v,res);
l = CommandLineToArgvW (GetCommandLineW (), &n);
if (l == NULL) {
win32_maperr (GetLastError ());
uerror("argv", Nothing);
}
res = caml_alloc (n, 0);
for (i = 0; i < n; i++) {
v = copy_wstring (l[i]);
Store_field (res, i, v);
}
LocalFree (l);
CAMLreturn (res);
}
CAMLprim value unix_select(value readfds, value writefds, value exceptfds,
value timeout)
{
fd_set read, write, except;
int maxfd;
double tm;
struct timeval tv;
struct timeval * tvp;
int retcode;
value res;
Begin_roots3 (readfds, writefds, exceptfds);
maxfd = -1;
fdlist_to_fdset(readfds, &read, &maxfd);
fdlist_to_fdset(writefds, &write, &maxfd);
fdlist_to_fdset(exceptfds, &except, &maxfd);
tm = Double_val(timeout);
if (tm < 0.0)
tvp = (struct timeval *) NULL;
else {
tv.tv_sec = (int) tm;
tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec));
tvp = &tv;
}
enter_blocking_section();
retcode = select(maxfd + 1, &read, &write, &except, tvp);
leave_blocking_section();
if (retcode == -1) uerror("select", Nothing);
readfds = fdset_to_fdlist(readfds, &read);
writefds = fdset_to_fdlist(writefds, &write);
exceptfds = fdset_to_fdlist(exceptfds, &except);
res = alloc_small(3, 0);
Field(res, 0) = readfds;
Field(res, 1) = writefds;
Field(res, 2) = exceptfds;
End_roots();
return res;
}
CAMLprim value win_wait (value timeout, value event_count) {
CAMLparam2(timeout, event_count);
DWORD t, t2;
DWORD res;
long ret, n = Long_val(event_count);
t = Long_val(timeout);
if (t < 0) t = INFINITE;
t2 = (compN > 0) ? 0 : t;
D(printf("Waiting: %ld events, timeout %ldms -> %ldms\n", n, t, t2));
res =
(n > 0) ?
WaitForMultipleObjectsEx(n, events, FALSE, t, TRUE) :
WaitForMultipleObjectsEx(1, &dummyEvent, FALSE, t, TRUE);
D(printf("Done waiting\n"));
if ((t != t2) && (res == WAIT_TIMEOUT)) res = WAIT_IO_COMPLETION;
switch (res) {
case WAIT_TIMEOUT:
D(printf("Timeout\n"));
ret = -1;
break;
case WAIT_IO_COMPLETION:
D(printf("I/O completion\n"));
ret = -2;
break;
case WAIT_FAILED:
D(printf("Wait failed\n"));
ret = 0;
win32_maperr (GetLastError ());
uerror("WaitForMultipleObjectsEx", Nothing);
break;
default:
ret = res;
D(printf("Event: %ld\n", res));
break;
}
get_queue (Val_unit);
CAMLreturn (Val_long(ret));
}
CAMLexport value
unix_setsockopt_aux(char * name,
enum option_type ty, int level, int option,
value socket, value val)
{
union option_value optval;
socklen_param_type optsize;
double f;
switch (ty) {
case TYPE_BOOL:
case TYPE_INT:
optsize = sizeof(optval.i);
optval.i = Int_val(val);
break;
case TYPE_LINGER:
optsize = sizeof(optval.lg);
optval.lg.l_onoff = Is_block (val);
if (optval.lg.l_onoff)
optval.lg.l_linger = Int_val (Field (val, 0));
break;
case TYPE_TIMEVAL:
f = Double_val(val);
optsize = sizeof(optval.tv);
optval.tv.tv_sec = (int) f;
optval.tv.tv_usec = (int) (1e6 * (f - optval.tv.tv_sec));
break;
case TYPE_UNIX_ERROR:
default:
unix_error(EINVAL, name, Nothing);
}
if (setsockopt(Int_val(socket), level, option,
(void *) &optval, optsize) == -1)
uerror(name, Nothing);
return Val_unit;
}
CAMLprim value netsys_mem_send(value fdv, value memv, value offv, value lenv,
value flagsv)
{
intnat numbytes;
intnat ret;
char *data;
int flags;
#ifdef _WIN32
DWORD err = 0;
SOCKET s;
#else
int s;
#endif
numbytes = Long_val(lenv);
data = ((char *) (Bigarray_val(memv)->data)) + Long_val(offv);
flags = convert_flag_list(flagsv, msg_flag_table);
#ifdef _WIN32
s = Socket_val(fdv);
#else
s = Int_val(fdv);
#endif
enter_blocking_section();
ret = send(s, data, (int) numbytes, flags);
#ifdef _WIN32
if (ret == -1) err = WSAGetLastError();
leave_blocking_section();
if (ret == -1) win32_maperr(err);
#else
leave_blocking_section();
#endif
if (ret == -1) uerror("mem_send", Nothing);
return Val_long(ret);
}
CAMLprim value stub_openfile_direct(value filename, value rw, value perm){
CAMLparam3(filename, rw, perm);
CAMLlocal1(result);
int fd;
const char *filename_c = strdup(String_val(filename));
enter_blocking_section();
int flags = O_DIRECT;
if (Bool_val(rw)) {
flags |= O_RDWR;
} else {
flags |= O_RDONLY;
}
fd = open(filename_c, flags, Int_val(perm));
leave_blocking_section();
free((void*)filename_c);
if (fd == -1) uerror("open", filename);
CAMLreturn(Val_int(fd));
}
CAMLprim value netsys_del_event_source(value pav, value idv, value tagv)
{
#ifdef HAVE_POLL_AGGREG
struct poll_aggreg *pa;
int code;
int fd;
#ifdef USABLE_EPOLL
struct epoll_event ee;
#endif
pa = *(Poll_aggreg_val(pav));
fd = Int_val(Field(tagv, 0)); /* EV_FD */
#ifdef USABLE_EPOLL
code = epoll_ctl(pa->fd, EPOLL_CTL_DEL, fd, &ee);
if (code == -1) uerror("epoll_ctl (DEL)", Nothing);
#endif
return Val_unit;
#else
invalid_argument("Netsys_posix.del_event_source not available");
#endif
}
CAMLprim value oci_wait4(value flags, value pid_req)
{
CAMLparam0();
CAMLlocal1(v_usage);
int pid, status, cv_flags;
struct rusage ru;
cv_flags = convert_flag_list(flags, wait_flag_table);
enter_blocking_section();
pid = wait4(Int_val(pid_req), &status, cv_flags, &ru);
leave_blocking_section();
if (pid == -1) uerror("wait4", pid_req);
v_usage = caml_alloc(16, 0);
Store_field(v_usage, 0,
caml_copy_double((double) ru.ru_utime.tv_sec +
(double) ru.ru_utime.tv_usec / 1e6));
Store_field(v_usage, 1,
caml_copy_double((double) ru.ru_stime.tv_sec +
(double) ru.ru_stime.tv_usec / 1e6));
Store_field(v_usage, 2, caml_copy_int64(ru.ru_maxrss));
Store_field(v_usage, 3, caml_copy_int64(ru.ru_ixrss));
Store_field(v_usage, 4, caml_copy_int64(ru.ru_idrss));
Store_field(v_usage, 5, caml_copy_int64(ru.ru_isrss));
Store_field(v_usage, 6, caml_copy_int64(ru.ru_minflt));
Store_field(v_usage, 7, caml_copy_int64(ru.ru_majflt));
Store_field(v_usage, 8, caml_copy_int64(ru.ru_nswap));
Store_field(v_usage, 9, caml_copy_int64(ru.ru_inblock));
Store_field(v_usage, 10, caml_copy_int64(ru.ru_oublock));
Store_field(v_usage, 11, caml_copy_int64(ru.ru_msgsnd));
Store_field(v_usage, 12, caml_copy_int64(ru.ru_msgrcv));
Store_field(v_usage, 13, caml_copy_int64(ru.ru_nsignals));
Store_field(v_usage, 14, caml_copy_int64(ru.ru_nvcsw));
Store_field(v_usage, 15, caml_copy_int64(ru.ru_nivcsw));
CAMLreturn(alloc_process_status(pid, status,v_usage));
}
value
mlptrace_patchcode (value pid_v, value adr_v, value byte_v)
{
pid_t pid;
int savederrno = errno;
unsigned long l = 0;
long adr = 0;
int byte = 0;
int oldbyte = 0;
CAMLparam3 (pid_v, adr_v, byte_v);
pid = Long_val (pid_v);
byte = Int_val (byte_v);
adr = Nativeint_val (adr_v);
/* on Intel x86 the breakpoint is a single byte 0xCC */
if (byte < 0)
byte = 0xCC;
else
byte &= 0xff;
errno = 0;
#ifndef NO_BLOCKING_SECTION
caml_enter_blocking_section ();
#endif
l = ptrace (PTRACE_PEEKDATA, pid, adr, 0);
if (l != -1UL && !errno) {
oldbyte = l & 0xff;
l = ((-1L << 8) & l) | byte;
l = ptrace (PTRACE_POKEDATA, pid, adr, l);
};
#ifndef NO_BLOCKING_SECTION
caml_leave_blocking_section ();
#endif
if (l == -1 && errno)
uerror ("Ptrace.patch", Nothing);
if (savederrno)
errno = savederrno;
CAMLreturn (Val_int(oldbyte));
}