1 // mpipack.cpp Copyright (C) 2016-2020 Codemist
2 //
3 // Packing stuff into buffers for cross-PE communication
4 //
5
6 /**************************************************************************
7 * Copyright (C) 2020, Codemist. A C Norman *
8 * *
9 * Redistribution and use in source and binary forms, with or without *
10 * modification, are permitted provided that the following conditions are *
11 * met: *
12 * *
13 * * Redistributions of source code must retain the relevant *
14 * copyright notice, this list of conditions and the following *
15 * disclaimer. *
16 * * Redistributions in binary form must reproduce the above *
17 * copyright notice, this list of conditions and the following *
18 * disclaimer in the documentation and/or other materials provided *
19 * with the distribution. *
20 * *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *
24 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *
25 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *
26 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *
27 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS *
28 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
29 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR *
30 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF *
31 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *
32 * DAMAGE. *
33 *************************************************************************/
34
35 // $Id: mpipack.cpp 5604 2021-01-20 22:22:10Z arthurcnorman $
36
37
38 #ifndef header_mpipack_h
39 #define header_mpipack_h
40
41
42 // Code to pack a Lisp cons-structure into a linear buffer and retrieve it.
43
44 // These are the calls to do it; think of them as
45 // void pack_object(Lisp_Object a);
46 // and Lisp_Object unpack_object();
47 //
48
49 #define pack_object(a) (mpi_pack_buffer = 0, \
50 mpi_pack_position = 0, \
51 mpi_pack_size = 0, \
52 pack_cell(a) )
53
54 // Once a message has been packed, it may be sent using mpi_pack_buffer and
55 // mpi_pack_position as the "buf" and "count" fields, and MPI_PACKED as the
56 // Datatype.
57 //
58
59
60 // mpi_pack_buffer should be set to the recieve buffer before calling this.
61 #define unpack_object() (mpi_pack_position = 0, unpack_cell())
62
63
64
65
66 // There must be a buffer to put them in.
67 // It will grow by MPI_BUFFER_BLOCK bytes at a time, as needed.
68 //
69 static char* mpi_pack_buffer = 0;
70 static int mpi_pack_size = 0;
71 #define MPI_BUFFER_BLOCK 1024
72
73 // position marker for MPI_(Un)Pack
74 static int mpi_pack_position = 0;
75
76
77 // THE REST OF THIS FILE IS PRIVATE
78
79 // Function to check the size of the buffer, and grow it if necessary.
80 // check_buffer(n) will make sure that there are n free bytes in the buffer.
81 //
default_check_buffer(int n)82 static void default_check_buffer(int n)
83 { if (mpi_pack_size - mpi_pack_position < n)
84 { mpi_pack_size += MPI_BUFFER_BLOCK;
85 mpi_pack_buffer = reinterpret_cast<char*>(std)::realloc(
86 mpi_pack_buffer, mpi_pack_size);
87 if (mpi_pack_buffer == 0)
88 return aerror0("Not enough memory for MPI buffer.");
89 }
90 }
91 static char* mpi_buffer_bottom;
92 static int mpi_pack_offset;
93 static int mpi_real_size;
scatter_check_buffer(int n)94 static void scatter_check_buffer(int n)
95 { if (mpi_real_size - ( (mpi_pack_buffer - mpi_buffer_bottom) +
96 mpi_pack_position ) < n)
97 { mpi_real_size += MPI_BUFFER_BLOCK;
98 mpi_pack_size += MPI_BUFFER_BLOCK;
99 mpi_buffer_bottom = reinterpret_cast<char*>(std)::realloc(
100 mpi_buffer_bottom, mpi_real_size);
101 if (mpi_buffer_bottom == 0)
102 return aerror0("Not enough memory for MPI buffer.");
103 mpi_pack_buffer = mpi_buffer_bottom + mpi_pack_offset;
104 }
105 }
106
107
108 typedef void buffptr(int);
109 static buffptr *check_buffer = default_check_buffer;
110
111 // MPI insists on using pointers everywhere, so here are things to point at.
112 static char mpi_packing_symbols[] = {' ', '(', ')', '.', ','};
113 static LispObject mpi_pack_number;
114 static char mpi_pack_char;
115
116 // The MPI function calls for packing
117
118 // Think of this as void pack_32bit(Lisp_Object),but it actually returns int
119 // The name is to remind one that the size is fixed for now. It would be
120 // better to conditionally define a type of either MPI_LONG or MPI_LONG_LONG
121 // depending on the size of Lisp objects. This may happen eventually.
122 //
123 #define pack_32bit(n) (check_buffer(4), \
124 MPI_Pack(&(n), 1, MPI_UNSIGNED_LONG, \
125 mpi_pack_buffer, mpi_pack_size, \
126 &mpi_pack_position, MPI_COMM_WORLD) )
127
128 // The functions to flatten the list structures, according to a simple grammar
129 static void pack_list(LispObject a);
130 static void pack_cell(LispObject a);
pack_atom(LispObject a)131 static void pack_atom(LispObject a)
132 { if (is_fixnum(a)) pack_32bit(a);
133 else if (is_bfloat(a))
134 { Header* h = &flthdr(a);
135 if (type_of_header(*h) == TYPE_DOUBLE_FLOAT)
136 { pack_32bit(*h);
137 check_buffer(sizeof(double));
138 MPI_Pack( double_float(addr(h)), 1, MPI_DOUBLE,
139 mpi_pack_buffer, mpi_pack_size,
140 &mpi_pack_position, MPI_COMM_WORLD);
141 }
142 else err_printf("Unsupported float type %x\n",type_of_header(*h));
143 }
144 else if (is_numbers(a))
145 { Header* h = &numhdr(a);
146 int size = length_of_header(*h) - sizeof(Header);
147 if (type_of_header(*h) == TYPE_BIGNUM)
148 { pack_32bit(*h);
149 // Bignums are arrays of 32-bit things; we'll have to pack them
150 // as such to avoid byte-ordering problems.
151 check_buffer(size);
152 MPI_Pack(h+1, size >> 2, MPI_UNSIGNED_LONG,
153 mpi_pack_buffer, mpi_pack_size, &mpi_pack_position,
154 MPI_COMM_WORLD);
155 }
156 else err_printf("Unsupported number type %x\n",type_of_header(*h));
157 }
158 else if (is_vector(a))
159 { Header* h = &vechdr(a);
160 switch(type_of_header(*h))
161 { case TYPE_STRING:
162 pack_32bit(*h);
163 { int size = length_of_byteheader(*h) - sizeof(Header);
164 check_buffer(size);
165 MPI_Pack(h+1, size, MPI_CHAR,
166 mpi_pack_buffer, mpi_pack_size,
167 &mpi_pack_position, MPI_COMM_WORLD);
168 }
169 break;
170 case TYPE_SIMPLE_VEC: case TYPE_ARRAY: case TYPE_STRUCTURE:
171 pack_32bit(*h);
172 { int i;
173 for (i = 0; i < (length_of_header(*h)>>2) - 1; ++i)
174 pack_cell(elt(a,i));
175 }
176 break;
177 default:
178 err_printf("Unsupported vector type %x\n",type_of_header(*h));
179 }
180 }
181 else if (is_symbol(a))
182 { Symbol_Head* h = (Symbol_Head*)( reinterpret_cast<char*>
183 (a)-TAG_SYMBOL);
184 Header My_Head = TYPE_SYMBOL;
185 pack_32bit(My_Head);
186 pack_atom(h->pname); // This is a string.
187 }
188
189 else err_printf("Unsupported type %d\n",a & TAG_BITS);
190 }
191
192 // again, think of void pack_xxxx(void); (but actually returning int)
193 #define pack_space() ( check_buffer(1), \
194 MPI_Pack(mpi_packing_symbols, 1, MPI_CHAR, \
195 mpi_pack_buffer, mpi_pack_size, \
196 &mpi_pack_position, MPI_COMM_WORLD) )
197 #define pack_open() ( check_buffer(1), \
198 MPI_Pack(mpi_packing_symbols+1, 1, MPI_CHAR, \
199 mpi_pack_buffer, mpi_pack_size, \
200 &mpi_pack_position, MPI_COMM_WORLD) )
201 #define pack_close() ( check_buffer(1), \
202 MPI_Pack(mpi_packing_symbols+2, 1, MPI_CHAR, \
203 mpi_pack_buffer, mpi_pack_size, \
204 &mpi_pack_position, MPI_COMM_WORLD) )
205 #define pack_dot() ( check_buffer(1), \
206 MPI_Pack(mpi_packing_symbols+3, 1, MPI_CHAR, \
207 mpi_pack_buffer, mpi_pack_size, \
208 &mpi_pack_position, MPI_COMM_WORLD) )
209 #define pack_comma() ( check_buffer(1), \
210 MPI_Pack(mpi_packing_symbols+4, 1, MPI_CHAR, \
211 mpi_pack_buffer, mpi_pack_size, \
212 &mpi_pack_position, MPI_COMM_WORLD) )
213
pack_cell(LispObject a)214 static void pack_cell(LispObject a)
215 { // In Common mode, consp needs nil defined. I don't want to
216 // clutter the stack with unnecessary variables, so I don't
217 // define it in CSL mode.
218 //
219 if (consp(a)) pack_open(), pack_cell(car(a)), pack_list(cdr(a));
220 else pack_space(), pack_atom(a);
221 }
222
pack_list(LispObject a)223 static void pack_list(LispObject a)
224 { if (consp(a)) pack_comma(), pack_cell(car(a)), pack_list(cdr(a));
225 else if (a == nil) pack_close();
226 else pack_dot(), pack_atom(a);
227 }
228
229 // Now unpacking...
230 // The MPI calls
231 // Think of these as char unpack_char(); Lisp_Object unpack_32bit();
232 #define unpack_char() (MPI_Unpack(mpi_pack_buffer, mpi_pack_size, \
233 &mpi_pack_position, &mpi_pack_char, 1, \
234 MPI_CHAR, MPI_COMM_WORLD), \
235 mpi_pack_char)
236
237 #define unpack_32bit() (MPI_Unpack(mpi_pack_buffer, mpi_pack_size, \
238 &mpi_pack_position, &mpi_pack_number, 1, \
239 MPI_UNSIGNED_LONG, MPI_COMM_WORLD), \
240 mpi_pack_number)
241
242 // The functions to parse the linear buffer
243 static LispObject unpack_list(void);
244 static LispObject unpack_cell(void);
unpack_atom()245 static LispObject unpack_atom()
246 { LispObject a = unpack_32bit();
247 if (is_fixnum(a)) return a;
248
249 switch (type_of_header(a))
250 { int size;
251 case TYPE_DOUBLE_FLOAT:
252 size = length_of_header(a);
253 a = get_basic_vector(TAG_BOXFLOAT,TYPE_DOUBLE_FLOAT,size);
254 MPI_Unpack(mpi_pack_buffer, mpi_pack_size, &mpi_pack_position,
255 double_float_addr(a),
256 1, MPI_DOUBLE, MPI_COMM_WORLD);
257 return a;
258
259 case TYPE_BIGNUM:
260 size = length_of_header(a);
261 a = get_basic_vector(TAG_NUMBERS,type_of_header(a),size);
262 MPI_Unpack(mpi_pack_buffer,mpi_pack_size,&mpi_pack_position,
263 reinterpret_cast<char*>(a) - TAG_NUMBERS + CELL,
264 (size - sizeof(Header))>>2, MPI_UNSIGNED_LONG, MPI_COMM_WORLD);
265 return a;
266
267 case TYPE_STRING:
268 size = length_of_byteheader(a);
269 a = get_basic_vector(TAG_VECTOR,TYPE_STRING,size);
270 MPI_Unpack(mpi_pack_buffer, mpi_pack_size, &mpi_pack_position,
271 reinterpret_cast<char*>(a) - TAG_VECTOR + CELL,
272 size - sizeof(Header), MPI_CHAR, MPI_COMM_WORLD);
273 return a;
274
275 case TYPE_SIMPLE_VEC: case TYPE_ARRAY: case TYPE_STRUCTURE:
276 size = length_of_header(a);
277 LispObject v = get_basic_vector(TAG_VECTOR,type_of_header(a),size);
278 Save save(v);
279 { int i;
280 for (i=0; i<(size>>2)-1; ++i)
281 { save.restore(v);
282 elt(v, i) = unpack_cell();
283 errexit();
284 }
285 save.restore(v);
286 if (!(i&1)) elt(v, i) = nil;
287 }
288 return v;
289
290 case TYPE_SYMBOL:
291 { a = unpack_atom(); // Name in a string
292 return iintern(a, length_of_byteheader(vechdr(a))-CELL, CP, 0);
293 }
294 default:
295 err_printf("Unknown header type %d", type_of_header(a));
296 }
297 }
298
299
unpack_cell()300 static LispObject unpack_cell()
301 { switch (unpack_char())
302 { case ' ': return unpack_atom();
303 case '(': return unpack_list();
304 default :
305 { err_printf("Syntax error in message.\n");
306 return nil;
307 }
308 }
309 }
310
unpack_list()311 static LispObject unpack_list()
312 { LispObject r = unpack_cell();
313 errexit();
314 Save save(r);
315 switch (unpack_char())
316 { case ')': return cons(r, nil);
317 case '.':
318 { LispObject tail = unpack_atom();
319 errexit();
320 save.restore(r);
321 return cons(r, tail);
322 }
323 case ',':
324 { LispObject tail = unpack_list();
325 errexit();
326 save.restore(r);
327 return cons(r, tail);
328 }
329 default :
330 { err_printf("Syntax error in message.\n");
331 return r;
332 }
333 }
334 }
335
336 #endif
337
338
339 // end of mpipack.cpp
340