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       scm_wrong_type_arg_msg (FUNC_NAME, 1, foreign, "foreign");
 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       scm_wrong_type_arg_msg (FUNC_NAME, 1, val, "foreign");
 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       scm_wrong_type_arg_msg ("%print-foreign", 1, foreign, "foreign");
 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           scm_wrong_type_arg_msg ("make-foreign-function", 0, type,
 542                                   "foreign type");
 543         }
 544     }
 545   else
 546     {
 547       long i, len;
 548
 549       len = scm_ilength (type);
 550
 551       ftype->size = 0;
 552       ftype->alignment = 0;
 553       ftype->type = FFI_TYPE_STRUCT;
 554       ftype->elements = *type_ptrs;
 555       *type_ptrs += len + 1;
 556
 557       for (i = 0; i < len; i++)
 558         {
 559           ftype->elements[i] = *types;
 560           *types += 1;
 561           fill_ffi_type (scm_car (type), ftype->elements[i],
 562                          type_ptrs, types);
 563           type = scm_cdr (type);
 564         }
 565       ftype->elements[i] = NULL;
 566     }
 567 }
 568
 569 SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0,
 570             (SCM return_type, SCM func_ptr, SCM arg_types),
 571             "foo")
 572 #define FUNC_NAME s_scm_make_foreign_function
 573 {
 574   SCM walk, scm_cif;
 575   long i, nargs, n_structs, n_struct_elts;
 576   size_t cif_len;
 577   char *mem;
 578   ffi_cif *cif;
 579   ffi_type **type_ptrs;
 580   ffi_type *types;
 581
 582   SCM_VALIDATE_FOREIGN_TYPED (2, func_ptr, VOID);
 583   nargs = scm_ilength (arg_types);
 584   SCM_ASSERT (nargs >= 0, arg_types, 3, FUNC_NAME);
 585   /* fixme: assert nargs < 1<<32 */
 586   n_structs = n_struct_elts = 0;
 587
 588   /* For want of talloc, we're going to have to do this in two passes: first we
 589      figure out how much memory is needed for all types, then we allocate the
 590      cif and the types all in one block. */
 591   if (!parse_ffi_type (return_type, 1, &n_structs, &n_struct_elts))
 592     scm_wrong_type_arg (FUNC_NAME, 1, return_type);
 593   for (walk = arg_types; scm_is_pair (walk); walk = scm_cdr (walk))
 594     if (!parse_ffi_type (scm_car (walk), 0, &n_structs, &n_struct_elts))
 595       scm_wrong_type_arg (FUNC_NAME, 3, scm_car (walk));
 596
 597   /* the memory: with space for the cif itself */
 598   cif_len = sizeof (ffi_cif);
 599
 600   /* then ffi_type pointers: one for each arg, one for each struct
 601      element, and one for each struct (for null-termination) */
 602   cif_len = (ROUND_UP (cif_len, alignof(void*))
 603              + (nargs + n_structs + n_struct_elts)*sizeof(void*));
 604
 605   /* then the ffi_type structs themselves, one per arg and struct element, and
 606      one for the return val */
 607   cif_len = (ROUND_UP (cif_len, alignof(ffi_type))
 608              + (nargs + n_struct_elts + 1)*sizeof(ffi_type));
 609
 610   mem = scm_malloc (cif_len);
 611   scm_cif = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, mem, cif_len, free);
 612   cif = (ffi_cif*)mem;
 613   /* reuse cif_len to walk through the mem */
 614   cif_len = ROUND_UP (sizeof (ffi_cif), alignof(void*));
 615   type_ptrs = (ffi_type**)(mem + cif_len);
 616   cif_len = ROUND_UP (cif_len
 617                       + (nargs + n_structs + n_struct_elts)*sizeof(void*),
 618                       alignof(ffi_type));
 619   types = (ffi_type*)(mem + cif_len);
 620
 621   /* whew. now knit the pointers together. */
 622   cif->rtype = types++;
 623   fill_ffi_type (return_type, cif->rtype, &type_ptrs, &types);
 624   cif->arg_types = type_ptrs;
 625   type_ptrs += nargs;
 626   for (walk = arg_types, i = 0; scm_is_pair (walk); walk = scm_cdr (walk), i++)
 627     {
 628       cif->arg_types[i] = types++;
 629       fill_ffi_type (scm_car (walk), cif->arg_types[i], &type_ptrs, &types);
 630     }
 631
 632   /* round out the cif, and we're done. */
 633   cif->abi = FFI_DEFAULT_ABI;
 634   cif->nargs = nargs;
 635   cif->bytes = 0;
 636   cif->flags = 0;
 637
 638   if (FFI_OK != ffi_prep_cif (cif, FFI_DEFAULT_ABI, cif->nargs, cif->rtype,
 639                               cif->arg_types))
 640     scm_misc_error (FUNC_NAME, "ffi_prep_cif failed", SCM_EOL);
 641
 642   return cif_to_procedure (scm_cif, func_ptr);
 643 }
 644 #undef FUNC_NAME
 645
 646 \f
 647
 648 /* Pre-generate trampolines for less than 10 arguments. */
 649
 650 #ifdef WORDS_BIGENDIAN
 651 #define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40
 652 #define META_HEADER    0, 0, 0, 32, 0, 0, 0, 0
 653 #else
 654 #define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
 655 #define META_HEADER    32, 0, 0, 0, 0, 0, 0, 0
 656 #endif
 657
 658 #define CODE(nreq)                                                      \
 659   OBJCODE_HEADER,                                                       \
 660   /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */  \
 661   /* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function pointer */ \
 662   /* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well) */ \
 663   /* 7 */ scm_op_nop,                                                   \
 664   /* 8 */ META (3, 7, nreq)
 665
 666 #define META(start, end, nreq)                                          \
 667   META_HEADER,                                                          \
 668   /* 0 */ scm_op_make_eol, /* bindings */                               \
 669   /* 1 */ scm_op_make_eol, /* sources */                                \
 670   /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
 671   /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */    \
 672   /* 8 */ scm_op_list, 0, 3, /* make a list of those 3 vals */         \
 673   /* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
 674   /* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
 675   /* 22 */ scm_op_object_ref, 1, /* the name from the object table */   \
 676   /* 24 */ scm_op_cons, /* make a pair for the properties */            \
 677   /* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
 678   /* 28 */ scm_op_return, /* and return */                              \
 679   /* 29 */ scm_op_nop, scm_op_nop, scm_op_nop                           \
 680   /* 32 */
 681
 682 static const struct
 683 {
 684   scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
 685   const scm_t_uint8 bytes[10 * (sizeof (struct scm_objcode) + 8
 686                                 + sizeof (struct scm_objcode) + 32)];
 687 } raw_bytecode = {
 688   0,
 689   {
 690     CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
 691     CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
 692   }
 693 };
 694
 695 #undef CODE
 696 #undef META
 697 #undef OBJCODE_HEADER
 698 #undef META_HEADER
 699
 700 /*
 701  (defun generate-objcode-cells (n)
 702    "Generate objcode cells for up to N arguments"
 703    (interactive "p")
 704    (let ((i 0))
 705      (while (< i n)
 706        (insert
 707         (format "    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
 708                 (* (+ 4 4 8 4 4 32) i)))
 709        (insert "    { SCM_BOOL_F, SCM_PACK (0) },\n")
 710        (setq i (1+ i)))))
 711 */
 712 #define STATIC_OBJCODE_TAG                                      \
 713   SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
 714
 715 static const struct
 716 {
 717   scm_t_uint64 dummy; /* alignment */
 718   scm_t_cell cells[10 * 2]; /* 10 double cells */
 719 } objcode_cells = {
 720   0,
 721   /* C-u 1 0 M-x generate-objcode-cells RET */
 722   {
 723     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
 724     { SCM_BOOL_F, SCM_PACK (0) },
 725     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 56) },
 726     { SCM_BOOL_F, SCM_PACK (0) },
 727     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 112) },
 728     { SCM_BOOL_F, SCM_PACK (0) },
 729     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 168) },
 730     { SCM_BOOL_F, SCM_PACK (0) },
 731     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 224) },
 732     { SCM_BOOL_F, SCM_PACK (0) },
 733     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 280) },
 734     { SCM_BOOL_F, SCM_PACK (0) },
 735     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 336) },
 736     { SCM_BOOL_F, SCM_PACK (0) },
 737     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 392) },
 738     { SCM_BOOL_F, SCM_PACK (0) },
 739     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
 740     { SCM_BOOL_F, SCM_PACK (0) },
 741     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 504) },
 742     { SCM_BOOL_F, SCM_PACK (0) }
 743   }
 744 };
 745
 746 static const SCM objcode_trampolines[10] = {
 747   SCM_PACK (objcode_cells.cells+0),
 748   SCM_PACK (objcode_cells.cells+2),
 749   SCM_PACK (objcode_cells.cells+4),
 750   SCM_PACK (objcode_cells.cells+6),
 751   SCM_PACK (objcode_cells.cells+8),
 752   SCM_PACK (objcode_cells.cells+10),
 753   SCM_PACK (objcode_cells.cells+12),
 754   SCM_PACK (objcode_cells.cells+14),
 755   SCM_PACK (objcode_cells.cells+16),
 756   SCM_PACK (objcode_cells.cells+18),
 757 };
 758
 759 static SCM
 760 cif_to_procedure (SCM cif, SCM func_ptr)
 761 {
 762   unsigned nargs = SCM_FOREIGN_POINTER (cif, ffi_cif)->nargs;
 763   SCM objcode, table, ret;
 764
 765   if (nargs < 10)
 766     objcode = objcode_trampolines[nargs];
 767   else
 768     scm_misc_error ("make-foreign-function", "args >= 10 currently unimplemented",
 769                     SCM_EOL);
 770
 771   table = scm_c_make_vector (2, SCM_UNDEFINED);
 772   SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr));
 773   SCM_SIMPLE_VECTOR_SET (table, 1, SCM_BOOL_F); /* name */
 774   ret = scm_make_program (objcode, table, SCM_BOOL_F);
 775
 776   return ret;
 777 }
 778
 779 static void
 780 unpack (ffi_type *type, void *loc, SCM x)
 781 {
 782   switch (type->type)
 783     {
 784     case FFI_TYPE_FLOAT:
 785       *(float*)loc = scm_to_double (x);
 786       break;
 787     case FFI_TYPE_DOUBLE:
 788       *(double*)loc = scm_to_double (x);
 789       break;
 790     case FFI_TYPE_UINT8:
 791       *(scm_t_uint8*)loc = scm_to_uint8 (x);
 792       break;
 793     case FFI_TYPE_SINT8:
 794       *(scm_t_int8*)loc = scm_to_int8 (x);
 795       break;
 796     case FFI_TYPE_UINT16:
 797       *(scm_t_uint16*)loc = scm_to_uint16 (x);
 798       break;
 799     case FFI_TYPE_SINT16:
 800       *(scm_t_int16*)loc = scm_to_int16 (x);
 801       break;
 802     case FFI_TYPE_UINT32:
 803       *(scm_t_uint32*)loc = scm_to_uint32 (x);
 804       break;
 805     case FFI_TYPE_SINT32:
 806       *(scm_t_int32*)loc = scm_to_int32 (x);
 807       break;
 808     case FFI_TYPE_UINT64:
 809       *(scm_t_uint64*)loc = scm_to_uint64 (x);
 810       break;
 811     case FFI_TYPE_SINT64:
 812       *(scm_t_int64*)loc = scm_to_int64 (x);
 813       break;
 814     case FFI_TYPE_STRUCT:
 815       if (!SCM_FOREIGN_TYPED_P (x, VOID))
 816         scm_wrong_type_arg_msg ("foreign-call", 0, x,
 817                                 "foreign void pointer");
 818       if (SCM_FOREIGN_LEN (x) && SCM_FOREIGN_LEN (x) != type->size)
 819         scm_wrong_type_arg_msg ("foreign-call", 0, x,
 820                                 "foreign void pointer of correct length");
 821       memcpy (loc, SCM_FOREIGN_POINTER (x, void), type->size);
 822       break;
 823     case FFI_TYPE_POINTER:
 824       if (!SCM_FOREIGN_TYPED_P (x, VOID))
 825         scm_wrong_type_arg_msg ("foreign-call", 0, x,
 826                                 "foreign void pointer");
 827       *(void**)loc = SCM_FOREIGN_POINTER (x, void);
 828       break;
 829     default:
 830       abort ();
 831     }
 832 }
 833
 834 static SCM
 835 pack (ffi_type *type, void *loc)
 836 {
 837   switch (type->type)
 838     {
 839     case FFI_TYPE_VOID:
 840       return SCM_UNSPECIFIED;
 841     case FFI_TYPE_FLOAT:
 842       return scm_from_double (*(float*)loc);
 843     case FFI_TYPE_DOUBLE:
 844       return scm_from_double (*(double*)loc);
 845     case FFI_TYPE_UINT8:
 846       return scm_from_uint8 (*(scm_t_uint8*)loc);
 847     case FFI_TYPE_SINT8:
 848       return scm_from_int8 (*(scm_t_int8*)loc);
 849     case FFI_TYPE_UINT16:
 850       return scm_from_uint16 (*(scm_t_uint16*)loc);
 851     case FFI_TYPE_SINT16:
 852       return scm_from_int16 (*(scm_t_int16*)loc);
 853     case FFI_TYPE_UINT32:
 854       return scm_from_uint32 (*(scm_t_uint32*)loc);
 855     case FFI_TYPE_SINT32:
 856       return scm_from_int32 (*(scm_t_int32*)loc);
 857     case FFI_TYPE_UINT64:
 858       return scm_from_uint64 (*(scm_t_uint64*)loc);
 859     case FFI_TYPE_SINT64:
 860       return scm_from_int64 (*(scm_t_int64*)loc);
 861     case FFI_TYPE_STRUCT:
 862       {
 863         void *mem = scm_malloc (type->size);
 864         memcpy (mem, loc, type->size);
 865         return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
 866                                          mem, type->size, free);
 867       }
 868     case FFI_TYPE_POINTER:
 869       return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
 870                                        *(void**)loc, 0, NULL);
 871     default:
 872       abort ();
 873     }
 874 }
 875
 876 SCM
 877 scm_i_foreign_call (SCM foreign, SCM *argv)
 878 {
 879   /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
 880      objtable. */
 881   ffi_cif *cif;
 882   void (*func)();
 883   scm_t_uint8 *data;
 884   void *rvalue;
 885   void **args;
 886   unsigned i;
 887   scm_t_ptrdiff off;
 888
 889   cif = SCM_FOREIGN_POINTER (scm_car (foreign), ffi_cif);
 890   func = SCM_FOREIGN_POINTER (scm_cdr (foreign), void);
 891
 892   /* arg pointers */
 893   args = alloca (sizeof(void*) * cif->nargs);
 894   /* arg values, then return type value */
 895   data = alloca (ROUND_UP (cif->bytes, cif->rtype->alignment)
 896                  + cif->rtype->size);
 897   /* unpack argv to native values, setting argv pointers */
 898   off = 0;
 899   for (i = 0; i < cif->nargs; i++)
 900     {
 901       off = ROUND_UP (off, cif->arg_types[i]->alignment);
 902       args[i] = data + off;
 903       unpack (cif->arg_types[i], args[i], argv[i]);
 904       off += cif->arg_types[i]->size;
 905     }
 906   /* prep space for the return value */
 907   off = ROUND_UP (off, cif->rtype->alignment);
 908   rvalue = data + off;
 909
 910   /* off we go! */
 911   ffi_call (cif, func, rvalue, args);
 912
 913   return pack (cif->rtype, rvalue);
 914 }
 915
 916 \f
 917
 918 static void
 919 scm_init_foreign (void)
 920 {
 921 #ifndef SCM_MAGIC_SNARFER
 922 #include "libguile/foreign.x"
 923 #endif
 924   scm_define (sym_void, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID));
 925   scm_define (sym_float, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT));
 926   scm_define (sym_double, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE));
 927   scm_define (sym_uint8, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8));
 928   scm_define (sym_int8, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8));
 929   scm_define (sym_uint16, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16));
 930   scm_define (sym_int16, scm_from_uint8 (SCM_FOREIGN_TYPE_INT16));
 931   scm_define (sym_uint32, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32));
 932   scm_define (sym_int32, scm_from_uint8 (SCM_FOREIGN_TYPE_INT32));
 933   scm_define (sym_uint64, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64));
 934   scm_define (sym_int64, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64));
 935 }
 936
 937 void
 938 scm_register_foreign (void)
 939 {
 940   scm_c_register_extension ("libguile", "scm_init_foreign",
 941                             (scm_t_extension_init_func)scm_init_foreign,
 942                             NULL);
 943   foreign_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
 944 }
 945
 946 /*
 947   Local Variables:
 948   c-file-style: "gnu"
 949   End:
 950 */