From 99d24d646179aa81fc576a469cac3d6d39760a89 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Mon, 2 Oct 2023 09:54:48 +0800 Subject: [PATCH 01/28] Generate compiler macros in `defcobjfun` to reduce allocations --- defcfun.lisp | 125 ++++++++++++++++++++++++++++++++++++++++++++------- ops.lisp | 7 +++ 2 files changed, 116 insertions(+), 16 deletions(-) diff --git a/defcfun.lisp b/defcfun.lisp index 9cc2417..74ba626 100644 --- a/defcfun.lisp +++ b/defcfun.lisp @@ -9,9 +9,14 @@ (defparameter *return-argument-names* '(#:%%claw-result-)) +(defparameter *optimize-object-allocation-p* t) +(defparameter *optimize-out-temporary-object-p* t) + (defun symbol-name= (sym1 sym2) (string= (symbol-name sym1) (symbol-name sym2))) +(defgeneric funcall-dynamic-extent-form (function args)) + (defconstant +defcfun+ (macro-function 'cffi:defcfun)) (setf (macro-function 'defcfun) +defcfun+) @@ -27,21 +32,109 @@ (export ',internal-symbol ',(symbol-package internal-symbol)) ,(when should-define-wrapper-p (if return-object-p - (let* ((object-type (cffi-object-type-p (cadar args))) - (object-constructor - (if-let ((definition (when object-type (assoc-value *cobject-class-definitions* object-type)))) - (cobject-class-definition-constructor definition) - (if-let ((type-name (when object-type (cffi::name object-type)))) - (intern (format nil "~A~A" '#:make- type-name) (symbol-package type-name)) - (error "Defining a C function that returns non-structure pointer is currently not supported."))))) - `(progn - (declaim (ftype function ,object-constructor) - (notinline ,object-constructor)) - (defun ,symbol ,(mapcar #'car (cdr args)) - (let ((,(caar args) (,object-constructor))) - (progn - (,internal-symbol . ,(loop :for (name type) :in args :collect (if (cffi-pointer-type-p type) `(cobj:cobject-pointer ,name) name))) - ,(caar args)))))) + (let ((object-type (cffi-object-type-p (cadar args)))) + (multiple-value-bind (object-constructor object-internal-constructor object-copier) + (if-let ((definition (when object-type (assoc-value *cobject-class-definitions* object-type)))) + (values (cobject-class-definition-constructor definition) + (cobject-class-definition-internal-constructor definition) + (cobject-class-definition-copier definition)) + (if-let ((type-name (when object-type (cffi::name object-type)))) + (values (intern (format nil "~A~A" '#:make- type-name) (symbol-package type-name)) + (intern (format nil "~A~A" '#:%%%make- type-name) (symbol-package type-name)) + (intern (format nil "~A~A" '#:copy- type-name) (symbol-package type-name))) + (error "Defining a C function that returns non-structure pointer is currently not supported."))) + `(progn + (declaim (ftype function ,object-constructor) + (notinline ,object-constructor)) + (defun ,symbol ,(mapcar #'car (cdr args)) + (let ((,(caar args) (,object-constructor))) + (progn + (,internal-symbol . ,(loop :for (name type) :in args :collect (if (cffi-pointer-type-p type) `(cobj:cobject-pointer ,name) name))) + ,(caar args)))) + ,(with-gensyms (function function-args body dynamic-extent-forms dynamic-extent-form temp-vars form name result) + `(defmethod funcall-dynamic-extent-form ((,function (eql ',symbol)) ,function-args) + (declare (ignore ,function)) + #+sbcl (declare (sb-ext:muffle-conditions warning)) + (destructuring-bind ,(mapcar #'car (cdr args)) ,function-args + (let ((,temp-vars (list . ,(loop :for (name nil) :in args :collect `(cons ',name (gensym ,(symbol-name name))))))) + (let ((,dynamic-extent-forms nil)) + ,@(loop :for (name type) :in (cdr args) + :if (cffi-pointer-type-p type) + :collect `(if-let ((,dynamic-extent-form (when (consp ,name) (funcall-dynamic-extent-form (car ,name) (cdr ,name))))) + (push (cons ',name (compose (curry ,dynamic-extent-form (assoc-value ,temp-vars ',name)) #'list)) ,dynamic-extent-forms) + (push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) + :else + :collect `(push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) + (nreversef ,dynamic-extent-forms) + (lambda (,(caar args) ,body) + `(cffi:with-foreign-object (,,(caar args) ',',(cffi::pointer-type (cffi::ensure-parsed-base-type (cadar args)))) + ,(reduce #'funcall ,(if *optimize-out-temporary-object-p* + `(loop :for (,name . ,form) :in ,dynamic-extent-forms + :if ,name + :collect (let ((,form ,form)) + (compose + (lambda (,body) + (let ((,result (funcall ,form ,body))) + `(,@(subseq ,result 0 3) ,@,body))) + #'list)) + :else + :collect ,form) + `(mapcar #'cdr ,dynamic-extent-forms)) + :initial-value (list ',internal-symbol ,(caar args) + . ,(loop :for (name type) :in (cdr args) + :collect (if (cffi-pointer-type-p type) + (if *optimize-out-temporary-object-p* + `(if (assoc-value ,dynamic-extent-forms ',name) + (assoc-value ,temp-vars ',name) + `(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) + ``(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) + `(assoc-value ,temp-vars ',name)))) + :from-end t) + (let ((,,(caar args) (,',object-internal-constructor :pointer ,,(caar args)))) + (declare (dynamic-extent ,,(caar args))) + ,@,body)))))))) + ,(when *optimize-object-allocation-p* + (let ((args (cdr args))) + (with-gensyms (var) + `(define-compiler-macro ,symbol ,(mapcar #'car args) + (with-gensyms (,var) + (funcall (funcall-dynamic-extent-form ',symbol (list . ,(mapcar #'car args))) ,var `((,',object-copier ,,var))))))))))) `(progn (defun ,symbol ,(mapcar #'car args) - (,internal-symbol . ,(loop :for (name type) :in args :collect (if (cffi-pointer-type-p type) `(cobj:cobject-pointer ,name) name))))))))))) + (,internal-symbol . ,(loop :for (name type) :in args :collect (if (cffi-pointer-type-p type) `(cobj:cobject-pointer ,name) name)))) + ,(when (and *optimize-object-allocation-p* (loop :for (nil type) :in args :thereis (cffi-pointer-type-p type))) + `(define-compiler-macro ,symbol ,(mapcar #'car args) + #+sbcl (declare (sb-ext:muffle-conditions warning)) + ,(with-gensyms (dynamic-extent-forms dynamic-extent-form body temp-vars name form result) + `(let ((,temp-vars (list . ,(loop :for (name nil) :in args :collect `(cons ',name (gensym ,(symbol-name name)))))) + (,dynamic-extent-forms nil)) + ,@(loop :for (name type) :in args + :if (cffi-pointer-type-p type) + :collect `(if-let ((,dynamic-extent-form (when (consp ,name) (funcall-dynamic-extent-form (car ,name) (cdr ,name))))) + (push (cons ',name (compose (curry ,dynamic-extent-form (assoc-value ,temp-vars ',name)) #'list)) ,dynamic-extent-forms) + (push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) + :else + :collect `(push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) + (nreversef ,dynamic-extent-forms) + (reduce #'funcall ,(if *optimize-out-temporary-object-p* + `(loop :for (,name . ,form) :in ,dynamic-extent-forms + :if ,name + :collect (let ((,form ,form)) + (compose + (lambda (,body) + (let ((,result (funcall ,form ,body))) + `(,@(subseq ,result 0 3) ,@,body))) + #'list)) + :else + :collect ,form) + `(mapcar #'cdr ,dynamic-extent-forms)) + :initial-value (list ',internal-symbol + . ,(loop :for (name type) :in args + :collect (if (cffi-pointer-type-p type) + (if *optimize-out-temporary-object-p* + `(if (assoc-value ,dynamic-extent-forms ',name) + (assoc-value ,temp-vars ',name) + `(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) + ``(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) + `(assoc-value ,temp-vars ',name)))) + :from-end t)))))))))))) diff --git a/ops.lisp b/ops.lisp index 18f836e..5d88d7d 100644 --- a/ops.lisp +++ b/ops.lisp @@ -9,6 +9,8 @@ (defconstant +ctypes-slots+ (fdefinition 'cffi-ops::ctypes-slots)) +(setf (fdefinition 'cobj::funcall-dynamic-extent-form) (fdefinition 'cffi-ops::funcall-dynamic-extent-form)) + (defun ctypes-slots-with-cobject (types) (funcall +ctypes-slots+ (mapcar (lambda (type) (if (and (listp type) (eq (car type) :object)) @@ -16,6 +18,11 @@ type)) types))) +(defgeneric funcall-form-type (function args)) + +(defmethod funcall-form-type ((function (eql 'vector2-add)) args) + (values '(:object (:struct abc)) (cons function args))) + (defun form-type-with-object-unwrapped (form) (multiple-value-bind (type form) (funcall +form-type+ form) (cond From 98c66f6f36cd7c6234ef1f162494019ab56c3799 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Mon, 2 Oct 2023 12:23:41 +0800 Subject: [PATCH 02/28] Allow defining object variables of dynamic extent with `cffi-ops` --- defcfun.lisp | 88 ++++++++++++++++++++++++++++------------------------ ops.lisp | 17 +++++++++- 2 files changed, 63 insertions(+), 42 deletions(-) diff --git a/defcfun.lisp b/defcfun.lisp index 74ba626..98e75e1 100644 --- a/defcfun.lisp +++ b/defcfun.lisp @@ -17,6 +17,8 @@ (defgeneric funcall-dynamic-extent-form (function args)) +(defgeneric funcall-form-type (function args)) + (defconstant +defcfun+ (macro-function 'cffi:defcfun)) (setf (macro-function 'defcfun) +defcfun+) @@ -52,47 +54,51 @@ (,internal-symbol . ,(loop :for (name type) :in args :collect (if (cffi-pointer-type-p type) `(cobj:cobject-pointer ,name) name))) ,(caar args)))) ,(with-gensyms (function function-args body dynamic-extent-forms dynamic-extent-form temp-vars form name result) - `(defmethod funcall-dynamic-extent-form ((,function (eql ',symbol)) ,function-args) - (declare (ignore ,function)) - #+sbcl (declare (sb-ext:muffle-conditions warning)) - (destructuring-bind ,(mapcar #'car (cdr args)) ,function-args - (let ((,temp-vars (list . ,(loop :for (name nil) :in args :collect `(cons ',name (gensym ,(symbol-name name))))))) - (let ((,dynamic-extent-forms nil)) - ,@(loop :for (name type) :in (cdr args) - :if (cffi-pointer-type-p type) - :collect `(if-let ((,dynamic-extent-form (when (consp ,name) (funcall-dynamic-extent-form (car ,name) (cdr ,name))))) - (push (cons ',name (compose (curry ,dynamic-extent-form (assoc-value ,temp-vars ',name)) #'list)) ,dynamic-extent-forms) - (push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) - :else - :collect `(push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) - (nreversef ,dynamic-extent-forms) - (lambda (,(caar args) ,body) - `(cffi:with-foreign-object (,,(caar args) ',',(cffi::pointer-type (cffi::ensure-parsed-base-type (cadar args)))) - ,(reduce #'funcall ,(if *optimize-out-temporary-object-p* - `(loop :for (,name . ,form) :in ,dynamic-extent-forms - :if ,name - :collect (let ((,form ,form)) - (compose - (lambda (,body) - (let ((,result (funcall ,form ,body))) - `(,@(subseq ,result 0 3) ,@,body))) - #'list)) - :else - :collect ,form) - `(mapcar #'cdr ,dynamic-extent-forms)) - :initial-value (list ',internal-symbol ,(caar args) - . ,(loop :for (name type) :in (cdr args) - :collect (if (cffi-pointer-type-p type) - (if *optimize-out-temporary-object-p* - `(if (assoc-value ,dynamic-extent-forms ',name) - (assoc-value ,temp-vars ',name) - `(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) - ``(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) - `(assoc-value ,temp-vars ',name)))) - :from-end t) - (let ((,,(caar args) (,',object-internal-constructor :pointer ,,(caar args)))) - (declare (dynamic-extent ,,(caar args))) - ,@,body)))))))) + `(progn + (defmethod funcall-form-type ((,function (eql ',symbol)) ,function-args) + (declare (ignore ,function)) + `(:object ,(cffi::unparse-type ',object-type))) + (defmethod funcall-dynamic-extent-form ((,function (eql ',symbol)) ,function-args) + (declare (ignore ,function)) + #+sbcl (declare (sb-ext:muffle-conditions warning)) + (destructuring-bind ,(mapcar #'car (cdr args)) ,function-args + (let ((,temp-vars (list . ,(loop :for (name nil) :in args :collect `(cons ',name (gensym ,(symbol-name name))))))) + (let ((,dynamic-extent-forms nil)) + ,@(loop :for (name type) :in (cdr args) + :if (cffi-pointer-type-p type) + :collect `(if-let ((,dynamic-extent-form (when (consp ,name) (funcall-dynamic-extent-form (car ,name) (cdr ,name))))) + (push (cons ',name (compose (curry ,dynamic-extent-form (assoc-value ,temp-vars ',name)) #'list)) ,dynamic-extent-forms) + (push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) + :else + :collect `(push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) + (nreversef ,dynamic-extent-forms) + (lambda (,(caar args) ,body) + `(cffi:with-foreign-object (,,(caar args) ',',(cffi::pointer-type (cffi::ensure-parsed-base-type (cadar args)))) + ,(reduce #'funcall ,(if *optimize-out-temporary-object-p* + `(loop :for (,name . ,form) :in ,dynamic-extent-forms + :if ,name + :collect (let ((,form ,form)) + (compose + (lambda (,body) + (let ((,result (funcall ,form ,body))) + `(,@(subseq ,result 0 3) ,@,body))) + #'list)) + :else + :collect ,form) + `(mapcar #'cdr ,dynamic-extent-forms)) + :initial-value (list ',internal-symbol ,(caar args) + . ,(loop :for (name type) :in (cdr args) + :collect (if (cffi-pointer-type-p type) + (if *optimize-out-temporary-object-p* + `(if (assoc-value ,dynamic-extent-forms ',name) + (assoc-value ,temp-vars ',name) + `(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) + ``(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) + `(assoc-value ,temp-vars ',name)))) + :from-end t) + (let ((,,(caar args) (,',object-internal-constructor :pointer ,,(caar args)))) + (declare (dynamic-extent ,,(caar args))) + ,@,body))))))))) ,(when *optimize-object-allocation-p* (let ((args (cdr args))) (with-gensyms (var) diff --git a/ops.lisp b/ops.lisp index 5d88d7d..1bfdffa 100644 --- a/ops.lisp +++ b/ops.lisp @@ -9,7 +9,12 @@ (defconstant +ctypes-slots+ (fdefinition 'cffi-ops::ctypes-slots)) -(setf (fdefinition 'cobj::funcall-dynamic-extent-form) (fdefinition 'cffi-ops::funcall-dynamic-extent-form)) +(defconstant +pointer-type-p+ (fdefinition 'cffi-ops::pointer-type-p)) + +(defconstant +ensure-pointer-type+ (fdefinition 'cffi-ops::ensure-pointer-type)) + +(setf (fdefinition 'cobj::funcall-dynamic-extent-form) (fdefinition 'cffi-ops::funcall-dynamic-extent-form) + (fdefinition 'cobj::funcall-form-type) (fdefinition 'cffi-ops::funcall-form-type)) (defun ctypes-slots-with-cobject (types) (funcall +ctypes-slots+ (mapcar (lambda (type) @@ -31,17 +36,27 @@ (values (cons :pointer (cdr type)) `(cobj:cobject-pointer ,form))) (t (values type form))))) +(defun pointer-or-object-type-p (type) + (if (and (consp type) (eq (car type) :object)) t (funcall +pointer-type-p+ type))) + +(defun ensure-pointer-or-object-type (type) + (if (and (consp type) (eq (car type) :object)) type (funcall +ensure-pointer-type+ type))) + (defmacro & (form) `(cobj:cobject-pointer ,form)) (defun enable-cobject-ops () (setf (fdefinition 'cffi-ops::form-type) #'form-type-with-object-unwrapped (fdefinition 'cffi-ops::ctypes-slots) #'ctypes-slots-with-cobject + (fdefinition 'cffi-ops::pointer-type-p) #'pointer-or-object-type-p + (fdefinition 'cffi-ops::ensure-pointer-type) #'ensure-pointer-or-object-type (fdefinition 'cffi-ops:&) #'cobj:cobject-pointer (compiler-macro-function 'cffi-ops:&) (macro-function '&))) (defun disable-cobject-ops () (setf (fdefinition 'cffi-ops::form-type) +form-type+ (fdefinition 'cffi-ops::ctypes-slots) +ctypes-slots+ + (fdefinition 'cffi-ops::pointer-type-p) +pointer-type-p+ + (fdefinition 'cffi-ops::ensure-pointer-type) +ensure-pointer-type+ (compiler-macro-function 'cffi-ops:&) nil) (fmakunbound 'cffi-ops:&)) From 0b0803607212a3d601b3132050e54e9b43ea31ce Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Mon, 2 Oct 2023 17:43:50 +0800 Subject: [PATCH 03/28] Add the default memory allocator --- allocator.lisp | 29 ++++++++++++++++++----------- package.lisp | 1 + test/package.lisp | 4 ++-- 3 files changed, 21 insertions(+), 13 deletions(-) diff --git a/allocator.lisp b/allocator.lisp index 2faa2a8..9e78412 100644 --- a/allocator.lisp +++ b/allocator.lisp @@ -4,8 +4,11 @@ (allocator (constantly (cffi:null-pointer)) :type (function (non-negative-fixnum) (values cffi:foreign-pointer))) (deallocator #'values :type (function (cffi:foreign-pointer)))) +(declaim (type foreign-allocator *default-foreign-allocator*)) +(defparameter *default-foreign-allocator* (make-foreign-allocator :allocator #'cffi-sys:%foreign-alloc :deallocator #'cffi-sys:foreign-free)) + (declaim (type foreign-allocator *foreign-allocator*)) -(defparameter *foreign-allocator* (make-foreign-allocator :allocator #'cffi-sys:%foreign-alloc :deallocator #'cffi-sys:foreign-free)) +(defparameter *foreign-allocator* *default-foreign-allocator*) (declaim (inline %make-sized-monotonic-buffer-allocator)) (defstruct (sized-monotonic-buffer-allocator (:include foreign-allocator) (:constructor %make-sized-monotonic-buffer-allocator)) @@ -14,9 +17,9 @@ (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) +(defun make-sized-monotonic-buffer-allocator (&key (pointer (cffi:null-pointer)) (size 0) (upstream *foreign-allocator*)) + #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + (let* ((allocator-1 nil) (allocator-2 (%make-sized-monotonic-buffer-allocator :allocator (lambda (size) (declare (type non-negative-fixnum size)) (with-accessors ((offset sized-monotonic-buffer-allocator-offset) @@ -28,20 +31,24 @@ (if (<= (+ offset size) buffer-size) (prog1 (cffi:inc-pointer pointer offset) (incf offset size)) - (prog1 (funcall (foreign-allocator-allocator upstream-allocator) size) + (prog1 (funcall (foreign-allocator-allocator upstream) size) (setf offset buffer-size) - (setf deallocator (foreign-allocator-deallocator upstream-allocator)))))) + (setf deallocator (foreign-allocator-deallocator upstream)))))) :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))) +(defmacro with-monotonic-buffer-allocator ((&key (size 128) (upstream '*foreign-allocator*)) &body body) + (with-gensyms (buffer pointer size-var allocator) + `(let* ((,size-var ,size) + (,buffer (cffi:make-shareable-byte-vector ,size-var))) (declare (dynamic-extent ,buffer)) (cffi:with-pointer-to-vector-data (,pointer ,buffer) - (let ((,allocator (make-sized-monotonic-buffer-allocator :pointer ,pointer :size ,size))) + (let ((,allocator (make-sized-monotonic-buffer-allocator :pointer ,pointer :size ,size-var :upstream ,upstream))) (declare (dynamic-extent ,allocator)) (let ((*foreign-allocator* ,allocator)) ,@body)))))) + +(defmacro with-default-allocator (&body body) + `(let ((*foreign-allocator* *default-foreign-allocator*)) + ,@body)) diff --git a/package.lisp b/package.lisp index 15d5b36..6ddc6aa 100644 --- a/package.lisp +++ b/package.lisp @@ -30,6 +30,7 @@ #:manage-cobject #:unmanage-cobject #:with-monotonic-buffer-allocator + #:with-default-allocator #:defcobjfun)) (in-package #:cffi-object) diff --git a/test/package.lisp b/test/package.lisp index ea1f54f..d20db12 100644 --- a/test/package.lisp +++ b/test/package.lisp @@ -278,8 +278,8 @@ (is string= "" (carray-string arr)))) (define-test monotonic-buffer-allocator :parent suite - (with-monotonic-buffer-allocator (:buffer-size 8) - (with-monotonic-buffer-allocator (:buffer-size 8) + (with-monotonic-buffer-allocator (:size 8) + (with-monotonic-buffer-allocator (:size 8) (of-type cobj::sized-monotonic-buffer-allocator cobj::*foreign-allocator*) (make-vector2) (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*foreign-allocator*)) From adbf78e28639e42e00ab86b43567927c14b2a8f3 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Mon, 2 Oct 2023 18:49:46 +0800 Subject: [PATCH 04/28] Allow unspecified upstream allocator of monotonic buffer allocator --- allocator.lisp | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/allocator.lisp b/allocator.lisp index 9e78412..925bb7b 100644 --- a/allocator.lisp +++ b/allocator.lisp @@ -31,14 +31,16 @@ (if (<= (+ offset size) buffer-size) (prog1 (cffi:inc-pointer pointer offset) (incf offset size)) - (prog1 (funcall (foreign-allocator-allocator upstream) size) - (setf offset buffer-size) - (setf deallocator (foreign-allocator-deallocator upstream)))))) + (if upstream + (prog1 (funcall (foreign-allocator-allocator upstream) size) + (setf offset buffer-size) + (setf deallocator (foreign-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 (size 128) (upstream '*foreign-allocator*)) &body body) +(defmacro with-monotonic-buffer-allocator ((&key (size 128) (upstream '*foreign-allocator*) (values '#'values)) &body body) (with-gensyms (buffer pointer size-var allocator) `(let* ((,size-var ,size) (,buffer (cffi:make-shareable-byte-vector ,size-var))) @@ -46,8 +48,9 @@ (cffi:with-pointer-to-vector-data (,pointer ,buffer) (let ((,allocator (make-sized-monotonic-buffer-allocator :pointer ,pointer :size ,size-var :upstream ,upstream))) (declare (dynamic-extent ,allocator)) - (let ((*foreign-allocator* ,allocator)) - ,@body)))))) + (multiple-value-call ,values + (let ((*foreign-allocator* ,allocator)) + ,@body))))))) (defmacro with-default-allocator (&body body) `(let ((*foreign-allocator* *default-foreign-allocator*)) From a6adad73fd35e65e553ee7c95e7955c666378646 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Mon, 2 Oct 2023 19:29:47 +0800 Subject: [PATCH 05/28] Allow specify the buffer of a monotonic buffer allocator --- allocator.lisp | 31 ++++++++++++++++++++----------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/allocator.lisp b/allocator.lisp index 925bb7b..19caa44 100644 --- a/allocator.lisp +++ b/allocator.lisp @@ -40,17 +40,26 @@ (setf allocator-1 allocator-2) allocator-2)) -(defmacro with-monotonic-buffer-allocator ((&key (size 128) (upstream '*foreign-allocator*) (values '#'values)) &body body) - (with-gensyms (buffer pointer size-var allocator) - `(let* ((,size-var ,size) - (,buffer (cffi:make-shareable-byte-vector ,size-var))) - (declare (dynamic-extent ,buffer)) - (cffi:with-pointer-to-vector-data (,pointer ,buffer) - (let ((,allocator (make-sized-monotonic-buffer-allocator :pointer ,pointer :size ,size-var :upstream ,upstream))) - (declare (dynamic-extent ,allocator)) - (multiple-value-call ,values - (let ((*foreign-allocator* ,allocator)) - ,@body))))))) +(defmacro with-monotonic-buffer-allocator ((&key + buffer + (size (if buffer `(length ,buffer) 128)) + (upstream '*foreign-allocator*) + (values '#'values)) + &body body) + (with-gensyms (buffer-var pointer size-var allocator) + (flet ((wrap-with-buffer-var (form) + (if buffer + `(let ((,buffer-var ,buffer)) ,form) + `(let ((,buffer-var (cffi:make-shareable-byte-vector ,size-var))) + (declare (dynamic-extent ,buffer-var)) ,form)))) + `(let ((,size-var ,size)) + ,(wrap-with-buffer-var + `(cffi:with-pointer-to-vector-data (,pointer ,buffer-var) + (let ((,allocator (make-sized-monotonic-buffer-allocator :pointer ,pointer :size ,size-var :upstream ,upstream))) + (declare (dynamic-extent ,allocator)) + (multiple-value-call ,values + (let ((*foreign-allocator* ,allocator)) + ,@body))))))))) (defmacro with-default-allocator (&body body) `(let ((*foreign-allocator* *default-foreign-allocator*)) From e115b882b127e7c2b34189f0e77be7e6484881f1 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Sat, 7 Oct 2023 13:49:55 +0800 Subject: [PATCH 06/28] Fix access to pointer-to-pointer objects --- definition.lisp | 5 +++-- test/package.lisp | 29 ++++++++++++++++++++++++++++- 2 files changed, 31 insertions(+), 3 deletions(-) diff --git a/definition.lisp b/definition.lisp index a9c5610..cee1381 100644 --- a/definition.lisp +++ b/definition.lisp @@ -53,14 +53,15 @@ :shared-from shared-from :element-type element-type :dimensions dimensions))) - `(:array ,(nth-value 1 (cobject-class-definition element-type)) . ,dimensions))) + (make-instance 'cffi::foreign-array-type :element-type (nth-value 1 (cobject-class-definition element-type)) + :dimensions dimensions))) (as-pointer (values (make-cobject-class-definition :class type :internal-constructor (lambda (&key pointer shared-from) (declare (ignore shared-from)) (%make-cpointer :pointer (cffi:mem-ref pointer :pointer) :element-type element-type))) - `(:pointer ,(nth-value 1 (cobject-class-definition element-type)))))) + (make-instance 'cffi::foreign-pointer-type :pointer-type (nth-value 1 (cobject-class-definition element-type)))))) (destructuring-ecase type ((carray element-type &optional dimensions) (if dimensions diff --git a/test/package.lisp b/test/package.lisp index d20db12..e64ea86 100644 --- a/test/package.lisp +++ b/test/package.lisp @@ -234,13 +234,40 @@ (setf (caref strarr 0) "000") (is string= "000" (caref strarr 0)))) -(define-test array-of-pointer :parent suite +(define-test array-of-array-of-pointer :parent suite (let ((arr (make-carray 3 :element-type '(carray (cpointer (signed-byte 8)) 1) :initial-element (make-carray 1 :element-type '(cpointer (signed-byte 8)) :initial-element (pointer-cpointer (cffi-sys::make-pointer 123) '(signed-byte 8)))))) (loop :for i :below 3 :do (is cpointer-eq (caref (caref arr i) 0) (pointer-cpointer (make-pointer 123) '(signed-byte 8)))))) +(define-test pointer-of-pointer :parent suite + (let* ((arr1 (make-carray 1 :element-type '(signed-byte 8) + :initial-element 1)) + (arr2 (make-carray 1 :element-type '(signed-byte 8) + :initial-element 2)) + (arr3 (make-carray 1 :element-type '(signed-byte 8) + :initial-element 3)) + (arr4 (make-carray 3 :element-type '(cpointer (signed-byte 8)) + :initial-contents (list arr1 arr2 arr3)))) + (loop :for ptr :in (carray-list arr4) + :for arr :in (list arr1 arr2 arr3) + :do (is cobject-eq arr ptr) + (is = (caref arr 0) (cref ptr))))) + +(define-test array-of-array :parent suite + (let* ((arr1 (make-carray 1 :element-type '(signed-byte 8) + :initial-element 1)) + (arr2 (make-carray 1 :element-type '(signed-byte 8) + :initial-element 2)) + (arr3 (make-carray 1 :element-type '(signed-byte 8) + :initial-element 3)) + (arr4 (make-carray 3 :element-type '(carray (signed-byte 8) 1) + :initial-contents (list arr1 arr2 arr3)))) + (loop :for ptr :in (carray-list arr4) + :for arr :in (list arr1 arr2 arr3) + :do (is = (caref arr 0) (caref ptr 0))))) + (eval-when (:compile-toplevel :load-toplevel :execute) (cobj.ops:enable-cobject-ops)) From b1c17d44c877df04bed40f3d4f6c9ddfff92db46 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Sat, 7 Oct 2023 14:40:12 +0800 Subject: [PATCH 07/28] Add support for wrapping functions that return pointers --- defcfun.lisp | 115 ++++++++++++++++++++++++++++----------------------- 1 file changed, 64 insertions(+), 51 deletions(-) diff --git a/defcfun.lisp b/defcfun.lisp index 98e75e1..f688162 100644 --- a/defcfun.lisp +++ b/defcfun.lisp @@ -23,28 +23,32 @@ (setf (macro-function 'defcfun) +defcfun+) +(defun cobject-type-constructor (object-type) + (if-let ((definition (when object-type (assoc-value *cobject-class-definitions* object-type)))) + (values (cobject-class-definition-constructor definition) + (cobject-class-definition-internal-constructor definition) + (cobject-class-definition-copier definition)) + (if-let ((type-name (when object-type (cffi::name object-type)))) + (values (intern (format nil "~A~A" '#:make- type-name) (symbol-package type-name)) + (intern (format nil "~A~A" '#:copy- type-name) (symbol-package type-name)) + (intern (format nil "~A~A" '#:%%%make- type-name) (symbol-package type-name))) + (error "Defining a C function that returns non-structure pointer is currently not supported.")))) + (defmacro defcobjfun (name result &rest args) (destructuring-bind (name symbol) name (let* ((should-define-wrapper-p (not (member '&rest args))) (internal-symbol (if should-define-wrapper-p (intern (format nil "%~A" symbol) (symbol-package symbol)) symbol)) - (return-object-p (member (caar args) *return-argument-names* :test #'symbol-name=))) + (return-pointer-from-result-p (cffi-pointer-type-p result)) + (return-object-from-result-p (cffi-object-type-p result)) + (return-object-from-argument-p (member (caar args) *return-argument-names* :test #'symbol-name=))) `(progn (declaim (inline ,internal-symbol)) (defcfun (,name ,internal-symbol) ,result . ,args) (export ',internal-symbol ',(symbol-package internal-symbol)) ,(when should-define-wrapper-p - (if return-object-p + (if return-object-from-argument-p (let ((object-type (cffi-object-type-p (cadar args)))) - (multiple-value-bind (object-constructor object-internal-constructor object-copier) - (if-let ((definition (when object-type (assoc-value *cobject-class-definitions* object-type)))) - (values (cobject-class-definition-constructor definition) - (cobject-class-definition-internal-constructor definition) - (cobject-class-definition-copier definition)) - (if-let ((type-name (when object-type (cffi::name object-type)))) - (values (intern (format nil "~A~A" '#:make- type-name) (symbol-package type-name)) - (intern (format nil "~A~A" '#:%%%make- type-name) (symbol-package type-name)) - (intern (format nil "~A~A" '#:copy- type-name) (symbol-package type-name))) - (error "Defining a C function that returns non-structure pointer is currently not supported."))) + (multiple-value-bind (object-constructor object-copier object-internal-constructor) (cobject-type-constructor object-type) `(progn (declaim (ftype function ,object-constructor) (notinline ,object-constructor)) @@ -105,42 +109,51 @@ `(define-compiler-macro ,symbol ,(mapcar #'car args) (with-gensyms (,var) (funcall (funcall-dynamic-extent-form ',symbol (list . ,(mapcar #'car args))) ,var `((,',object-copier ,,var))))))))))) - `(progn - (defun ,symbol ,(mapcar #'car args) - (,internal-symbol . ,(loop :for (name type) :in args :collect (if (cffi-pointer-type-p type) `(cobj:cobject-pointer ,name) name)))) - ,(when (and *optimize-object-allocation-p* (loop :for (nil type) :in args :thereis (cffi-pointer-type-p type))) - `(define-compiler-macro ,symbol ,(mapcar #'car args) - #+sbcl (declare (sb-ext:muffle-conditions warning)) - ,(with-gensyms (dynamic-extent-forms dynamic-extent-form body temp-vars name form result) - `(let ((,temp-vars (list . ,(loop :for (name nil) :in args :collect `(cons ',name (gensym ,(symbol-name name)))))) - (,dynamic-extent-forms nil)) - ,@(loop :for (name type) :in args - :if (cffi-pointer-type-p type) - :collect `(if-let ((,dynamic-extent-form (when (consp ,name) (funcall-dynamic-extent-form (car ,name) (cdr ,name))))) - (push (cons ',name (compose (curry ,dynamic-extent-form (assoc-value ,temp-vars ',name)) #'list)) ,dynamic-extent-forms) - (push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) - :else - :collect `(push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) - (nreversef ,dynamic-extent-forms) - (reduce #'funcall ,(if *optimize-out-temporary-object-p* - `(loop :for (,name . ,form) :in ,dynamic-extent-forms - :if ,name - :collect (let ((,form ,form)) - (compose - (lambda (,body) - (let ((,result (funcall ,form ,body))) - `(,@(subseq ,result 0 3) ,@,body))) - #'list)) - :else - :collect ,form) - `(mapcar #'cdr ,dynamic-extent-forms)) - :initial-value (list ',internal-symbol - . ,(loop :for (name type) :in args - :collect (if (cffi-pointer-type-p type) - (if *optimize-out-temporary-object-p* - `(if (assoc-value ,dynamic-extent-forms ',name) - (assoc-value ,temp-vars ',name) - `(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) - ``(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) - `(assoc-value ,temp-vars ',name)))) - :from-end t)))))))))))) + (let ((result-wrapper + (with-gensyms (result) + `(lambda (,result) + ,(cond + (return-object-from-result-p (let ((internal-constructor (nth-value 2 (cobject-type-constructor return-object-from-result-p)))) + `(locally (declare (notinline ,internal-constructor)) (,internal-constructor :pointer ,result)))) + (return-pointer-from-result-p `(pointer-cpointer ,result ',(cobject-class-definition-class (find-cobject-class-definition (cffi::pointer-type return-pointer-from-result-p))))) + (t result)))))) + `(progn + (defun ,symbol ,(mapcar #'car args) + (,result-wrapper (,internal-symbol . ,(loop :for (name type) :in args :collect (if (cffi-pointer-type-p type) `(cobj:cobject-pointer ,name) name))))) + ,(when (and *optimize-object-allocation-p* (loop :for (nil type) :in args :thereis (cffi-pointer-type-p type))) + `(define-compiler-macro ,symbol ,(mapcar #'car args) + #+sbcl (declare (sb-ext:muffle-conditions warning)) + ,(with-gensyms (dynamic-extent-forms dynamic-extent-form body temp-vars name form result) + `(let ((,temp-vars (list . ,(loop :for (name nil) :in args :collect `(cons ',name (gensym ,(symbol-name name)))))) + (,dynamic-extent-forms nil)) + ,@(loop :for (name type) :in args + :if (cffi-pointer-type-p type) + :collect `(if-let ((,dynamic-extent-form (when (consp ,name) (funcall-dynamic-extent-form (car ,name) (cdr ,name))))) + (push (cons ',name (compose (curry ,dynamic-extent-form (assoc-value ,temp-vars ',name)) #'list)) ,dynamic-extent-forms) + (push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) + :else + :collect `(push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) + (nreversef ,dynamic-extent-forms) + (reduce #'funcall ,(if *optimize-out-temporary-object-p* + `(loop :for (,name . ,form) :in ,dynamic-extent-forms + :if ,name + :collect (let ((,form ,form)) + (compose + (lambda (,body) + (let ((,result (funcall ,form ,body))) + `(,@(subseq ,result 0 3) ,@,body))) + #'list)) + :else + :collect ,form) + `(mapcar #'cdr ,dynamic-extent-forms)) + :initial-value (list ',result-wrapper + (list ',internal-symbol + . ,(loop :for (name type) :in args + :collect (if (cffi-pointer-type-p type) + (if *optimize-out-temporary-object-p* + `(if (assoc-value ,dynamic-extent-forms ',name) + (assoc-value ,temp-vars ',name) + `(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) + ``(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) + `(assoc-value ,temp-vars ',name))))) + :from-end t))))))))))))) From 7e3dbe4b0e880535f339a1cd9b64c34e9cd05c86 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Sat, 7 Oct 2023 14:52:48 +0800 Subject: [PATCH 08/28] Add option of wrapping the returned pointer as a cobject or cpointer --- defcfun.lisp | 14 +++++++++++--- definition.lisp | 7 ++++++- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/defcfun.lisp b/defcfun.lisp index f688162..8e6aa3d 100644 --- a/defcfun.lisp +++ b/defcfun.lisp @@ -9,7 +9,10 @@ (defparameter *return-argument-names* '(#:%%claw-result-)) +(defparameter *return-pointer-as-object-p* nil) + (defparameter *optimize-object-allocation-p* t) + (defparameter *optimize-out-temporary-object-p* t) (defun symbol-name= (sym1 sym2) @@ -113,9 +116,14 @@ (with-gensyms (result) `(lambda (,result) ,(cond - (return-object-from-result-p (let ((internal-constructor (nth-value 2 (cobject-type-constructor return-object-from-result-p)))) - `(locally (declare (notinline ,internal-constructor)) (,internal-constructor :pointer ,result)))) - (return-pointer-from-result-p `(pointer-cpointer ,result ',(cobject-class-definition-class (find-cobject-class-definition (cffi::pointer-type return-pointer-from-result-p))))) + ((and return-object-from-result-p *return-pointer-as-object-p*) + (let ((internal-constructor (nth-value 2 (cobject-type-constructor return-object-from-result-p)))) + `(locally (declare (notinline ,internal-constructor)) (,internal-constructor :pointer ,result)))) + (return-pointer-from-result-p `(pointer-cpointer ,result ',(or (ignore-some-conditions (cobject-class-definition-not-found-error) + (cobject-class-definition-class + (find-cobject-class-definition + (cffi::pointer-type return-pointer-from-result-p)))) + (cffi::name (cffi::pointer-type return-pointer-from-result-p))))) (t result)))))) `(progn (defun ,symbol ,(mapcar #'car args) diff --git a/definition.lisp b/definition.lisp index cee1381..8bc8310 100644 --- a/definition.lisp +++ b/definition.lisp @@ -72,6 +72,11 @@ ((cpointer element-type) as-pointer))) (error "Undefined CFFI object class ~A." type))))) +(define-condition cobject-class-definition-not-found-error (error) + ((type :initform nil :initarg :type :type cffi::foreign-type)) + (:report (lambda (condition stream) + (format stream "Cannot find the CFFI object class for type ~A." (cffi::name (slot-value condition 'type)))))) + (defun find-cobject-class-definition (type) "Get the class definition of a cobject at compile-time." (check-type type cffi::foreign-type) @@ -95,4 +100,4 @@ (cffi::foreign-pointer-type `(cpointer ,(cobject-class-definition-class (find-cobject-class-definition (cffi::pointer-type type)))))))))) - (error "Cannot find the CFFI object class for type ~A." (cffi::name type)))) + (error 'cobject-class-definition-not-found-error :type type))) From 1d2361f5bf7624b37b82aed72051057d8e4eaad6 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Sat, 7 Oct 2023 15:01:58 +0800 Subject: [PATCH 09/28] Add support for upgrading cpointer to carray --- array.lisp | 11 ++++++++--- package.lisp | 1 + 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/array.lisp b/array.lisp index 76ca33b..f61bb55 100644 --- a/array.lisp +++ b/array.lisp @@ -4,6 +4,12 @@ (:constructor %make-carray)) (dimensions '(0) :type (cons fixnum null))) +(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)) @@ -62,9 +68,8 @@ 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)) diff --git a/package.lisp b/package.lisp index 6ddc6aa..2969a03 100644 --- a/package.lisp +++ b/package.lisp @@ -12,6 +12,7 @@ #:carray #:make-carray #:pointer-carray + #:cpointer-carray #:carray-dimensions #:carray-displacement #:carray-element-type From 4e8e02302c379a5ef04fac66162762068b5abd74 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Sun, 8 Oct 2023 15:46:15 +0800 Subject: [PATCH 10/28] Rename `foreign-allocator` to `cobject-allocator` --- allocator.lisp | 46 +++++++++++++++++++++++----------------------- array.lisp | 2 +- macros.lisp | 4 ++-- object.lisp | 2 +- test/package.lisp | 18 +++++++++--------- 5 files changed, 36 insertions(+), 36 deletions(-) diff --git a/allocator.lisp b/allocator.lisp index 19caa44..06fd633 100644 --- a/allocator.lisp +++ b/allocator.lisp @@ -1,23 +1,23 @@ (in-package #:cffi-object) -(defstruct foreign-allocator +(defstruct cobject-allocator (allocator (constantly (cffi:null-pointer)) :type (function (non-negative-fixnum) (values cffi:foreign-pointer))) (deallocator #'values :type (function (cffi:foreign-pointer)))) -(declaim (type foreign-allocator *default-foreign-allocator*)) -(defparameter *default-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 #'cffi-sys:%foreign-alloc :deallocator #'cffi-sys:foreign-free)) -(declaim (type foreign-allocator *foreign-allocator*)) -(defparameter *foreign-allocator* *default-foreign-allocator*) +(declaim (type cobject-allocator *cobject-allocator*)) +(defparameter *cobject-allocator* *default-cobject-allocator*) (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) (upstream *foreign-allocator*)) +(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 (size) @@ -32,9 +32,9 @@ (prog1 (cffi:inc-pointer pointer offset) (incf offset size)) (if upstream - (prog1 (funcall (foreign-allocator-allocator upstream) size) + (prog1 (funcall (cobject-allocator-allocator upstream) size) (setf offset buffer-size) - (setf deallocator (foreign-allocator-deallocator upstream))) + (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) @@ -43,24 +43,24 @@ (defmacro with-monotonic-buffer-allocator ((&key buffer (size (if buffer `(length ,buffer) 128)) - (upstream '*foreign-allocator*) + (upstream '*cobject-allocator*) (values '#'values)) &body body) (with-gensyms (buffer-var pointer size-var allocator) (flet ((wrap-with-buffer-var (form) - (if buffer - `(let ((,buffer-var ,buffer)) ,form) - `(let ((,buffer-var (cffi:make-shareable-byte-vector ,size-var))) - (declare (dynamic-extent ,buffer-var)) ,form)))) - `(let ((,size-var ,size)) - ,(wrap-with-buffer-var - `(cffi:with-pointer-to-vector-data (,pointer ,buffer-var) - (let ((,allocator (make-sized-monotonic-buffer-allocator :pointer ,pointer :size ,size-var :upstream ,upstream))) - (declare (dynamic-extent ,allocator)) - (multiple-value-call ,values - (let ((*foreign-allocator* ,allocator)) - ,@body))))))))) + (if buffer + `(let ((,buffer-var ,buffer)) ,form) + `(let ((,buffer-var (cffi:make-shareable-byte-vector ,size-var))) + (declare (dynamic-extent ,buffer-var)) ,form)))) + `(let ((,size-var ,size)) + ,(wrap-with-buffer-var + `(cffi:with-pointer-to-vector-data (,pointer ,buffer-var) + (let ((,allocator (make-sized-monotonic-buffer-allocator :pointer ,pointer :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 ((*foreign-allocator* *default-foreign-allocator*)) + `(let ((*cobject-allocator* *default-cobject-allocator*)) ,@body)) diff --git a/array.lisp b/array.lisp index f61bb55..39a3aae 100644 --- a/array.lisp +++ b/array.lisp @@ -75,7 +75,7 @@ (element-size (cobject-class-object-size element-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*) total-size))) (array (if displaced-to (progn (assert (<= 0 displaced-index-offset (+ displaced-index-offset (first dimensions)) (first (carray-dimensions displaced-to)))) diff --git a/macros.lisp b/macros.lisp index 80724dd..e90b9be 100644 --- a/macros.lisp +++ b/macros.lisp @@ -119,7 +119,7 @@ ,pointer)) (declaim (inline ,constructor)) (defun ,constructor (&key . ,(mapcar #'list slots (mapcar (constantly nil) slots) slot-supplied-p-list)) - (let* ((,pointer (funcall (foreign-allocator-allocator *foreign-allocator*) (cffi:foreign-type-size ',type))) + (let* ((,pointer (funcall (cobject-allocator-allocator *cobject-allocator*) (cffi:foreign-type-size ',type))) (,instance (,internal-constructor :pointer ,pointer))) ,@(loop :for slot :in slots :for slot-type := (cffi::ensure-parsed-base-type (cffi:foreign-slot-type type slot)) @@ -134,7 +134,7 @@ (cobject-pointer ,instance2) (cffi:foreign-type-size ',type))))) (declaim (inline ,copier)) - (defun ,copier (,instance &optional (,destination (manage-cobject (,internal-constructor :pointer (funcall (foreign-allocator-allocator *foreign-allocator*) (cffi:foreign-type-size ',type)))))) + (defun ,copier (,instance &optional (,destination (manage-cobject (,internal-constructor :pointer (funcall (cobject-allocator-allocator *cobject-allocator*) (cffi:foreign-type-size ',type)))))) (check-type ,instance ,name) (check-type ,destination ,name) (memcpy (cobject-pointer ,destination) (cobject-pointer ,instance) (cffi:foreign-type-size ',type)) diff --git a/object.lisp b/object.lisp index 4822aae..34786f2 100644 --- a/object.lisp +++ b/object.lisp @@ -20,7 +20,7 @@ (defun manage-cobject (cobject) (let ((pointer (cobject-pointer cobject)) - (deallocator (foreign-allocator-deallocator *foreign-allocator*))) + (deallocator (cobject-allocator-deallocator *cobject-allocator*))) (tg:finalize cobject (lambda () (funcall deallocator pointer))))) (defun unmanage-cobject (cobject) diff --git a/test/package.lisp b/test/package.lisp index e64ea86..bb1da77 100644 --- a/test/package.lisp +++ b/test/package.lisp @@ -307,17 +307,17 @@ (define-test monotonic-buffer-allocator :parent suite (with-monotonic-buffer-allocator (:size 8) (with-monotonic-buffer-allocator (:size 8) - (of-type cobj::sized-monotonic-buffer-allocator cobj::*foreign-allocator*) + (of-type cobj::sized-monotonic-buffer-allocator cobj::*cobject-allocator*) (make-vector2) - (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*foreign-allocator*)) + (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*cobject-allocator*)) (make-vector2) - (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*foreign-allocator*)) - (is eq #'values (cobj::sized-monotonic-buffer-allocator-deallocator cobj::*foreign-allocator*)) + (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*cobject-allocator*)) + (is eq #'values (cobj::sized-monotonic-buffer-allocator-deallocator cobj::*cobject-allocator*)) (make-vector2) - (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*foreign-allocator*)) - (isnt eq #'values (cobj::sized-monotonic-buffer-allocator-deallocator cobj::*foreign-allocator*))) - (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*foreign-allocator*)) + (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*cobject-allocator*)) + (isnt eq #'values (cobj::sized-monotonic-buffer-allocator-deallocator cobj::*cobject-allocator*))) + (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*cobject-allocator*)) (make-vector2) - (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*foreign-allocator*)) - (isnt eq #'values (cobj::sized-monotonic-buffer-allocator-deallocator cobj::*foreign-allocator*))) + (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*cobject-allocator*)) + (isnt eq #'values (cobj::sized-monotonic-buffer-allocator-deallocator cobj::*cobject-allocator*))) (tg:gc :full t)) From b54de3d9048ef985a19da525dee9a43e808fd0b2 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Fri, 20 Oct 2023 10:12:01 +0800 Subject: [PATCH 11/28] Allow passing buffer pointer to `with-monotonic-buffer-allocator` --- allocator.lisp | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/allocator.lisp b/allocator.lisp index 06fd633..840c6ce 100644 --- a/allocator.lisp +++ b/allocator.lisp @@ -41,25 +41,30 @@ allocator-2)) (defmacro with-monotonic-buffer-allocator ((&key - buffer + buffer pointer (size (if buffer `(length ,buffer) 128)) (upstream '*cobject-allocator*) (values '#'values)) &body body) - (with-gensyms (buffer-var pointer size-var allocator) + (with-gensyms (buffer-var pointer-var size-var allocator) (flet ((wrap-with-buffer-var (form) - (if buffer - `(let ((,buffer-var ,buffer)) ,form) - `(let ((,buffer-var (cffi:make-shareable-byte-vector ,size-var))) - (declare (dynamic-extent ,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 - `(cffi:with-pointer-to-vector-data (,pointer ,buffer-var) - (let ((,allocator (make-sized-monotonic-buffer-allocator :pointer ,pointer :size ,size-var :upstream ,upstream))) - (declare (dynamic-extent ,allocator)) - (multiple-value-call ,values - (let ((*cobject-allocator* ,allocator)) - ,@body))))))))) + (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*)) From 4fdd41959cdbe8b3e59de033e381873001144a98 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Mon, 23 Oct 2023 16:35:09 +0800 Subject: [PATCH 12/28] Handle memory alignment in monotonic buffer allocator --- allocator.lisp | 27 +++++++++++++++------------ array.lisp | 10 ++++++++-- macros.lisp | 4 ++-- 3 files changed, 25 insertions(+), 16 deletions(-) diff --git a/allocator.lisp b/allocator.lisp index 840c6ce..1be79dd 100644 --- a/allocator.lisp +++ b/allocator.lisp @@ -1,11 +1,13 @@ (in-package #:cffi-object) (defstruct cobject-allocator - (allocator (constantly (cffi:null-pointer)) :type (function (non-negative-fixnum) (values cffi:foreign-pointer))) + (allocator (constantly (cffi:null-pointer)) :type (function (cffi::foreign-type) (values cffi:foreign-pointer))) (deallocator #'values :type (function (cffi:foreign-pointer)))) (declaim (type cobject-allocator *default-cobject-allocator*)) -(defparameter *default-cobject-allocator* (make-cobject-allocator :allocator #'cffi-sys:%foreign-alloc :deallocator #'cffi-sys:foreign-free)) +(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*) @@ -20,22 +22,23 @@ (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 (size) - (declare (type non-negative-fixnum size)) + (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)) - (if upstream - (prog1 (funcall (cobject-allocator-allocator upstream) size) - (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))))) + (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)) diff --git a/array.lisp b/array.lisp index 39a3aae..e02f90c 100644 --- a/array.lisp +++ b/array.lisp @@ -72,10 +72,13 @@ (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 (cobject-allocator-allocator *cobject-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)))) @@ -88,6 +91,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)) @@ -114,6 +119,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) diff --git a/macros.lisp b/macros.lisp index e90b9be..789bd0b 100644 --- a/macros.lisp +++ b/macros.lisp @@ -119,7 +119,7 @@ ,pointer)) (declaim (inline ,constructor)) (defun ,constructor (&key . ,(mapcar #'list slots (mapcar (constantly nil) slots) slot-supplied-p-list)) - (let* ((,pointer (funcall (cobject-allocator-allocator *cobject-allocator*) (cffi:foreign-type-size ',type))) + (let* ((,pointer (funcall (cobject-allocator-allocator *cobject-allocator*) ',type)) (,instance (,internal-constructor :pointer ,pointer))) ,@(loop :for slot :in slots :for slot-type := (cffi::ensure-parsed-base-type (cffi:foreign-slot-type type slot)) @@ -134,7 +134,7 @@ (cobject-pointer ,instance2) (cffi:foreign-type-size ',type))))) (declaim (inline ,copier)) - (defun ,copier (,instance &optional (,destination (manage-cobject (,internal-constructor :pointer (funcall (cobject-allocator-allocator *cobject-allocator*) (cffi:foreign-type-size ',type)))))) + (defun ,copier (,instance &optional (,destination (manage-cobject (,internal-constructor :pointer (funcall (cobject-allocator-allocator *cobject-allocator*) ',type))))) (check-type ,instance ,name) (check-type ,destination ,name) (memcpy (cobject-pointer ,destination) (cobject-pointer ,instance) (cffi:foreign-type-size ',type)) From be716dd103c0a223fcb53301cb180ca1f2332112 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Sun, 5 Nov 2023 22:02:28 +0800 Subject: [PATCH 13/28] Disable warning muffling on SBCL The bug in SBCL has been reported and fixed in thread https://sourceforge.net/p/sbcl/mailman/sbcl-bugs/thread/tencent_9C9549ADDEE1D71B17C21F6A48A451531206@qq.com. --- defcfun.lisp | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/defcfun.lisp b/defcfun.lisp index 8e6aa3d..5002c6d 100644 --- a/defcfun.lisp +++ b/defcfun.lisp @@ -67,9 +67,9 @@ `(:object ,(cffi::unparse-type ',object-type))) (defmethod funcall-dynamic-extent-form ((,function (eql ',symbol)) ,function-args) (declare (ignore ,function)) - #+sbcl (declare (sb-ext:muffle-conditions warning)) (destructuring-bind ,(mapcar #'car (cdr args)) ,function-args (let ((,temp-vars (list . ,(loop :for (name nil) :in args :collect `(cons ',name (gensym ,(symbol-name name))))))) + (declare (ignorable ,temp-vars)) (let ((,dynamic-extent-forms nil)) ,@(loop :for (name type) :in (cdr args) :if (cffi-pointer-type-p type) @@ -130,7 +130,6 @@ (,result-wrapper (,internal-symbol . ,(loop :for (name type) :in args :collect (if (cffi-pointer-type-p type) `(cobj:cobject-pointer ,name) name))))) ,(when (and *optimize-object-allocation-p* (loop :for (nil type) :in args :thereis (cffi-pointer-type-p type))) `(define-compiler-macro ,symbol ,(mapcar #'car args) - #+sbcl (declare (sb-ext:muffle-conditions warning)) ,(with-gensyms (dynamic-extent-forms dynamic-extent-form body temp-vars name form result) `(let ((,temp-vars (list . ,(loop :for (name nil) :in args :collect `(cons ',name (gensym ,(symbol-name name)))))) (,dynamic-extent-forms nil)) From 09248196bf5b18714b9cb1d7e3d803b4d8e62fd9 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Wed, 22 Nov 2023 15:39:42 +0800 Subject: [PATCH 14/28] Do not add unnecessary finalizers for cobjects --- object.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/object.lisp b/object.lisp index 34786f2..b107687 100644 --- a/object.lisp +++ b/object.lisp @@ -21,7 +21,7 @@ (defun manage-cobject (cobject) (let ((pointer (cobject-pointer cobject)) (deallocator (cobject-allocator-deallocator *cobject-allocator*))) - (tg:finalize cobject (lambda () (funcall deallocator pointer))))) + (if (eq deallocator #'values) cobject (tg:finalize cobject (lambda () (funcall deallocator pointer)))))) (defun unmanage-cobject (cobject) (tg:cancel-finalization cobject) From 9850fc068e0f862b0c8e65d3ad6eca8e1d47ad85 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Sat, 25 Nov 2023 19:53:59 +0800 Subject: [PATCH 15/28] Add support for printing cobjects readably --- array.lisp | 41 +++++++++++++++++++++++++---------------- macros.lisp | 22 +++++++++++++++------- pointer.lisp | 16 ++++++++++++---- test/package.lisp | 18 ++++++++++++++++++ 4 files changed, 70 insertions(+), 27 deletions(-) diff --git a/array.lisp b/array.lisp index e02f90c..c3399e0 100644 --- a/array.lisp +++ b/array.lisp @@ -26,22 +26,31 @@ (first (carray-dimensions carray))) (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 ',(carray-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 (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)))))) (defstruct (displaced-carray (:include carray) (:constructor %make-displaced-carray)) diff --git a/macros.lisp b/macros.lisp index 789bd0b..6823864 100644 --- a/macros.lisp +++ b/macros.lisp @@ -139,13 +139,21 @@ (check-type ,destination ,name) (memcpy (cobject-pointer ,destination) (cobject-pointer ,instance) (cffi:foreign-type-size ',type)) ,destination) - (defmethod print-object ((,instance ,name) ,stream) - (print-unreadable-object (,instance ,stream) - (princ ,(string name) ,stream) - ,@(loop :for (slot . slot-accessor) :in slot-accessors - :collect `(format ,stream ," :~A ~S" ,(symbol-name slot) (,slot-accessor ,instance))) - (format ,stream ,(concatenate 'string " @0x~" (prin1-to-string (* 2 (cffi:foreign-type-size :size))) ",'0X") - (cffi:pointer-address (cobject-pointer ,instance))))) + ,(with-gensyms (print-slots) + `(defmethod print-object ((,instance ,name) ,stream) + (flet ((,print-slots () + ,@(loop :for (slot . slot-accessor) :in slot-accessors + :collect `(format ,stream ," :~A ~S" ',slot (,slot-accessor ,instance))))) + (if *print-readably* + (progn + (format ,stream "#.(~S" ',constructor) + (,print-slots) + (format ,stream ")")) + (print-unreadable-object (,instance ,stream) + (format ,stream "~S" ',name) + (,print-slots) + (format ,stream ,(concatenate 'string " @0x~" (prin1-to-string (* 2 (cffi:foreign-type-size :size))) ",'0X") + (cffi:pointer-address (cobject-pointer ,instance)))))))) (eval-when (:compile-toplevel :load-toplevel :execute) (setf (assoc-value *cobject-class-definitions* ',type) ,cobject-class-definition))))))))) diff --git a/pointer.lisp b/pointer.lisp index 773dfff..a33d469 100644 --- a/pointer.lisp +++ b/pointer.lisp @@ -5,10 +5,18 @@ (element-type nil :type (or symbol cons))) (defmethod print-object ((pointer cpointer) stream) - (print-unreadable-object (pointer stream) - (format stream #.(concatenate 'string "~A @0x~" (prin1-to-string (* 2 (cffi:foreign-type-size :size))) ",'0X") - (cpointer-element-type pointer) - (cffi:pointer-address (cobject-pointer pointer))))) + (if *print-readably* + (progn + (format stream "#.") + (prin1 `(pointer-cpointer + (cffi:make-pointer + ',(cffi:pointer-address (cpointer-pointer pointer))) + ',(cpointer-element-type pointer)) + stream)) + (print-unreadable-object (pointer stream) + (format stream #.(concatenate 'string "~A @0x~" (prin1-to-string (* 2 (cffi:foreign-type-size :size))) ",'0X") + (cpointer-element-type pointer) + (cffi:pointer-address (cobject-pointer pointer)))))) (defun cref (cpointer &optional (subscript 0)) (multiple-value-bind (definition type) diff --git a/test/package.lisp b/test/package.lisp index bb1da77..1744de7 100644 --- a/test/package.lisp +++ b/test/package.lisp @@ -321,3 +321,21 @@ (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*cobject-allocator*)) (isnt eq #'values (cobj::sized-monotonic-buffer-allocator-deallocator cobj::*cobject-allocator*))) (tg:gc :full t)) + +(define-test readable-cobject :parent suite :fix (*print-readably*) + (setf *print-readably* t) + (define-test readable-cpointer + (let ((cpointer (pointer-cpointer (make-pointer 1234) '(unsigned-byte 32)))) + (is cpointer-eq cpointer (read-from-string (prin1-to-string cpointer))))) + (define-test readable-carray + (let* ((carray (make-carray 10 :element-type '(unsigned-byte 32))) + (displaced-carray (make-carray 10 :element-type '(unsigned-byte 32) + :displaced-to carray))) + (is carray-equal carray (read-from-string (prin1-to-string carray))) + (is carray-equal displaced-carray (read-from-string (prin1-to-string displaced-carray))))) + (define-test readable-simple-cobject + (let ((vector2 (make-vector2))) + (is vector2-equal vector2 (read-from-string (prin1-to-string vector2))))) + (define-test readable-complex-cobject + (let ((camera-2d (make-camera-2d))) + (is camera-2d-equal camera-2d (read-from-string (prin1-to-string camera-2d)))))) From 43fbf8eb60b87dd805d0f3ebaa78e27c14f8ac8c Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Thu, 11 Jan 2024 17:37:10 +0800 Subject: [PATCH 16/28] Fix `find-cobject-class-definition` for `cffi:foreign-string-type` --- definition.lisp | 39 +++++++++++++++++++-------------------- 1 file changed, 19 insertions(+), 20 deletions(-) diff --git a/definition.lisp b/definition.lisp index 8bc8310..2847b66 100644 --- a/definition.lisp +++ b/definition.lisp @@ -81,23 +81,22 @@ "Get the class definition of a cobject at compile-time." (check-type type cffi::foreign-type) (or (assoc-value *cobject-class-definitions* type) - (and (typep type 'cffi::foreign-built-in-type) - (make-cobject-class-definition - :class (case type - (#.(cffi::ensure-parsed-base-type :float) 'single-float) - (#.(cffi::ensure-parsed-base-type :double) 'double-float) - (#.(cffi::ensure-parsed-base-type :string) 'string) - (#.(mapcar #'cffi::ensure-parsed-base-type '(:int8 :int16 :int32 :int64)) - `(signed-byte ,(* (cffi:foreign-type-size type) 8))) - (#.(mapcar #'cffi::ensure-parsed-base-type '(:uint8 :uint16 :uint32 :uint64)) - `(unsigned-byte ,(* (cffi:foreign-type-size type) 8))) - (#.(cffi::ensure-parsed-base-type :void) 'null) - (t (etypecase type - (cffi::foreign-array-type - `(carray ,(cobject-class-definition-class - (find-cobject-class-definition (cffi::element-type type))) - ,(cffi::dimensions type))) - (cffi::foreign-pointer-type - `(cpointer ,(cobject-class-definition-class - (find-cobject-class-definition (cffi::pointer-type type)))))))))) - (error 'cobject-class-definition-not-found-error :type type))) + (make-cobject-class-definition + :class (case type + (#.(cffi::ensure-parsed-base-type :float) 'single-float) + (#.(cffi::ensure-parsed-base-type :double) 'double-float) + (#.(mapcar #'cffi::ensure-parsed-base-type '(:int8 :int16 :int32 :int64)) + `(signed-byte ,(* (cffi:foreign-type-size type) 8))) + (#.(mapcar #'cffi::ensure-parsed-base-type '(:uint8 :uint16 :uint32 :uint64)) + `(unsigned-byte ,(* (cffi:foreign-type-size type) 8))) + (#.(cffi::ensure-parsed-base-type :void) 'null) + (t (typecase type + (cffi::foreign-string-type 'string) + (cffi::foreign-array-type + `(carray ,(cobject-class-definition-class + (find-cobject-class-definition (cffi::element-type type))) + ,(cffi::dimensions type))) + (cffi::foreign-pointer-type + `(cpointer ,(cobject-class-definition-class + (find-cobject-class-definition (cffi::pointer-type type))))) + (t (error 'cobject-class-definition-not-found-error :type type)))))))) From 4780de3779ec5fbc6f8f4838645e92da130c9667 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Fri, 12 Jan 2024 23:15:07 +0800 Subject: [PATCH 17/28] Allow recursive cobject class definitions --- macros.lisp | 201 ++++++++++++++++++++++++++-------------------------- 1 file changed, 101 insertions(+), 100 deletions(-) diff --git a/macros.lisp b/macros.lisp index 6823864..dcc2c5f 100644 --- a/macros.lisp +++ b/macros.lisp @@ -54,108 +54,109 @@ (when-let ((constructor-option (getf options :constructor))) (setf (getf (cdr cobject-class-definition) :constructor) `',(setf constructor constructor-option))) (with-gensyms (pointer instance value stream destination) - `(progn - (declaim (inline ,internal-constructor)) - (defstruct (,name - (:include cobject) - (:predicate ,predicate) - (:copier nil) - (:constructor ,internal-constructor))) - ,@(loop :for (slot . slot-accessor) :in slot-accessors - :for slot-type := (cffi::ensure-parsed-base-type (cffi:foreign-slot-type type slot)) - :for slot-pointer := `(cffi:foreign-slot-pointer (cobject-pointer ,instance) ',type ',slot) - :for slot-value := `(cffi:foreign-slot-value (cobject-pointer ,instance) ',type ',slot) - :nconc `((declaim (inline ,slot-accessor)) - (defun ,slot-accessor (,instance) - ,(typecase slot-type - (cffi::foreign-struct-type - `(,(cobject-class-definition-internal-constructor - (find-cobject-class-definition slot-type)) - :pointer ,slot-pointer - :shared-from ,instance)) - (cffi::foreign-array-type - `(%make-carray - :pointer ,slot-pointer - :shared-from ,instance - :dimensions ',(cffi::dimensions slot-type) - :element-type ',(cobject-class-definition-class - (find-cobject-class-definition - (cffi::ensure-parsed-base-type - (cffi::element-type slot-type)))))) - (cffi::foreign-pointer-type - `(%make-cpointer - :pointer ,slot-value - :shared-from ,instance - :element-type ',(cobject-class-definition-class - (find-cobject-class-definition - (cffi::ensure-parsed-base-type - (cffi::pointer-type slot-type)))))) - (t slot-value))) - (declaim (inline (setf ,slot-accessor))) - (defun (setf ,slot-accessor) (,value ,instance) - ,(typecase slot-type - (cffi::foreign-struct-type - `(memcpy ,slot-pointer (cobject-pointer ,value) (cffi:foreign-type-size ',slot-type))) - (cffi::foreign-array-type - `(creplace (,slot-accessor ,instance) ,value)) - (cffi::foreign-pointer-type - `(setf ,slot-value (cobject-pointer ,value))) - (t `(setf ,slot-value ,value)))))) - (declaim (inline ,in-place-constructor)) - (defun ,in-place-constructor (,pointer &key . ,(mapcar #'list slots (mapcar (constantly nil) slots) slot-supplied-p-list)) - (let ((,instance (,internal-constructor :pointer ,pointer))) - (declare (ignorable ,instance) (dynamic-extent ,instance)) - ,@(loop :for slot :in slots - :for slot-type := (cffi::ensure-parsed-base-type (cffi:foreign-slot-type type slot)) - :for slot-supplied-p :in slot-supplied-p-list - :if (typep slot-type '(or cffi::foreign-struct-type cffi::foreign-array-type cffi::foreign-pointer-type)) - :collect `(when ,slot-supplied-p - (let ((,value (make-cobject :pointer ,slot))) - (declare (dynamic-extent ,value)) - (setf (,(assoc-value slot-accessors slot) ,instance) ,value))) - :else + (let ((*cobject-class-definitions* (acons type (eval cobject-class-definition) *cobject-class-definitions*))) + `(progn + (declaim (inline ,internal-constructor)) + (defstruct (,name + (:include cobject) + (:predicate ,predicate) + (:copier nil) + (:constructor ,internal-constructor))) + ,@(loop :for (slot . slot-accessor) :in slot-accessors + :for slot-type := (cffi::ensure-parsed-base-type (cffi:foreign-slot-type type slot)) + :for slot-pointer := `(cffi:foreign-slot-pointer (cobject-pointer ,instance) ',type ',slot) + :for slot-value := `(cffi:foreign-slot-value (cobject-pointer ,instance) ',type ',slot) + :nconc `((declaim (inline ,slot-accessor)) + (defun ,slot-accessor (,instance) + ,(typecase slot-type + (cffi::foreign-struct-type + `(,(cobject-class-definition-internal-constructor + (find-cobject-class-definition slot-type)) + :pointer ,slot-pointer + :shared-from ,instance)) + (cffi::foreign-array-type + `(%make-carray + :pointer ,slot-pointer + :shared-from ,instance + :dimensions ',(cffi::dimensions slot-type) + :element-type ',(cobject-class-definition-class + (find-cobject-class-definition + (cffi::ensure-parsed-base-type + (cffi::element-type slot-type)))))) + (cffi::foreign-pointer-type + `(%make-cpointer + :pointer ,slot-value + :shared-from ,instance + :element-type ',(cobject-class-definition-class + (find-cobject-class-definition + (cffi::ensure-parsed-base-type + (cffi::pointer-type slot-type)))))) + (t slot-value))) + (declaim (inline (setf ,slot-accessor))) + (defun (setf ,slot-accessor) (,value ,instance) + ,(typecase slot-type + (cffi::foreign-struct-type + `(memcpy ,slot-pointer (cobject-pointer ,value) (cffi:foreign-type-size ',slot-type))) + (cffi::foreign-array-type + `(creplace (,slot-accessor ,instance) ,value)) + (cffi::foreign-pointer-type + `(setf ,slot-value (cobject-pointer ,value))) + (t `(setf ,slot-value ,value)))))) + (declaim (inline ,in-place-constructor)) + (defun ,in-place-constructor (,pointer &key . ,(mapcar #'list slots (mapcar (constantly nil) slots) slot-supplied-p-list)) + (let ((,instance (,internal-constructor :pointer ,pointer))) + (declare (ignorable ,instance) (dynamic-extent ,instance)) + ,@(loop :for slot :in slots + :for slot-type := (cffi::ensure-parsed-base-type (cffi:foreign-slot-type type slot)) + :for slot-supplied-p :in slot-supplied-p-list + :if (typep slot-type '(or cffi::foreign-struct-type cffi::foreign-array-type cffi::foreign-pointer-type)) + :collect `(when ,slot-supplied-p + (let ((,value (make-cobject :pointer ,slot))) + (declare (dynamic-extent ,value)) + (setf (,(assoc-value slot-accessors slot) ,instance) ,value))) + :else + :collect `(when ,slot-supplied-p + (setf (,(assoc-value slot-accessors slot) ,instance) ,slot))) + ,pointer)) + (declaim (inline ,constructor)) + (defun ,constructor (&key . ,(mapcar #'list slots (mapcar (constantly nil) slots) slot-supplied-p-list)) + (let* ((,pointer (funcall (cobject-allocator-allocator *cobject-allocator*) ',type)) + (,instance (,internal-constructor :pointer ,pointer))) + ,@(loop :for slot :in slots + :for slot-type := (cffi::ensure-parsed-base-type (cffi:foreign-slot-type type slot)) + :for slot-supplied-p :in slot-supplied-p-list :collect `(when ,slot-supplied-p (setf (,(assoc-value slot-accessors slot) ,instance) ,slot))) - ,pointer)) - (declaim (inline ,constructor)) - (defun ,constructor (&key . ,(mapcar #'list slots (mapcar (constantly nil) slots) slot-supplied-p-list)) - (let* ((,pointer (funcall (cobject-allocator-allocator *cobject-allocator*) ',type)) - (,instance (,internal-constructor :pointer ,pointer))) - ,@(loop :for slot :in slots - :for slot-type := (cffi::ensure-parsed-base-type (cffi:foreign-slot-type type slot)) - :for slot-supplied-p :in slot-supplied-p-list - :collect `(when ,slot-supplied-p - (setf (,(assoc-value slot-accessors slot) ,instance) ,slot))) - (manage-cobject ,instance))) - (declaim (inline ,equality-comparator)) - ,(with-gensyms (instance1 instance2) - `(defun ,equality-comparator (,instance1 ,instance2) - (zerop (memcmp (cobject-pointer ,instance1) - (cobject-pointer ,instance2) - (cffi:foreign-type-size ',type))))) - (declaim (inline ,copier)) - (defun ,copier (,instance &optional (,destination (manage-cobject (,internal-constructor :pointer (funcall (cobject-allocator-allocator *cobject-allocator*) ',type))))) - (check-type ,instance ,name) - (check-type ,destination ,name) - (memcpy (cobject-pointer ,destination) (cobject-pointer ,instance) (cffi:foreign-type-size ',type)) - ,destination) - ,(with-gensyms (print-slots) - `(defmethod print-object ((,instance ,name) ,stream) - (flet ((,print-slots () - ,@(loop :for (slot . slot-accessor) :in slot-accessors - :collect `(format ,stream ," :~A ~S" ',slot (,slot-accessor ,instance))))) - (if *print-readably* - (progn - (format ,stream "#.(~S" ',constructor) - (,print-slots) - (format ,stream ")")) - (print-unreadable-object (,instance ,stream) - (format ,stream "~S" ',name) - (,print-slots) - (format ,stream ,(concatenate 'string " @0x~" (prin1-to-string (* 2 (cffi:foreign-type-size :size))) ",'0X") - (cffi:pointer-address (cobject-pointer ,instance)))))))) - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (assoc-value *cobject-class-definitions* ',type) ,cobject-class-definition))))))))) + (manage-cobject ,instance))) + (declaim (inline ,equality-comparator)) + ,(with-gensyms (instance1 instance2) + `(defun ,equality-comparator (,instance1 ,instance2) + (zerop (memcmp (cobject-pointer ,instance1) + (cobject-pointer ,instance2) + (cffi:foreign-type-size ',type))))) + (declaim (inline ,copier)) + (defun ,copier (,instance &optional (,destination (manage-cobject (,internal-constructor :pointer (funcall (cobject-allocator-allocator *cobject-allocator*) ',type))))) + (check-type ,instance ,name) + (check-type ,destination ,name) + (memcpy (cobject-pointer ,destination) (cobject-pointer ,instance) (cffi:foreign-type-size ',type)) + ,destination) + ,(with-gensyms (print-slots) + `(defmethod print-object ((,instance ,name) ,stream) + (flet ((,print-slots () + ,@(loop :for (slot . slot-accessor) :in slot-accessors + :collect `(format ,stream ," :~A ~S" ',slot (,slot-accessor ,instance))))) + (if *print-readably* + (progn + (format ,stream "#.(~S" ',constructor) + (,print-slots) + (format ,stream ")")) + (print-unreadable-object (,instance ,stream) + (format ,stream "~S" ',name) + (,print-slots) + (format ,stream ,(concatenate 'string " @0x~" (prin1-to-string (* 2 (cffi:foreign-type-size :size))) ",'0X") + (cffi:pointer-address (cobject-pointer ,instance)))))))) + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (assoc-value *cobject-class-definitions* ',type) ,cobject-class-definition)))))))))) (defmacro define-type-cobject-class (desc) (with-parsed-desc (name type) desc From 515f121f67b5fcb6b33a21729eb81a28baadd266 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Fri, 12 Jan 2024 23:16:23 +0800 Subject: [PATCH 18/28] Fix `define-prototype-cobject-class` --- macros.lisp | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/macros.lisp b/macros.lisp index dcc2c5f..3a7801d 100644 --- a/macros.lisp +++ b/macros.lisp @@ -40,9 +40,15 @@ (defmacro define-prototype-cobject-class (desc) (with-parsed-desc (name type) desc - (with-new-cobject-class-definition (name type) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (setf (assoc-value *cobject-class-definitions* ',type) ,cobject-class-definition))))) + `(progn + ,(with-new-cobject-class-definition (name type) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (assoc-value *cobject-class-definitions* ',type) ,cobject-class-definition))) + ,(let ((base-type (cffi::ensure-parsed-base-type type))) + (unless (or (eq type base-type) (assoc-value *cobject-class-definitions* base-type)) + (with-new-cobject-class-definition (name base-type) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (assoc-value *cobject-class-definitions* ',base-type) ,cobject-class-definition)))))))) (defmacro define-struct-cobject-class (desc &rest options) (let ((options (reduce #'append options))) From 446c2453dd4976410c3fbaeb98d1771c61953018 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Mon, 19 Feb 2024 19:47:23 +0800 Subject: [PATCH 19/28] Allow using `define-global-cobject` to define global carrays --- array.lisp | 3 +++ definition.lisp | 23 ++++++++++++++--------- global.lisp | 6 +++--- object.lisp | 4 ++++ pointer.lisp | 3 +++ 5 files changed, 27 insertions(+), 12 deletions(-) diff --git a/array.lisp b/array.lisp index c3399e0..6d24410 100644 --- a/array.lisp +++ b/array.lisp @@ -4,6 +4,9 @@ (: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) diff --git a/definition.lisp b/definition.lisp index 2847b66..aa75655 100644 --- a/definition.lisp +++ b/definition.lisp @@ -46,15 +46,20 @@ (t nil)) primitive-type) (if (listp type) - (symbol-macrolet ((as-array (values (make-cobject-class-definition - :class type - :internal-constructor (lambda (&key pointer shared-from) - (%make-carray :pointer pointer - :shared-from shared-from - :element-type element-type - :dimensions dimensions))) - (make-instance 'cffi::foreign-array-type :element-type (nth-value 1 (cobject-class-definition element-type)) - :dimensions dimensions))) + (symbol-macrolet ((as-array (let ((ctype (make-instance + 'cffi::foreign-array-type + :element-type (nth-value 1 (cobject-class-definition element-type)) + :dimensions dimensions)) + (internal-constructor (lambda (&key pointer shared-from) + (%make-carray :pointer pointer + :shared-from shared-from + :element-type element-type + :dimensions dimensions)))) + (values (make-cobject-class-definition + :class type + :internal-constructor internal-constructor + :constructor (lambda () (manage-cobject (funcall internal-constructor :pointer (cffi:foreign-alloc ctype))))) + ctype))) (as-pointer (values (make-cobject-class-definition :class type :internal-constructor (lambda (&key pointer shared-from) diff --git a/global.lisp b/global.lisp index 7a771b2..9b9e7c1 100644 --- a/global.lisp +++ b/global.lisp @@ -6,12 +6,12 @@ (loop :with definitions := *cobject-class-definitions* :for (name . value) :in *global-cobjects* :for cobject := (symbol-value name) - :for class := (class-of (symbol-value name)) - :for (ctype . definition) := (rassoc (class-name class) definitions :key #'cobject-class-definition-class) + :for type := (cobject-type (symbol-value name)) + :for (definition ctype) := (multiple-value-list (cobject-class-definition type)) :for constructor := (cobject-class-definition-constructor definition) :for size := (cffi:foreign-type-size ctype) :nconc (carray-list (pointer-carray (cobject-pointer cobject) '(unsigned-byte 8) size)) :into data - :collect (let ((constructor (fdefinition constructor)) (size size) + :collect (let ((constructor (ensure-function constructor)) (size size) (offset offset) (symbol name)) (lambda (bytes) (let ((cobject (funcall constructor))) diff --git a/object.lisp b/object.lisp index b107687..ec511c2 100644 --- a/object.lisp +++ b/object.lisp @@ -26,3 +26,7 @@ (defun unmanage-cobject (cobject) (tg:cancel-finalization cobject) (cobject-pointer cobject)) + +(defgeneric cobject-type (object) + (:method (object) + (type-of object))) diff --git a/pointer.lisp b/pointer.lisp index a33d469..6d5b773 100644 --- a/pointer.lisp +++ b/pointer.lisp @@ -4,6 +4,9 @@ (:constructor %make-cpointer)) (element-type nil :type (or symbol cons))) +(defmethod cobject-type ((pointer cpointer)) + `(cpointer ,(cpointer-element-type pointer))) + (defmethod print-object ((pointer cpointer) stream) (if *print-readably* (progn From 4b69bbddbfb8c27203b1f3723d1bcf26f31a85fe Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Mon, 11 Mar 2024 22:38:40 +0800 Subject: [PATCH 20/28] Use `ccoerce` to unify the carray conversion functions to sequences --- array.lisp | 61 +++++++++++++++++++++++++++++++---------------- global.lisp | 2 +- package.lisp | 4 +--- test/package.lisp | 20 ++++++++-------- 4 files changed, 53 insertions(+), 34 deletions(-) diff --git a/array.lisp b/array.lisp index 6d24410..60e1211 100644 --- a/array.lisp +++ b/array.lisp @@ -28,6 +28,45 @@ (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) (if *print-readably* (progn @@ -36,7 +75,7 @@ `(make-carray ',(carray-dimensions array) :element-type ',(carray-element-type array) - :initial-contents ',(carray-array array)) + :initial-contents ',(ccoerce array 'array)) stream)) (print-unreadable-object (array stream) (loop :named print-element-loop @@ -45,7 +84,7 @@ (case (carray-element-type array) (character (ignore-errors (return-from print-element-loop - (print-object (carray-string array) stream))))) + (print-object (ccoerce array 'string) stream))))) :for i :below length :if (< i 10) :unless (zerop i) @@ -69,12 +108,6 @@ (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 @@ -176,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)))) diff --git a/global.lisp b/global.lisp index 9b9e7c1..a391b51 100644 --- a/global.lisp +++ b/global.lisp @@ -10,7 +10,7 @@ :for (definition ctype) := (multiple-value-list (cobject-class-definition type)) :for constructor := (cobject-class-definition-constructor definition) :for size := (cffi:foreign-type-size ctype) - :nconc (carray-list (pointer-carray (cobject-pointer cobject) '(unsigned-byte 8) size)) :into data + :nconc (ccoerce (pointer-carray (cobject-pointer cobject) '(unsigned-byte 8) size) 'list) :into data :collect (let ((constructor (ensure-function constructor)) (size size) (offset offset) (symbol name)) (lambda (bytes) diff --git a/package.lisp b/package.lisp index 2969a03..b7ea37e 100644 --- a/package.lisp +++ b/package.lisp @@ -16,9 +16,7 @@ #:carray-dimensions #:carray-displacement #:carray-element-type - #:carray-list - #:carray-array - #:carray-string + #:ccoerce #:caref #:clength #:creplace diff --git a/test/package.lisp b/test/package.lisp index 1744de7..3643280 100644 --- a/test/package.lisp +++ b/test/package.lisp @@ -250,7 +250,7 @@ :initial-element 3)) (arr4 (make-carray 3 :element-type '(cpointer (signed-byte 8)) :initial-contents (list arr1 arr2 arr3)))) - (loop :for ptr :in (carray-list arr4) + (loop :for ptr :in (ccoerce arr4 'list) :for arr :in (list arr1 arr2 arr3) :do (is cobject-eq arr ptr) (is = (caref arr 0) (cref ptr))))) @@ -264,7 +264,7 @@ :initial-element 3)) (arr4 (make-carray 3 :element-type '(carray (signed-byte 8) 1) :initial-contents (list arr1 arr2 arr3)))) - (loop :for ptr :in (carray-list arr4) + (loop :for ptr :in (ccoerce arr4 'list) :for arr :in (list arr1 arr2 arr3) :do (is = (caref arr 0) (caref ptr 0))))) @@ -292,17 +292,17 @@ :for i :from 0 :do (setf (caref arr i) c) :finally (setf (caref arr 5) #\Nul)) - (is string= "Hello" (carray-string arr)) - (is = 10 (length (carray-list arr))) - (is string= "Hello" (coerce (subseq (carray-list arr) 0 5) 'string)) - (setf (carray-string arr) "World") - (is string= "World" (carray-string arr))) + (is string= "Hello" (ccoerce arr 'string)) + (is = 10 (length (ccoerce arr 'list))) + (is string= "Hello" (coerce (subseq (ccoerce arr 'list) 0 5) 'string)) + (setf (ccoerce arr 'string) "World") + (is string= "World" (ccoerce arr 'string))) (let ((arr (make-carray 5 :element-type 'character :initial-contents "Hello World!"))) - (is string= "Hell" (carray-string arr))) + (is string= "Hell" (ccoerce arr 'string))) (let ((arr (make-carray 20 :element-type 'character :initial-contents "Hello World!"))) - (is string= "Hello World!" (carray-string arr))) + (is string= "Hello World!" (ccoerce arr 'string))) (let ((arr (make-carray 20 :element-type 'character :initial-element #\Nul))) - (is string= "" (carray-string arr)))) + (is string= "" (ccoerce arr 'string)))) (define-test monotonic-buffer-allocator :parent suite (with-monotonic-buffer-allocator (:size 8) From 47127cdc51394092f2b421f163becdc59d78975f Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Sun, 19 May 2024 13:52:13 +0800 Subject: [PATCH 21/28] Support `cffi::aggregate-struct-slot` with its `count` other than 1 --- definition.lisp | 4 +- macros.lisp | 99 +++++++++++++++++++++++++++++------------------ test/package.lisp | 25 ++++++++++++ 3 files changed, 89 insertions(+), 39 deletions(-) diff --git a/definition.lisp b/definition.lisp index aa75655..58f9324 100644 --- a/definition.lisp +++ b/definition.lisp @@ -99,9 +99,9 @@ (cffi::foreign-string-type 'string) (cffi::foreign-array-type `(carray ,(cobject-class-definition-class - (find-cobject-class-definition (cffi::element-type type))) + (find-cobject-class-definition (cffi::ensure-parsed-base-type (cffi::element-type type)))) ,(cffi::dimensions type))) (cffi::foreign-pointer-type `(cpointer ,(cobject-class-definition-class - (find-cobject-class-definition (cffi::pointer-type type))))) + (find-cobject-class-definition (cffi::ensure-parsed-base-type (cffi::pointer-type type)))))) (t (error 'cobject-class-definition-not-found-error :type type)))))))) diff --git a/macros.lisp b/macros.lisp index 3a7801d..d14d548 100644 --- a/macros.lisp +++ b/macros.lisp @@ -68,46 +68,71 @@ (:predicate ,predicate) (:copier nil) (:constructor ,internal-constructor))) - ,@(loop :for (slot . slot-accessor) :in slot-accessors - :for slot-type := (cffi::ensure-parsed-base-type (cffi:foreign-slot-type type slot)) - :for slot-pointer := `(cffi:foreign-slot-pointer (cobject-pointer ,instance) ',type ',slot) - :for slot-value := `(cffi:foreign-slot-value (cobject-pointer ,instance) ',type ',slot) + ,@(loop :with slots := (cffi::slots type) + :for (slot-name . slot-accessor) :in slot-accessors + :for slot := (gethash slot-name slots) + :for slot-type := (cffi::ensure-parsed-base-type (cffi:foreign-slot-type type slot-name)) + :for slot-pointer := `(cffi:foreign-slot-pointer (cobject-pointer ,instance) ',type ',slot-name) + :for slot-value := `(cffi:foreign-slot-value (cobject-pointer ,instance) ',type ',slot-name) :nconc `((declaim (inline ,slot-accessor)) (defun ,slot-accessor (,instance) - ,(typecase slot-type - (cffi::foreign-struct-type - `(,(cobject-class-definition-internal-constructor - (find-cobject-class-definition slot-type)) - :pointer ,slot-pointer - :shared-from ,instance)) - (cffi::foreign-array-type - `(%make-carray - :pointer ,slot-pointer - :shared-from ,instance - :dimensions ',(cffi::dimensions slot-type) - :element-type ',(cobject-class-definition-class - (find-cobject-class-definition - (cffi::ensure-parsed-base-type - (cffi::element-type slot-type)))))) - (cffi::foreign-pointer-type - `(%make-cpointer - :pointer ,slot-value - :shared-from ,instance - :element-type ',(cobject-class-definition-class - (find-cobject-class-definition - (cffi::ensure-parsed-base-type - (cffi::pointer-type slot-type)))))) - (t slot-value))) - (declaim (inline (setf ,slot-accessor))) + ,(flet ((access-simple-slot () + (typecase slot-type + (cffi::foreign-struct-type + `(,(cobject-class-definition-internal-constructor + (find-cobject-class-definition slot-type)) + :pointer ,slot-pointer + :shared-from ,instance)) + (cffi::foreign-array-type + `(%make-carray + :pointer ,slot-pointer + :shared-from ,instance + :dimensions ',(cffi::dimensions slot-type) + :element-type ',(cobject-class-definition-class + (find-cobject-class-definition + (cffi::ensure-parsed-base-type + (cffi::element-type slot-type)))))) + (cffi::foreign-pointer-type + `(%make-cpointer + :pointer ,slot-value + :shared-from ,instance + :element-type ',(cobject-class-definition-class + (find-cobject-class-definition + (cffi::ensure-parsed-base-type + (cffi::pointer-type slot-type)))))) + (t slot-value)))) + (etypecase slot + (cffi::aggregate-struct-slot + (case (cffi::slot-count slot) + (0 `(%make-cpointer + :pointer ,slot-pointer + :shared-from ,instance + :element-type ',(cobject-class-definition-class (find-cobject-class-definition slot-type)))) + (1 (access-simple-slot)) + (t `(%make-carray + :pointer ,slot-pointer + :shared-from ,instance + :dimensions '(,(cffi::slot-count slot)) + :element-type ',(cobject-class-definition-class (find-cobject-class-definition slot-type)))))) + (cffi::simple-struct-slot (access-simple-slot)))))) + :nconc `((declaim (inline (setf ,slot-accessor))) (defun (setf ,slot-accessor) (,value ,instance) - ,(typecase slot-type - (cffi::foreign-struct-type - `(memcpy ,slot-pointer (cobject-pointer ,value) (cffi:foreign-type-size ',slot-type))) - (cffi::foreign-array-type - `(creplace (,slot-accessor ,instance) ,value)) - (cffi::foreign-pointer-type - `(setf ,slot-value (cobject-pointer ,value))) - (t `(setf ,slot-value ,value)))))) + ,(flet ((access-simple-slot () + (typecase slot-type + (cffi::foreign-struct-type + `(memcpy ,slot-pointer (cobject-pointer ,value) (cffi:foreign-type-size ',slot-type))) + (cffi::foreign-array-type + `(creplace (,slot-accessor ,instance) ,value)) + (cffi::foreign-pointer-type + `(setf ,slot-value (cobject-pointer ,value))) + (t `(setf ,slot-value ,value))))) + (etypecase slot + (cffi::aggregate-struct-slot + (case (cffi::slot-count slot) + (1 (access-simple-slot)) + (t `(creplace (,slot-accessor ,instance) ,value)))) + (cffi::simple-struct-slot + (access-simple-slot))))))) (declaim (inline ,in-place-constructor)) (defun ,in-place-constructor (,pointer &key . ,(mapcar #'list slots (mapcar (constantly nil) slots) slot-supplied-p-list)) (let ((,instance (,internal-constructor :pointer ,pointer))) diff --git a/test/package.lisp b/test/package.lisp index 3643280..62299b6 100644 --- a/test/package.lisp +++ b/test/package.lisp @@ -339,3 +339,28 @@ (define-test readable-complex-cobject (let ((camera-2d (make-camera-2d))) (is camera-2d-equal camera-2d (read-from-string (prin1-to-string camera-2d)))))) + +(defcstruct aggregate-struct + (a (:array :uint8 3) :count 0) + (b (:array :uint8 1) :count 1) + (c :uint8 :count 2)) + +(define-cobject-class (:struct aggregate-struct)) + +(defvar *aggregate-struct* nil) + +(define-test aggregate-struct-slot :parent suite :fix (*aggregate-struct*) + (setf *aggregate-struct* (make-aggregate-struct :b (make-carray 1 :element-type '(unsigned-byte 8) :initial-contents '(1)) + :c (make-carray 2 :element-type '(unsigned-byte 8) :initial-contents '(2 3)))) + (define-test count=0 + (of-type cpointer (aggregate-struct-a *aggregate-struct*)) + (is carray-equal (make-carray 3 :element-type '(unsigned-byte 8) :initial-contents '(1 2 3)) (cref (aggregate-struct-a *aggregate-struct*))) + (fail (setf (aggregate-struct-a *aggregate-struct*) (make-carray 3 :element-type '(unsigned-byte 8) :initial-contents '(1 2 3))))) + (define-test count=1 + (of-type carray (aggregate-struct-b *aggregate-struct*)) + (is equal '(unsigned-byte 8) (carray-element-type (aggregate-struct-b *aggregate-struct*))) + (is carray-equal (make-carray 1 :element-type '(unsigned-byte 8) :initial-contents '(1)) (aggregate-struct-b *aggregate-struct*))) + (define-test count=2 + (of-type carray (aggregate-struct-c *aggregate-struct*)) + (is equal '(unsigned-byte 8) (carray-element-type (aggregate-struct-b *aggregate-struct*))) + (is carray-equal (make-carray 2 :element-type '(unsigned-byte 8) :initial-contents '(2 3)) (aggregate-struct-c *aggregate-struct*)))) From e799ec3ebf661bc6126a2f059ed3806f262a84c9 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Thu, 23 May 2024 12:17:12 +0800 Subject: [PATCH 22/28] Support CFFI pointer types whose element types are unspecified (#2) --- defcfun.lisp | 8 ++++---- definition.lisp | 4 ++-- macros.lisp | 6 +++--- test/package.lisp | 18 ++++++++++++++++++ type.lisp | 5 +++++ 5 files changed, 32 insertions(+), 9 deletions(-) diff --git a/defcfun.lisp b/defcfun.lisp index 5002c6d..36bb4ad 100644 --- a/defcfun.lisp +++ b/defcfun.lisp @@ -5,7 +5,7 @@ (defun cffi-object-type-p (type) (when-let ((type (cffi-pointer-type-p type))) - (and (typep (setf type (cffi::ensure-parsed-base-type (cffi::pointer-type type))) 'cffi::foreign-struct-type) type))) + (and (typep (setf type (cffi::ensure-parsed-base-type (cffi-pointer-type type))) 'cffi::foreign-struct-type) type))) (defparameter *return-argument-names* '(#:%%claw-result-)) @@ -80,7 +80,7 @@ :collect `(push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) (nreversef ,dynamic-extent-forms) (lambda (,(caar args) ,body) - `(cffi:with-foreign-object (,,(caar args) ',',(cffi::pointer-type (cffi::ensure-parsed-base-type (cadar args)))) + `(cffi:with-foreign-object (,,(caar args) ',',(cffi-pointer-type (cffi::ensure-parsed-base-type (cadar args)))) ,(reduce #'funcall ,(if *optimize-out-temporary-object-p* `(loop :for (,name . ,form) :in ,dynamic-extent-forms :if ,name @@ -122,8 +122,8 @@ (return-pointer-from-result-p `(pointer-cpointer ,result ',(or (ignore-some-conditions (cobject-class-definition-not-found-error) (cobject-class-definition-class (find-cobject-class-definition - (cffi::pointer-type return-pointer-from-result-p)))) - (cffi::name (cffi::pointer-type return-pointer-from-result-p))))) + (cffi-pointer-type return-pointer-from-result-p)))) + (cffi::name (cffi-pointer-type return-pointer-from-result-p))))) (t result)))))) `(progn (defun ,symbol ,(mapcar #'car args) diff --git a/definition.lisp b/definition.lisp index 58f9324..718b26b 100644 --- a/definition.lisp +++ b/definition.lisp @@ -99,9 +99,9 @@ (cffi::foreign-string-type 'string) (cffi::foreign-array-type `(carray ,(cobject-class-definition-class - (find-cobject-class-definition (cffi::ensure-parsed-base-type (cffi::element-type type)))) + (find-cobject-class-definition (cffi::ensure-parsed-base-type (cffi-element-type type)))) ,(cffi::dimensions type))) (cffi::foreign-pointer-type `(cpointer ,(cobject-class-definition-class - (find-cobject-class-definition (cffi::ensure-parsed-base-type (cffi::pointer-type type)))))) + (find-cobject-class-definition (cffi::ensure-parsed-base-type (cffi-pointer-type type)))))) (t (error 'cobject-class-definition-not-found-error :type type)))))))) diff --git a/macros.lisp b/macros.lisp index d14d548..3375b1e 100644 --- a/macros.lisp +++ b/macros.lisp @@ -91,7 +91,7 @@ :element-type ',(cobject-class-definition-class (find-cobject-class-definition (cffi::ensure-parsed-base-type - (cffi::element-type slot-type)))))) + (cffi-element-type slot-type)))))) (cffi::foreign-pointer-type `(%make-cpointer :pointer ,slot-value @@ -99,7 +99,7 @@ :element-type ',(cobject-class-definition-class (find-cobject-class-definition (cffi::ensure-parsed-base-type - (cffi::pointer-type slot-type)))))) + (cffi-pointer-type slot-type)))))) (t slot-value)))) (etypecase slot (cffi::aggregate-struct-slot @@ -236,7 +236,7 @@ (when (typep (cffi::actual-type type) 'cffi::foreign-struct-type) (push `(define-type-cobject-class (,name ,type)) definitions))) (cffi::foreign-pointer-type - (push-definition (cffi::pointer-type type))) + (push-definition (cffi-pointer-type type))) (cffi::foreign-struct-type (mapc (compose #'push-definition #'cffi::parse-type #'cffi::slot-type) (hash-table-values (cffi::slots type))) diff --git a/test/package.lisp b/test/package.lisp index 62299b6..3ccaf48 100644 --- a/test/package.lisp +++ b/test/package.lisp @@ -364,3 +364,21 @@ (of-type carray (aggregate-struct-c *aggregate-struct*)) (is equal '(unsigned-byte 8) (carray-element-type (aggregate-struct-b *aggregate-struct*))) (is carray-equal (make-carray 2 :element-type '(unsigned-byte 8) :initial-contents '(2 3)) (aggregate-struct-c *aggregate-struct*)))) + +(defcstruct void-pointer-struct + (a :pointer) + (b (:pointer :pointer)) + (c (:pointer :void)) + (d (:pointer (:pointer :void)))) + +(define-cobject-class (:struct void-pointer-struct)) + +(define-test void-pointer :parent suite + (let* ((carray (make-carray 1 :element-type '(unsigned-byte 32) :initial-contents '(123456))) + (cpointer (make-carray 1 :element-type '(cpointer (unsigned-byte 32)) :initial-contents (list carray)))) + (is = 123456 (cref (cref cpointer))) + (let ((struct (make-void-pointer-struct :a carray :b cpointer :c carray :d cpointer))) + (is = 123456 (cref (pointer-cpointer (cobject-pointer (void-pointer-struct-a struct)) '(unsigned-byte 32)))) + (is = 123456 (cref (cref (pointer-cpointer (cobject-pointer (void-pointer-struct-b struct)) '(cpointer (unsigned-byte 32)))))) + (is = 123456 (cref (pointer-cpointer (cobject-pointer (void-pointer-struct-c struct)) '(unsigned-byte 32)))) + (is = 123456 (cref (cref (pointer-cpointer (cobject-pointer (void-pointer-struct-d struct)) '(cpointer (unsigned-byte 32))))))))) diff --git a/type.lisp b/type.lisp index d4cb8cd..a531eb6 100644 --- a/type.lisp +++ b/type.lisp @@ -38,3 +38,8 @@ (or (type= type1 type2) (and (symbolp type1) (symbolp type2) (eql (find-class type1 nil) (find-class type2 nil)))))) + +(setf (fdefinition 'cffi-element-type) (fdefinition 'cffi::element-type)) + +(defun cffi-pointer-type (type) + (or (cffi::pointer-type type) :void)) From 30649f46656275c273184aef561ebeac24099085 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Thu, 23 May 2024 12:32:11 +0800 Subject: [PATCH 23/28] No longer treat pointer fields as shared from the structure itself --- macros.lisp | 1 - 1 file changed, 1 deletion(-) diff --git a/macros.lisp b/macros.lisp index 3375b1e..e6df779 100644 --- a/macros.lisp +++ b/macros.lisp @@ -95,7 +95,6 @@ (cffi::foreign-pointer-type `(%make-cpointer :pointer ,slot-value - :shared-from ,instance :element-type ',(cobject-class-definition-class (find-cobject-class-definition (cffi::ensure-parsed-base-type From dcaca84bf2e5a2d07dd35ecbd90ec373339b2aaa Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Tue, 23 Jul 2024 21:22:16 +0800 Subject: [PATCH 24/28] Add macro `with-leaky-allocator` --- allocator.lisp | 11 +++++++++++ package.lisp | 1 + 2 files changed, 12 insertions(+) diff --git a/allocator.lisp b/allocator.lisp index 1be79dd..de02651 100644 --- a/allocator.lisp +++ b/allocator.lisp @@ -1,5 +1,6 @@ (in-package #:cffi-object) +(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)))) @@ -12,6 +13,16 @@ (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 cobject-allocator) (:constructor %make-sized-monotonic-buffer-allocator)) (pointer (cffi:null-pointer) :type cffi:foreign-pointer) diff --git a/package.lisp b/package.lisp index b7ea37e..2a19a8d 100644 --- a/package.lisp +++ b/package.lisp @@ -30,6 +30,7 @@ #:unmanage-cobject #:with-monotonic-buffer-allocator #:with-default-allocator + #:with-leaky-allocator #:defcobjfun)) (in-package #:cffi-object) From f23b5c26b466e4d9cbf1bca61d5bf3835f5a99e0 Mon Sep 17 00:00:00 2001 From: coco24 <1281299809@qq.com> Date: Tue, 23 Jul 2024 23:24:00 +0800 Subject: [PATCH 25/28] Use GC to allocate foreign objects on ECL --- allocator-ecl.lisp | 36 ++++++++++++++++++++++++++++++++++++ cffi-object.asd | 1 + 2 files changed, 37 insertions(+) create mode 100644 allocator-ecl.lisp diff --git a/allocator-ecl.lisp b/allocator-ecl.lisp new file mode 100644 index 0000000..7eef2ea --- /dev/null +++ b/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) diff --git a/cffi-object.asd b/cffi-object.asd index 4ec11c6..698ac60 100644 --- a/cffi-object.asd +++ b/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") From f16b006c94f88625b607ad5f17f1ec7cf21c4f23 Mon Sep 17 00:00:00 2001 From: Madhu Date: Fri, 20 Dec 2024 05:09:28 +0530 Subject: [PATCH 26/28] defcfun.lisp: (defcobjfun): handle return-type of form (:pointer (:pointer type)) --- defcfun.lisp | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/defcfun.lisp b/defcfun.lisp index 36bb4ad..b96197b 100644 --- a/defcfun.lisp +++ b/defcfun.lisp @@ -37,6 +37,19 @@ (intern (format nil "~A~A" '#:%%%make- type-name) (symbol-package type-name))) (error "Defining a C function that returns non-structure pointer is currently not supported.")))) +(defun frob-return-pointer-from-result (return-pointer-from-result-p result) + (labels ((resolve (return-pointer-from-result-p) + (if (not (cffi-pointer-type-p (cffi-pointer-type return-pointer-from-result-p))) + (or (ignore-some-conditions (cobject-class-definition-not-found-error) + (cobject-class-definition-class + (find-cobject-class-definition + (cffi-pointer-type return-pointer-from-result-p)))) + (cffi::name (cffi-pointer-type return-pointer-from-result-p))) + `(:pointer ,(resolve (cffi-pointer-type return-pointer-from-result-p)))))) + `(pointer-cpointer ,result + ',(resolve + return-pointer-from-result-p)))) + (defmacro defcobjfun (name result &rest args) (destructuring-bind (name symbol) name (let* ((should-define-wrapper-p (not (member '&rest args))) @@ -119,11 +132,8 @@ ((and return-object-from-result-p *return-pointer-as-object-p*) (let ((internal-constructor (nth-value 2 (cobject-type-constructor return-object-from-result-p)))) `(locally (declare (notinline ,internal-constructor)) (,internal-constructor :pointer ,result)))) - (return-pointer-from-result-p `(pointer-cpointer ,result ',(or (ignore-some-conditions (cobject-class-definition-not-found-error) - (cobject-class-definition-class - (find-cobject-class-definition - (cffi-pointer-type return-pointer-from-result-p)))) - (cffi::name (cffi-pointer-type return-pointer-from-result-p))))) + (return-pointer-from-result-p + (frob-return-pointer-from-result return-pointer-from-result-p result)) (t result)))))) `(progn (defun ,symbol ,(mapcar #'car args) From b9e4f8f7eed44cfa5319fd086f282efbcf3ed705 Mon Sep 17 00:00:00 2001 From: Madhu Date: Thu, 19 Dec 2024 18:53:56 +0530 Subject: [PATCH 27/28] definition.lisp: (find-cobject-class-definitions): handle enums --- definition.lisp | 2 ++ 1 file changed, 2 insertions(+) diff --git a/definition.lisp b/definition.lisp index 718b26b..5a873df 100644 --- a/definition.lisp +++ b/definition.lisp @@ -104,4 +104,6 @@ (cffi::foreign-pointer-type `(cpointer ,(cobject-class-definition-class (find-cobject-class-definition (cffi::ensure-parsed-base-type (cffi-pointer-type type)))))) + (cffi::foreign-enum + `(unsigned-byte ,(* (cffi:foreign-type-size (cffi::ensure-parsed-base-type :unsigned-int))))) (t (error 'cobject-class-definition-not-found-error :type type)))))))) From 21af3163fb26dc0b8187595bfa535ab68fffae6b Mon Sep 17 00:00:00 2001 From: Madhu Date: Mon, 23 Dec 2024 22:20:14 +0530 Subject: [PATCH 28/28] macros.lisp: (with-new-cobject-class-definition): avoid errors on non-existent slots * macros.lisp: (define-package-cobject-classes): Unwrap the loop which pushes forward declarations for slots and correctly handle slots which are foreign pointer typedefs: Do not try to find slots when "class" doesn't have slots. i.e. when "class" is a cffi::foreign-pointer-type, a typedef of a pointer to a struct. Push the fwd decls of "pointed-to" class instead. --- macros.lisp | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/macros.lisp b/macros.lisp index e6df779..280cf59 100644 --- a/macros.lisp +++ b/macros.lisp @@ -237,8 +237,12 @@ (cffi::foreign-pointer-type (push-definition (cffi-pointer-type type))) (cffi::foreign-struct-type - (mapc (compose #'push-definition #'cffi::parse-type #'cffi::slot-type) - (hash-table-values (cffi::slots type))) + (loop for slot in (hash-table-values (cffi::slots type)) + for slot-type = (cffi::slot-type slot) + for parsed-slot-type = (cffi::ensure-parsed-base-type slot-type) + do (etypecase parsed-slot-type + (cffi::foreign-pointer-type (push-definition (cffi-pointer-type parsed-slot-type))) + (t (push-definition parsed-slot-type)))) (push `(define-struct-cobject-class (,name ,type)) definitions))) (setf (gethash type type-set) t)))))) (ignore-some-conditions (warning) (push-definition (funcall type-getter)))))