File Coverage

include/ffi_platypus_call.h

Criterion	Covered	Total	%
statement	809	903	89.5
branch	415	1028	40.3
condition			n/a
subroutine			n/a
pod			n/a
total	1224	1931	63.3

line	stmt	bran	code
1
2			/*
3			* Philosophy: FFI dispatch should be as fast as possible considering
4			* reasonable trade offs.
5			*
6			* - don't allocate memory for small things using `malloc`, instead use
7			* alloca on platforms that allow it (most modern platforms do).
8			* - don't make function calls. You shouldn't have to make a function
9			* calls to call a function. Exceptions are for custom types and
10			* some of the more esoteric types.
11			* - one way we avoid making function calls is by putting the FFI dispatch
12			* in this header file so that it can be "called" twice without an
13			* extra function call. (`$ffi->function(...)->call(...)` and
14			* `$ffi->attach(foo => ...); foo(...)`). This is obviously absurd.
15			*
16			* Maybe each of these weird trade offs each save only a few ms on
17			* each call, but in the end the can add up. As a result of this
18			* priority set, FFI::Platypus does seem to perform considerably better
19			* than any other FFI implementations available in Perl ( see
20			* https://github.com/perl5-FFI/FFI-Performance ) and is even competitive
21			* with XS tbh.
22			*/
23
24	2059		ffi_pl_heap *heap = NULL;
25
26			#if FFI_PL_CALL_NO_RECORD_VALUE
27			#define RESULT &result
28			ffi_pl_result result;
29			#elif FFI_PL_CALL_RET_NO_NORMAL
30			#define RESULT result_ptr
31			void *result_ptr;
32	2		Newx_or_alloca(result_ptr, self->return_type->extra[0].record.size, char);
33			#else
34			#define RESULT result_ptr
35			ffi_pl_result result;
36			void *result_ptr;
37	401	100	if(self->return_type->type_code == FFI_PL_TYPE_RECORD_VALUE
38	400	100	\|\| self->return_type->type_code == (FFI_PL_TYPE_RECORD_VALUE \| FFI_PL_SHAPE_CUSTOM_PERL))
39			{
40	2		Newx_or_alloca(result_ptr, self->return_type->extra[0].record.size, char);
41			}
42			else
43			{
44	399		result_ptr = &result;
45			}
46			#endif
47
48			{
49			/* buffer contains the memory required for the arguments structure */
50			char *buffer;
51	2059		size_t buffer_size = sizeof(ffi_pl_argument) * self->ffi_cif.nargs +
52			sizeof(void) self->ffi_cif.nargs +
53			sizeof(ffi_pl_arguments);
54	2059		ffi_pl_heap_add(buffer, buffer_size, char);
55	2059		MY_CXT.current_argv = arguments = (ffi_pl_arguments*) buffer;
56			}
57
58	2059		arguments->count = self->ffi_cif.nargs;
59	2059		argument_pointers = (void**) &arguments->slot[arguments->count];
60
61			/*
62			* ARGUMENT IN
63			*/
64
65	4670	100	for(i=0, perl_arg_index=(EXTRA_ARGS); i < self->ffi_cif.nargs; i++, perl_arg_index++)
		100
		100
66			{
67	2627		int type_code = self->argument_types[i]->type_code;
68	2627		argument_pointers[i] = (void*) &arguments->slot[i];
69
70	2627	100	arg = perl_arg_index < items ? ST(perl_arg_index) : &PL_sv_undef;
		50
		100
71
72	2627		int custom_flag = (type_code & FFI_PL_SHAPE_MASK) == FFI_PL_SHAPE_CUSTOM_PERL;
73	2627	100	if(custom_flag)
		50
		100
74			{
75	154		arg = ffi_pl_custom_perl(
76	154		self->argument_types[i]->extra[0].custom_perl.perl_to_native,
77			arg, i
78			);
79	141		if(arg == NULL)
80	6		{
81	6		int max = self->argument_types[i]->extra[0].custom_perl.argument_count;
82	12	0	for(n=0; n < max; n++)
		0
		100
83			{
84	6		i++;
85	6		argument_pointers[i] = &arguments->slot[i];
86			}
87	6		continue;
88			}
89	135		av_push(MY_CXT.custom_keepers, newRV_inc(arg));
90	135		type_code ^= FFI_PL_SHAPE_CUSTOM_PERL;
91			}
92
93	2608		switch(type_code)
94			{
95
96			/*
97			* ARGUMENT IN - SCALAR TYPES
98			*/
99
100	68		case FFI_PL_TYPE_UINT8:
101	68	50	ffi_pl_arguments_set_uint8(arguments, i, SvOK(arg) ? SvUV(arg) : 0);
		0
		100
102	68		break;
103	36		case FFI_PL_TYPE_SINT8:
104	36	50	ffi_pl_arguments_set_sint8(arguments, i, SvOK(arg) ? SvIV(arg) : 0);
		0
		100
105	36		break;
106	47		case FFI_PL_TYPE_UINT16:
107	47	50	ffi_pl_arguments_set_uint16(arguments, i, SvOK(arg) ? SvUV(arg) : 0);
		0
		100
108	47		break;
109	35		case FFI_PL_TYPE_SINT16:
110	35	50	ffi_pl_arguments_set_sint16(arguments, i, SvOK(arg) ? SvIV(arg) : 0);
		0
		100
111	35		break;
112	47		case FFI_PL_TYPE_UINT32:
113	47	50	ffi_pl_arguments_set_uint32(arguments, i, SvOK(arg) ? SvUV(arg) : 0);
		0
		100
114	47		break;
115	400		case FFI_PL_TYPE_SINT32:
116	400	100	ffi_pl_arguments_set_sint32(arguments, i, SvOK(arg) ? SvIV(arg) : 0);
		50
		100
117	400		break;
118	204		case FFI_PL_TYPE_UINT64:
119	204	50	ffi_pl_arguments_set_uint64(arguments, i, SvOK(arg) ? SvU64(arg) : 0);
		0
		100
120	204		break;
121	35		case FFI_PL_TYPE_SINT64:
122	35	50	ffi_pl_arguments_set_sint64(arguments, i, SvOK(arg) ? SvI64(arg) : 0);
		0
		100
123	35		break;
124	74		case FFI_PL_TYPE_FLOAT:
125	74	50	ffi_pl_arguments_set_float(arguments, i, SvOK(arg) ? SvNV(arg) : 0.0);
		0
		100
126	74		break;
127	83		case FFI_PL_TYPE_DOUBLE:
128	83	50	ffi_pl_arguments_set_double(arguments, i, SvOK(arg) ? SvNV(arg) : 0.0);
		0
		100
129	83		break;
130	371		case FFI_PL_TYPE_OPAQUE:
131	371	100	ffi_pl_arguments_set_pointer(arguments, i, SvOK(arg) ? INT2PTR(void*, SvIV(arg)) : NULL);
		0
		100
132	371		break;
133	455		case FFI_PL_TYPE_STRING:
134	455	100	ffi_pl_arguments_set_string(arguments, i, SvOK(arg) ? SvPV_nolen(arg) : NULL);
		50
		100
135	455		break;
136			#ifdef FFI_PL_PROBE_LONGDOUBLE
137	0		case FFI_PL_TYPE_LONG_DOUBLE:
138			{
139			long double *ptr;
140	0		Newx_or_alloca(ptr, 1, long double);
141	0		argument_pointers[i] = ptr;
142	0	0	ffi_pl_perl_to_long_double(arg, ptr);
		0
		0
		0
		0
		0
		0
		0
		0
143			}
144	0		break;
145			#endif
146			#ifdef FFI_PL_PROBE_COMPLEX
147	36		case FFI_PL_TYPE_COMPLEX_FLOAT:
148			{
149			float *ptr;
150	36		Newx_or_alloca(ptr, 2, float);
151	36		argument_pointers[i] = ptr;
152	36		ffi_pl_perl_to_complex_float(arg, ptr);
153			}
154	36		break;
155	36		case FFI_PL_TYPE_COMPLEX_DOUBLE:
156			{
157			double *ptr;
158	36		Newx_or_alloca(ptr, 2, double);
159	36		argument_pointers[i] = ptr;
160	36		ffi_pl_perl_to_complex_double(arg, ptr);
161			}
162	36		break;
163			#endif
164	53		case FFI_PL_TYPE_RECORD:
165			{
166			void *ptr;
167			STRLEN size;
168			int expected;
169	53		expected = self->argument_types[i]->extra[0].record.size;
170	53	100	if(SvROK(arg))
		0
		100
171			{
172	41		SV *arg2 = SvRV(arg);
173	41	100	ptr = SvOK(arg2) ? SvPV(arg2, size) : NULL;
		0
		50
174			}
175			else
176			{
177	12	100	ptr = SvOK(arg) ? SvPV(arg, size) : NULL;
		0
		100
178			}
179	53	100	if(ptr != NULL && expected != 0 && size != expected)
		50
		50
		0
		0
		0
		100
		50
		50
180	0		warn("record argument %d has wrong size (is %d, expected %d)", i, (int)size, expected);
181	53		ffi_pl_arguments_set_pointer(arguments, i, ptr);
182			}
183	53		break;
184	8		case FFI_PL_TYPE_RECORD_VALUE:
185			{
186	8		const char *record_class = self->argument_types[i]->extra[0].record.class;
187			/* TODO if object is read-onyl ? */
188	8	100	if(sv_isobject(arg) && sv_derived_from(arg, record_class))
		100
		0
		0
		0
		0
189			{
190	5		argument_pointers[i] = SvPV_nolen(SvRV(arg));
191			}
192			else
193			{
194	6	100	ffi_pl_croak("argument %d is not an instance of %s", i, record_class);
		0
		0
195			}
196			}
197	5		break;
198	122		case FFI_PL_TYPE_CLOSURE:
199			{
200	122	100	if(!SvROK(arg))
		0
		100
201			{
202	32	50	ffi_pl_arguments_set_pointer(arguments, i, SvOK(arg) ? INT2PTR(void*, SvIV(arg)) : NULL);
		0
		50
203			}
204			else
205			{
206			ffi_pl_closure *closure;
207			ffi_status ffi_status;
208
209	90		SvREFCNT_inc(arg);
210	90		SvREFCNT_inc(SvRV(arg));
211
212	90		closure = ffi_pl_closure_get_data(arg, self->argument_types[i]);
213	90		if(closure != NULL)
214			{
215	1		ffi_pl_arguments_set_pointer(arguments, i, closure->function_pointer);
216			}
217			else
218			{
219	89		Newx(closure, 1, ffi_pl_closure);
220	89		closure->ffi_closure = ffi_closure_alloc(sizeof(ffi_closure), &closure->function_pointer);
221	89		if(closure->ffi_closure == NULL)
222			{
223	0		Safefree(closure);
224	0		ffi_pl_arguments_set_pointer(arguments, i, NULL);
225	0		warn("unable to allocate memory for closure");
226			}
227			else
228			{
229	89		closure->type = self->argument_types[i];
230
231	89		ffi_status = ffi_prep_closure_loc(
232			closure->ffi_closure,
233	89		&self->argument_types[i]->extra[0].closure.ffi_cif,
234			ffi_pl_closure_call,
235			closure,
236			closure->function_pointer
237			);
238	89		if(ffi_status != FFI_OK)
239			{
240	0		ffi_closure_free(closure->ffi_closure);
241	0		Safefree(closure);
242	0		ffi_pl_arguments_set_pointer(arguments, i, NULL);
243	0		warn("unable to create closure");
244			}
245			else
246			{
247			SV **svp;
248	89		svp = hv_fetch((HV *)SvRV(arg), "code", 4, 0);
249	89		if(svp != NULL)
250			{
251	89		closure->coderef = *svp;
252	89		SvREFCNT_inc(closure->coderef);
253	89		ffi_pl_closure_add_data(arg, closure);
254	89		ffi_pl_arguments_set_pointer(arguments, i, closure->function_pointer);
255			}
256			else
257			{
258	0		ffi_closure_free(closure->ffi_closure);
259	0		Safefree(closure);
260	0		ffi_pl_arguments_set_pointer(arguments, i, NULL);
261	0		warn("closure has no coderef");
262			}
263			}
264			}
265			}
266			}
267			}
268	122		break;
269	498		default:
270
271	498		switch(type_code & FFI_PL_SHAPE_MASK)
272			{
273
274			/*
275			* ARGUMENT IN - POINTER & ARRAY TYPES
276			*/
277
278	478		case FFI_PL_SHAPE_POINTER:
279			case FFI_PL_SHAPE_ARRAY:
280			{
281	478		void *ptr = NULL;
282	478		SSize_t count = 0;
283	478		int is_pointer = (type_code & FFI_PL_SHAPE_MASK) == FFI_PL_SHAPE_POINTER;
284	478		int is_bad = 0;
285	478	50	if(SvROK(arg))
		0
		100
286			{
287	385		SV *arg2 = SvRV(arg);
288	385	100	if(SvTYPE(arg2) < SVt_PVAV && is_pointer)
		50
		0
		0
		100
		50
289			{
290	170		switch(type_code & (FFI_PL_BASE_MASK\|FFI_PL_SIZE_MASK))
291			{
292	9		case FFI_PL_TYPE_UINT8:
293	9		Newx_or_alloca(ptr, 1, uint8_t);
294	9	0	((uint8_t)ptr) = SvOK(arg2) ? SvUV(arg2) : 0;
		0
		50
295	9		break;
296	9		case FFI_PL_TYPE_SINT8:
297	9		Newx_or_alloca(ptr, 1, int8_t);
298	9	0	((int8_t)ptr) = SvOK(arg2) ? SvIV(arg2) : 0;
		0
		50
299	9		break;
300	9		case FFI_PL_TYPE_UINT16:
301	9		Newx_or_alloca(ptr, 1, uint16_t);
302	9	0	((uint16_t)ptr) = SvOK(arg2) ? SvUV(arg2) : 0;
		0
		50
303	9		break;
304	9		case FFI_PL_TYPE_SINT16:
305	9		Newx_or_alloca(ptr, 1, int16_t);
306	9	0	((int16_t)ptr) = SvOK(arg2) ? SvIV(arg2) : 0;
		0
		50
307	9		break;
308	9		case FFI_PL_TYPE_UINT32:
309	9		Newx_or_alloca(ptr, 1, uint32_t);
310	9	0	((uint32_t)ptr) = SvOK(arg2) ? SvUV(arg2) : 0;
		0
		50
311	9		break;
312	17		case FFI_PL_TYPE_SINT32:
313	17		Newx_or_alloca(ptr, 1, int32_t);
314	17	50	((int32_t)ptr) = SvOK(arg2) ? SvIV(arg2) : 0;
		0
		50
315	17		break;
316	9		case FFI_PL_TYPE_UINT64:
317	9		Newx_or_alloca(ptr, 1, uint64_t);
318	9	0	((uint64_t)ptr) = SvOK(arg2) ? SvU64(arg2) : 0;
		0
		50
319	9		break;
320	9		case FFI_PL_TYPE_SINT64:
321	9		Newx_or_alloca(ptr, 1, int64_t);
322	9	0	((int64_t)ptr) = SvOK(arg2) ? SvI64(arg2) : 0;
		0
		50
323	9		break;
324	9		case FFI_PL_TYPE_FLOAT:
325	9		Newx_or_alloca(ptr, 1, float);
326	9	0	((float)ptr) = SvOK(arg2) ? SvNV(arg2) : 0.0;
		0
		50
327	9		break;
328	9		case FFI_PL_TYPE_DOUBLE:
329	9		Newx_or_alloca(ptr, 1, double);
330	9	0	((double)ptr) = SvOK(arg2) ? SvNV(arg2) : 0.0;
		0
		50
331	9		break;
332	12		case FFI_PL_TYPE_OPAQUE:
333	12		Newx_or_alloca(ptr, 1, void*);
334			{
335	12		SV *tmp = SvRV(arg);
336	12	0	((void)ptr) = SvOK(tmp) ? INT2PTR(void , SvIV(tmp)) : NULL;
		0
		100
337			}
338	12		break;
339			#ifdef FFI_PL_PROBE_LONGDOUBLE
340	0		case FFI_PL_TYPE_LONG_DOUBLE:
341	0		Newx_or_alloca(ptr, 1, long double);
342	0	0	ffi_pl_perl_to_long_double(arg2, (long double*)ptr);
		0
		0
		0
		0
		0
		0
		0
		0
343	0		break;
344			#endif
345			#ifdef FFI_PL_PROBE_COMPLEX
346	27		case FFI_PL_TYPE_COMPLEX_FLOAT:
347	27		Newx_or_alloca(ptr, 1, float complex);
348	27		ffi_pl_perl_to_complex_float(arg2, (float *)ptr);
349	27		break;
350	27		case FFI_PL_TYPE_COMPLEX_DOUBLE:
351	27		Newx_or_alloca(ptr, 1, double complex);
352	27		ffi_pl_perl_to_complex_double(arg2, (double *)ptr);
353	27		break;
354			#endif
355	6		case FFI_PL_TYPE_STRING:
356	6		Newx_or_alloca(ptr, 1, char *);
357	6	0	if(SvOK(arg2))
		0
		100
358			{
359			char *pv;
360			STRLEN len;
361			char *str;
362	3		pv = SvPV(arg2, len);
363			/* TODO: this should probably be a malloc since it could be arbitrarily large */
364	3		Newx_or_alloca(str, len+1, char);
365	3		memcpy(str, pv, len+1);
366	3		((char*)ptr) = str;
367			}
368			else
369			{
370	3		((char*)ptr) = NULL;
371			}
372	6		break;
373	0		default:
374	0		warn("argument type not supported (%d)", i);
375	0		Newx_or_alloca(ptr, 1, void*);
376	0		((void*)ptr) = NULL;
377	0		break;
378			}
379			}
380	215	50	else if(SvTYPE(arg2) == SVt_PVAV && (!is_pointer) \|\| (is_pointer && self->platypus_api >= 2))
		100
		50
		50
		0
		0
		0
		0
		50
		100
		50
		50
381	215		{
382	215		AV av = (AV) arg2;
383	215	100	if(!is_pointer)
		0
		100
384			{
385	182		count = self->argument_types[i]->extra[0].array.element_count;
386			}
387	215	100	if(count == 0)
		0
		100
388			{
389	124		count = av_len(av)+1;
390			}
391	215		switch(type_code & (FFI_PL_BASE_MASK\|FFI_PL_SIZE_MASK))
392			{
393	11		case FFI_PL_TYPE_UINT8:
394	11		Newx(ptr, count, uint8_t);
395	121	0	for(n=0; n
		0
		100
396			{
397	110		((uint8_t)ptr)[n] = SvUV(av_fetch(av, n, 1));
398			}
399	11		break;
400	11		case FFI_PL_TYPE_SINT8:
401	11		Newx(ptr, count, int8_t);
402	121	0	for(n=0; n
		0
		100
403			{
404	110		((int8_t)ptr)[n] = SvIV(av_fetch(av, n, 1));
405			}
406	11		break;
407	11		case FFI_PL_TYPE_UINT16:
408	11	0	Newx(ptr, count, uint16_t);
		0
		50
409	121	0	for(n=0; n
		0
		100
410			{
411	110		((uint16_t)ptr)[n] = SvUV(av_fetch(av, n, 1));
412			}
413	11		break;
414	11		case FFI_PL_TYPE_SINT16:
415	11	0	Newx(ptr, count, int16_t);
		0
		50
416	121	0	for(n=0; n
		0
		100
417			{
418	110		((int16_t)ptr)[n] = SvIV(av_fetch(av, n, 1));
419			}
420	11		break;
421	11		case FFI_PL_TYPE_UINT32:
422	11	0	Newx(ptr, count, uint32_t);
		0
		50
423	121	0	for(n=0; n
		0
		100
424			{
425	110		((uint32_t)ptr)[n] = SvUV(av_fetch(av, n, 1));
426			}
427	11		break;
428	11		case FFI_PL_TYPE_SINT32:
429	11	0	Newx(ptr, count, int32_t);
		0
		50
430	121	0	for(n=0; n
		0
		100
431			{
432	110		((int32_t)ptr)[n] = SvIV(av_fetch(av, n, 1));
433			}
434	11		break;
435	11		case FFI_PL_TYPE_UINT64:
436	11	0	Newx(ptr, count, uint64_t);
		0
		50
437	121	0	for(n=0; n
		0
		100
438			{
439	110		((uint64_t)ptr)[n] = SvU64(av_fetch(av, n, 1));
440			}
441	11		break;
442	11		case FFI_PL_TYPE_SINT64:
443	11	0	Newx(ptr, count, int64_t);
		0
		50
444	121	0	for(n=0; n
		0
		100
445			{
446	110		((int64_t)ptr)[n] = SvI64(av_fetch(av, n, 1));
447			}
448	11		break;
449	11		case FFI_PL_TYPE_FLOAT:
450	11	0	Newx(ptr, count, float);
		0
		50
451	121	0	for(n=0; n
		0
		100
452			{
453	110		((float)ptr)[n] = SvNV(av_fetch(av, n, 1));
454			}
455	11		break;
456	11		case FFI_PL_TYPE_DOUBLE:
457	11	0	Newx(ptr, count, double);
		0
		50
458	121	0	for(n=0; n
		0
		100
459			{
460	110		((double)ptr)[n] = SvNV(av_fetch(av, n, 1));
461			}
462	11		break;
463	39		case FFI_PL_TYPE_OPAQUE:
464	39	50	Newx(ptr, count, void*);
		0
		50
465	434	100	for(n=0; n
		0
		100
466			{
467	395		SV sv = av_fetch(av, n, 1);
468	395	100	((void*)ptr)[n] = SvOK(sv) ? INT2PTR(void, SvIV(sv)) : NULL;
		0
		100
469			}
470	39		break;
471			#ifdef FFI_PL_PROBE_LONGDOUBLE
472	0		case FFI_PL_TYPE_LONG_DOUBLE:
473			/* gh#236: lets hope the compiler is smart enough to opitmize this */
474			if(sizeof(long double) >= 16)
475			{
476	0	0	Newx(ptr, count, long double);
		0
		0
477			}
478			else
479			{
480			Newx(ptr, count*16, char);
481			}
482	0	0	for(n=0; n
		0
		0
483			{
484	0		SV sv = av_fetch(av, n, 1);
485	0	0	ffi_pl_perl_to_long_double(sv, &((long double*)ptr)[n]);
		0
		0
		0
		0
		0
		0
		0
		0
486			}
487	0		break;
488			#endif
489			#ifdef FFI_PL_PROBE_COMPLEX
490	16		case FFI_PL_TYPE_COMPLEX_FLOAT:
491	16	50	Newx(ptr, count, float complex);
		0
		0
492	64	100	for(n=0; n
		0
		0
493			{
494	48		SV sv = av_fetch(av, n, 1);
495	48		ffi_pl_perl_to_complex_float(sv, &((float)ptr)[n2]);
496			}
497	16		break;
498	16		case FFI_PL_TYPE_COMPLEX_DOUBLE:
499	16	50	Newx(ptr, count, double complex);
		0
		0
500	64	100	for(n=0; n
		0
		0
501			{
502	48		SV sv = av_fetch(av, n, 1);
503	48		ffi_pl_perl_to_complex_double(sv, &((double)ptr)[n2]);
504			}
505	16		break;
506			#endif
507	34		case FFI_PL_TYPE_STRING:
508	34	50	Newx(ptr, count, char *);
		0
		0
509	182	100	for(n=0; n
		0
		0
510			{
511	148		SV sv = av_fetch(av, n, 1);
512	148		if(SvOK(sv))
513			{
514			char *str;
515			char *pv;
516			STRLEN len;
517	114		pv = SvPV(sv, len);
518			/* TODO: this should probably be a malloc since it could be arbitrarily large */
519	114		Newx_or_alloca(str, len+1, char);
520	114		memcpy(str, pv, len+1);
521	114		((char**)ptr)[n] = str;
522			}
523			else
524			{
525	34		((char**)ptr)[n] = NULL;
526			}
527			}
528	34		break;
529	0		default:
530	0		Newxz(ptr, count*(1 << ((type_code & FFI_PL_SIZE_MASK)-1)), char);
531	0		warn("argument type not supported (%d)", i);
532	0		break;
533			}
534	215		ffi_pl_heap_add_ptr(ptr);
535			}
536			else
537			{
538	0		is_bad = 1;
539			}
540			}
541			else
542			{
543	93	0	if(is_pointer)
		0
		100
544			{
545	63		ptr = NULL;
546			}
547			else
548			{
549	30		is_bad = 1;
550			}
551			}
552	478	50	if(is_bad)
		0
		100
553			{
554	30	0	if(is_pointer)
		0
		50
555			{
556	0	0	if(self->platypus_api >= 2)
		0
		0
557			{
558	0		warn("argument type not a reference to scalar or array (%d)", i);
559			}
560			else
561			{
562	0		warn("argument type not a reference to scalar (%d)", i);
563			}
564			}
565			else
566			{
567	30		warn("passing non array reference into ffi/platypus array argument type");
568	30		count = self->argument_types[i]->extra[0].array.element_count;
569	30		Newxz(ptr, count*(1 << ((type_code & FFI_PL_SIZE_MASK)-1)), char);
570	30		ffi_pl_heap_add_ptr(ptr);
571			}
572			}
573	478		ffi_pl_arguments_set_pointer(arguments, i, ptr);
574			}
575	478		break;
576
577			/*
578			* ARGUMENT IN - OBJECT
579			*/
580
581	20		case FFI_PL_SHAPE_OBJECT:
582			{
583	20	50	if(sv_isobject(arg) && sv_derived_from(arg, self->argument_types[i]->extra[0].object.class))
		50
		0
		0
		0
		0
584	20		{
585	20		SV *arg2 = SvRV(arg);
586	20		switch(type_code)
587			{
588	2		case FFI_PL_TYPE_UINT8 \| FFI_PL_SHAPE_OBJECT:
589	2		ffi_pl_arguments_set_uint8(arguments, i, SvUV(arg2) );
590	2		break;
591	2		case FFI_PL_TYPE_SINT8 \| FFI_PL_SHAPE_OBJECT:
592	2		ffi_pl_arguments_set_sint8(arguments, i, SvIV(arg2) );
593	2		break;
594	2		case FFI_PL_TYPE_UINT16 \| FFI_PL_SHAPE_OBJECT:
595	2		ffi_pl_arguments_set_uint16(arguments, i, SvUV(arg2) );
596	2		break;
597	2		case FFI_PL_TYPE_SINT16 \| FFI_PL_SHAPE_OBJECT:
598	2		ffi_pl_arguments_set_sint16(arguments, i, SvIV(arg2) );
599	2		break;
600	2		case FFI_PL_TYPE_UINT32 \| FFI_PL_SHAPE_OBJECT:
601	2		ffi_pl_arguments_set_uint32(arguments, i, SvUV(arg2) );
602	2		break;
603	2		case FFI_PL_TYPE_SINT32 \| FFI_PL_SHAPE_OBJECT:
604	2		ffi_pl_arguments_set_sint32(arguments, i, SvIV(arg2) );
605	2		break;
606	2		case FFI_PL_TYPE_UINT64 \| FFI_PL_SHAPE_OBJECT:
607	2		ffi_pl_arguments_set_uint64(arguments, i, SvU64(arg2) );
608	2		break;
609	2		case FFI_PL_TYPE_SINT64 \| FFI_PL_SHAPE_OBJECT:
610	2		ffi_pl_arguments_set_sint64(arguments, i, SvI64(arg2) );
611	2		break;
612	4		case FFI_PL_TYPE_OPAQUE \| FFI_PL_SHAPE_OBJECT:
613	4	50	ffi_pl_arguments_set_pointer(arguments, i, SvOK(arg2) ? INT2PTR(void*, SvIV(arg2)) : NULL);
		0
		0
614	4		break;
615	0		default:
616	0	0	ffi_pl_croak("Object argument %d type not supported %d", i, type_code);
		0
		0
617			}
618			}
619			else
620			{
621	0	0	ffi_pl_croak("Object argument %d must be an object of class %s", i, self->argument_types[i]->extra[0].object.class);
		0
		0
622			}
623			}
624	20		break;
625
626			/*
627			* ARGUMENT IN - UNSUPPORTED
628			*/
629
630	0		default:
631	0		warn("FFI::Platypus: argument %d type not supported (%04x)", i, type_code);
632	0		break;
633			}
634			}
635
636	2605	100	if(custom_flag)
		50
		100
637			{
638	135		int max = self->argument_types[i]->extra[0].custom_perl.argument_count;
639	135		SvREFCNT_dec(arg);
640	135	50	for(n=0; n < max; n++)
		0
		50
641			{
642	0		i++;
643	0		argument_pointers[i] = &arguments->slot[i];
644			}
645			}
646			}
647
648			/*
649			* CALL
650			*/
651
652			#if 0
653			fprintf(stderr, "# ===[%p]===\n", self->address);
654			for(i=0; i < self->ffi_cif.nargs; i++)
655			{
656			fprintf(stderr, "# [%d] <%04x> %p %p",
657			i,
658			self->argument_types[i]->type_code,
659			argument_pointers[i],
660			&arguments->slot[i]
661			);
662			switch(self->argument_types[i]->type_code)
663			{
664			case FFI_PL_TYPE_LONG_DOUBLE:
665			fprintf(stderr, " %Lg", ((long double)argument_pointers[i]));
666			break;
667			case FFI_PL_TYPE_COMPLEX_FLOAT:
668			fprintf(stderr, " %g + %g * i",
669			crealf(((float complex)argument_pointers[i])),
670			cimagf(((float complex)argument_pointers[i]))
671			);
672			break;
673			case FFI_PL_TYPE_COMPLEX_DOUBLE:
674			fprintf(stderr, " %g + %g * i",
675			creal(((double complex)argument_pointers[i])),
676			cimag(((double complex)argument_pointers[i]))
677			);
678			break;
679			default:
680			fprintf(stderr, "%016llx", ffi_pl_arguments_get_uint64(arguments, i));
681			break;
682			}
683			fprintf(stderr, "\n");
684			}
685			fprintf(stderr, "# === ===\n");
686			fflush(stderr);
687			#endif
688
689	2043		MY_CXT.current_argv = NULL;
690
691	2043		ffi_call(&self->ffi_cif, self->address, RESULT, ffi_pl_arguments_pointers(arguments));
692
693			/*
694			* ARGUMENT OUT
695			*/
696
697	2043		MY_CXT.current_argv = arguments;
698
699	4653	100	for(i=self->ffi_cif.nargs-1,perl_arg_index--; i >= 0; i--, perl_arg_index--)
		100
		100
700			{
701	2611		int type_code = self->argument_types[i]->type_code;
702
703	2611	100	switch(type_code)
		50
		100
704			{
705
706			/*
707			* ARGUMENT OUT - SCALAR TYPES
708			*/
709
710	122		case FFI_PL_TYPE_CLOSURE:
711			{
712	122	50	arg = perl_arg_index < items ? ST(perl_arg_index) : &PL_sv_undef;
		0
		100
713	122	100	if(SvROK(arg))
		0
		100
714			{
715	90		SvREFCNT_dec(arg);
716	90		SvREFCNT_dec(SvRV(arg));
717			}
718			}
719	122		break;
720
721	2489		default:
722	2489		switch(type_code & FFI_PL_SHAPE_MASK)
723			{
724
725			/*
726			* ARGUMENT OUT - POINTER & ARRAY TYPES
727			*/
728
729	478		case FFI_PL_SHAPE_POINTER:
730			case FFI_PL_SHAPE_ARRAY:
731			{
732	478		void *ptr = ffi_pl_arguments_get_pointer(arguments, i);
733	478	50	arg = perl_arg_index < items ? ST(perl_arg_index) : &PL_sv_undef;
		0
		100
734	478	50	if(ptr != NULL && SvOK(arg))
		50
		0
		0
		100
		100
735			{
736	385	50	SV *arg2 = SvROK(arg) ? SvRV(arg) : &PL_sv_undef;
		0
		50
737	385	100	if(SvTYPE(arg2) == SVt_PVAV)
		0
		100
738			{
739	215		SSize_t count = 0;
740	215		AV av = (AV)arg2;
741	215	100	if((type_code & FFI_PL_SHAPE_MASK) == FFI_PL_SHAPE_ARRAY)
		0
		100
742			{
743	182		count = self->argument_types[i]->extra[0].array.element_count;
744			}
745	215	100	if(count == 0)
		0
		100
746			{
747	124		count = av_len(av)+1;
748			}
749	215		switch(type_code & (FFI_PL_BASE_MASK\|FFI_PL_SIZE_MASK))
750			{
751	11		case FFI_PL_TYPE_UINT8:
752	121	0	for(n=0; n
		0
		100
753			{
754	110		sv_setuv(av_fetch(av, n, 1), ((uint8_t)ptr)[n]);
755			}
756	11		break;
757	11		case FFI_PL_TYPE_SINT8:
758	121	0	for(n=0; n
		0
		100
759			{
760	110		sv_setiv(av_fetch(av, n, 1), ((int8_t)ptr)[n]);
761			}
762	11		break;
763	11		case FFI_PL_TYPE_UINT16:
764	121	0	for(n=0; n
		0
		100
765			{
766	110		sv_setuv(av_fetch(av, n, 1), ((uint16_t)ptr)[n]);
767			}
768	11		break;
769	11		case FFI_PL_TYPE_SINT16:
770	121	0	for(n=0; n
		0
		100
771			{
772	110		sv_setiv(av_fetch(av, n, 1), ((int16_t)ptr)[n]);
773			}
774	11		break;
775	11		case FFI_PL_TYPE_UINT32:
776	121	0	for(n=0; n
		0
		100
777			{
778	110		sv_setuv(av_fetch(av, n, 1), ((uint32_t)ptr)[n]);
779			}
780	11		break;
781	11		case FFI_PL_TYPE_SINT32:
782	121	0	for(n=0; n
		0
		100
783			{
784	110		sv_setiv(av_fetch(av, n, 1), ((int32_t)ptr)[n]);
785			}
786	11		break;
787	11		case FFI_PL_TYPE_UINT64:
788	121	0	for(n=0; n
		0
		100
789			{
790	110		sv_setu64(av_fetch(av, n, 1), ((uint64_t)ptr)[n]);
791			}
792	11		break;
793	11		case FFI_PL_TYPE_SINT64:
794	121	0	for(n=0; n
		0
		100
795			{
796	110		sv_seti64(av_fetch(av, n, 1), ((int64_t)ptr)[n]);
797			}
798	11		break;
799	11		case FFI_PL_TYPE_FLOAT:
800	121	0	for(n=0; n
		0
		100
801			{
802	110		sv_setnv(av_fetch(av, n, 1), ((float)ptr)[n]);
803			}
804	11		break;
805	73		case FFI_PL_TYPE_OPAQUE:
806			case FFI_PL_TYPE_STRING:
807	616	100	for(n=0; n
		0
		100
808			{
809	543	100	if( ((void**)ptr)[n] == NULL)
		0
		100
810			{
811	74		av_store(av, n, &PL_sv_undef);
812			}
813			else
814			{
815	469		switch(type_code) {
816	349		case FFI_PL_TYPE_OPAQUE \| FFI_PL_SHAPE_ARRAY:
817	349		sv_setnv(av_fetch(av,n,1), PTR2IV( ((void*)ptr)[n]) );
818	349		break;
819	105		case FFI_PL_TYPE_STRING \| FFI_PL_SHAPE_ARRAY:
820	105		sv_setpv(av_fetch(av,n,1), ((char*)ptr)[n] );
821	105		break;
822			}
823			}
824			}
825	73		break;
826	11		case FFI_PL_TYPE_DOUBLE:
827	121	0	for(n=0; n
		0
		100
828			{
829	110		sv_setnv(av_fetch(av, n, 1), ((double)ptr)[n]);
830			}
831	11		break;
832			#ifdef FFI_PL_PROBE_LONGDOUBLE
833	0		case FFI_PL_TYPE_LONG_DOUBLE:
834	0	0	for(n=0; n
		0
		0
835			{
836			SV *sv;
837	0		sv = *av_fetch(av, n, 1);
838	0	0	ffi_pl_long_double_to_perl(sv, &((long double*)ptr)[n]);
		0
		0
		0
		0
		0
		0
		0
		0
839			}
840	0		break;
841			#endif
842			#ifdef FFI_PL_PROBE_COMPLEX
843	16		case FFI_PL_TYPE_COMPLEX_DOUBLE:
844	64	100	for(n=0; n
		0
		0
845			{
846			SV *sv;
847	48		sv = *av_fetch(av, n, 1);
848	48		ffi_pl_complex_double_to_perl(sv, &((double)ptr)[n2]);
849			}
850	16		break;
851	16		case FFI_PL_TYPE_COMPLEX_FLOAT:
852	64	100	for(n=0; n
		0
		0
853			{
854			SV *sv;
855	48		sv = *av_fetch(av, n, 1);
856	48		ffi_pl_complex_float_to_perl(sv, &((float)ptr)[n2]);
857			}
858	16		break;
859			#endif
860			}
861			}
862	170	50	else if(SvTYPE(arg2) < SVt_PVAV && !SvREADONLY(arg2))
		50
		0
		0
		50
		100
863			{
864	107		switch(type_code & (FFI_PL_BASE_MASK\|FFI_PL_SIZE_MASK))
865			{
866	3		case FFI_PL_TYPE_UINT8:
867	3		sv_setuv(arg2, ((uint8_t)ptr));
868	3		break;
869	6		case FFI_PL_TYPE_SINT8:
870	6		sv_setiv(arg2, ((int8_t)ptr));
871	6		break;
872	3		case FFI_PL_TYPE_UINT16:
873	3		sv_setuv(arg2, ((uint16_t)ptr));
874	3		break;
875	6		case FFI_PL_TYPE_SINT16:
876	6		sv_setiv(arg2, ((int16_t)ptr));
877	6		break;
878	3		case FFI_PL_TYPE_UINT32:
879	3		sv_setuv(arg2, ((uint32_t)ptr));
880	3		break;
881	14		case FFI_PL_TYPE_SINT32:
882	14		sv_setiv(arg2, ((int32_t)ptr));
883	14		break;
884	3		case FFI_PL_TYPE_UINT64:
885	3		sv_setu64(arg2, ((uint64_t)ptr));
886	3		break;
887	6		case FFI_PL_TYPE_SINT64:
888	6		sv_seti64(arg2, ((int64_t)ptr));
889	6		break;
890	3		case FFI_PL_TYPE_FLOAT:
891	3		sv_setnv(arg2, ((float)ptr));
892	3		break;
893	9		case FFI_PL_TYPE_OPAQUE:
894	9	0	if( ((void*)ptr) == NULL)
		0
		100
895	3		sv_setsv(arg2, &PL_sv_undef);
896			else
897	6		sv_setiv(arg2, PTR2IV(((void*)ptr)));
898	9		break;
899	3		case FFI_PL_TYPE_DOUBLE:
900	3		sv_setnv(arg2, ((double)ptr));
901	3		break;
902			#ifdef FFI_PL_PROBE_LONGDOUBLE
903	0		case FFI_PL_TYPE_LONG_DOUBLE:
904	0	0	ffi_pl_long_double_to_perl(arg2,(long double*)ptr);
		0
		0
		0
		0
		0
		0
		0
		0
905	0		break;
906			#endif
907			#ifdef FFI_PL_PROBE_COMPLEX
908	21		case FFI_PL_TYPE_COMPLEX_FLOAT:
909	21		ffi_pl_complex_float_to_perl(arg2, (float *)ptr);
910	21		break;
911	21		case FFI_PL_TYPE_COMPLEX_DOUBLE:
912	21		ffi_pl_complex_double_to_perl(arg2, (double *)ptr);
913	21		break;
914			#endif
915	6		case FFI_PL_TYPE_STRING:
916			{
917	6		char **pv = ptr;
918	6	0	if(*pv == NULL)
		0
		50
919			{
920	0		sv_setsv(arg2, &PL_sv_undef);
921			}
922			else
923			{
924	6		sv_setpv(arg2, *pv);
925			}
926			}
927	6		break;
928			}
929			}
930			}
931			}
932	478		break;
933
934			/*
935			* ARGUMENT OUT - CUSTOM TYPE
936			*/
937
938	141		case FFI_PL_SHAPE_CUSTOM_PERL:
939			{
940			/* FIXME: need to fill out argument_types for skipping */
941	141		i -= self->argument_types[i]->extra[0].custom_perl.argument_count;
942			{
943	141		SV *coderef = self->argument_types[i]->extra[0].custom_perl.perl_to_native_post;
944	141	100	if(coderef != NULL)
		0
		100
945			{
946	85	50	arg = perl_arg_index < items ? ST(perl_arg_index) : &PL_sv_undef;
		0
		50
947	85		ffi_pl_custom_perl_cb(coderef, arg, i);
948			}
949			}
950			{
951	140		SV *sv = av_pop(MY_CXT.custom_keepers);
952	140		if(SvOK(sv))
953	134		SvREFCNT_dec(sv);
954			}
955			}
956	140		break;
957
958	1870		default:
959	1870		break;
960			}
961			}
962			}
963
964			{
965
966	2042		int type_code = self->return_type->type_code;
967
968			/*
969			* TODO: This should always happen later if possible
970			*/
971	2042	100	if((type_code & FFI_PL_SHAPE_MASK) != FFI_PL_SHAPE_CUSTOM_PERL
		50
		100
972	1962	100	&& type_code != FFI_PL_TYPE_RECORD_VALUE)
		50
		50
973	4139	100	ffi_pl_heap_free();
		0
		100
974
975	2042		MY_CXT.current_argv = NULL;
976
977			/*
978			* RETURN VALUE
979			*/
980
981	2042		switch(type_code)
982			{
983
984			/*
985			* RETURN VALUE - TYPE SCALAR
986			*/
987
988
989			#if ! FFI_PL_CALL_NO_RECORD_VALUE
990	3		case FFI_PL_TYPE_RECORD_VALUE:
991			{
992			SV value, ref;
993	3		value = newSV(0);
994	3		sv_setpvn(value, result_ptr, self->return_type->extra[0].record.size);
995	3		ref = ST(0) = sv_2mortal(newRV_noinc(value));
996	3		sv_bless(ref, gv_stashpv(self->return_type->extra[0].record.class, GV_ADD));
997	6	100	ffi_pl_heap_free();
		100
998	3		XSRETURN(1);
999			}
1000			break;
1001	1		case FFI_PL_TYPE_RECORD_VALUE \| FFI_PL_SHAPE_CUSTOM_PERL:
1002			{
1003			SV value, ref;
1004	1		value = newSV(0);
1005	1		sv_setpvn(value, result_ptr, self->return_type->extra[0].record.size);
1006	1		ref = sv_2mortal(newRV_noinc(value));
1007	1		sv_bless(ref, gv_stashpv(self->return_type->extra[0].record.class, GV_ADD));
1008
1009	1		MY_CXT.current_argv = arguments;
1010
1011	2		ST(0) = ffi_pl_custom_perl(
1012	1		self->return_type->extra[0].custom_perl.native_to_perl,
1013			ref,
1014			-1
1015			);
1016
1017	1		MY_CXT.current_argv = NULL;
1018
1019	2	100	ffi_pl_heap_free();
		0
1020	1		XSRETURN(1);
1021			}
1022			break;
1023			#endif
1024			#if ! FFI_PL_CALL_RET_NO_NORMAL
1025	351		case FFI_PL_TYPE_VOID:
1026	351		XSRETURN_EMPTY;
1027			break;
1028	47		case FFI_PL_TYPE_UINT8:
1029			#if defined FFI_PL_PROBE_BIGENDIAN
1030			XSRETURN_UV(result.uint8_array[3]);
1031			#elif defined FFI_PL_PROBE_BIGENDIAN64
1032			XSRETURN_UV(result.uint8_array[7]);
1033			#else
1034	47		XSRETURN_UV(result.uint8);
1035			#endif
1036			break;
1037	26		case FFI_PL_TYPE_SINT8:
1038			#if defined FFI_PL_PROBE_BIGENDIAN
1039			XSRETURN_IV(result.sint8_array[3]);
1040			#elif defined FFI_PL_PROBE_BIGENDIAN64
1041			XSRETURN_IV(result.sint8_array[7]);
1042			#else
1043	26		XSRETURN_IV(result.sint8);
1044			#endif
1045			break;
1046	29		case FFI_PL_TYPE_UINT16:
1047			#if defined FFI_PL_PROBE_BIGENDIAN
1048			XSRETURN_UV(result.uint16_array[1]);
1049			#elif defined FFI_PL_PROBE_BIGENDIAN64
1050			XSRETURN_UV(result.uint16_array[3]);
1051			#else
1052	29		XSRETURN_UV(result.uint16);
1053			#endif
1054			break;
1055	25		case FFI_PL_TYPE_SINT16:
1056			#if defined FFI_PL_PROBE_BIGENDIAN
1057			XSRETURN_IV(result.sint16_array[1]);
1058			#elif defined FFI_PL_PROBE_BIGENDIAN64
1059			XSRETURN_IV(result.sint16_array[3]);
1060			#else
1061	25		XSRETURN_IV(result.sint16);
1062			#endif
1063			break;
1064	28		case FFI_PL_TYPE_UINT32:
1065			#if defined FFI_PL_PROBE_BIGENDIAN64
1066			XSRETURN_UV(result.uint32_array[1]);
1067			#else
1068	28		XSRETURN_UV(result.uint32);
1069			#endif
1070			break;
1071	243		case FFI_PL_TYPE_SINT32:
1072			#if defined FFI_PL_PROBE_BIGENDIAN64
1073			XSRETURN_IV(result.sint32_array[1]);
1074			#else
1075	243		XSRETURN_IV(result.sint32);
1076			#endif
1077			break;
1078	57		case FFI_PL_TYPE_UINT64:
1079	57		XSRETURN_U64(result.uint64);
1080			break;
1081	25		case FFI_PL_TYPE_SINT64:
1082	25		XSRETURN_I64(result.sint64);
1083			break;
1084	59		case FFI_PL_TYPE_FLOAT:
1085	59		XSRETURN_NV(result.xfloat);
1086			break;
1087	59		case FFI_PL_TYPE_DOUBLE:
1088	59		XSRETURN_NV(result.xdouble);
1089			break;
1090	704		case FFI_PL_TYPE_OPAQUE:
1091			case FFI_PL_TYPE_STRING:
1092	704	100	if(result.pointer == NULL)
		100
1093			{
1094	33	100	if(self->platypus_api >= 2)
		100
1095			{
1096	9		XSRETURN_UNDEF;
1097			}
1098			else
1099			{
1100	24		XSRETURN_EMPTY;
1101			}
1102			}
1103			else
1104			{
1105	671		switch(type_code)
1106			{
1107	504		case FFI_PL_TYPE_OPAQUE:
1108	504		XSRETURN_IV(PTR2IV(result.pointer));
1109			break;
1110	167		case FFI_PL_TYPE_STRING:
1111	167		XSRETURN_PV(result.pointer);
1112			break;
1113			}
1114			}
1115	0		break;
1116			#ifdef FFI_PL_PROBE_LONGDOUBLE
1117	0		case FFI_PL_TYPE_LONG_DOUBLE:
1118			{
1119			#if !(defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE))
1120	0	0	if(MY_CXT.loaded_math_longdouble == 1)
		0
1121			{
1122			SV *sv;
1123			long double *ptr;
1124	0		Newx(ptr, 1, long double);
1125	0		*ptr = result.longdouble;
1126	0		sv = sv_newmortal();
1127	0		sv_setref_pv(sv, "Math::LongDouble", (void*)ptr);
1128	0		ST(0) = sv;
1129	0		XSRETURN(1);
1130			}
1131			else
1132			{
1133			#endif
1134	0		XSRETURN_NV((NV) result.longdouble);
1135			#if !(defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE))
1136			}
1137			#endif
1138			}
1139			#endif
1140			#ifdef FFI_PL_PROBE_COMPLEX
1141	15		case FFI_PL_TYPE_COMPLEX_FLOAT:
1142			{
1143			SV *c[2];
1144			AV *av;
1145
1146	15		c[0] = sv_2mortal(newSVnv( ((float*)&result.complex_float)[0]) );
1147	15		c[1] = sv_2mortal(newSVnv( ((float*)&result.complex_float)[1]) );
1148	15		av = av_make(2,c);
1149	15		ST(0) = sv_2mortal(newRV_noinc((SV*) av));
1150	15		XSRETURN(1);
1151			}
1152			break;
1153	15		case FFI_PL_TYPE_COMPLEX_DOUBLE:
1154			{
1155			SV *c[2];
1156			AV *av;
1157
1158	15		c[0] = sv_2mortal(newSVnv( ((double*)&result.complex_double)[0]) );
1159	15		c[1] = sv_2mortal(newSVnv( ((double*)&result.complex_double)[1]) );
1160	15		av = av_make(2,c);
1161	15		ST(0) = sv_2mortal(newRV_noinc((SV*) av));
1162	15		XSRETURN(1);
1163			}
1164			break;
1165			#endif
1166	26		case FFI_PL_TYPE_RECORD:
1167			case FFI_PL_TYPE_RECORD \| FFI_PL_SHAPE_CUSTOM_PERL:
1168	26	100	if(result.pointer == NULL)
		100
1169			{
1170	8	100	if((type_code & FFI_PL_SHAPE_MASK) == FFI_PL_SHAPE_CUSTOM_PERL)
		50
1171			{
1172	1		MY_CXT.current_argv = arguments;
1173
1174	2		ST(0) = ffi_pl_custom_perl(
1175	1		self->return_type->extra[0].custom_perl.native_to_perl,
1176			&PL_sv_undef,
1177			-1
1178			);
1179
1180	1		MY_CXT.current_argv = NULL;
1181	2	100	ffi_pl_heap_free();
		0
1182	1		XSRETURN(1);
1183			}
1184	7	100	if(self->platypus_api >= 2)
		100
1185			{
1186	2		XSRETURN_UNDEF;
1187			}
1188			else
1189			{
1190	5		XSRETURN_EMPTY;
1191			}
1192			}
1193			else
1194			{
1195			SV *ref;
1196	18		SV *value = newSV(0);
1197	18		sv_setpvn(value, result.pointer, self->return_type->extra[0].record.size);
1198	18		if(self->return_type->extra[0].record.class != NULL)
1199			{
1200	5		ref = sv_2mortal(newRV_noinc(value));
1201	5		sv_bless(ref, gv_stashpv(self->return_type->extra[0].record.class, GV_ADD));
1202			}
1203			else
1204			{
1205	13		ref = sv_2mortal(value);
1206			}
1207
1208	18	100	if((type_code & FFI_PL_SHAPE_MASK) == FFI_PL_SHAPE_CUSTOM_PERL)
		50
1209			{
1210	1		MY_CXT.current_argv = arguments;
1211
1212	2		ST(0) = ffi_pl_custom_perl(
1213	1		self->return_type->extra[0].custom_perl.native_to_perl,
1214			ref,
1215			-1
1216			);
1217
1218	1		MY_CXT.current_argv = NULL;
1219	2	100	ffi_pl_heap_free();
		0
1220			}
1221			else
1222			{
1223	17		ST(0) = ref;
1224			}
1225
1226	18		XSRETURN(1);
1227			}
1228			break;
1229	8		case FFI_PL_SHAPE_OBJECT \| FFI_PL_TYPE_OPAQUE:
1230	8	100	if(result.pointer == NULL)
		0
1231			{
1232	4	100	if(self->platypus_api >= 2)
		0
1233			{
1234	2		XSRETURN_UNDEF;
1235			}
1236			else
1237			{
1238	2		XSRETURN_EMPTY;
1239			}
1240			}
1241			else
1242			{
1243			SV *ref;
1244	4		SV *value = newSV(0);
1245	4		sv_setiv(value, PTR2IV(((void*)result.pointer)));
1246	4		ref = ST(0) = sv_2mortal(newRV_noinc(value));
1247	4		sv_bless(ref, gv_stashpv(self->return_type->extra[0].object.class, GV_ADD));
1248	4		XSRETURN(1);
1249			}
1250			break;
1251	321		default:
1252
1253	321		switch(type_code & FFI_PL_SHAPE_MASK)
1254			{
1255
1256			/*
1257			* RETURN VALUE - TYPE POINTER
1258			*/
1259
1260	117		case FFI_PL_SHAPE_POINTER:
1261	117	0	if(result.pointer == NULL)
		100
1262			{
1263	39	0	if(self->platypus_api >= 2)
		100
1264			{
1265	13		XSRETURN_UNDEF;
1266			}
1267			else
1268			{
1269	26		XSRETURN_EMPTY;
1270			}
1271			}
1272			else
1273			{
1274			SV *value;
1275	78		switch(type_code)
1276			{
1277	6		case FFI_PL_TYPE_UINT8 \| FFI_PL_SHAPE_POINTER:
1278	6		value = newSV(0);
1279	6		sv_setuv(value, ((uint8_t) result.pointer));
1280	6		break;
1281	6		case FFI_PL_TYPE_SINT8 \| FFI_PL_SHAPE_POINTER:
1282	6		value = newSV(0);
1283	6		sv_setiv(value, ((int8_t) result.pointer));
1284	6		break;
1285	6		case FFI_PL_TYPE_UINT16 \| FFI_PL_SHAPE_POINTER:
1286	6		value = newSV(0);
1287	6		sv_setuv(value, ((uint16_t) result.pointer));
1288	6		break;
1289	6		case FFI_PL_TYPE_SINT16 \| FFI_PL_SHAPE_POINTER:
1290	6		value = newSV(0);
1291	6		sv_setiv(value, ((int16_t) result.pointer));
1292	6		break;
1293	6		case FFI_PL_TYPE_UINT32 \| FFI_PL_SHAPE_POINTER:
1294	6		value = newSV(0);
1295	6		sv_setuv(value, ((uint32_t) result.pointer));
1296	6		break;
1297	6		case FFI_PL_TYPE_SINT32 \| FFI_PL_SHAPE_POINTER:
1298	6		value = newSV(0);
1299	6		sv_setiv(value, ((int32_t) result.pointer));
1300	6		break;
1301	6		case FFI_PL_TYPE_UINT64 \| FFI_PL_SHAPE_POINTER:
1302	6		value = newSV(0);
1303	6		sv_setu64(value, ((uint64_t) result.pointer));
1304	6		break;
1305	6		case FFI_PL_TYPE_SINT64 \| FFI_PL_SHAPE_POINTER:
1306	6		value = newSV(0);
1307	6		sv_seti64(value, ((int64_t) result.pointer));
1308	6		break;
1309	6		case FFI_PL_TYPE_FLOAT \| FFI_PL_SHAPE_POINTER:
1310	6		value = newSV(0);
1311	6		sv_setnv(value, ((float) result.pointer));
1312	6		break;
1313	6		case FFI_PL_TYPE_DOUBLE \| FFI_PL_SHAPE_POINTER:
1314	6		value = newSV(0);
1315	6		sv_setnv(value, ((double) result.pointer));
1316	6		break;
1317	6		case FFI_PL_TYPE_OPAQUE \| FFI_PL_SHAPE_POINTER:
1318	6	0	if( ((void*)result.pointer) == NULL )
		100
1319	3		value = &PL_sv_undef;
1320			else
1321			{
1322	3		value = newSV(0);
1323	3		sv_setiv(value, PTR2IV(((void*)result.pointer)));
1324			}
1325	6		break;
1326			#ifdef FFI_PL_PROBE_LONGDOUBLE
1327	0		case FFI_PL_TYPE_LONG_DOUBLE \| FFI_PL_SHAPE_POINTER:
1328	0		value = newSV(0);
1329	0	0	ffi_pl_long_double_to_perl(value, (long double*)result.pointer);
		0
		0
		0
		0
		0
1330	0		break;
1331			#endif
1332			#ifdef FFI_PL_PROBE_COMPLEX
1333	3		case FFI_PL_TYPE_COMPLEX_FLOAT \| FFI_PL_SHAPE_POINTER:
1334			{
1335			SV *c[2];
1336			AV *av;
1337	3		c[0] = sv_2mortal(newSVnv( ((float*)result.pointer)[0] ));
1338	3		c[1] = sv_2mortal(newSVnv( ((float*)result.pointer)[1] ));
1339	3		av = av_make(2, c);
1340	3		value = newRV_noinc((SV*)av);
1341			}
1342	3		break;
1343	3		case FFI_PL_TYPE_COMPLEX_DOUBLE \| FFI_PL_SHAPE_POINTER:
1344			{
1345			SV *c[2];
1346			AV *av;
1347	3		c[0] = sv_2mortal(newSVnv( ((double*)result.pointer)[0] ));
1348	3		c[1] = sv_2mortal(newSVnv( ((double*)result.pointer)[1] ));
1349	3		av = av_make(2, c);
1350	3		value = newRV_noinc((SV*)av);
1351			}
1352	3		break;
1353			#endif
1354	6		case FFI_PL_TYPE_STRING \| FFI_PL_SHAPE_POINTER:
1355	6		value = newSV(0);
1356	6		if( ((void*)result.pointer) == NULL )
1357	3		value = &PL_sv_undef;
1358			else
1359	3		sv_setpv(value, (char*) result.pointer);
1360	6		break;
1361	0		default:
1362	0		warn("return type not supported");
1363	0		XSRETURN_EMPTY;
1364			}
1365	78		ST(0) = sv_2mortal(newRV_noinc(value));
1366	78		XSRETURN(1);
1367			}
1368			break;
1369
1370			/*
1371			* RETURN VALUE - TYPE ARRAY
1372			*/
1373
1374	111		case FFI_PL_SHAPE_ARRAY:
1375	111	100	if(result.pointer == NULL)
		100
1376			{
1377	36	100	if(self->platypus_api >= 2)
		100
1378			{
1379	12		XSRETURN_UNDEF;
1380			}
1381			else
1382			{
1383	24		XSRETURN_EMPTY;
1384			}
1385			}
1386			else
1387			{
1388	75		int count = self->return_type->extra[0].array.element_count;
1389	75	100	if(count == 0 && type_code & FFI_PL_TYPE_OPAQUE)
		50
		100
		50
1390			{
1391	39	100	while(((void**)result.pointer)[count] != NULL)
		100
1392	26		count++;
1393			}
1394			AV *av;
1395			SV **sv;
1396	75		Newx(sv, count, SV*);
1397	75		switch(type_code)
1398			{
1399	10		case FFI_PL_TYPE_UINT8 \| FFI_PL_SHAPE_ARRAY:
1400	67	100	for(i=0; i
		100
1401			{
1402	57		sv[i] = sv_2mortal( newSVuv( ((uint8_t*)result.pointer)[i] ));
1403			}
1404	10		break;
1405	4		case FFI_PL_TYPE_SINT8 \| FFI_PL_SHAPE_ARRAY:
1406	37	0	for(i=0; i
		100
1407			{
1408	33		sv[i] = sv_2mortal( newSViv( ((int8_t*)result.pointer)[i] ) );
1409			}
1410	4		break;
1411	4		case FFI_PL_TYPE_UINT16 \| FFI_PL_SHAPE_ARRAY:
1412	37	0	for(i=0; i
		100
1413			{
1414	33		sv[i] = sv_2mortal( newSVuv( ((uint16_t*)result.pointer)[i] ) );
1415			}
1416	4		break;
1417	4		case FFI_PL_TYPE_SINT16 \| FFI_PL_SHAPE_ARRAY:
1418	37	0	for(i=0; i
		100
1419			{
1420	33		sv[i] = sv_2mortal( newSViv( ((int16_t*)result.pointer)[i] ) );
1421			}
1422	4		break;
1423	4		case FFI_PL_TYPE_UINT32 \| FFI_PL_SHAPE_ARRAY:
1424	37	0	for(i=0; i
		100
1425			{
1426	33		sv[i] = sv_2mortal( newSVuv( ((uint32_t*)result.pointer)[i] ) );
1427			}
1428	4		break;
1429	4		case FFI_PL_TYPE_SINT32 \| FFI_PL_SHAPE_ARRAY:
1430	37	0	for(i=0; i
		100
1431			{
1432	33		sv[i] = sv_2mortal( newSViv( ((int32_t*)result.pointer)[i] ) );
1433			}
1434	4		break;
1435	4		case FFI_PL_TYPE_UINT64 \| FFI_PL_SHAPE_ARRAY:
1436	37	0	for(i=0; i
		100
1437			{
1438	33		sv[i] = sv_2mortal( newSVu64( ((uint64_t*)result.pointer)[i] ) );
1439			}
1440	4		break;
1441	4		case FFI_PL_TYPE_SINT64 \| FFI_PL_SHAPE_ARRAY:
1442	37	0	for(i=0; i
		100
1443			{
1444	33		sv[i] = sv_2mortal( newSVi64( ((int64_t*)result.pointer)[i] ) );
1445			}
1446	4		break;
1447	3		case FFI_PL_TYPE_FLOAT \| FFI_PL_SHAPE_ARRAY:
1448	33	0	for(i=0; i
		100
1449			{
1450	30		sv[i] = sv_2mortal( newSVnv( ((float*)result.pointer)[i] ) );
1451			}
1452	3		break;
1453	3		case FFI_PL_TYPE_DOUBLE \| FFI_PL_SHAPE_ARRAY:
1454	33	0	for(i=0; i
		100
1455			{
1456	30		sv[i] = sv_2mortal( newSVnv( ((double*)result.pointer)[i] ) );
1457			}
1458	3		break;
1459	25		case FFI_PL_TYPE_STRING \| FFI_PL_SHAPE_ARRAY:
1460			case FFI_PL_TYPE_OPAQUE \| FFI_PL_SHAPE_ARRAY:
1461	87	100	for(i=0; i
		100
1462			{
1463	62	100	if( ((void**)result.pointer)[i] == NULL)
		100
1464			{
1465	12		sv[i] = &PL_sv_undef;
1466			}
1467			else
1468			{
1469	50		switch(type_code) {
1470	27		case FFI_PL_TYPE_STRING \| FFI_PL_SHAPE_ARRAY:
1471	27		sv[i] = sv_2mortal( newSVpv( ((char**)result.pointer)[i], 0 ) );
1472	27		break;
1473	23		case FFI_PL_TYPE_OPAQUE \| FFI_PL_SHAPE_ARRAY:
1474	23		sv[i] = sv_2mortal( newSViv( PTR2IV( ((void**)result.pointer)[i] )) );
1475	23		break;
1476			}
1477			}
1478			}
1479	25		break;
1480			#ifdef FFI_PL_PROBE_LONGDOUBLE
1481	0		case FFI_PL_TYPE_LONG_DOUBLE \| FFI_PL_SHAPE_ARRAY:
1482	0	0	for(i=0; i
		0
1483			{
1484	0		sv[i] = sv_2mortal(newSV(0));
1485	0	0	ffi_pl_long_double_to_perl(sv[i], &((long double*)result.pointer)[i]);
		0
		0
		0
		0
		0
1486			}
1487	0		break;
1488			#endif
1489			#ifdef FFI_PL_PROBE_COMPLEX
1490	3		case FFI_PL_TYPE_COMPLEX_FLOAT \| FFI_PL_SHAPE_ARRAY:
1491	12	100	for(i=0; i
		0
1492			{
1493			SV *c[2];
1494			AV *av;
1495	9		c[0] = sv_2mortal(newSVnv(((float)result.pointer)[i2]));
1496	9		c[1] = sv_2mortal(newSVnv(((float)result.pointer)[i2+1]));
1497	9		av = av_make(2, c);
1498	9		sv[i] = sv_2mortal(newRV_noinc((SV*)av));
1499			}
1500	3		break;
1501	3		case FFI_PL_TYPE_COMPLEX_DOUBLE \| FFI_PL_SHAPE_ARRAY:
1502	12	100	for(i=0; i
		0
1503			{
1504			SV *c[2];
1505			AV *av;
1506	9		c[0] = sv_2mortal(newSVnv(((double)result.pointer)[i2]));
1507	9		c[1] = sv_2mortal(newSVnv(((double)result.pointer)[i2+1]));
1508	9		av = av_make(2, c);
1509	9		sv[i] = sv_2mortal(newRV_noinc((SV*)av));
1510			}
1511	3		break;
1512			#endif
1513	0		default:
1514	0		warn("return type not supported");
1515	0		XSRETURN_EMPTY;
1516			}
1517	75		av = av_make(count, sv);
1518	75		Safefree(sv);
1519	75		ST(0) = sv_2mortal(newRV_noinc((SV*)av));
1520	75		XSRETURN(1);
1521			}
1522			break;
1523
1524			/*
1525			* RETURN VALUE - CUSTOM PERL
1526			*/
1527
1528	77		case FFI_PL_SHAPE_CUSTOM_PERL:
1529			{
1530	77		SV ret_in=NULL, ret_out;
1531	77		switch(type_code)
1532			{
1533			/* TODO: FFI_PL_BASE_VOID, FFI_PL_BASE_COMPLEX, FFI_PL_BASE_STRING, FFI_PL_BASE_CLOSURE, FFI_PL_BASE_RECORD */
1534	4		case FFI_PL_TYPE_UINT8 \| FFI_PL_SHAPE_CUSTOM_PERL:
1535			#if defined FFI_PL_PROBE_BIGENDIAN
1536			ret_in = newSVuv(result.uint8_array[3]);
1537			#elif defined FFI_PL_PROBE_BIGENDIAN64
1538			ret_in = newSVuv(result.uint8_array[7]);
1539			#else
1540	4		ret_in = newSVuv(result.uint8);
1541			#endif
1542	4		break;
1543	3		case FFI_PL_TYPE_SINT8 \| FFI_PL_SHAPE_CUSTOM_PERL:
1544			#if defined FFI_PL_PROBE_BIGENDIAN
1545			ret_in = newSViv(result.sint8_array[3]);
1546			#elif defined FFI_PL_PROBE_BIGENDIAN64
1547			ret_in = newSViv(result.sint8_array[7]);
1548			#else
1549	3		ret_in = newSViv(result.sint8);
1550			#endif
1551	3		break;
1552	3		case FFI_PL_TYPE_UINT16 \| FFI_PL_SHAPE_CUSTOM_PERL:
1553			#if defined FFI_PL_PROBE_BIGENDIAN
1554			ret_in = newSVuv(result.uint16_array[1]);
1555			#elif defined FFI_PL_PROBE_BIGENDIAN64
1556			ret_in = newSVuv(result.uint16_array[3]);
1557			#else
1558	3		ret_in = newSVuv(result.uint16);
1559			#endif
1560	3		break;
1561	3		case FFI_PL_TYPE_SINT16 \| FFI_PL_SHAPE_CUSTOM_PERL:
1562			#if defined FFI_PL_PROBE_BIGENDIAN
1563			ret_in = newSViv(result.sint16_array[1]);
1564			#elif defined FFI_PL_PROBE_BIGENDIAN64
1565			ret_in = newSViv(result.sint16_array[3]);
1566			#else
1567	3		ret_in = newSViv(result.sint16);
1568			#endif
1569	3		break;
1570	3		case FFI_PL_TYPE_UINT32 \| FFI_PL_SHAPE_CUSTOM_PERL:
1571			#if defined FFI_PL_PROBE_BIGENDIAN64
1572			ret_in = newSVuv(result.uint32_array[1]);
1573			#else
1574	3		ret_in = newSVuv(result.uint32);
1575			#endif
1576	3		break;
1577	3		case FFI_PL_TYPE_SINT32 \| FFI_PL_SHAPE_CUSTOM_PERL:
1578			#if defined FFI_PL_PROBE_BIGENDIAN64
1579			ret_in = newSViv(result.sint32_array[1]);
1580			#else
1581	3		ret_in = newSViv(result.sint32);
1582			#endif
1583	3		break;
1584	3		case FFI_PL_TYPE_UINT64 \| FFI_PL_SHAPE_CUSTOM_PERL:
1585	3		ret_in = newSVu64(result.uint64);
1586	3		break;
1587	3		case FFI_PL_TYPE_SINT64 \| FFI_PL_SHAPE_CUSTOM_PERL:
1588	3		ret_in = newSVi64(result.sint64);
1589	3		break;
1590	3		case FFI_PL_TYPE_FLOAT \| FFI_PL_SHAPE_CUSTOM_PERL:
1591	3		ret_in = newSVnv(result.xfloat);
1592	3		break;
1593	3		case FFI_PL_TYPE_DOUBLE \| FFI_PL_SHAPE_CUSTOM_PERL:
1594	3		ret_in = newSVnv(result.xdouble);
1595	3		break;
1596	46		case FFI_PL_TYPE_OPAQUE \| FFI_PL_SHAPE_CUSTOM_PERL:
1597	46	100	if(result.pointer != NULL)
		100
1598	42		ret_in = newSViv(PTR2IV(result.pointer));
1599	46		break;
1600	0		default:
1601	0	0	ffi_pl_heap_free();
		0
1602	0		warn("return type not supported");
1603	0		XSRETURN_EMPTY;
1604			}
1605
1606	77		MY_CXT.current_argv = arguments;
1607
1608	77	100	ret_out = ffi_pl_custom_perl(
		100
1609	77		self->return_type->extra[0].custom_perl.native_to_perl,
1610			ret_in != NULL ? ret_in : &PL_sv_undef,
1611			-1
1612			);
1613
1614	76		MY_CXT.current_argv = NULL;
1615
1616	176	100	ffi_pl_heap_free();
		100
1617
1618	76	100	if(ret_in != NULL)
		100
1619			{
1620	72		SvREFCNT_dec(ret_in);
1621			}
1622
1623	76	100	if(ret_out == NULL)
		100
1624			{
1625	3	50	if(self->platypus_api >= 2)
		50
1626			{
1627	0		XSRETURN_UNDEF;
1628			}
1629			else
1630			{
1631	3		XSRETURN_EMPTY;
1632			}
1633			}
1634			else
1635			{
1636	73		ST(0) = sv_2mortal(ret_out);
1637	73		XSRETURN(1);
1638			}
1639
1640			}
1641			break;
1642
1643	16		case FFI_PL_SHAPE_OBJECT:
1644			{
1645			SV *ref;
1646	16		SV *value = newSV(0);
1647	16		switch(type_code)
1648			{
1649	2		case FFI_PL_TYPE_SINT8 \| FFI_PL_SHAPE_OBJECT:
1650			#if defined FFI_PL_PROBE_BIGENDIAN
1651			sv_setiv(value, result.sint8_array[3]);
1652			#elif defined FFI_PL_PROBE_BIGENDIAN64
1653			sv_setiv(value, result.sint8_array[7]);
1654			#else
1655	2		sv_setiv(value, result.sint8);
1656			#endif
1657	2		break;
1658	2		case FFI_PL_TYPE_UINT8 \| FFI_PL_SHAPE_OBJECT:
1659			#if defined FFI_PL_PROBE_BIGENDIAN
1660			sv_setuv(value, result.uint8_array[3]);
1661			#elif defined FFI_PL_PROBE_BIGENDIAN64
1662			sv_setuv(value, result.uint8_array[7]);
1663			#else
1664	2		sv_setuv(value, result.uint8);
1665			#endif
1666	2		break;
1667	2		case FFI_PL_TYPE_SINT16 \| FFI_PL_SHAPE_OBJECT:
1668			#if defined FFI_PL_PROBE_BIGENDIAN
1669			sv_setiv(value, result.sint16_array[1]);
1670			#elif defined FFI_PL_PROBE_BIGENDIAN64
1671			sv_setiv(value, result.sint16_array[3]);
1672			#else
1673	2		sv_setiv(value, result.sint16);
1674			#endif
1675	2		break;
1676	2		case FFI_PL_TYPE_UINT16 \| FFI_PL_SHAPE_OBJECT:
1677			#if defined FFI_PL_PROBE_BIGENDIAN
1678			sv_setiv(value, result.uint16_array[1]);
1679			#elif defined FFI_PL_PROBE_BIGENDIAN64
1680			sv_setuv(value, result.uint16_array[3]);
1681			#else
1682	2		sv_setuv(value, result.uint16);
1683			#endif
1684	2		break;
1685	2		case FFI_PL_TYPE_SINT32 \| FFI_PL_SHAPE_OBJECT:
1686			#if defined FFI_PL_PROBE_BIGENDIAN64
1687			sv_setiv(value, result.sint32_array[1]);
1688			#else
1689	2		sv_setiv(value, result.sint32);
1690			#endif
1691	2		break;
1692	2		case FFI_PL_TYPE_UINT32 \| FFI_PL_SHAPE_OBJECT:
1693			#if defined FFI_PL_PROBE_BIGENDIAN64
1694			sv_setuv(value, result.uint32_array[1]);
1695			#else
1696	2		sv_setuv(value, result.uint32);
1697			#endif
1698	2		break;
1699	2		case FFI_PL_TYPE_SINT64 \| FFI_PL_SHAPE_OBJECT:
1700	2		sv_seti64(value, result.sint64);
1701	2		break;
1702	2		case FFI_PL_TYPE_UINT64 \| FFI_PL_SHAPE_OBJECT:
1703	2		sv_setu64(value, result.uint64);
1704	2		break;
1705	0		default:
1706	0		break;
1707			}
1708	16		ref = ST(0) = sv_2mortal(newRV_noinc(value));
1709	16		sv_bless(ref, gv_stashpv(self->return_type->extra[0].object.class, GV_ADD));
1710	16		XSRETURN(1);
1711			}
1712			break;
1713
1714	0		default:
1715	0		warn("return type not supported");
1716	0		XSRETURN_EMPTY;
1717			break;
1718			}
1719			#endif
1720			}
1721			}
1722
1723	0		warn("return type not supported");
1724	0		XSRETURN_EMPTY;
1725
1726			#undef EXTRA_ARGS
1727			#undef FFI_PL_CALL_NO_RECORD_VALUE
1728			#undef FFI_PL_CALL_RET_NO_NORMAL
1729			#undef RESULT