libguile/foreign.c

   1 /* Copyright (C) 2010  Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 #if HAVE_CONFIG_H
  20 #  include <config.h>
  21 #endif
  22
  23 #include <ffi.h>
  24
  25 #include <alignof.h>
  26 #include <string.h>
  27 #include "libguile/_scm.h"
  28 #include "libguile/bytevectors.h"
  29 #include "libguile/instructions.h"
  30 #include "libguile/foreign.h"
  31
  32 \f
  33
  34 SCM_SYMBOL (sym_void, "void");
  35 SCM_SYMBOL (sym_float, "float");
  36 SCM_SYMBOL (sym_double, "double");
  37 SCM_SYMBOL (sym_uint8, "uint8");
  38 SCM_SYMBOL (sym_int8, "int8");
  39 SCM_SYMBOL (sym_uint16, "uint16");
  40 SCM_SYMBOL (sym_int16, "int16");
  41 SCM_SYMBOL (sym_uint32, "uint32");
  42 SCM_SYMBOL (sym_int32, "int32");
  43 SCM_SYMBOL (sym_uint64, "uint64");
  44 SCM_SYMBOL (sym_int64, "int64");
  45
  46 static SCM cif_to_procedure (SCM cif, SCM func_ptr);
  47
  48
  49 static SCM foreign_weak_refs = SCM_BOOL_F;
  50
  51 static void
  52 register_weak_reference (SCM from, SCM to)
  53 {
  54   scm_hashq_set_x (foreign_weak_refs, from, to);
  55 }
  56
  57 static void
  58 foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
  59 {
  60   scm_t_foreign_finalizer finalizer = data;
  61   finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr), void));
  62 }
  63
  64 SCM
  65 scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len,
  66                           scm_t_foreign_finalizer finalizer)
  67 {
  68   SCM ret;
  69   scm_t_bits word0;
  70
  71   word0 = (scm_t_bits)(scm_tc7_foreign | (type<<8)
  72                        | (finalizer ? (1<<16) : 0) | (len<<17));
  73   if (SCM_UNLIKELY ((word0 >> 17) != len))
  74     scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len));
  75
  76   ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2,
  77                                             "foreign"));
  78   SCM_SET_CELL_WORD_0 (ret, word0);
  79   SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)ptr);
  80
  81   if (finalizer)
  82     {
  83       /* Register a finalizer for the newly created instance.  */
  84       GC_finalization_proc prev_finalizer;
  85       GC_PTR prev_finalizer_data;
  86       GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
  87                                       foreign_finalizer_trampoline,
  88                                       finalizer,
  89                                       &prev_finalizer,
  90                                       &prev_finalizer_data);
  91     }
  92
  93   return ret;
  94 }
  95
  96 SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0,
  97             (SCM foreign),
  98             "Reference the foreign value wrapped by @var{foreign}.\n\n"
  99             "The value will be referenced according to its type.")
 100 #define FUNC_NAME s_scm_foreign_ref
 101 {
 102   scm_t_foreign_type ftype;
 103   scm_t_uint8 *ptr;
 104
 105   SCM_VALIDATE_FOREIGN (1, foreign);
 106   ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
 107   ftype = SCM_FOREIGN_TYPE (foreign);
 108
 109   /* FIXME: is there a window in which we can see ptr but not foreign? */
 110   /* FIXME: accessing unaligned pointers */
 111   switch (ftype)
 112     {
 113     case SCM_FOREIGN_TYPE_VOID:
 114       return scm_from_ulong ((unsigned long)ptr);
 115     case SCM_FOREIGN_TYPE_FLOAT:
 116       return scm_from_double (*(float*)ptr);
 117     case SCM_FOREIGN_TYPE_DOUBLE:
 118       return scm_from_double (*(double*)ptr);
 119     case SCM_FOREIGN_TYPE_UINT8:
 120       return scm_from_uint8 (*(scm_t_uint8*)ptr);
 121     case SCM_FOREIGN_TYPE_INT8:
 122       return scm_from_int8 (*(scm_t_int8*)ptr);
 123     case SCM_FOREIGN_TYPE_UINT16:
 124       return scm_from_uint16 (*(scm_t_uint16*)ptr);
 125     case SCM_FOREIGN_TYPE_INT16:
 126       return scm_from_int16 (*(scm_t_int16*)ptr);
 127     case SCM_FOREIGN_TYPE_UINT32:
 128       return scm_from_uint32 (*(scm_t_uint32*)ptr);
 129     case SCM_FOREIGN_TYPE_INT32:
 130       return scm_from_int32 (*(scm_t_int32*)ptr);
 131     case SCM_FOREIGN_TYPE_UINT64:
 132       return scm_from_uint64 (*(scm_t_uint64*)ptr);
 133     case SCM_FOREIGN_TYPE_INT64:
 134       return scm_from_int64 (*(scm_t_int64*)ptr);
 135     default:
 136       abort ();
 137     }
 138 }
 139 #undef FUNC_NAME
 140
 141 SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 0, 0,
 142             (SCM foreign, SCM val),
 143             "Set the foreign value wrapped by @var{foreign}.\n\n"
 144             "The value will be set according to its type.")
 145 #define FUNC_NAME s_scm_foreign_set_x
 146 {
 147   scm_t_foreign_type ftype;
 148   scm_t_uint8 *ptr;
 149
 150   SCM_VALIDATE_FOREIGN (1, foreign);
 151   ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
 152   ftype = SCM_FOREIGN_TYPE (foreign);
 153
 154   /* FIXME: is there a window in which we can see ptr but not foreign? */
 155   /* FIXME: unaligned access */
 156   switch (ftype)
 157     {
 158     case SCM_FOREIGN_TYPE_VOID:
 159       SCM_SET_CELL_WORD_1 (foreign, scm_to_ulong (val));
 160       break;
 161     case SCM_FOREIGN_TYPE_FLOAT:
 162       *(float*)ptr = scm_to_double (val);
 163       break;
 164     case SCM_FOREIGN_TYPE_DOUBLE:
 165       *(double*)ptr = scm_to_double (val);
 166       break;
 167     case SCM_FOREIGN_TYPE_UINT8:
 168       *(scm_t_uint8*)ptr = scm_to_uint8 (val);
 169       break;
 170     case SCM_FOREIGN_TYPE_INT8:
 171       *(scm_t_int8*)ptr = scm_to_int8 (val);
 172       break;
 173     case SCM_FOREIGN_TYPE_UINT16:
 174       *(scm_t_uint16*)ptr = scm_to_uint16 (val);
 175       break;
 176     case SCM_FOREIGN_TYPE_INT16:
 177       *(scm_t_int16*)ptr = scm_to_int16 (val);
 178       break;
 179     case SCM_FOREIGN_TYPE_UINT32:
 180       *(scm_t_uint32*)ptr = scm_to_uint32 (val);
 181       break;
 182     case SCM_FOREIGN_TYPE_INT32:
 183       *(scm_t_int32*)ptr = scm_to_int32 (val);
 184       break;
 185     case SCM_FOREIGN_TYPE_UINT64:
 186       *(scm_t_uint64*)ptr = scm_to_uint64 (val);
 187       break;
 188     case SCM_FOREIGN_TYPE_INT64:
 189       *(scm_t_int64*)ptr = scm_to_int64 (val);
 190       break;
 191     default:
 192       abort ();
 193     }
 194
 195   return SCM_UNSPECIFIED;
 196 }
 197 #undef FUNC_NAME
 198
 199 SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 1, 3, 0,
 200             (SCM foreign, SCM uvec_type, SCM offset, SCM len),
 201             "Return a bytevector aliasing the memory pointed to by\n"
 202             "@var{foreign}.\n\n"
 203             "@var{foreign} must be a void pointer, a foreign whose type is\n"
 204             "@var{void}. By default, the resulting bytevector will alias\n"
 205             "all of the memory pointed to by @var{foreign}, from beginning\n"
 206             "to end, treated as a @code{vu8} array.\n\n"
 207             "The user may specify an alternate default interpretation for\n"
 208             "the memory by passing the @var{uvec_type} argument, to indicate\n"
 209             "that the memory is an array of elements of that type.\n"
 210             "@var{uvec_type} should be something that\n"
 211             "@code{uniform-vector-element-type} would return, like @code{f32}\n"
 212             "or @code{s16}.\n\n"
 213             "Users may also specify that the bytevector should only alias a\n"
 214             "subset of the memory, by specifying @var{offset} and @var{len}\n"
 215             "arguments.")
 216 #define FUNC_NAME s_scm_foreign_to_bytevector
 217 {
 218   SCM ret;
 219   scm_t_int8 *ptr;
 220   size_t boffset, blen;
 221   scm_t_array_element_type btype;
 222
 223   SCM_VALIDATE_FOREIGN_TYPED (1, foreign, VOID);
 224   ptr = SCM_FOREIGN_POINTER (foreign, scm_t_int8);
 225
 226   if (SCM_UNBNDP (uvec_type))
 227     btype = SCM_ARRAY_ELEMENT_TYPE_VU8;
 228   else
 229     {
 230       int i;
 231       for (i = 0; i <= SCM_ARRAY_ELEMENT_TYPE_LAST; i++)
 232         if (scm_is_eq (uvec_type, scm_i_array_element_types[i]))
 233           break;
 234       switch (i)
 235         {
 236         case SCM_ARRAY_ELEMENT_TYPE_VU8:
 237         case SCM_ARRAY_ELEMENT_TYPE_U8:
 238         case SCM_ARRAY_ELEMENT_TYPE_S8:
 239         case SCM_ARRAY_ELEMENT_TYPE_U16:
 240         case SCM_ARRAY_ELEMENT_TYPE_S16:
 241         case SCM_ARRAY_ELEMENT_TYPE_U32:
 242         case SCM_ARRAY_ELEMENT_TYPE_S32:
 243         case SCM_ARRAY_ELEMENT_TYPE_U64:
 244         case SCM_ARRAY_ELEMENT_TYPE_S64:
 245         case SCM_ARRAY_ELEMENT_TYPE_F32:
 246         case SCM_ARRAY_ELEMENT_TYPE_F64:
 247         case SCM_ARRAY_ELEMENT_TYPE_C32:
 248         case SCM_ARRAY_ELEMENT_TYPE_C64:
 249           btype = i;
 250           break;
 251         default:
 252           scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec_type,
 253                                   "uniform vector type");
 254         }
 255     }
 256
 257   if (SCM_UNBNDP (offset))
 258     boffset = 0;
 259   else if (SCM_FOREIGN_LEN (foreign))
 260     boffset = scm_to_unsigned_integer (offset, 0,
 261                                        SCM_FOREIGN_LEN (foreign) - 1);
 262   else
 263     boffset = scm_to_size_t (offset);
 264
 265   if (SCM_UNBNDP (len))
 266     {
 267       if (SCM_FOREIGN_LEN (foreign))
 268         blen = SCM_FOREIGN_LEN (foreign) - boffset;
 269       else
 270         scm_misc_error (FUNC_NAME,
 271                         "length needed to convert foreign pointer to bytevector",
 272                         SCM_EOL);
 273     }
 274   else
 275     {
 276       if (SCM_FOREIGN_LEN (foreign))
 277         blen = scm_to_unsigned_integer (len, 0,
 278                                         SCM_FOREIGN_LEN (foreign) - boffset);
 279       else
 280         blen = scm_to_size_t (len);
 281     }
 282
 283   ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype);
 284   register_weak_reference (ret, foreign);
 285   return ret;
 286 }
 287 #undef FUNC_NAME
 288
 289 SCM_DEFINE (scm_bytevector_to_foreign, "bytevector->foreign", 1, 2, 0,
 290             (SCM bv, SCM offset, SCM len),
 291             "Return a foreign pointer aliasing the memory pointed to by\n"
 292             "@var{bv}.\n\n"
 293             "The resulting foreign will be a void pointer, a foreign whose\n"
 294             "type is @code{void}. By default it will alias all of the\n"
 295             "memory pointed to by @var{bv}, from beginning to end.\n\n"
 296             "Users may explicily specify that the foreign should only alias a\n"
 297             "subset of the memory, by specifying @var{offset} and @var{len}\n"
 298             "arguments.")
 299 #define FUNC_NAME s_scm_bytevector_to_foreign
 300 {
 301   SCM ret;
 302   scm_t_int8 *ptr;
 303   size_t boffset, blen;
 304
 305   SCM_VALIDATE_BYTEVECTOR (1, bv);
 306   ptr = SCM_BYTEVECTOR_CONTENTS (bv);
 307
 308   if (SCM_UNBNDP (offset))
 309     boffset = 0;
 310   else
 311     boffset = scm_to_unsigned_integer (offset, 0,
 312                                        SCM_BYTEVECTOR_LENGTH (bv) - 1);
 313
 314   if (SCM_UNBNDP (len))
 315     blen = SCM_BYTEVECTOR_LENGTH (bv) - boffset;
 316   else
 317     blen = scm_to_unsigned_integer (len, 0,
 318                                     SCM_BYTEVECTOR_LENGTH (bv) - boffset);
 319
 320   ret = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, ptr + boffset, blen,
 321                                   NULL);
 322   register_weak_reference (ret, bv);
 323   return ret;
 324 }
 325 #undef FUNC_NAME
 326
 327 void
 328 scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate)
 329 {
 330   scm_puts ("#<foreign ", port);
 331   switch (SCM_FOREIGN_TYPE (foreign))
 332     {
 333     case SCM_FOREIGN_TYPE_FLOAT:
 334       scm_puts ("float ", port);
 335       break;
 336     case SCM_FOREIGN_TYPE_DOUBLE:
 337       scm_puts ("double ", port);
 338       break;
 339     case SCM_FOREIGN_TYPE_UINT8:
 340       scm_puts ("uint8 ", port);
 341       break;
 342     case SCM_FOREIGN_TYPE_INT8:
 343       scm_puts ("int8 ", port);
 344       break;
 345     case SCM_FOREIGN_TYPE_UINT16:
 346       scm_puts ("uint16 ", port);
 347       break;
 348     case SCM_FOREIGN_TYPE_INT16:
 349       scm_puts ("int16 ", port);
 350       break;
 351     case SCM_FOREIGN_TYPE_UINT32:
 352       scm_puts ("uint32 ", port);
 353       break;
 354     case SCM_FOREIGN_TYPE_INT32:
 355       scm_puts ("int32 ", port);
 356       break;
 357     case SCM_FOREIGN_TYPE_UINT64:
 358       scm_puts ("uint64 ", port);
 359       break;
 360     case SCM_FOREIGN_TYPE_INT64:
 361       scm_puts ("int64 ", port);
 362       break;
 363     case SCM_FOREIGN_TYPE_VOID:
 364       scm_puts ("pointer ", port);
 365       break;
 366     default:
 367       abort ();
 368     }
 369   scm_display (scm_foreign_ref (foreign), port);
 370   scm_putc ('>', port);
 371 }
 372
 373 \f
 374
 375
 376 #define ROUND_UP(len,align) (align?(((len-1)|(align-1))+1):len)
 377
 378 SCM_DEFINE (scm_alignof, "alignof", 1, 0, 0, (SCM type), "")
 379 #define FUNC_NAME s_scm_alignof
 380 {
 381   if (SCM_I_INUMP (type))
 382     {
 383       switch (SCM_I_INUM (type))
 384         {
 385         case SCM_FOREIGN_TYPE_FLOAT:
 386           return scm_from_size_t (alignof (float));
 387         case SCM_FOREIGN_TYPE_DOUBLE:
 388           return scm_from_size_t (alignof (double));
 389         case SCM_FOREIGN_TYPE_UINT8:
 390           return scm_from_size_t (alignof (scm_t_uint8));
 391         case SCM_FOREIGN_TYPE_INT8:
 392           return scm_from_size_t (alignof (scm_t_int8));
 393         case SCM_FOREIGN_TYPE_UINT16:
 394           return scm_from_size_t (alignof (scm_t_uint16));
 395         case SCM_FOREIGN_TYPE_INT16:
 396           return scm_from_size_t (alignof (scm_t_int16));
 397         case SCM_FOREIGN_TYPE_UINT32:
 398           return scm_from_size_t (alignof (scm_t_uint32));
 399         case SCM_FOREIGN_TYPE_INT32:
 400           return scm_from_size_t (alignof (scm_t_int32));
 401         case SCM_FOREIGN_TYPE_UINT64:
 402           return scm_from_size_t (alignof (scm_t_uint64));
 403         case SCM_FOREIGN_TYPE_INT64:
 404           return scm_from_size_t (alignof (scm_t_int64));
 405         default:
 406           scm_wrong_type_arg (FUNC_NAME, 1, type);
 407         }
 408     }
 409   else if (scm_is_pair (type))
 410     /* a struct, yo */
 411     return scm_alignof (scm_car (type));
 412   else
 413     scm_wrong_type_arg (FUNC_NAME, 1, type);
 414 }
 415 #undef FUNC_NAME
 416
 417 SCM_DEFINE (scm_sizeof, "sizeof", 1, 0, 0, (SCM type), "")
 418 #define FUNC_NAME s_scm_sizeof
 419 {
 420   if (SCM_I_INUMP (type))
 421     {
 422       switch (SCM_I_INUM (type))
 423         {
 424         case SCM_FOREIGN_TYPE_FLOAT:
 425           return scm_from_size_t (sizeof (float));
 426         case SCM_FOREIGN_TYPE_DOUBLE:
 427           return scm_from_size_t (sizeof (double));
 428         case SCM_FOREIGN_TYPE_UINT8:
 429           return scm_from_size_t (sizeof (scm_t_uint8));
 430         case SCM_FOREIGN_TYPE_INT8:
 431           return scm_from_size_t (sizeof (scm_t_int8));
 432         case SCM_FOREIGN_TYPE_UINT16:
 433           return scm_from_size_t (sizeof (scm_t_uint16));
 434         case SCM_FOREIGN_TYPE_INT16:
 435           return scm_from_size_t (sizeof (scm_t_int16));
 436         case SCM_FOREIGN_TYPE_UINT32:
 437           return scm_from_size_t (sizeof (scm_t_uint32));
 438         case SCM_FOREIGN_TYPE_INT32:
 439           return scm_from_size_t (sizeof (scm_t_int32));
 440         case SCM_FOREIGN_TYPE_UINT64:
 441           return scm_from_size_t (sizeof (scm_t_uint64));
 442         case SCM_FOREIGN_TYPE_INT64:
 443           return scm_from_size_t (sizeof (scm_t_int64));
 444         default:
 445           scm_wrong_type_arg (FUNC_NAME, 1, type);
 446         }
 447     }
 448   else if (scm_is_pair (type))
 449     {
 450       /* a struct */
 451       size_t off = 0;
 452       while (scm_is_pair (type))
 453         {
 454           off = ROUND_UP (off, scm_to_size_t (scm_alignof (scm_car (type))));
 455           off += scm_to_size_t (scm_sizeof (scm_car (type)));
 456           type = scm_cdr (type);
 457         }
 458       return scm_from_size_t (off);
 459     }
 460   else
 461     scm_wrong_type_arg (FUNC_NAME, 1, type);
 462 }
 463 #undef FUNC_NAME
 464
 465
 466 /* return 1 on success, 0 on failure */
 467 static int
 468 parse_ffi_type (SCM type, int return_p, long *n_structs, long *n_struct_elts)
 469 {
 470   if (SCM_I_INUMP (type))
 471     {
 472       if ((SCM_I_INUM (type) < 0 )
 473           || (SCM_I_INUM (type) > SCM_FOREIGN_TYPE_LAST))
 474         return 0;
 475       else if (SCM_I_INUM (type) == SCM_FOREIGN_TYPE_VOID && !return_p)
 476         return 0;
 477       else
 478         return 1;
 479     }
 480   else
 481     {
 482       long len;
 483
 484       len = scm_ilength (type);
 485       if (len < 1)
 486         return 0;
 487       while (len--)
 488         {
 489           if (!parse_ffi_type (scm_car (type), 0, n_structs, n_struct_elts))
 490             return 0;
 491           (*n_struct_elts)++;
 492           type = scm_cdr (type);
 493         }
 494       (*n_structs)++;
 495       return 1;
 496     }
 497 }
 498
 499 static void
 500 fill_ffi_type (SCM type, ffi_type *ftype, ffi_type ***type_ptrs,
 501                ffi_type **types)
 502 {
 503   if (SCM_I_INUMP (type))
 504     {
 505       switch (SCM_I_INUM (type))
 506         {
 507         case SCM_FOREIGN_TYPE_FLOAT:
 508           *ftype = ffi_type_float;
 509           return;
 510         case SCM_FOREIGN_TYPE_DOUBLE:
 511           *ftype = ffi_type_double;
 512           return;
 513         case SCM_FOREIGN_TYPE_UINT8:
 514           *ftype = ffi_type_uint8;
 515           return;
 516         case SCM_FOREIGN_TYPE_INT8:
 517           *ftype = ffi_type_sint8;
 518           return;
 519         case SCM_FOREIGN_TYPE_UINT16:
 520           *ftype = ffi_type_uint16;
 521           return;
 522         case SCM_FOREIGN_TYPE_INT16:
 523           *ftype = ffi_type_sint16;
 524           return;
 525         case SCM_FOREIGN_TYPE_UINT32:
 526           *ftype = ffi_type_uint32;
 527           return;
 528         case SCM_FOREIGN_TYPE_INT32:
 529           *ftype = ffi_type_sint32;
 530           return;
 531         case SCM_FOREIGN_TYPE_UINT64:
 532           *ftype = ffi_type_uint64;
 533           return;
 534         case SCM_FOREIGN_TYPE_INT64:
 535           *ftype = ffi_type_sint64;
 536           return;
 537         case SCM_FOREIGN_TYPE_VOID:
 538           *ftype = ffi_type_void;
 539           return;
 540         default:
 541           abort ();
 542         }
 543     }
 544   else
 545     {
 546       long i, len;
 547
 548       len = scm_ilength (type);
 549
 550       ftype->size = 0;
 551       ftype->alignment = 0;
 552       ftype->type = FFI_TYPE_STRUCT;
 553       ftype->elements = *type_ptrs;
 554       *type_ptrs += len + 1;
 555
 556       for (i = 0; i < len; i++)
 557         {
 558           ftype->elements[i] = *types;
 559           *types += 1;
 560           fill_ffi_type (scm_car (type), ftype->elements[i],
 561                          type_ptrs, types);
 562           type = scm_cdr (type);
 563         }
 564       ftype->elements[i] = NULL;
 565     }
 566 }
 567
 568 SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0,
 569             (SCM return_type, SCM func_ptr, SCM arg_types),
 570             "foo")
 571 #define FUNC_NAME s_scm_make_foreign_function
 572 {
 573   SCM walk, scm_cif;
 574   long i, nargs, n_structs, n_struct_elts;
 575   size_t cif_len;
 576   char *mem;
 577   ffi_cif *cif;
 578   ffi_type **type_ptrs;
 579   ffi_type *types;
 580
 581   SCM_VALIDATE_FOREIGN_TYPED (2, func_ptr, VOID);
 582   nargs = scm_ilength (arg_types);
 583   SCM_ASSERT (nargs >= 0, arg_types, 3, FUNC_NAME);
 584   /* fixme: assert nargs < 1<<32 */
 585   n_structs = n_struct_elts = 0;
 586
 587   /* For want of talloc, we're going to have to do this in two passes: first we
 588      figure out how much memory is needed for all types, then we allocate the
 589      cif and the types all in one block. */
 590   if (!parse_ffi_type (return_type, 1, &n_structs, &n_struct_elts))
 591     scm_wrong_type_arg (FUNC_NAME, 1, return_type);
 592   for (walk = arg_types; scm_is_pair (walk); walk = scm_cdr (walk))
 593     if (!parse_ffi_type (scm_car (walk), 0, &n_structs, &n_struct_elts))
 594       scm_wrong_type_arg (FUNC_NAME, 3, scm_car (walk));
 595
 596   /* the memory: with space for the cif itself */
 597   cif_len = sizeof (ffi_cif);
 598
 599   /* then ffi_type pointers: one for each arg, one for each struct
 600      element, and one for each struct (for null-termination) */
 601   cif_len = (ROUND_UP (cif_len, alignof(void*))
 602              + (nargs + n_structs + n_struct_elts)*sizeof(void*));
 603
 604   /* then the ffi_type structs themselves, one per arg and struct element, and
 605      one for the return val */
 606   cif_len = (ROUND_UP (cif_len, alignof(ffi_type))
 607              + (nargs + n_struct_elts + 1)*sizeof(ffi_type));
 608
 609   mem = scm_malloc (cif_len);
 610   scm_cif = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, mem, cif_len, free);
 611   cif = (ffi_cif*)mem;
 612   /* reuse cif_len to walk through the mem */
 613   cif_len = ROUND_UP (sizeof (ffi_cif), alignof(void*));
 614   type_ptrs = (ffi_type**)(mem + cif_len);
 615   cif_len = ROUND_UP (cif_len
 616                       + (nargs + n_structs + n_struct_elts)*sizeof(void*),
 617                       alignof(ffi_type));
 618   types = (ffi_type*)(mem + cif_len);
 619
 620   /* whew. now knit the pointers together. */
 621   cif->rtype = types++;
 622   fill_ffi_type (return_type, cif->rtype, &type_ptrs, &types);
 623   cif->arg_types = type_ptrs;
 624   type_ptrs += nargs;
 625   for (walk = arg_types, i = 0; scm_is_pair (walk); walk = scm_cdr (walk), i++)
 626     {
 627       cif->arg_types[i] = types++;
 628       fill_ffi_type (scm_car (walk), cif->arg_types[i], &type_ptrs, &types);
 629     }
 630
 631   /* round out the cif, and we're done. */
 632   cif->abi = FFI_DEFAULT_ABI;
 633   cif->nargs = nargs;
 634   cif->bytes = 0;
 635   cif->flags = 0;
 636
 637   if (FFI_OK != ffi_prep_cif (cif, FFI_DEFAULT_ABI, cif->nargs, cif->rtype,
 638                               cif->arg_types))
 639     scm_misc_error (FUNC_NAME, "ffi_prep_cif failed", SCM_EOL);
 640
 641   return cif_to_procedure (scm_cif, func_ptr);
 642 }
 643 #undef FUNC_NAME
 644
 645 \f
 646
 647 /* Pre-generate trampolines for less than 10 arguments. */
 648
 649 #ifdef WORDS_BIGENDIAN
 650 #define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40
 651 #define META_HEADER    0, 0, 0, 32, 0, 0, 0, 0
 652 #else
 653 #define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
 654 #define META_HEADER    32, 0, 0, 0, 0, 0, 0, 0
 655 #endif
 656
 657 #define CODE(nreq)                                                      \
 658   OBJCODE_HEADER,                                                       \
 659   /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */  \
 660   /* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function pointer */ \
 661   /* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well) */ \
 662   /* 7 */ scm_op_nop,                                                   \
 663   /* 8 */ META (3, 7, nreq)
 664
 665 #define META(start, end, nreq)                                          \
 666   META_HEADER,                                                          \
 667   /* 0 */ scm_op_make_eol, /* bindings */                               \
 668   /* 1 */ scm_op_make_eol, /* sources */                                \
 669   /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
 670   /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */    \
 671   /* 8 */ scm_op_list, 0, 3, /* make a list of those 3 vals */         \
 672   /* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
 673   /* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
 674   /* 22 */ scm_op_object_ref, 1, /* the name from the object table */   \
 675   /* 24 */ scm_op_cons, /* make a pair for the properties */            \
 676   /* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
 677   /* 28 */ scm_op_return, /* and return */                              \
 678   /* 29 */ scm_op_nop, scm_op_nop, scm_op_nop                           \
 679   /* 32 */
 680
 681 static const struct
 682 {
 683   scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
 684   const scm_t_uint8 bytes[10 * (sizeof (struct scm_objcode) + 8
 685                                 + sizeof (struct scm_objcode) + 32)];
 686 } raw_bytecode = {
 687   0,
 688   {
 689     CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
 690     CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
 691   }
 692 };
 693
 694 #undef CODE
 695 #undef META
 696 #undef OBJCODE_HEADER
 697 #undef META_HEADER
 698
 699 /*
 700  (defun generate-objcode-cells (n)
 701    "Generate objcode cells for up to N arguments"
 702    (interactive "p")
 703    (let ((i 0))
 704      (while (< i n)
 705        (insert
 706         (format "    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
 707                 (* (+ 4 4 8 4 4 32) i)))
 708        (insert "    { SCM_BOOL_F, SCM_PACK (0) },\n")
 709        (setq i (1+ i)))))
 710 */
 711 #define STATIC_OBJCODE_TAG                                      \
 712   SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
 713
 714 static const struct
 715 {
 716   scm_t_uint64 dummy; /* alignment */
 717   scm_t_cell cells[10 * 2]; /* 10 double cells */
 718 } objcode_cells = {
 719   0,
 720   /* C-u 1 0 M-x generate-objcode-cells RET */
 721   {
 722     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
 723     { SCM_BOOL_F, SCM_PACK (0) },
 724     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 56) },
 725     { SCM_BOOL_F, SCM_PACK (0) },
 726     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 112) },
 727     { SCM_BOOL_F, SCM_PACK (0) },
 728     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 168) },
 729     { SCM_BOOL_F, SCM_PACK (0) },
 730     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 224) },
 731     { SCM_BOOL_F, SCM_PACK (0) },
 732     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 280) },
 733     { SCM_BOOL_F, SCM_PACK (0) },
 734     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 336) },
 735     { SCM_BOOL_F, SCM_PACK (0) },
 736     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 392) },
 737     { SCM_BOOL_F, SCM_PACK (0) },
 738     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
 739     { SCM_BOOL_F, SCM_PACK (0) },
 740     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 504) },
 741     { SCM_BOOL_F, SCM_PACK (0) }
 742   }
 743 };
 744
 745 static const SCM objcode_trampolines[10] = {
 746   SCM_PACK (objcode_cells.cells+0),
 747   SCM_PACK (objcode_cells.cells+2),
 748   SCM_PACK (objcode_cells.cells+4),
 749   SCM_PACK (objcode_cells.cells+6),
 750   SCM_PACK (objcode_cells.cells+8),
 751   SCM_PACK (objcode_cells.cells+10),
 752   SCM_PACK (objcode_cells.cells+12),
 753   SCM_PACK (objcode_cells.cells+14),
 754   SCM_PACK (objcode_cells.cells+16),
 755   SCM_PACK (objcode_cells.cells+18),
 756 };
 757
 758 static SCM
 759 cif_to_procedure (SCM cif, SCM func_ptr)
 760 {
 761   unsigned nargs = SCM_FOREIGN_POINTER (cif, ffi_cif)->nargs;
 762   SCM objcode, table, ret;
 763
 764   if (nargs < 10)
 765     objcode = objcode_trampolines[nargs];
 766   else
 767     abort ();
 768
 769   table = scm_c_make_vector (2, SCM_UNDEFINED);
 770   SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr));
 771   SCM_SIMPLE_VECTOR_SET (table, 1, SCM_BOOL_F); /* name */
 772   ret = scm_make_program (objcode, table, SCM_BOOL_F);
 773
 774   return ret;
 775 }
 776
 777 static void
 778 unpack (ffi_type *type, void *loc, SCM x)
 779 {
 780   switch (type->type)
 781     {
 782     case FFI_TYPE_FLOAT:
 783       *(float*)loc = scm_to_double (x);
 784       break;
 785     case FFI_TYPE_DOUBLE:
 786       *(double*)loc = scm_to_double (x);
 787       break;
 788     case FFI_TYPE_UINT8:
 789       *(scm_t_uint8*)loc = scm_to_uint8 (x);
 790       break;
 791     case FFI_TYPE_SINT8:
 792       *(scm_t_int8*)loc = scm_to_int8 (x);
 793       break;
 794     case FFI_TYPE_UINT16:
 795       *(scm_t_uint16*)loc = scm_to_uint16 (x);
 796       break;
 797     case FFI_TYPE_SINT16:
 798       *(scm_t_int16*)loc = scm_to_int16 (x);
 799       break;
 800     case FFI_TYPE_UINT32:
 801       *(scm_t_uint32*)loc = scm_to_uint32 (x);
 802       break;
 803     case FFI_TYPE_SINT32:
 804       *(scm_t_int32*)loc = scm_to_int32 (x);
 805       break;
 806     case FFI_TYPE_UINT64:
 807       *(scm_t_uint64*)loc = scm_to_uint64 (x);
 808       break;
 809     case FFI_TYPE_SINT64:
 810       *(scm_t_int64*)loc = scm_to_int64 (x);
 811       break;
 812     case FFI_TYPE_STRUCT:
 813       if (!SCM_FOREIGN_TYPED_P (x, VOID))
 814         abort ();
 815       if (SCM_FOREIGN_LEN (x) && SCM_FOREIGN_LEN (x) != type->size)
 816         abort ();
 817       memcpy (loc, SCM_FOREIGN_POINTER (x, void), type->size);
 818       break;
 819     case FFI_TYPE_POINTER:
 820       if (!SCM_FOREIGN_TYPED_P (x, VOID))
 821         abort ();
 822       *(void**)loc = SCM_FOREIGN_POINTER (x, void);
 823       break;
 824     default:
 825       abort ();
 826     }
 827 }
 828
 829 static SCM
 830 pack (ffi_type *type, void *loc)
 831 {
 832   switch (type->type)
 833     {
 834     case FFI_TYPE_VOID:
 835       return SCM_UNSPECIFIED;
 836     case FFI_TYPE_FLOAT:
 837       return scm_from_double (*(float*)loc);
 838     case FFI_TYPE_DOUBLE:
 839       return scm_from_double (*(double*)loc);
 840     case FFI_TYPE_UINT8:
 841       return scm_from_uint8 (*(scm_t_uint8*)loc);
 842     case FFI_TYPE_SINT8:
 843       return scm_from_int8 (*(scm_t_int8*)loc);
 844     case FFI_TYPE_UINT16:
 845       return scm_from_uint16 (*(scm_t_uint16*)loc);
 846     case FFI_TYPE_SINT16:
 847       return scm_from_int16 (*(scm_t_int16*)loc);
 848     case FFI_TYPE_UINT32:
 849       return scm_from_uint32 (*(scm_t_uint32*)loc);
 850     case FFI_TYPE_SINT32:
 851       return scm_from_int32 (*(scm_t_int32*)loc);
 852     case FFI_TYPE_UINT64:
 853       return scm_from_uint64 (*(scm_t_uint64*)loc);
 854     case FFI_TYPE_SINT64:
 855       return scm_from_int64 (*(scm_t_int64*)loc);
 856     case FFI_TYPE_STRUCT:
 857       {
 858         void *mem = scm_malloc (type->size);
 859         memcpy (mem, loc, type->size);
 860         return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
 861                                          mem, type->size, free);
 862       }
 863     case FFI_TYPE_POINTER:
 864       return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
 865                                        *(void**)loc, 0, NULL);
 866     default:
 867       abort ();
 868     }
 869 }
 870
 871 SCM
 872 scm_i_foreign_call (SCM foreign, SCM *argv)
 873 {
 874   /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
 875      objtable. */
 876   ffi_cif *cif;
 877   void (*func)();
 878   scm_t_uint8 *data;
 879   void *rvalue;
 880   void **args;
 881   unsigned i;
 882   scm_t_ptrdiff off;
 883
 884   cif = SCM_FOREIGN_POINTER (scm_car (foreign), ffi_cif);
 885   func = SCM_FOREIGN_POINTER (scm_cdr (foreign), void);
 886
 887   /* arg pointers */
 888   args = alloca (sizeof(void*) * cif->nargs);
 889   /* arg values, then return type value */
 890   data = alloca (ROUND_UP (cif->bytes, cif->rtype->alignment)
 891                  + cif->rtype->size);
 892   /* unpack argv to native values, setting argv pointers */
 893   off = 0;
 894   for (i = 0; i < cif->nargs; i++)
 895     {
 896       off = ROUND_UP (off, cif->arg_types[i]->alignment);
 897       args[i] = data + off;
 898       unpack (cif->arg_types[i], args[i], argv[i]);
 899       off += cif->arg_types[i]->size;
 900     }
 901   /* prep space for the return value */
 902   off = ROUND_UP (off, cif->rtype->alignment);
 903   rvalue = data + off;
 904
 905   /* off we go! */
 906   ffi_call (cif, func, rvalue, args);
 907
 908   return pack (cif->rtype, rvalue);
 909 }
 910
 911 \f
 912
 913 static void
 914 scm_init_foreign (void)
 915 {
 916 #ifndef SCM_MAGIC_SNARFER
 917 #include "libguile/foreign.x"
 918 #endif
 919   scm_define (sym_void, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID));
 920   scm_define (sym_float, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT));
 921   scm_define (sym_double, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE));
 922   scm_define (sym_uint8, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8));
 923   scm_define (sym_int8, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8));
 924   scm_define (sym_uint16, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16));
 925   scm_define (sym_int16, scm_from_uint8 (SCM_FOREIGN_TYPE_INT16));
 926   scm_define (sym_uint32, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32));
 927   scm_define (sym_int32, scm_from_uint8 (SCM_FOREIGN_TYPE_INT32));
 928   scm_define (sym_uint64, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64));
 929   scm_define (sym_int64, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64));
 930 }
 931
 932 void
 933 scm_register_foreign (void)
 934 {
 935   scm_c_register_extension ("libguile", "scm_init_foreign",
 936                             (scm_t_extension_init_func)scm_init_foreign,
 937                             NULL);
 938   foreign_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
 939 }
 940
 941 /*
 942   Local Variables:
 943   c-file-style: "gnu"
 944   End:
 945 */