Merge remote-tracking branch 'origin/stable-2.0'
[bpt/guile.git] / libguile / foreign.c
index ae9e27a..a734f2d 100644 (file)
@@ -87,22 +87,19 @@ static SCM cif_to_procedure (SCM cif, SCM func_ptr);
 
 
 static SCM pointer_weak_refs = SCM_BOOL_F;
-static scm_i_pthread_mutex_t weak_refs_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 
 
 static void
 register_weak_reference (SCM from, SCM to)
 {
-  scm_i_pthread_mutex_lock (&weak_refs_lock);
-  scm_hashq_set_x (pointer_weak_refs, from, to);
-  scm_i_pthread_mutex_unlock (&weak_refs_lock);
+  scm_weak_table_putq_x (pointer_weak_refs, from, to);
 }
 
 static void
 pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
 {
   scm_t_pointer_finalizer finalizer = data;
-  finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr)));
+  finalizer (SCM_POINTER_VALUE (SCM_PACK_POINTER (ptr)));
 }
 
 SCM_DEFINE (scm_pointer_p, "pointer?", 1, 0, 0,
@@ -155,7 +152,7 @@ scm_from_pointer (void *ptr, scm_t_pointer_finalizer finalizer)
          /* Register a finalizer for the newly created instance.  */
          GC_finalization_proc prev_finalizer;
          GC_PTR prev_finalizer_data;
-         GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
+         GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (ret),
                                          pointer_finalizer_trampoline,
                                          finalizer,
                                          &prev_finalizer,
@@ -198,7 +195,7 @@ SCM_DEFINE (scm_scm_to_pointer, "scm->pointer", 1, 0, 0,
   SCM ret;
 
   ret = scm_from_pointer ((void*) SCM_UNPACK (scm), NULL);
-  if (SCM_NIMP (ret))
+  if (SCM_HEAP_OBJECT_P (ret))
     register_weak_reference (ret, scm);
 
   return ret;
@@ -269,8 +266,8 @@ SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0,
 
   blen = scm_to_size_t (len);
 
-  ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype);
-  register_weak_reference (ret, pointer);
+  ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype, pointer);
+
   return ret;
 }
 #undef FUNC_NAME
@@ -320,7 +317,7 @@ SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0,
 
   SCM_SET_CELL_WORD_0 (pointer, SCM_CELL_WORD_0 (pointer) | (1 << 16UL));
 
-  GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer),
+  GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (pointer),
                                   pointer_finalizer_trampoline,
                                   c_finalizer,
                                   &prev_finalizer,
@@ -333,9 +330,9 @@ SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0,
 void
 scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate)
 {
-  scm_puts ("#<pointer 0x", port);
+  scm_puts_unlocked ("#<pointer 0x", port);
   scm_uintprint (scm_to_uintptr (scm_pointer_address (pointer)), 16, port);
-  scm_putc ('>', port);
+  scm_putc_unlocked ('>', port);
 }
 
 \f
@@ -454,32 +451,32 @@ SCM_DEFINE (scm_alignof, "alignof", 1, 0, 0, (SCM type),
       switch (SCM_I_INUM (type))
         {
         case SCM_FOREIGN_TYPE_FLOAT:
-          return scm_from_size_t (alignof (float));
+          return scm_from_size_t (alignof_type (float));
         case SCM_FOREIGN_TYPE_DOUBLE:
-          return scm_from_size_t (alignof (double));
+          return scm_from_size_t (alignof_type (double));
         case SCM_FOREIGN_TYPE_UINT8:
-          return scm_from_size_t (alignof (scm_t_uint8));
+          return scm_from_size_t (alignof_type (scm_t_uint8));
         case SCM_FOREIGN_TYPE_INT8:
-          return scm_from_size_t (alignof (scm_t_int8));
+          return scm_from_size_t (alignof_type (scm_t_int8));
         case SCM_FOREIGN_TYPE_UINT16:
-          return scm_from_size_t (alignof (scm_t_uint16));
+          return scm_from_size_t (alignof_type (scm_t_uint16));
         case SCM_FOREIGN_TYPE_INT16:
-          return scm_from_size_t (alignof (scm_t_int16));
+          return scm_from_size_t (alignof_type (scm_t_int16));
         case SCM_FOREIGN_TYPE_UINT32:
-          return scm_from_size_t (alignof (scm_t_uint32));
+          return scm_from_size_t (alignof_type (scm_t_uint32));
         case SCM_FOREIGN_TYPE_INT32:
-          return scm_from_size_t (alignof (scm_t_int32));
+          return scm_from_size_t (alignof_type (scm_t_int32));
         case SCM_FOREIGN_TYPE_UINT64:
-          return scm_from_size_t (alignof (scm_t_uint64));
+          return scm_from_size_t (alignof_type (scm_t_uint64));
         case SCM_FOREIGN_TYPE_INT64:
-          return scm_from_size_t (alignof (scm_t_int64));
+          return scm_from_size_t (alignof_type (scm_t_int64));
         default:
           scm_wrong_type_arg (FUNC_NAME, 1, type);
         }
     }
   else if (scm_is_eq (type, sym_asterisk))
     /* a pointer */
-    return scm_from_size_t (alignof (void*));
+    return scm_from_size_t (alignof_type (void*));
   else if (scm_is_pair (type))
     {
       /* TYPE is a structure.  Section 3-3 of the i386, x86_64, PowerPC,
@@ -707,12 +704,12 @@ make_cif (SCM return_type, SCM arg_types, const char *caller)
 
   /* then ffi_type pointers: one for each arg, one for each struct
      element, and one for each struct (for null-termination) */
-  cif_len = (ROUND_UP (cif_len, alignof(void*))
+  cif_len = (ROUND_UP (cif_len, alignof_type (void *))
             + (nargs + n_structs + n_struct_elts)*sizeof(void*));
 
   /* then the ffi_type structs themselves, one per arg and struct element, and
      one for the return val */
-  cif_len = (ROUND_UP (cif_len, alignof(ffi_type))
+  cif_len = (ROUND_UP (cif_len, alignof_type (ffi_type))
             + (nargs + n_struct_elts + 1)*sizeof(ffi_type));
 
   mem = scm_gc_malloc_pointerless (cif_len, "foreign");
@@ -721,11 +718,11 @@ make_cif (SCM return_type, SCM arg_types, const char *caller)
   cif = (ffi_cif *) mem;
 
   /* reuse cif_len to walk through the mem */
-  cif_len = ROUND_UP (sizeof (ffi_cif), alignof(void*));
+  cif_len = ROUND_UP (sizeof (ffi_cif), alignof_type (void *));
   type_ptrs = (ffi_type**)(mem + cif_len);
   cif_len = ROUND_UP (cif_len
                      + (nargs + n_structs + n_struct_elts)*sizeof(void*),
-                     alignof(ffi_type));
+                     alignof_type (ffi_type));
   types = (ffi_type*)(mem + cif_len);
 
   /* whew. now knit the pointers together. */
@@ -913,7 +910,7 @@ cif_to_procedure (SCM cif, SCM func_ptr)
 
 /* Set *LOC to the foreign representation of X with TYPE.  */
 static void
-unpack (const ffi_type *type, void *loc, SCM x)
+unpack (const ffi_type *type, void *loc, SCM x, int return_value_p)
 #define FUNC_NAME "scm_i_foreign_call"
 {
   switch (type->type)
@@ -924,23 +921,45 @@ unpack (const ffi_type *type, void *loc, SCM x)
     case FFI_TYPE_DOUBLE:
       *(double *) loc = scm_to_double (x);
       break;
+
+    /* For integer return values smaller than `int', libffi expects the
+       result in an `ffi_arg'-long buffer.  */
+
     case FFI_TYPE_UINT8:
-      *(scm_t_uint8 *) loc = scm_to_uint8 (x);
+      if (return_value_p)
+       *(ffi_arg *) loc = scm_to_uint8 (x);
+      else
+       *(scm_t_uint8 *) loc = scm_to_uint8 (x);
       break;
     case FFI_TYPE_SINT8:
-      *(scm_t_int8 *) loc = scm_to_int8 (x);
+      if (return_value_p)
+       *(ffi_arg *) loc = scm_to_int8 (x);
+      else
+       *(scm_t_int8 *) loc = scm_to_int8 (x);
       break;
     case FFI_TYPE_UINT16:
-      *(scm_t_uint16 *) loc = scm_to_uint16 (x);
+      if (return_value_p)
+       *(ffi_arg *) loc = scm_to_uint16 (x);
+      else
+       *(scm_t_uint16 *) loc = scm_to_uint16 (x);
       break;
     case FFI_TYPE_SINT16:
-      *(scm_t_int16 *) loc = scm_to_int16 (x);
+      if (return_value_p)
+       *(ffi_arg *) loc = scm_to_int16 (x);
+      else
+       *(scm_t_int16 *) loc = scm_to_int16 (x);
       break;
     case FFI_TYPE_UINT32:
-      *(scm_t_uint32 *) loc = scm_to_uint32 (x);
+      if (return_value_p)
+       *(ffi_arg *) loc = scm_to_uint32 (x);
+      else
+       *(scm_t_uint32 *) loc = scm_to_uint32 (x);
       break;
     case FFI_TYPE_SINT32:
-      *(scm_t_int32 *) loc = scm_to_int32 (x);
+      if (return_value_p)
+       *(ffi_arg *) loc = scm_to_int32 (x);
+      else
+       *(scm_t_int32 *) loc = scm_to_int32 (x);
       break;
     case FFI_TYPE_UINT64:
       *(scm_t_uint64 *) loc = scm_to_uint64 (x);
@@ -965,9 +984,12 @@ unpack (const ffi_type *type, void *loc, SCM x)
 }
 #undef FUNC_NAME
 
-/* Return a Scheme representation of the foreign value at LOC of type TYPE.  */
+/* Return a Scheme representation of the foreign value at LOC of type
+   TYPE.  When RETURN_VALUE_P is true, LOC is assumed to point to a
+   return value buffer; otherwise LOC is assumed to point to an
+   argument buffer.  */
 static SCM
-pack (const ffi_type * type, const void *loc)
+pack (const ffi_type * type, const void *loc, int return_value_p)
 {
   switch (type->type)
     {
@@ -977,22 +999,48 @@ pack (const ffi_type * type, const void *loc)
       return scm_from_double (*(float *) loc);
     case FFI_TYPE_DOUBLE:
       return scm_from_double (*(double *) loc);
+
+      /* For integer return values smaller than `int', libffi stores the
+        result in an `ffi_arg'-long buffer, of which only the
+        significant bits must be kept---hence the pair of casts below.
+        See <http://thread.gmane.org/gmane.comp.lib.ffi.general/406>
+        for details.  */
+
     case FFI_TYPE_UINT8:
-      return scm_from_uint8 (*(scm_t_uint8 *) loc);
+      if (return_value_p)
+       return scm_from_uint8 ((scm_t_uint8) *(ffi_arg *) loc);
+      else
+       return scm_from_uint8 (* (scm_t_uint8 *) loc);
     case FFI_TYPE_SINT8:
-      return scm_from_int8 (*(scm_t_int8 *) loc);
+      if (return_value_p)
+       return scm_from_int8 ((scm_t_int8) *(ffi_arg *) loc);
+      else
+       return scm_from_int8 (* (scm_t_int8 *) loc);
     case FFI_TYPE_UINT16:
-      return scm_from_uint16 (*(scm_t_uint16 *) loc);
+      if (return_value_p)
+       return scm_from_uint16 ((scm_t_uint16) *(ffi_arg *) loc);
+      else
+       return scm_from_uint16 (* (scm_t_uint16 *) loc);
     case FFI_TYPE_SINT16:
-      return scm_from_int16 (*(scm_t_int16 *) loc);
+      if (return_value_p)
+       return scm_from_int16 ((scm_t_int16) *(ffi_arg *) loc);
+      else
+       return scm_from_int16 (* (scm_t_int16 *) loc);
     case FFI_TYPE_UINT32:
-      return scm_from_uint32 (*(scm_t_uint32 *) loc);
+      if (return_value_p)
+       return scm_from_uint32 ((scm_t_uint32) *(ffi_arg *) loc);
+      else
+       return scm_from_uint32 (* (scm_t_uint32 *) loc);
     case FFI_TYPE_SINT32:
-      return scm_from_int32 (*(scm_t_int32 *) loc);
+      if (return_value_p)
+       return scm_from_int32 ((scm_t_int32) *(ffi_arg *) loc);
+      else
+       return scm_from_int32 (* (scm_t_int32 *) loc);
     case FFI_TYPE_UINT64:
       return scm_from_uint64 (*(scm_t_uint64 *) loc);
     case FFI_TYPE_SINT64:
       return scm_from_int64 (*(scm_t_int64 *) loc);
+
     case FFI_TYPE_STRUCT:
       {
        void *mem = scm_gc_malloc_pointerless (type->size, "foreign");
@@ -1047,7 +1095,7 @@ scm_i_foreign_call (SCM foreign, const SCM *argv)
       args[i] = (void *) ROUND_UP ((scm_t_uintptr) data + off,
                                   cif->arg_types[i]->alignment);
       assert ((scm_t_uintptr) args[i] % cif->arg_types[i]->alignment == 0);
-      unpack (cif->arg_types[i], args[i], argv[i]);
+      unpack (cif->arg_types[i], args[i], argv[i], 0);
     }
 
   /* Prepare space for the return value.  On some platforms, such as
@@ -1060,7 +1108,7 @@ scm_i_foreign_call (SCM foreign, const SCM *argv)
   /* off we go! */
   ffi_call (cif, func, rvalue, args);
 
-  return pack (cif->rtype, rvalue);
+  return pack (cif->rtype, rvalue, 1);
 }
 
 \f
@@ -1076,17 +1124,17 @@ invoke_closure (ffi_cif *cif, void *ret, void **args, void *data)
   size_t i;
   SCM proc, *argv, result;
 
-  proc = PTR2SCM (data);
+  proc = SCM_PACK_POINTER (data);
 
   argv = alloca (cif->nargs * sizeof (*argv));
 
   /* Pack ARGS to SCM values, setting ARGV pointers.  */
   for (i = 0; i < cif->nargs; i++)
-    argv[i] = pack (cif->arg_types[i], args[i]);
+    argv[i] = pack (cif->arg_types[i], args[i], 0);
 
   result = scm_call_n (proc, argv, cif->nargs);
 
-  unpack (cif->rtype, ret, result);
+  unpack (cif->rtype, ret, result, 1);
 }
 
 SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
@@ -1098,7 +1146,7 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
            "type should match @var{return-type} and @var{arg-types}.\n")
 #define FUNC_NAME s_scm_procedure_to_pointer
 {
-  SCM pointer;
+  SCM cif_pointer, pointer;
   ffi_cif *cif;
   ffi_status err;
   void *closure, *executable;
@@ -1107,7 +1155,7 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
 
   closure = ffi_closure_alloc (sizeof (ffi_closure), &executable);
   err = ffi_prep_closure_loc ((ffi_closure *) closure, cif,
-                             invoke_closure, SCM2PTR (proc),
+                             invoke_closure, SCM_UNPACK_POINTER (proc),
                              executable);
   if (err != FFI_OK)
     {
@@ -1115,8 +1163,17 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
       SCM_MISC_ERROR ("`ffi_prep_closure_loc' failed", SCM_EOL);
     }
 
+  /* CIF points to GC-managed memory and it should remain as long as
+     POINTER (see below) is live.  Wrap it in a Scheme pointer to then
+     hold a weak reference on it.  */
+  cif_pointer = scm_from_pointer (cif, NULL);
+
   if (closure == executable)
-    pointer = scm_from_pointer (executable, ffi_closure_free);
+    {
+      pointer = scm_from_pointer (executable, ffi_closure_free);
+      register_weak_reference (pointer,
+                              scm_list_2 (proc, cif_pointer));
+    }
   else
     {
       /* CLOSURE needs to be freed eventually.  However, since
@@ -1129,7 +1186,8 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
       pointer = scm_from_pointer (executable, NULL);
       friend = scm_from_pointer (closure, ffi_closure_free);
 
-      register_weak_reference (pointer, friend);
+      register_weak_reference (pointer,
+                              scm_list_3 (proc, cif_pointer, friend));
     }
 
   return pointer;
@@ -1243,7 +1301,7 @@ scm_register_foreign (void)
                             "scm_init_foreign",
                             (scm_t_extension_init_func)scm_init_foreign,
                             NULL);
-  pointer_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+  pointer_weak_refs = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 }
 
 /*