Use C code to guess the alignment of different types.

src/CHANGELOG

@@ -14,6 +14,9 @@ ECL 10.4.2:
 
  - EXT:MAKE-FOREIGN-DATA-FROM-ARRAY now supports all unboxed types.
 
+ - ECL did not properly compute the alignment of foreign types in structures.
+   This is now done using standard C constructs in a portable and robust way.
+
 * Visible changes:
 
  - "fasb" is now a valid FASL file type, accepted by ECL even in absence of

src/c/ffi.d

@@ -61,43 +61,58 @@ static const cl_object ecl_aet_to_ffi_table[aet_bc+1] = {
 	@':char' /* aet_bc */
 };
 
-static const cl_object ecl_foreign_type_table[] = {
-	@':char',
-	@':unsigned-char',
-	@':byte',
-	@':unsigned-byte',
-	@':short',
-	@':unsigned-short',
-	@':int',
-	@':unsigned-int',
-	@':long',
-	@':unsigned-long',
+#define ALIGNMENT(type) \
+        (long)(((struct { char a; type b[1]; } *)0)->b)
+#define FFI_DESC(symbol,type) \
+        {symbol, sizeof(type), ALIGNMENT(type)}
+
+static const struct{
+        cl_object name;
+        cl_index size;
+        cl_index alignment;
+} ecl_foreign_type_table[] = {
+	FFI_DESC(@':char', char),
+	FFI_DESC(@':unsigned-char', unsigned char),
+	FFI_DESC(@':byte', ecl_int8_t),
+        FFI_DESC(@':unsigned-byte', ecl_uint8_t),
+	FFI_DESC(@':short', short),
+	FFI_DESC(@':unsigned-short', unsigned short),
+	FFI_DESC(@':int', int),
+	FFI_DESC(@':unsigned-int', unsigned int),
+	FFI_DESC(@':long', long),
+	FFI_DESC(@':unsigned-long', unsigned long),
 #ifdef ecl_uint8_t
-        @':int8-t',
-        @':uint8-t',
+        FFI_DESC(@':int8-t', ecl_int8_t),
+        FFI_DESC(@':uint8-t', ecl_uint8_t),
 #endif
 #ifdef ecl_uint16_t
-        @':int16-t',
-        @':uint16-t',
+        FFI_DESC(@':int16-t', ecl_int16_t),
+        FFI_DESC(@':uint16-t', ecl_uint16_t),
 #endif
 #ifdef ecl_uint32_t
-        @':int32-t',
-        @':uint32-t',
+        FFI_DESC(@':int32-t', ecl_int32_t),
+        FFI_DESC(@':uint32-t', ecl_uint32_t),
 #endif
 #ifdef ecl_uint64_t
-        @':int64-t',
-        @':uint64-t',
+        FFI_DESC(@':int64-t', ecl_int64_t),
+        FFI_DESC(@':uint64-t', ecl_uint64_t),
 #endif
 #ifdef ecl_long_long_t
-        @':long-long',
-        @':unsigned-long-long',
+        FFI_DESC(@':long-long', long long),
+        FFI_DESC(@':unsigned-long-long', unsigned long long),
 #endif
-	@':pointer-void',
-	@':cstring',
-	@':object',
-	@':float',
-	@':double',
-	@':void'
+	FFI_DESC(@':pointer-void', void *),
+	FFI_DESC(@':cstring', char *),
+	FFI_DESC(@':object', cl_object),
+	FFI_DESC(@':float', float),
+	FFI_DESC(@':double', double),
+	{@':void', 0, 0}
+};
+
+static const int foreign_type_alignment[] = {
+        ALIGNMENT(char),
+        ALIGNMENT(unsigned char),
+        ALIGNMENT(int)
 };
 
 #ifdef ECL_DYNAMIC_FFI
@@ -107,45 +122,6 @@ static const cl_object ecl_foreign_cc_table[] = {
 };
 #endif
 
-static unsigned int ecl_foreign_type_size[] = {
-	sizeof(char),
-	sizeof(unsigned char),
-	sizeof(int8_t),
-	sizeof(uint8_t),
-	sizeof(short),
-	sizeof(unsigned short),
-	sizeof(int),
-	sizeof(unsigned int),
-	sizeof(long),
-	sizeof(unsigned long),
-#ifdef ecl_uint8_t
-        sizeof(ecl_int8_t),
-        sizeof(ecl_uint8_t),
-#endif
-#ifdef ecl_uint16_t
-        sizeof(ecl_int16_t),
-        sizeof(ecl_uint16_t),
-#endif
-#ifdef ecl_uint32_t
-        sizeof(ecl_int32_t),
-        sizeof(ecl_uint32_t),
-#endif
-#ifdef ecl_uint64_t
-        sizeof(ecl_int64_t),
-        sizeof(ecl_uint64_t),
-#endif
-#ifdef ecl_long_long_t
-        sizeof(long long),
-        sizeof(unsigned long long),
-#endif
-	sizeof(void *),
-	sizeof(char *),
-	sizeof(cl_object),
-	sizeof(float),
-	sizeof(double),
-	0
-};
-
 #ifdef HAVE_LIBFFI
 static struct {
         const cl_object symbol;
@@ -416,7 +392,7 @@ foreign_type_code(cl_object type)
 {
 	int i;
 	for (i = 0; i <= ECL_FFI_VOID; i++) {
-		if (type == ecl_foreign_type_table[i])
+		if (type == ecl_foreign_type_table[i].name)
 			return i;
 	}
         return -1;
@@ -629,7 +605,8 @@ si_foreign_data_ref_elt(cl_object f, cl_object andx, cl_object type)
 	cl_index ndx = fixnnint(andx);
 	cl_index limit = f->foreign.size;
 	enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
-	if (ecl_unlikely(ndx >= limit || (ndx + ecl_foreign_type_size[tag] > limit))) {
+	if (ecl_unlikely(ndx >= limit ||
+                         (ndx + ecl_foreign_type_table[tag].size > limit))) {
 		FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
 	}
 	if (ecl_unlikely(type_of(f) != t_foreign)) {
@@ -645,7 +622,8 @@ si_foreign_data_set_elt(cl_object f, cl_object andx, cl_object type, cl_object v
 	cl_index ndx = fixnnint(andx);
 	cl_index limit = f->foreign.size;
 	enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
-	if (ecl_unlikely(ndx >= limit || ndx + ecl_foreign_type_size[tag] > limit)) {
+	if (ecl_unlikely(ndx >= limit ||
+                         ndx + ecl_foreign_type_table[tag].size > limit)) {
 		FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
 	}
 	if (ecl_unlikely(type_of(f) != t_foreign)) {
@@ -660,7 +638,14 @@ cl_object
 si_size_of_foreign_elt_type(cl_object type)
 {
 	enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
-	@(return MAKE_FIXNUM(ecl_foreign_type_size[tag]))
+	@(return MAKE_FIXNUM(ecl_foreign_type_table[tag].size))
+}
+
+cl_object
+si_alignment_of_foreign_elt_type(cl_object type)
+{
+	enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
+	@(return MAKE_FIXNUM(ecl_foreign_type_table[tag].alignment))
 }
 
 cl_object

src/c/symbols_list.h

@@ -1415,6 +1415,7 @@ cl_symbols[] = {
 {SYS_ "LOAD-FOREIGN-MODULE", SI_ORDINARY, si_load_foreign_module, 1, OBJNULL},
 {SYS_ "NULL-POINTER-P", SI_ORDINARY, si_null_pointer_p, 1, OBJNULL},
 {SYS_ "SIZE-OF-FOREIGN-ELT-TYPE", SI_ORDINARY, si_size_of_foreign_elt_type, 1, OBJNULL},
+{SYS_ "ALIGNMENT-OF-FOREIGN-ELT-TYPE", SI_ORDINARY, si_alignment_of_foreign_elt_type, 1, OBJNULL},
 {KEY_ "BYTE", KEYWORD, NULL, -1, OBJNULL},
 {KEY_ "CHAR", KEYWORD, NULL, -1, OBJNULL},
 {KEY_ "CSTRING", KEYWORD, NULL, -1, OBJNULL},

src/c/symbols_list2.h

@@ -1415,6 +1415,7 @@ cl_symbols[] = {
 {SYS_ "LOAD-FOREIGN-MODULE","si_load_foreign_module"},
 {SYS_ "NULL-POINTER-P","si_null_pointer_p"},
 {SYS_ "SIZE-OF-FOREIGN-ELT-TYPE","si_size_of_foreign_elt_type"},
+{SYS_ "ALIGNMENT-OF-FOREIGN-ELT-TYPE","si_alignment_of_foreign_elt_type"},
 {KEY_ "BYTE",NULL},
 {KEY_ "CHAR",NULL},
 {KEY_ "CSTRING",NULL},

src/h/external.h

@@ -605,6 +605,7 @@ extern ECL_API cl_object si_free_foreign_data(cl_object x);
 extern ECL_API cl_object si_make_foreign_data_from_array(cl_object x);
 extern ECL_API cl_object si_null_pointer_p(cl_object f);
 extern ECL_API cl_object si_size_of_foreign_elt_type(cl_object tag);
+extern ECL_API cl_object si_alignment_of_foreign_elt_type(cl_object tag);
 extern ECL_API cl_object si_load_foreign_module(cl_object module);
 extern ECL_API cl_object si_find_foreign_symbol(cl_object var, cl_object module, cl_object type, cl_object size);
 extern ECL_API cl_object si_call_cfun(cl_narg, cl_object fun, cl_object return_type, cl_object arg_types, cl_object args, ...);

src/lsp/ffi.lsp

@@ -87,14 +87,15 @@
     (unless type
       (error "Incomplete or unknown foreign type ~A" name))
     (cond ((symbolp type)
-	   (setf size (si::size-of-foreign-elt-type type)))
+	   (setf size (si:size-of-foreign-elt-type type)
+                 align (si:alignment-of-foreign-elt-type type)))
 	  ((atom type)
 	   (error "~A is not a valid foreign type identifier" name))
 	  ((eq (setf name (first type)) :struct)
-	   (setf size (slot-position type nil))
-	   (setf align (apply #'max (mapcar #'(lambda (field)
+	   (setf size (slot-position type nil)
+                 align (apply #'max (mapcar #'(lambda (field)
 	                                        (multiple-value-bind (field-size field-align)
-						  (size-of-foreign-type (second field))
+                                                    (size-of-foreign-type (second field))
 						  field-align))
 	                                    (rest type))))
 	   (%align-data size align))
@@ -103,8 +104,8 @@
 	     (error "Incomplete foreign type: ~S" type))
 	   (multiple-value-bind (elt-size elt-align)
 	     (size-of-foreign-type (second type))
-	     (setf size (* size elt-size))
-	     (setf align elt-align)))
+	     (setf size (* size elt-size)
+                   align elt-align)))
 	  ((eq name :union)
 	   (dolist (field (rest type))
 	     (multiple-value-bind (field-size field-align)
@@ -114,14 +115,14 @@
 	       (when (or (null align) (> field-align align))
 	         (setf align field-align)))))
 	  ((eq name '*)
-	   (setf size (si::size-of-foreign-elt-type :pointer-void)))
+	   (setf size (si:size-of-foreign-elt-type :pointer-void)
+                 align (si:alignment-of-foreign-elt-type :pointer-void)))
           ((eq name 'quote)
-           (size-of-foreign-type (second type)))
+           (return-from size-of-foreign-type
+             (size-of-foreign-type (second type))))
 	  (t
 	   (error "~A does not denote a foreign type" name)))
-    (unless align
-      (setf align size))
-    (values size align)))
+    (values size (or align 0))))
 
 (defun allocate-foreign-object (type &optional (size 0 size-flag))
   (declare (fixnum size))