Fixes 2024 12 take 1

allocator-ecl.lisp

@@ -0,0 +1,36 @@
+(in-package #:cffi-object)
+
+(defun foreign-alloc/ecl (type)
+  (ext:with-backend
+    :bytecodes (si:allocate-foreign-data :void (cffi:foreign-type-size type))
+    :c/c++ (ffi:c-inline
+            (type (cffi:foreign-type-size type)) (:object :fixnum) :object
+            "ecl_allocate_foreign_data(#0, #1)"
+            :one-liner t :side-effects t)))
+
+(defun foreign-free/ecl (ptr)
+  (declare (ignorable ptr))
+  (ext:with-backend :bytecodes (cffi:foreign-free ptr) :c/c++ (progn)))
+
+(defun setup-ecl-allocator ()
+  (setf *default-cobject-allocator*
+        (make-cobject-allocator
+         :allocator #'foreign-alloc/ecl
+         :deallocator #'foreign-free/ecl)
+        *cobject-allocator* *default-cobject-allocator*
+        (fdefinition 'manage-cobject)
+        (let ((manage-cobject (fdefinition 'manage-cobject)))
+          (named-lambda manage-cobject/ecl (cobject)
+            (ext:with-backend
+              :bytecodes (funcall manage-cobject cobject)
+              :c/c++ (if (eq (cobject-allocator-deallocator *cobject-allocator*) #'foreign-free/ecl)
+                         cobject (funcall manage-cobject cobject)))))
+        (fdefinition 'unmanage-cobject)
+        (let ((unmanage-cobject (fdefinition 'unmanage-cobject)))
+          (named-lambda unmanage-cobject/ecl (cobject)
+            (if (ext:get-finalizer cobject)
+                (funcall unmanage-cobject cobject)
+                (warn "Object ~A has no finalizer, so its memory cannot be unmanaged." cobject))
+            (cobject-pointer cobject)))))
+
+(setup-ecl-allocator)

allocator.lisp

@@ -1,47 +1,85 @@
 (in-package #:cffi-object)
 
-(defstruct foreign-allocator
-  (allocator (constantly (cffi:null-pointer)) :type (function (non-negative-fixnum) (values cffi:foreign-pointer)))
+(declaim (inline make-cobject-allocator))
+(defstruct cobject-allocator
+  (allocator (constantly (cffi:null-pointer)) :type (function (cffi::foreign-type) (values cffi:foreign-pointer)))
   (deallocator #'values :type (function (cffi:foreign-pointer))))
 
-(declaim (type foreign-allocator *foreign-allocator*))
-(defparameter *foreign-allocator* (make-foreign-allocator :allocator #'cffi-sys:%foreign-alloc :deallocator #'cffi-sys:foreign-free))
+(declaim (type cobject-allocator *default-cobject-allocator*))
+(defparameter *default-cobject-allocator* (make-cobject-allocator
+                                           :allocator (lambda (type) (cffi-sys:%foreign-alloc (cffi:foreign-type-size type)))
+                                           :deallocator #'cffi-sys:foreign-free))
+
+(declaim (type cobject-allocator *cobject-allocator*))
+(defparameter *cobject-allocator* *default-cobject-allocator*)
+
+(declaim (inline make-leaky-allocator))
+(defun make-leaky-allocator (&key (allocator (cobject-allocator-allocator *cobject-allocator*)) (deallocator #'values))
+  (make-cobject-allocator :allocator allocator :deallocator deallocator))
+
+(defmacro with-leaky-allocator (&body body)
+  (with-gensyms (allocator)
+    `(let ((,allocator (make-leaky-allocator)))
+       (declare (dynamic-extent ,allocator))
+       (let ((*cobject-allocator* ,allocator)) . ,body))))
 
 (declaim (inline %make-sized-monotonic-buffer-allocator))
-(defstruct (sized-monotonic-buffer-allocator (:include foreign-allocator) (:constructor %make-sized-monotonic-buffer-allocator))
+(defstruct (sized-monotonic-buffer-allocator (:include cobject-allocator) (:constructor %make-sized-monotonic-buffer-allocator))
   (pointer (cffi:null-pointer) :type cffi:foreign-pointer)
   (size 0 :type non-negative-fixnum)
   (offset 0 :type non-negative-fixnum))
 
 (declaim (inline make-sized-monotonic-buffer-allocator))
-(defun make-sized-monotonic-buffer-allocator (&key (pointer (cffi:null-pointer)) (size 0))
-  (let* ((upstream-allocator *foreign-allocator*)
-         (allocator-1 nil)
-         (allocator-2 (%make-sized-monotonic-buffer-allocator :allocator (lambda (size)
-                                                                           (declare (type non-negative-fixnum size))
+(defun make-sized-monotonic-buffer-allocator (&key (pointer (cffi:null-pointer)) (size 0) (upstream *cobject-allocator*))
+  #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
+  (let* ((allocator-1 nil)
+         (allocator-2 (%make-sized-monotonic-buffer-allocator :allocator (lambda (type &aux (size (cffi:foreign-type-size type)) (align (cffi:foreign-type-alignment type)))
+                                                                           (declare (type non-negative-fixnum size align))
                                                                            (with-accessors ((offset sized-monotonic-buffer-allocator-offset)
                                                                                             (buffer-size sized-monotonic-buffer-allocator-size)
                                                                                             (pointer sized-monotonic-buffer-allocator-pointer)
                                                                                             (allocator sized-monotonic-buffer-allocator-allocator)
                                                                                             (deallocator sized-monotonic-buffer-allocator-deallocator))
                                                                                allocator-1
-                                                                             (if (<= (+ offset size) buffer-size)
-                                                                                 (prog1 (cffi:inc-pointer pointer offset)
-                                                                                   (incf offset size))
-                                                                                 (prog1 (funcall (foreign-allocator-allocator upstream-allocator) size)
-                                                                                   (setf offset buffer-size)
-                                                                                   (setf deallocator (foreign-allocator-deallocator upstream-allocator))))))
+                                                                             (let ((align-offset (mod (- align offset) align)))
+                                                                               (if (<= (+ offset align-offset size) buffer-size)
+                                                                                   (prog1 (cffi:inc-pointer pointer (incf offset align-offset))
+                                                                                     (incf offset size))
+                                                                                   (if upstream
+                                                                                       (prog1 (funcall (cobject-allocator-allocator upstream) type)
+                                                                                         (setf offset buffer-size)
+                                                                                         (setf deallocator (cobject-allocator-deallocator upstream)))
+                                                                                       (error "Cannot allocate a space of ~D byte~:P with allocator ~A." size allocator-1))))))
                                                               :deallocator #'values :size size :pointer pointer)))
     (setf allocator-1 allocator-2)
     allocator-2))
 
-(defmacro with-monotonic-buffer-allocator ((&key (buffer-size 128)) &body body)
-  (with-gensyms (buffer pointer size allocator)
-    `(let* ((,size ,buffer-size)
-            (,buffer (cffi:make-shareable-byte-vector ,size)))
-       (declare (dynamic-extent ,buffer))
-       (cffi:with-pointer-to-vector-data (,pointer ,buffer)
-         (let ((,allocator (make-sized-monotonic-buffer-allocator :pointer ,pointer :size ,size)))
-           (declare (dynamic-extent ,allocator))
-           (let ((*foreign-allocator* ,allocator))
-             ,@body))))))
+(defmacro with-monotonic-buffer-allocator ((&key
+                                              buffer pointer
+                                              (size (if buffer `(length ,buffer) 128))
+                                              (upstream '*cobject-allocator*)
+                                              (values '#'values))
+                                           &body body)
+  (with-gensyms (buffer-var pointer-var size-var allocator)
+    (flet ((wrap-with-buffer-var (form)
+             (cond
+               (buffer `(let ((,buffer-var ,buffer)) ,form))
+               (pointer form)
+               (t `(let ((,buffer-var (cffi:make-shareable-byte-vector ,size-var)))
+                     (declare (dynamic-extent ,buffer-var)) ,form))))
+           (wrap-with-pointer-var (form)
+             (if pointer
+                 `(let ((,pointer-var ,pointer)) ,form)
+                 `(cffi:with-pointer-to-vector-data (,pointer-var ,buffer-var) ,form))))
+      `(let ((,size-var ,size))
+         ,(wrap-with-buffer-var
+           (wrap-with-pointer-var
+            `(let ((,allocator (make-sized-monotonic-buffer-allocator :pointer ,pointer-var :size ,size-var :upstream ,upstream)))
+               (declare (dynamic-extent ,allocator))
+               (multiple-value-call ,values
+                 (let ((*cobject-allocator* ,allocator))
+                   ,@body)))))))))
+
+(defmacro with-default-allocator (&body body)
+  `(let ((*cobject-allocator* *default-cobject-allocator*))
+     ,@body))

array.lisp

@@ -4,6 +4,15 @@
                    (:constructor %make-carray))
   (dimensions '(0) :type (cons fixnum null)))
 
+(defmethod cobject-type ((array carray))
+  `(carray ,(carray-element-type array) ,(carray-dimensions array)))
+
+(defun cpointer-carray (cpointer dimensions)
+  (%make-carray :pointer (cpointer-pointer cpointer)
+                :shared-from (cpointer-shared-from cpointer)
+                :element-type (cpointer-element-type cpointer)
+                :dimensions (ensure-cons dimensions)))
+
 (defun caref (array &rest subscripts &aux (subscript (first subscripts)))
   (unless (<= 0 subscript (1- (first (carray-dimensions array))))
     (error "Index ~D is out of bound." subscript))
@@ -19,23 +28,71 @@
 (defun clength (carray)
   (first (carray-dimensions carray)))
 
+(defgeneric ccoerce (cobject type))
+
+(defgeneric (setf ccoerce) (value cobject type))
+
+(defmethod ccoerce ((array carray) (type (eql 'list)))
+  (declare (ignore type))
+  (loop :for i :below (clength array)
+        :collect (caref array i)))
+
+(defmethod ccoerce ((cobject cobject) (type list))
+  (ccoerce cobject (car type)))
+
+(defmethod ccoerce ((array carray) (type (eql 'simple-vector)))
+  (declare (ignore type))
+  (make-array (clength array) :initial-contents (ccoerce array 'list)))
+
+(defmethod ccoerce ((array carray) (type (eql 'simple-array)))
+  (declare (ignore type))
+  (if (symbolp (carray-element-type array))
+      (make-array (clength array) :element-type (carray-element-type array)
+                                  :initial-contents (ccoerce array 'list))
+      (ccoerce array 'simple-vector)))
+
+(defmethod ccoerce ((array carray) (type (eql 'vector)))
+  (declare (ignore type))
+  (ccoerce array 'simple-array))
+
+(defmethod ccoerce ((array carray) (type (eql 'array)))
+  (declare (ignore type))
+  (ccoerce array 'simple-array))
+
+(defmethod ccoerce ((array carray) (type (eql 'string)))
+  (declare (ignore type))
+  (cffi:foreign-string-to-lisp (carray-pointer array)))
+
+(defmethod (setf ccoerce) ((value string) (array carray) (type (eql 'string)))
+  (declare (ignore type))
+  (cffi:lisp-string-to-foreign value (carray-pointer array) (clength array)))
+
 (defmethod print-object ((array carray) stream)
-  (print-unreadable-object (array stream)
-    (loop :named print-element-loop
-          :with length := (first (carray-dimensions array))
-          :initially
-             (case (carray-element-type array)
-               (character (ignore-errors
-                           (return-from print-element-loop
-                             (print-object (carray-string array) stream)))))
-          :for i :below length
-          :if (< i 10)
-            :unless (zerop i)
-              :do (format stream "~%  ")
-          :end
-          :and :do (prin1 (caref array i) stream)
-          :else
-            :return (format stream " ... [~D elements elided]" (- length 10)))))
+  (if *print-readably*
+      (progn
+        (format stream "#.")
+        (prin1
+         `(make-carray
+           ',(carray-dimensions array)
+           :element-type ',(carray-element-type array)
+           :initial-contents ',(ccoerce array 'array))
+         stream))
+      (print-unreadable-object (array stream)
+        (loop :named print-element-loop
+              :with length := (first (carray-dimensions array))
+              :initially
+                 (case (carray-element-type array)
+                   (character (ignore-errors
+                               (return-from print-element-loop
+                                 (print-object (ccoerce array 'string) stream)))))
+              :for i :below length
+              :if (< i 10)
+                :unless (zerop i)
+                  :do (format stream "~%  ")
+              :end
+              :and :do (prin1 (caref array i) stream)
+              :else
+                :return (format stream " ... [~D elements elided]" (- length 10))))))
 
 (defstruct (displaced-carray (:include carray)
                              (:constructor %make-displaced-carray))
@@ -51,26 +108,22 @@
              (displaced-carray-displaced-index-offset array)))
     (t (values nil nil))))
 
-(defun carray-string (carray)
-  (cffi:foreign-string-to-lisp (carray-pointer carray)))
-
-(defun (setf carray-string) (value carray)
-  (cffi:lisp-string-to-foreign value (carray-pointer carray) (clength carray)))
-
 (defun make-carray (dimensions
                     &key element-type
                       initial-element initial-contents
                       displaced-to
                       (displaced-index-offset 0))
-  (unless (listp dimensions)
-    (setf dimensions (list dimensions)))
-  (let* ((primitive-type-p (primitive-type-p element-type))
+  (let* ((dimensions (ensure-cons dimensions))
+         (primitive-type-p (primitive-type-p element-type))
          (pointer-type-p (and (listp element-type) (eq (first element-type) 'cpointer)))
          (character-type-p (eq element-type 'character))
-         (element-size (cobject-class-object-size element-type))
+         (element-foreign-type (nth-value 1 (cobject-class-definition element-type)))
+         (element-size (cffi:foreign-type-size element-foreign-type))
          (total-size (* element-size (reduce #'* dimensions)))
          (pointer (if displaced-to (cffi:inc-pointer (cobject-pointer displaced-to) (* element-size displaced-index-offset))
-                      (funcall (foreign-allocator-allocator *foreign-allocator*) total-size)))
+                      (funcall (cobject-allocator-allocator *cobject-allocator*) (make-instance 'cffi::foreign-array-type
+                                                                                                :element-type element-foreign-type
+                                                                                                :dimensions dimensions))))
          (array (if displaced-to
                     (progn
                       (assert (<= 0 displaced-index-offset (+ displaced-index-offset (first dimensions)) (first (carray-dimensions displaced-to))))
@@ -83,6 +136,8 @@
                     (manage-cobject (%make-carray :pointer pointer
                                                   :dimensions dimensions
                                                   :element-type element-type)))))
+    (declare (type non-negative-fixnum element-size total-size)
+             (type (cons non-negative-fixnum t) dimensions))
     (when initial-element
       (assert (null initial-contents))
       (assert (null displaced-to))
@@ -109,6 +164,7 @@
          (unless character-type-p
            (assert (= (first dimensions) (length initial-contents))))
          (let ((i 0))
+           (declare (type non-negative-fixnum i))
            (map nil (cond
                       (character-type-p
                        (cffi:lisp-string-to-foreign (coerce initial-contents 'string) pointer total-size)
@@ -153,15 +209,3 @@
   (unless (= (clength array1) (clength array2))
     (return-from carray-equal nil))
   (cpointer-equal array1 array2 (clength array1)))
-
-(declaim (ftype (function (carray) (values list)) carray-list))
-(defun carray-list (array)
-  (loop :for i :below (clength array)
-        :collect (caref array i)))
-
-(declaim (ftype (function (carray) (values simple-array)) carray-array))
-(defun carray-array (carray)
-  (if (symbolp (carray-element-type carray))
-      (make-array (clength carray) :element-type (carray-element-type carray)
-                                   :initial-contents (carray-list carray))
-      (make-array (clength carray) :initial-contents (carray-list carray))))

cffi-object.asd

@@ -14,6 +14,7 @@
                (:file "definition")
                (:file "allocator")
                (:file "object")
+               (:file "allocator-ecl" :if-feature :ecl)
                (:file "pointer")
                (:file "array")
                (:file "macros")