/*
* mpipack.c
*
* Packing stuff into buffers for cross-PE communication
*/
/*
* This code may be used and modified, and redistributed in binary
* or source form, subject to the "CCL Public License", which should
* accompany it. This license is a variant on the BSD license, and thus
* permits use of code derived from this in either open and commercial
* projects: but it does require that updates to this code be made
* available back to the originators of the package.
* Before merging other code in with this or linking this code
* with other packages or libraries please check that the license terms
* of the other material are compatible with those of this.
*/
/* Signature: 777593e3 18-Jan-2007 */
#ifndef header_mpipack_h
#define header_mpipack_h
/* Code to pack a Lisp cons-structure into a linear buffer and retrieve it. */
/* These are the calls to do it; think of them as
* void pack_object(Lisp_Object a);
* and Lisp_Object unpack_object();
*/
#define pack_object(a) (mpi_pack_buffer = 0, \
mpi_pack_position = 0, \
mpi_pack_size = 0, \
pack_cell(a) )
/* Once a message has been packed, it may be sent using mpi_pack_buffer and
* mpi_pack_position as the "buf" and "count" fields, and MPI_PACKED as the
* Datatype.
*/
/* mpi_pack_buffer should be set to the recieve buffer before calling this. */
#define unpack_object() (mpi_pack_position = 0, unpack_cell())
/* There must be a buffer to put them in.
* It will grow by MPI_BUFFER_BLOCK bytes at a time, as needed.
*/
static char* mpi_pack_buffer = 0;
static int mpi_pack_size = 0;
#define MPI_BUFFER_BLOCK 1024
/* position marker for MPI_(Un)Pack */
static int mpi_pack_position = 0;
/* THE REST OF THIS FILE IS PRIVATE */
/* Function to check the size of the buffer, and grow it if necessary.
* check_buffer(n) will make sure that there are n free bytes in the buffer.
*/
static void default_check_buffer(int n)
{
if (mpi_pack_size - mpi_pack_position < n){
mpi_pack_size += MPI_BUFFER_BLOCK;
mpi_pack_buffer = (char*)realloc( mpi_pack_buffer, mpi_pack_size);
if (mpi_pack_buffer == 0) aerror0("Not enough memory for MPI buffer.");
}
}
static char* mpi_buffer_bottom;
static int mpi_pack_offset;
static int mpi_real_size;
static void scatter_check_buffer(int n)
{
if (mpi_real_size - ( (mpi_pack_buffer - mpi_buffer_bottom) +
mpi_pack_position ) < n) {
mpi_real_size += MPI_BUFFER_BLOCK;
mpi_pack_size += MPI_BUFFER_BLOCK;
mpi_buffer_bottom = (char*)realloc( mpi_buffer_bottom, mpi_real_size);
if (mpi_buffer_bottom == 0) aerror0("Not enough memory for MPI buffer.");
mpi_pack_buffer = mpi_buffer_bottom + mpi_pack_offset;
}
}
typedef void buffptr(int);
static buffptr *check_buffer = default_check_buffer;
/* MPI insists on using pointers everywhere, so here are things to point at. */
static char mpi_packing_symbols[] = {' ', '(', ')', '.', ','};
static Lisp_Object mpi_pack_number;
static char mpi_pack_char;
/* The MPI function calls for packing */
/* Think of this as void pack_32bit(Lisp_Object),but it actually returns int */
/* The name is to remind one that the size is fixed for now. It would be
* better to conditionally define a type of either MPI_LONG or MPI_LONG_LONG
* depending on the size of Lisp objects. This may happen eventually.
*/
#define pack_32bit(n) (check_buffer(4), \
MPI_Pack(&(n), 1, MPI_UNSIGNED_LONG, \
mpi_pack_buffer, mpi_pack_size, \
&mpi_pack_position, MPI_COMM_WORLD) )
/* The functions to flatten the list structures, according to a simple grammar*/
static void pack_list(Lisp_Object a);
static void pack_cell(Lisp_Object a);
static void pack_atom(Lisp_Object a)
{
if (is_fixnum(a)) pack_32bit(a);
else if (is_bfloat(a)) {
Header* h = &flthdr(a);
if (type_of_header(*h) == TYPE_DOUBLE_FLOAT){
pack_32bit(*h);
check_buffer(sizeof(double));
MPI_Pack( double_float(addr(h)), 1, MPI_DOUBLE,
mpi_pack_buffer, mpi_pack_size,
&mpi_pack_position, MPI_COMM_WORLD);
}
else err_printf("Unsupported float type %x\n",type_of_header(*h));
}
else if (is_numbers(a)) {
Header* h = &numhdr(a);
int size = length_of_header(*h) - sizeof(Header);
if (type_of_header(*h) == TYPE_BIGNUM){
pack_32bit(*h);
/* Bignums are arrays of 32-bit things; we'll have to pack them
as such to avoid byte-ordering problems. */
check_buffer(size);
MPI_Pack(h+1, size >> 2, MPI_UNSIGNED_LONG,
mpi_pack_buffer, mpi_pack_size, &mpi_pack_position,
MPI_COMM_WORLD);
}
else err_printf("Unsupported number type %x\n",type_of_header(*h));
}
else if (is_vector(a)) {
Header* h = &vechdr(a);
switch(type_of_header(*h)){
case TYPE_STRING:
pack_32bit(*h);
{
int size = length_of_header(*h) - sizeof(Header);
check_buffer(size);
MPI_Pack(h+1, size, MPI_CHAR,
mpi_pack_buffer, mpi_pack_size,
&mpi_pack_position, MPI_COMM_WORLD);
}
break;
case TYPE_SIMPLE_VEC: case TYPE_ARRAY: case TYPE_STRUCTURE:
pack_32bit(*h);
{
int i;
for (i = 0; i < (length_of_header(*h)>>2) - 1; ++i)
pack_cell(elt(a,i));
}
break;
default:
err_printf("Unsupported vector type %x\n",type_of_header(*h));
}
}
else if (is_symbol(a)) {
Symbol_Head* h = (Symbol_Head*)( (char*)a-TAG_SYMBOL);
Header My_Head = TYPE_SYMBOL;
pack_32bit(My_Head);
pack_atom(h->pname); /* This is a string. */
}
else err_printf("Unsupported type %d\n",a & TAG_BITS);
}
/* again, think of void pack_xxxx(void); (but actually returning int) */
#define pack_space() ( check_buffer(1), \
MPI_Pack(mpi_packing_symbols, 1, MPI_CHAR, \
mpi_pack_buffer, mpi_pack_size, \
&mpi_pack_position, MPI_COMM_WORLD) )
#define pack_open() ( check_buffer(1), \
MPI_Pack(mpi_packing_symbols+1, 1, MPI_CHAR, \
mpi_pack_buffer, mpi_pack_size, \
&mpi_pack_position, MPI_COMM_WORLD) )
#define pack_close() ( check_buffer(1), \
MPI_Pack(mpi_packing_symbols+2, 1, MPI_CHAR, \
mpi_pack_buffer, mpi_pack_size, \
&mpi_pack_position, MPI_COMM_WORLD) )
#define pack_dot() ( check_buffer(1), \
MPI_Pack(mpi_packing_symbols+3, 1, MPI_CHAR, \
mpi_pack_buffer, mpi_pack_size, \
&mpi_pack_position, MPI_COMM_WORLD) )
#define pack_comma() ( check_buffer(1), \
MPI_Pack(mpi_packing_symbols+4, 1, MPI_CHAR, \
mpi_pack_buffer, mpi_pack_size, \
&mpi_pack_position, MPI_COMM_WORLD) )
static void pack_cell(Lisp_Object a)
{
/* In Common mode, consp needs nil defined. I don't want to
* clutter the stack with unnecessary variables, so I don't
* define it in CSL mode.
*/
#ifdef COMMON
Lisp_Object nil = C_nil;
#endif
if (consp(a)) pack_open(), pack_cell(qcar(a)), pack_list(qcdr(a));
else pack_space(), pack_atom(a);
}
static void pack_list(Lisp_Object a)
{
#ifdef COMMON
Lisp_Object nil = C_nil;
#endif
if (consp(a)) pack_comma(), pack_cell(qcar(a)), pack_list(qcdr(a));
else if (a == C_nil) pack_close();
else pack_dot(), pack_atom(a);
}
/* Now unpacking... */
/* The MPI calls */
/* Think of these as char unpack_char(); Lisp_Object unpack_32bit(); */
#define unpack_char() (MPI_Unpack(mpi_pack_buffer, mpi_pack_size, \
&mpi_pack_position, &mpi_pack_char, 1, \
MPI_CHAR, MPI_COMM_WORLD), \
mpi_pack_char)
#define unpack_32bit() (MPI_Unpack(mpi_pack_buffer, mpi_pack_size, \
&mpi_pack_position, &mpi_pack_number, 1, \
MPI_UNSIGNED_LONG, MPI_COMM_WORLD), \
mpi_pack_number)
/* The functions to parse the linear buffer */
static Lisp_Object unpack_list(void);
static Lisp_Object unpack_cell(void);
static Lisp_Object unpack_atom()
{
Lisp_Object a = unpack_32bit();
if (is_fixnum(a)) return a;
switch (type_of_header(a)){
int size;
case TYPE_DOUBLE_FLOAT:
size = length_of_header(a);
a = getvector(TAG_BOXFLOAT,TYPE_DOUBLE_FLOAT,size);
MPI_Unpack(mpi_pack_buffer, mpi_pack_size, &mpi_pack_position,
double_float_addr(a),
1, MPI_DOUBLE, MPI_COMM_WORLD);
return a;
case TYPE_BIGNUM:
size = length_of_header(a);
a = getvector(TAG_NUMBERS,type_of_header(a),size);
MPI_Unpack(mpi_pack_buffer,mpi_pack_size,&mpi_pack_position,
(char*)a - TAG_NUMBERS + CELL,
(size - sizeof(Header))>>2, MPI_UNSIGNED_LONG, MPI_COMM_WORLD);
return a;
case TYPE_STRING:
size = length_of_header(a);
a = getvector(TAG_VECTOR,TYPE_STRING,size);
MPI_Unpack(mpi_pack_buffer, mpi_pack_size, &mpi_pack_position,
(char*)a - TAG_VECTOR + CELL,
size - sizeof(Header), MPI_CHAR, MPI_COMM_WORLD);
return a;
case TYPE_SIMPLE_VEC: case TYPE_ARRAY: case TYPE_STRUCTURE:
size = length_of_header(a);
push(getvector(TAG_VECTOR,type_of_header(a),size));
{
int i;
for (i=0; i<(size>>2)-1; ++i) elt(*stack,i) = unpack_cell();
if (!(i&1)) elt(*stack,i) = C_nil;
}
return my_pop();
case TYPE_SYMBOL:
{
Lisp_Object nil = C_nil;
a = unpack_atom(); /* Name in a string */
return iintern(a, length_of_header(vechdr(a))-CELL, CP, 0);
}
default:
err_printf("Unknown header type %d", type_of_header(a));
}
}
static Lisp_Object unpack_cell(void)
{
switch (unpack_char()){
case ' ': return unpack_atom();
case '(': return unpack_list();
default : {err_printf("Syntax error in message.\n"); return C_nil;}
}
}
static Lisp_Object unpack_list(void)
{
push(unpack_cell());
switch (unpack_char()){
case ')': return cons(my_pop(),C_nil);
case '.': {Lisp_Object tail = unpack_atom(); return cons(my_pop(), tail);}
case ',': {Lisp_Object tail = unpack_list(); return cons(my_pop(), tail);}
default : {err_printf("Syntax error in message.\n"); return (my_pop());}
}
}
#endif
/* end of mpipack.c */