/* _lib7_win32_IO_read_vec : (one_word_unt * int) -> word8vector.Vector
* handle nbytes
*
* Read the specified number of bytes from the specified handle,
* returning them in a vector.
*
* Note: Read operations on console devices do not trap ctrl-C.
* ctrl-Cs are placed in the input buffer.
*/
Val _lib7_win32_IO_read_vec(Task *task, Val arg)
{
HANDLE h = (HANDLE) WORD_LIB7toC(GET_TUPLE_SLOT_AS_VAL(arg, 0));
DWORD nbytes = (DWORD) GET_TUPLE_SLOT_AS_INT(arg, 1);
DWORD n;
// Allocate the vector.
// Note that this might cause a GC:
//
Val vec = allocate_nonempty_int1_vector( task, BYTES_TO_WORDS (nbytes) );
if (ReadFile( h, PTR_CAST(void*, vec), nbytes, &n, NULL)) {
if (n == 0) {
#ifdef WIN32_DEBUG
debug_say("_lib7_win32_IO_read_vec: eof on device\n");
#endif
return ZERO_LENGTH_STRING__GLOBAL;
}
if (n < nbytes) {
//
shrink_fresh_int1_vector( task, vec, BYTES_TO_WORDS(n) );
}
/* Allocate header: */
{ Val result;
SEQHDR_ALLOC (task, result, STRING_TAGWORD, vec, n);
return result;
}
} else {
/* _lib7_Sock_recvbuffrom
* : (socket * rw_unt8_vector.Rw_Vector * int * int * Bool * Bool) -> (int * addr)
*
* The arguments are: socket, data buffer, start position, number of
* bytes, OOB flag and peek flag. The result is number of bytes read and
* the source address.
*
* This function gets imported into the Mythryl world via:
* src/lib/std/src/socket/socket-guts.pkg
*/
lib7_val_t _lib7_Sock_recvbuffrom (lib7_state_t *lib7_state, lib7_val_t arg)
{
char addrBuf[MAX_SOCK_ADDR_SZB];
int addrLen = MAX_SOCK_ADDR_SZB;
int socket = REC_SELINT(arg, 0);
lib7_val_t buf = REC_SEL(arg, 1);
int nbytes = REC_SELINT(arg, 3);
char *start = STR_LIB7toC(buf) + REC_SELINT(arg, 2);
int flag = 0;
int n;
if (REC_SEL(arg, 4) == LIB7_true) flag |= MSG_OOB;
if (REC_SEL(arg, 5) == LIB7_true) flag |= MSG_PEEK;
/* do { */ /* Backed out 2010-02-26 CrT: See discussion at bottom of src/runtime/c-libs/lib7-socket/connect.c */
n = recvfrom (socket, start, nbytes, flag, (struct sockaddr *)addrBuf, &addrLen);
/* } while (n < 0 && errno == EINTR); */ /* Restart if interrupted by a SIGALRM or SIGCHLD or whatever. */
if (n < 0)
return RAISE_SYSERR(lib7_state, status);
else {
lib7_val_t data = LIB7_CData (lib7_state, addrBuf, addrLen);
lib7_val_t addr, res;
SEQHDR_ALLOC (lib7_state, addr, DESC_word8vec, data, addrLen);
REC_ALLOC2(lib7_state, res, INT_CtoLib7(n), addr);
return res;
}
} /* end of _lib7_Sock_recvbuffrom */
/* _lib7_OpenCV_cvLoadImage : String -> Image
*
*/
Val
_lib7_OpenCV_cvLoadImage (Task *task, Val arg)
{
#if HAVE_OPENCV_CV_H && HAVE_LIBCV
char* filename = HEAP_STRING_AS_C_STRING( arg );
IplImage* ipl_image = cvLoadImage( filename, CV_LOAD_IMAGE_UNCHANGED );
if (!ipl_image) RAISE_ERROR(task, "cvLoadImage returned NULL");
{
// Copy image into heap, so that it can be
// garbage-collected when no longer needed:
//
Val header; Val header_data;
Val image; Val image_data;
Val result;
header_data = make_int2_vector_sized_in_bytes( task, ipl_image, sizeof(IplImage));
SEQHDR_ALLOC(task, header, UNT8_RO_VECTOR_TAGWORD, header_data, sizeof(IplImage));
c_roots__global[c_roots_count__global++] = &header; // Protect header from garbage collection while allocating image.
image_data = make_int2_vector_sized_in_bytes( task, ipl_image->imageData, ipl_image->imageSize);
SEQHDR_ALLOC(task, image, UNT8_RO_VECTOR_TAGWORD, image_data, ipl_image->imageSize);
--c_roots_count__global;
cvReleaseImage( &ipl_image );
REC_ALLOC2(task, result, header, image);
return result;
}
#else
extern char* no_opencv_support_in_runtime;
return RAISE_ERROR(task, no_opencv_support_in_runtime);
#endif
}
/* _lib7_Sock_recv : (Socket, Int, Bool, Bool) -> unt8_vector::Vector
*
* The arguments are: socket, number of bytes, OOB flag and peek flag; the
* result is the vector of bytes received.
*
* This function gets imported into the Mythryl world via:
* src/lib/std/src/socket/socket-guts.pkg
*/
lib7_val_t _lib7_Sock_recv (lib7_state_t *lib7_state, lib7_val_t arg)
{
lib7_val_t vec;
lib7_val_t result;
int n;
int socket = REC_SELINT(arg, 0);
int nbytes = REC_SELINT(arg, 1);
lib7_val_t oob = REC_SEL( arg, 2);
lib7_val_t peek = REC_SEL( arg, 3);
int flag = 0;
if (oob == LIB7_true) flag |= MSG_OOB;
if (peek == LIB7_true) flag |= MSG_PEEK;
/* Allocate the vector.
* Note that this might cause a GC:
*/
vec = LIB7_AllocRaw32 (lib7_state, BYTES_TO_WORDS(nbytes));
print_if("recv.c/before: socket d=%d nbytes d=%d oob=%s peek=%s\n",socket,nbytes,(oob == LIB7_true)?"TRUE":"FALSE",(peek == LIB7_true)?"TRUE":"FALSE");
errno = 0;
/* do { */ /* Backed out 2010-02-26 CrT: See discussion at bottom of src/runtime/c-libs/lib7-socket/connect.c */
n = recv (socket, PTR_LIB7toC(char, vec), nbytes, flag);
/* } while (n < 0 && errno == EINTR); */ /* Restart if interrupted by a SIGALRM or SIGCHLD or whatever. */
print_if( "recv.c/after: n d=%d errno d=%d (%s)\n", n, errno, errno ? strerror(errno) : "");
hexdump_if( "recv.c/after: Received data: ", PTR_LIB7toC(unsigned char, vec), n );
if (n < 0)
return RAISE_SYSERR(lib7_state, status);
else if (n == 0)
return LIB7_string0;
if (n < nbytes) {
/* we need to shrink the vector */
LIB7_ShrinkRaw32 (lib7_state, vec, BYTES_TO_WORDS(n));
}
SEQHDR_ALLOC (lib7_state, result, DESC_string, vec, n);
return result;
}
/* _ml_Sock_getsockname : sock -> addr
*/
ml_val_t _ml_Sock_getsockname (ml_state_t *msp, ml_val_t arg)
{
int sock = INT_MLtoC(arg);
char addrBuf[MAX_SOCK_ADDR_SZB];
socklen_t addrLen = MAX_SOCK_ADDR_SZB;
int sts;
sts = getsockname (sock, (struct sockaddr *)addrBuf, &addrLen);
if (sts == -1)
return RAISE_SYSERR(msp, sts);
else {
ml_val_t data = ML_CData (msp, addrBuf, addrLen);
ml_val_t addr;
SEQHDR_ALLOC (msp, addr, DESC_word8vec, data, addrLen);
return addr;
}
} /* end of _ml_Sock_getsockname */
lib7_val_t _lib7_runtime_alloc_code ( lib7_state_t* lib7_state,
lib7_val_t arg
)
{
/* _lib7_runtime_alloc_code : int -> rw_unt8_vector.Rw_Vector
*
* Allocate a code chunk of the given size.
*
* Note: Generating the name string within the code chunk
* the code generator's responsibility.
*/
int nbytes = INT_LIB7toC( arg );
lib7_val_t code = LIB7_AllocCode( lib7_state, nbytes );
{ lib7_val_t result;
SEQHDR_ALLOC(lib7_state, result, DESC_word8arr, code, nbytes);
return result;
}
}
/* _lib7_Sock_accept : Socket -> (Socket, Address)
*
* This function gets imported into the Mythryl world via:
* src/lib/std/src/socket/socket-guts.pkg
*/
lib7_val_t _lib7_Sock_accept (lib7_state_t *lib7_state, lib7_val_t arg)
{
int socket = INT_LIB7toC(arg);
char addrBuf[MAX_SOCK_ADDR_SZB];
int addrLen = MAX_SOCK_ADDR_SZB;
int newSock;
/* do { */ /* Backed out 2010-02-26 CrT: See discussion at bottom of src/runtime/c-libs/lib7-socket/connect.c */
newSock = accept (socket, (struct sockaddr *)addrBuf, &addrLen);
/* } while (newSock < 0 && errno == EINTR); */ /* Restart if interrupted by a SIGALRM or SIGCHLD or whatever. */
if (newSock == -1) {
return RAISE_SYSERR(lib7_state, newSock);
} else {
lib7_val_t data = LIB7_CData (lib7_state, addrBuf, addrLen);
lib7_val_t addr, res;
SEQHDR_ALLOC(lib7_state, addr, DESC_word8vec, data, addrLen);
REC_ALLOC2(lib7_state, res, INT_CtoLib7(newSock), addr);
return res;
}
}
Val make_package_literals_via_bytecode_interpreter (Task* task, Unt8* bytecode_vector, int bytecode_vector_length_in_bytes) {
//==============
//
// NOTE: We allocate all of the chunks in agegroup 1,
// but allocate the vector of literals in agegroup0.
//
// This fn gets exported to the Mythryl level as
//
// make_package_literals_via_bytecode_interpreter
// in
// src/lib/compiler/execution/code-segments/code-segment.pkg
// via
// src/c/lib/heap/make-package-literals-via-bytecode-interpreter.c
//
// Our ultimate invocation is in
//
// src/lib/compiler/execution/main/execute.pkg
int pc = 0;
// Check that sufficient space is available for the
// literal chunk that we are about to allocate.
// Note that the cons cell has already been accounted
// for in space_available (but not in space_needed).
//
#define GC_CHECK \
do { \
if (space_needed > space_available \
&& need_to_call_heapcleaner( task, space_needed + LIST_CONS_CELL_BYTESIZE) \
){ \
call_heapcleaner_with_extra_roots (task, 0, (Val *)&bytecode_vector, &stk, NULL); \
space_available = 0; \
\
} else { \
\
space_available -= space_needed; \
} \
} while (0)
#ifdef DEBUG_LITERALS
debug_say("make_package_literals_via_bytecode_interpreter: bytecode_vector = %#x, bytecode_vector_length_in_bytes = %d\n", bytecode_vector, bytecode_vector_length_in_bytes);
#endif
if (bytecode_vector_length_in_bytes <= 8) return HEAP_NIL;
Val_Sized_Unt magic
=
GET32(bytecode_vector); pc += 4;
Val_Sized_Unt max_depth /* This variable is currently unused, so suppress 'unused var' compiler warning: */ __attribute__((unused))
=
GET32(bytecode_vector); pc += 4;
if (magic != V1_MAGIC) {
die("bogus literal magic number %#x", magic);
}
Val stk = HEAP_NIL;
int space_available = 0;
for (;;) {
//
ASSERT(pc < bytecode_vector_length_in_bytes);
space_available -= LIST_CONS_CELL_BYTESIZE; // Space for stack cons cell.
if (space_available < ONE_K_BINARY) {
//
if (need_to_call_heapcleaner(task, 64*ONE_K_BINARY)) {
//
call_heapcleaner_with_extra_roots (task, 0, (Val *)&bytecode_vector, &stk, NULL);
}
space_available = 64*ONE_K_BINARY;
}
switch (bytecode_vector[ pc++ ]) {
//
case I_INT:
{ int i = GET32(bytecode_vector); pc += 4;
#ifdef DEBUG_LITERALS
debug_say("[%2d]: INT(%d)\n", pc-5, i);
#endif
LIST_CONS(task, stk, TAGGED_INT_FROM_C_INT(i), stk);
}
break;
case I_RAW32:
{
int i = GET32(bytecode_vector); pc += 4;
#ifdef DEBUG_LITERALS
debug_say("[%2d]: RAW32[%d]\n", pc-5, i);
#endif
Val result;
INT1_ALLOC(task, result, i);
LIST_CONS(task, stk, result, stk);
space_available -= 2*WORD_BYTESIZE;
}
break;
case I_RAW32L:
{
int n = GET32(bytecode_vector); pc += 4;
#ifdef DEBUG_LITERALS
debug_say("[%2d]: RAW32L(%d) [...]\n", pc-5, n);
#endif
ASSERT(n > 0);
int space_needed = 4*(n+1);
GC_CHECK;
LIB7_AllocWrite (task, 0, MAKE_TAGWORD(n, FOUR_BYTE_ALIGNED_NONPOINTER_DATA_BTAG));
for (int j = 1; j <= n; j++) {
//
int i = GET32(bytecode_vector); pc += 4;
LIB7_AllocWrite (task, j, (Val)i);
}
Val result = LIB7_Alloc(task, n );
LIST_CONS(task, stk, result, stk);
}
break;
case I_RAW64:
{
double d = get_double(&(bytecode_vector[pc])); pc += 8;
Val result;
REAL64_ALLOC(task, result, d);
#ifdef DEBUG_LITERALS
debug_say("[%2d]: RAW64[%f] @ %#x\n", pc-5, d, result);
#endif
LIST_CONS(task, stk, result, stk);
space_available -= 4*WORD_BYTESIZE; // Extra 4 bytes for alignment padding.
}
break;
case I_RAW64L:
{
int n = GET32(bytecode_vector); pc += 4;
#ifdef DEBUG_LITERALS
debug_say("[%2d]: RAW64L(%d) [...]\n", pc-5, n);
#endif
ASSERT(n > 0);
int space_needed = 8*(n+1);
GC_CHECK;
#ifdef ALIGN_FLOAT64S
// Force FLOAT64_BYTESIZE alignment (descriptor is off by one word)
//
task->heap_allocation_pointer = (Val*)((Punt)(task->heap_allocation_pointer) | WORD_BYTESIZE);
#endif
int j = 2*n; // Number of words.
LIB7_AllocWrite (task, 0, MAKE_TAGWORD(j, EIGHT_BYTE_ALIGNED_NONPOINTER_DATA_BTAG));
Val result = LIB7_Alloc(task, j );
for (int j = 0; j < n; j++) {
//
PTR_CAST(double*, result)[j] = get_double(&(bytecode_vector[pc])); pc += 8;
}
LIST_CONS(task, stk, result, stk);
}
break;
case I_STR:
{
int n = GET32(bytecode_vector); pc += 4;
#ifdef DEBUG_LITERALS
debug_say("[%2d]: STR(%d) [...]", pc-5, n);
#endif
if (n == 0) {
#ifdef DEBUG_LITERALS
debug_say("\n");
#endif
LIST_CONS(task, stk, ZERO_LENGTH_STRING__GLOBAL, stk);
break;
}
int j = BYTES_TO_WORDS(n+1); // '+1' to include space for '\0'.
// The space request includes space for the data-chunk header word and
// the sequence header chunk.
//
int space_needed = WORD_BYTESIZE*(j+1+3);
GC_CHECK;
// Allocate the data chunk:
//
LIB7_AllocWrite(task, 0, MAKE_TAGWORD(j, FOUR_BYTE_ALIGNED_NONPOINTER_DATA_BTAG));
LIB7_AllocWrite (task, j, 0); // So word-by-word string equality works.
Val result = LIB7_Alloc (task, j);
#ifdef DEBUG_LITERALS
debug_say(" @ %#x (%d words)\n", result, j);
#endif
memcpy (PTR_CAST(void*, result), &bytecode_vector[pc], n); pc += n;
// Allocate the header chunk:
//
SEQHDR_ALLOC(task, result, STRING_TAGWORD, result, n);
// Push on stack:
//
LIST_CONS(task, stk, result, stk);
}
break;
case I_LIT:
{
int n = GET32(bytecode_vector); pc += 4;
Val result = stk;
for (int j = 0; j < n; j++) {
//
result = LIST_TAIL(result);
}
#ifdef DEBUG_LITERALS
debug_say("[%2d]: LIT(%d) = %#x\n", pc-5, n, LIST_HEAD(result));
#endif
LIST_CONS(task, stk, LIST_HEAD(result), stk);
}
break;
case I_VECTOR:
{
int n = GET32(bytecode_vector); pc += 4;
#ifdef DEBUG_LITERALS
debug_say("[%2d]: VECTOR(%d) [", pc-5, n);
#endif
if (n == 0) {
#ifdef DEBUG_LITERALS
debug_say("]\n");
#endif
LIST_CONS(task, stk, ZERO_LENGTH_VECTOR__GLOBAL, stk);
break;
}
// The space request includes space
// for the data-chunk header word and
// the sequence header chunk.
//
int space_needed = WORD_BYTESIZE*(n+1+3);
GC_CHECK;
// Allocate the data chunk:
//
LIB7_AllocWrite(task, 0, MAKE_TAGWORD(n, RO_VECTOR_DATA_BTAG));
// Top of stack is last element in vector:
//
for (int j = n; j > 0; j--) {
//
LIB7_AllocWrite(task, j, LIST_HEAD(stk));
stk = LIST_TAIL(stk);
}
Val result = LIB7_Alloc(task, n );
// Allocate the header chunk:
//
SEQHDR_ALLOC(task, result, TYPEAGNOSTIC_RO_VECTOR_TAGWORD, result, n);
#ifdef DEBUG_LITERALS
debug_say("...] @ %#x\n", result);
#endif
LIST_CONS(task, stk, result, stk);
}
break;
case I_RECORD:
{
int n = GET32(bytecode_vector); pc += 4;
#ifdef DEBUG_LITERALS
debug_say("[%2d]: RECORD(%d) [", pc-5, n);
#endif
if (n == 0) {
#ifdef DEBUG_LITERALS
debug_say("]\n");
#endif
LIST_CONS(task, stk, HEAP_VOID, stk);
break;
} else {
int space_needed = 4*(n+1);
GC_CHECK;
LIB7_AllocWrite(task, 0, MAKE_TAGWORD(n, PAIRS_AND_RECORDS_BTAG));
}
// Top of stack is last element in record:
//
for (int j = n; j > 0; j--) {
//
LIB7_AllocWrite(task, j, LIST_HEAD(stk));
stk = LIST_TAIL(stk);
}
Val result = LIB7_Alloc(task, n );
#ifdef DEBUG_LITERALS
debug_say("...] @ %#x\n", result);
#endif
LIST_CONS(task, stk, result, stk);
}
break;
case I_RETURN:
ASSERT(pc == bytecode_vector_length_in_bytes);
#ifdef DEBUG_LITERALS
debug_say("[%2d]: RETURN(%#x)\n", pc-5, LIST_HEAD(stk));
#endif
return LIST_HEAD( stk );
break;
default:
die ("bogus literal opcode #%x @ %d", bytecode_vector[pc-1], pc-1);
} // switch
} // while
} // fun make_package_literals_via_bytecode_interpreter