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 #define ROUND_UP(len,align) (align?(((len-1)|(align-1))+1):len)
 376
 377 /* return 1 on success, 0 on failure */
 378 static int
 379 parse_ffi_type (SCM type, int return_p, long *n_structs, long *n_struct_elts)
 380 {
 381   if (SCM_I_INUMP (type))
 382     {
 383       if ((SCM_I_INUM (type) < 0 )
 384           || (SCM_I_INUM (type) > SCM_FOREIGN_TYPE_LAST))
 385         return 0;
 386       else if (SCM_I_INUM (type) == SCM_FOREIGN_TYPE_VOID && !return_p)
 387         return 0;
 388       else
 389         return 1;
 390     }
 391   else
 392     {
 393       long len;
 394
 395       len = scm_ilength (type);
 396       if (len < 1)
 397         return 0;
 398       while (len--)
 399         {
 400           if (!parse_ffi_type (scm_car (type), 0, n_structs, n_struct_elts))
 401             return 0;
 402           (*n_struct_elts)++;
 403           type = scm_cdr (type);
 404         }
 405       (*n_structs)++;
 406       return 1;
 407     }
 408 }
 409
 410 static void
 411 fill_ffi_type (SCM type, ffi_type *ftype, ffi_type ***type_ptrs,
 412                ffi_type **types)
 413 {
 414   if (SCM_I_INUMP (type))
 415     {
 416       switch (SCM_I_INUM (type))
 417         {
 418         case SCM_FOREIGN_TYPE_FLOAT:
 419           *ftype = ffi_type_float;
 420           return;
 421         case SCM_FOREIGN_TYPE_DOUBLE:
 422           *ftype = ffi_type_double;
 423           return;
 424         case SCM_FOREIGN_TYPE_UINT8:
 425           *ftype = ffi_type_uint8;
 426           return;
 427         case SCM_FOREIGN_TYPE_INT8:
 428           *ftype = ffi_type_sint8;
 429           return;
 430         case SCM_FOREIGN_TYPE_UINT16:
 431           *ftype = ffi_type_uint16;
 432           return;
 433         case SCM_FOREIGN_TYPE_INT16:
 434           *ftype = ffi_type_sint16;
 435           return;
 436         case SCM_FOREIGN_TYPE_UINT32:
 437           *ftype = ffi_type_uint32;
 438           return;
 439         case SCM_FOREIGN_TYPE_INT32:
 440           *ftype = ffi_type_sint32;
 441           return;
 442         case SCM_FOREIGN_TYPE_UINT64:
 443           *ftype = ffi_type_uint64;
 444           return;
 445         case SCM_FOREIGN_TYPE_INT64:
 446           *ftype = ffi_type_sint64;
 447           return;
 448         case SCM_FOREIGN_TYPE_VOID:
 449           *ftype = ffi_type_void;
 450           return;
 451         default:
 452           abort ();
 453         }
 454     }
 455   else
 456     {
 457       long i, len;
 458
 459       len = scm_ilength (type);
 460
 461       ftype->size = 0;
 462       ftype->alignment = 0;
 463       ftype->type = FFI_TYPE_STRUCT;
 464       ftype->elements = *type_ptrs;
 465       *type_ptrs += len + 1;
 466
 467       for (i = 0; i < len; i++)
 468         {
 469           ftype->elements[i] = *(types++);
 470           fill_ffi_type (scm_car (type), ftype->elements[i],
 471                          type_ptrs, types);
 472           type = scm_cdr (type);
 473         }
 474       ftype->elements[i] = NULL;
 475     }
 476 }
 477
 478 SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0,
 479             (SCM return_type, SCM func_ptr, SCM arg_types),
 480             "foo")
 481 #define FUNC_NAME s_scm_make_foreign_function
 482 {
 483   SCM walk, scm_cif;
 484   long i, nargs, n_structs, n_struct_elts;
 485   size_t cif_len;
 486   char *mem;
 487   ffi_cif *cif;
 488   ffi_type **type_ptrs;
 489   ffi_type *types;
 490
 491   SCM_VALIDATE_FOREIGN_TYPED (2, func_ptr, VOID);
 492   nargs = scm_ilength (arg_types);
 493   SCM_ASSERT (nargs >= 0, arg_types, 3, FUNC_NAME);
 494   /* fixme: assert nargs < 1<<32 */
 495   n_structs = n_struct_elts = 0;
 496
 497   /* For want of talloc, we're going to have to do this in two passes: first we
 498      figure out how much memory is needed for all types, then we allocate the
 499      cif and the types all in one block. */
 500   if (!parse_ffi_type (return_type, 1, &n_structs, &n_struct_elts))
 501     scm_wrong_type_arg (FUNC_NAME, 1, return_type);
 502   for (walk = arg_types; scm_is_pair (walk); walk = scm_cdr (walk))
 503     if (!parse_ffi_type (scm_car (walk), 0, &n_structs, &n_struct_elts))
 504       scm_wrong_type_arg (FUNC_NAME, 3, scm_car (walk));
 505
 506   /* the memory: with space for the cif itself */
 507   cif_len = sizeof (ffi_cif);
 508
 509   /* then ffi_type pointers: one for each arg, one for each struct
 510      element, and one for each struct (for null-termination) */
 511   cif_len = (ROUND_UP (cif_len, alignof(void*))
 512              + (nargs + n_structs + n_struct_elts)*sizeof(void*));
 513
 514   /* then the ffi_type structs themselves, one per arg and struct element, and
 515      one for the return val */
 516   cif_len = (ROUND_UP (cif_len, alignof(ffi_type))
 517              + (nargs + n_struct_elts + 1)*sizeof(ffi_type));
 518
 519   mem = scm_malloc (cif_len);
 520   scm_cif = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, mem, cif_len, free);
 521   cif = (ffi_cif*)mem;
 522   /* reuse cif_len to walk through the mem */
 523   cif_len = ROUND_UP (sizeof (ffi_cif), alignof(void*));
 524   type_ptrs = (ffi_type**)(mem + cif_len);
 525   cif_len = ROUND_UP (cif_len
 526                       + (nargs + n_structs + n_struct_elts)*sizeof(void*),
 527                       alignof(ffi_type));
 528   types = (ffi_type*)(mem + cif_len);
 529
 530   /* whew. now knit the pointers together. */
 531   cif->rtype = types++;
 532   fill_ffi_type (return_type, cif->rtype, &type_ptrs, &types);
 533   cif->arg_types = type_ptrs;
 534   type_ptrs += nargs;
 535   for (walk = arg_types, i = 0; scm_is_pair (walk); walk = scm_cdr (walk), i++)
 536     {
 537       cif->arg_types[i] = types++;
 538       fill_ffi_type (scm_car (walk), cif->arg_types[i], &type_ptrs, &types);
 539     }
 540
 541   /* round out the cif, and we're done. */
 542   cif->abi = FFI_DEFAULT_ABI;
 543   cif->nargs = nargs;
 544   cif->bytes = 0;
 545   cif->flags = 0;
 546
 547   if (FFI_OK != ffi_prep_cif (cif, FFI_DEFAULT_ABI, cif->nargs, cif->rtype,
 548                               cif->arg_types))
 549     scm_misc_error (FUNC_NAME, "ffi_prep_cif failed", SCM_EOL);
 550
 551   return cif_to_procedure (scm_cif, func_ptr);
 552 }
 553 #undef FUNC_NAME
 554
 555 \f
 556
 557 /* Pre-generate trampolines for less than 10 arguments. */
 558
 559 #ifdef WORDS_BIGENDIAN
 560 #define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40
 561 #define META_HEADER    0, 0, 0, 32, 0, 0, 0, 0
 562 #else
 563 #define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
 564 #define META_HEADER    32, 0, 0, 0, 0, 0, 0, 0
 565 #endif
 566
 567 #define CODE(nreq)                                                      \
 568   OBJCODE_HEADER,                                                       \
 569   /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */  \
 570   /* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function pointer */ \
 571   /* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well) */ \
 572   /* 7 */ scm_op_nop,                                                   \
 573   /* 8 */ META (3, 7, nreq)
 574
 575 #define META(start, end, nreq)                                          \
 576   META_HEADER,                                                          \
 577   /* 0 */ scm_op_make_eol, /* bindings */                               \
 578   /* 1 */ scm_op_make_eol, /* sources */                                \
 579   /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
 580   /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */    \
 581   /* 8 */ scm_op_list, 0, 3, /* make a list of those 3 vals */         \
 582   /* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
 583   /* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
 584   /* 22 */ scm_op_object_ref, 1, /* the name from the object table */   \
 585   /* 24 */ scm_op_cons, /* make a pair for the properties */            \
 586   /* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
 587   /* 28 */ scm_op_return, /* and return */                              \
 588   /* 29 */ scm_op_nop, scm_op_nop, scm_op_nop                           \
 589   /* 32 */
 590
 591 static const struct
 592 {
 593   scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
 594   const scm_t_uint8 bytes[10 * (sizeof (struct scm_objcode) + 8
 595                                 + sizeof (struct scm_objcode) + 32)];
 596 } raw_bytecode = {
 597   0,
 598   {
 599     CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
 600     CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
 601   }
 602 };
 603
 604 #undef CODE
 605 #undef META
 606 #undef OBJCODE_HEADER
 607 #undef META_HEADER
 608
 609 /*
 610  (defun generate-objcode-cells (n)
 611    "Generate objcode cells for up to N arguments"
 612    (interactive "p")
 613    (let ((i 0))
 614      (while (< i n)
 615        (insert
 616         (format "    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
 617                 (* (+ 4 4 8 4 4 32) i)))
 618        (insert "    { SCM_BOOL_F, SCM_PACK (0) },\n")
 619        (setq i (1+ i)))))
 620 */
 621 #define STATIC_OBJCODE_TAG                                      \
 622   SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
 623
 624 static const struct
 625 {
 626   scm_t_uint64 dummy; /* alignment */
 627   scm_t_cell cells[10 * 2]; /* 10 double cells */
 628 } objcode_cells = {
 629   0,
 630   /* C-u 1 0 M-x generate-objcode-cells RET */
 631   {
 632     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
 633     { SCM_BOOL_F, SCM_PACK (0) },
 634     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 56) },
 635     { SCM_BOOL_F, SCM_PACK (0) },
 636     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 112) },
 637     { SCM_BOOL_F, SCM_PACK (0) },
 638     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 168) },
 639     { SCM_BOOL_F, SCM_PACK (0) },
 640     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 224) },
 641     { SCM_BOOL_F, SCM_PACK (0) },
 642     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 280) },
 643     { SCM_BOOL_F, SCM_PACK (0) },
 644     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 336) },
 645     { SCM_BOOL_F, SCM_PACK (0) },
 646     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 392) },
 647     { SCM_BOOL_F, SCM_PACK (0) },
 648     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
 649     { SCM_BOOL_F, SCM_PACK (0) },
 650     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 504) },
 651     { SCM_BOOL_F, SCM_PACK (0) }
 652   }
 653 };
 654
 655 static const SCM objcode_trampolines[10] = {
 656   SCM_PACK (objcode_cells.cells+0),
 657   SCM_PACK (objcode_cells.cells+2),
 658   SCM_PACK (objcode_cells.cells+4),
 659   SCM_PACK (objcode_cells.cells+6),
 660   SCM_PACK (objcode_cells.cells+8),
 661   SCM_PACK (objcode_cells.cells+10),
 662   SCM_PACK (objcode_cells.cells+12),
 663   SCM_PACK (objcode_cells.cells+14),
 664   SCM_PACK (objcode_cells.cells+16),
 665   SCM_PACK (objcode_cells.cells+18),
 666 };
 667
 668 static SCM
 669 cif_to_procedure (SCM cif, SCM func_ptr)
 670 {
 671   unsigned nargs = SCM_FOREIGN_POINTER (cif, ffi_cif)->nargs;
 672   SCM objcode, table, ret;
 673
 674   if (nargs < 10)
 675     objcode = objcode_trampolines[nargs];
 676   else
 677     abort ();
 678
 679   table = scm_c_make_vector (2, SCM_UNDEFINED);
 680   SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr));
 681   SCM_SIMPLE_VECTOR_SET (table, 1, SCM_BOOL_F); /* name */
 682   ret = scm_make_program (objcode, table, SCM_BOOL_F);
 683
 684   return ret;
 685 }
 686
 687 static void
 688 unpack (ffi_type *type, void *loc, SCM x)
 689 {
 690   switch (type->type)
 691     {
 692     case FFI_TYPE_FLOAT:
 693       *(float*)loc = scm_to_double (x);
 694       break;
 695     case FFI_TYPE_DOUBLE:
 696       *(double*)loc = scm_to_double (x);
 697       break;
 698     case FFI_TYPE_UINT8:
 699       *(scm_t_uint8*)loc = scm_to_uint8 (x);
 700       break;
 701     case FFI_TYPE_SINT8:
 702       *(scm_t_int8*)loc = scm_to_int8 (x);
 703       break;
 704     case FFI_TYPE_UINT16:
 705       *(scm_t_uint16*)loc = scm_to_uint16 (x);
 706       break;
 707     case FFI_TYPE_SINT16:
 708       *(scm_t_int16*)loc = scm_to_int16 (x);
 709       break;
 710     case FFI_TYPE_UINT32:
 711       *(scm_t_uint32*)loc = scm_to_uint32 (x);
 712       break;
 713     case FFI_TYPE_SINT32:
 714       *(scm_t_int32*)loc = scm_to_int32 (x);
 715       break;
 716     case FFI_TYPE_UINT64:
 717       *(scm_t_uint64*)loc = scm_to_uint64 (x);
 718       break;
 719     case FFI_TYPE_SINT64:
 720       *(scm_t_int64*)loc = scm_to_int64 (x);
 721       break;
 722     case FFI_TYPE_STRUCT:
 723       if (!SCM_FOREIGN_TYPED_P (x, VOID))
 724         abort ();
 725       if (SCM_FOREIGN_LEN (x) && SCM_FOREIGN_LEN (x) != type->size)
 726         abort ();
 727       memcpy (loc, SCM_FOREIGN_POINTER (x, void), type->size);
 728       break;
 729     case FFI_TYPE_POINTER:
 730       if (!SCM_FOREIGN_TYPED_P (x, VOID))
 731         abort ();
 732       *(void**)loc = SCM_FOREIGN_POINTER (x, void);
 733       break;
 734     default:
 735       abort ();
 736     }
 737 }
 738
 739 static SCM
 740 pack (ffi_type *type, void *loc)
 741 {
 742   switch (type->type)
 743     {
 744     case FFI_TYPE_VOID:
 745       return SCM_UNSPECIFIED;
 746     case FFI_TYPE_FLOAT:
 747       return scm_from_double (*(float*)loc);
 748     case FFI_TYPE_DOUBLE:
 749       return scm_from_double (*(double*)loc);
 750     case FFI_TYPE_UINT8:
 751       return scm_from_uint8 (*(scm_t_uint8*)loc);
 752     case FFI_TYPE_SINT8:
 753       return scm_from_int8 (*(scm_t_int8*)loc);
 754     case FFI_TYPE_UINT16:
 755       return scm_from_uint16 (*(scm_t_uint16*)loc);
 756     case FFI_TYPE_SINT16:
 757       return scm_from_int16 (*(scm_t_int16*)loc);
 758     case FFI_TYPE_UINT32:
 759       return scm_from_uint32 (*(scm_t_uint32*)loc);
 760     case FFI_TYPE_SINT32:
 761       return scm_from_int32 (*(scm_t_int32*)loc);
 762     case FFI_TYPE_UINT64:
 763       return scm_from_uint64 (*(scm_t_uint64*)loc);
 764     case FFI_TYPE_SINT64:
 765       return scm_from_int64 (*(scm_t_int64*)loc);
 766     case FFI_TYPE_STRUCT:
 767       {
 768         void *mem = scm_malloc (type->size);
 769         memcpy (mem, loc, type->size);
 770         return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
 771                                          mem, type->size, free);
 772       }
 773     case FFI_TYPE_POINTER:
 774       return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
 775                                        *(void**)loc, 0, NULL);
 776     default:
 777       abort ();
 778     }
 779 }
 780
 781 SCM
 782 scm_i_foreign_call (SCM foreign, SCM *argv)
 783 {
 784   /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
 785      objtable. */
 786   ffi_cif *cif;
 787   void (*func)();
 788   scm_t_uint8 *data;
 789   void *rvalue;
 790   void **args;
 791   unsigned i;
 792   scm_t_ptrdiff off;
 793
 794   cif = SCM_FOREIGN_POINTER (scm_car (foreign), ffi_cif);
 795   func = SCM_FOREIGN_POINTER (scm_cdr (foreign), void);
 796
 797   /* arg pointers */
 798   args = alloca (sizeof(void*) * cif->nargs);
 799   /* arg values, then return type value */
 800   data = alloca (ROUND_UP (cif->bytes, cif->rtype->alignment)
 801                  + cif->rtype->size);
 802   /* unpack argv to native values, setting argv pointers */
 803   off = 0;
 804   for (i = 0; i < cif->nargs; i++)
 805     {
 806       off = ROUND_UP (off, cif->arg_types[i]->alignment);
 807       args[i] = data + off;
 808       unpack (cif->arg_types[i], args[i], argv[i]);
 809       off += cif->arg_types[i]->size;
 810     }
 811   /* prep space for the return value */
 812   off = ROUND_UP (off, cif->rtype->alignment);
 813   rvalue = data + off;
 814
 815   /* off we go! */
 816   ffi_call (cif, func, rvalue, args);
 817
 818   return pack (cif->rtype, rvalue);
 819 }
 820
 821 \f
 822
 823 static void
 824 scm_init_foreign (void)
 825 {
 826 #ifndef SCM_MAGIC_SNARFER
 827 #include "libguile/foreign.x"
 828 #endif
 829   scm_define (sym_void, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID));
 830   scm_define (sym_float, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT));
 831   scm_define (sym_double, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE));
 832   scm_define (sym_uint8, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8));
 833   scm_define (sym_int8, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8));
 834   scm_define (sym_uint16, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16));
 835   scm_define (sym_int16, scm_from_uint8 (SCM_FOREIGN_TYPE_INT16));
 836   scm_define (sym_uint32, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32));
 837   scm_define (sym_int32, scm_from_uint8 (SCM_FOREIGN_TYPE_INT32));
 838   scm_define (sym_uint64, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64));
 839   scm_define (sym_int64, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64));
 840 }
 841
 842 void
 843 scm_register_foreign (void)
 844 {
 845   scm_c_register_extension ("libguile", "scm_init_foreign",
 846                             (scm_t_extension_init_func)scm_init_foreign,
 847                             NULL);
 848   foreign_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
 849 }
 850
 851 /*
 852   Local Variables:
 853   c-file-style: "gnu"
 854   End:
 855 */