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/allocator.lisp b/allocator.lisp index 2faa2a8..de02651 100644 --- a/allocator.lisp +++ b/allocator.lisp @@ -1,47 +1,85 @@ (in-package #:cffi-object) -(defstruct foreign-allocator - (allocator (constantly (cffi:null-pointer)) :type (function (non-negative-fixnum) (values cffi:foreign-pointer))) +(declaim (inline make-cobject-allocator)) +(defstruct cobject-allocator + (allocator (constantly (cffi:null-pointer)) :type (function (cffi::foreign-type) (values cffi:foreign-pointer))) (deallocator #'values :type (function (cffi:foreign-pointer)))) -(declaim (type foreign-allocator *foreign-allocator*)) -(defparameter *foreign-allocator* (make-foreign-allocator :allocator #'cffi-sys:%foreign-alloc :deallocator #'cffi-sys:foreign-free)) +(declaim (type cobject-allocator *default-cobject-allocator*)) +(defparameter *default-cobject-allocator* (make-cobject-allocator + :allocator (lambda (type) (cffi-sys:%foreign-alloc (cffi:foreign-type-size type))) + :deallocator #'cffi-sys:foreign-free)) + +(declaim (type cobject-allocator *cobject-allocator*)) +(defparameter *cobject-allocator* *default-cobject-allocator*) + +(declaim (inline make-leaky-allocator)) +(defun make-leaky-allocator (&key (allocator (cobject-allocator-allocator *cobject-allocator*)) (deallocator #'values)) + (make-cobject-allocator :allocator allocator :deallocator deallocator)) + +(defmacro with-leaky-allocator (&body body) + (with-gensyms (allocator) + `(let ((,allocator (make-leaky-allocator))) + (declare (dynamic-extent ,allocator)) + (let ((*cobject-allocator* ,allocator)) . ,body)))) (declaim (inline %make-sized-monotonic-buffer-allocator)) -(defstruct (sized-monotonic-buffer-allocator (:include foreign-allocator) (:constructor %make-sized-monotonic-buffer-allocator)) +(defstruct (sized-monotonic-buffer-allocator (:include cobject-allocator) (:constructor %make-sized-monotonic-buffer-allocator)) (pointer (cffi:null-pointer) :type cffi:foreign-pointer) (size 0 :type non-negative-fixnum) (offset 0 :type non-negative-fixnum)) (declaim (inline make-sized-monotonic-buffer-allocator)) -(defun make-sized-monotonic-buffer-allocator (&key (pointer (cffi:null-pointer)) (size 0)) - (let* ((upstream-allocator *foreign-allocator*) - (allocator-1 nil) - (allocator-2 (%make-sized-monotonic-buffer-allocator :allocator (lambda (size) - (declare (type non-negative-fixnum size)) +(defun make-sized-monotonic-buffer-allocator (&key (pointer (cffi:null-pointer)) (size 0) (upstream *cobject-allocator*)) + #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + (let* ((allocator-1 nil) + (allocator-2 (%make-sized-monotonic-buffer-allocator :allocator (lambda (type &aux (size (cffi:foreign-type-size type)) (align (cffi:foreign-type-alignment type))) + (declare (type non-negative-fixnum size align)) (with-accessors ((offset sized-monotonic-buffer-allocator-offset) (buffer-size sized-monotonic-buffer-allocator-size) (pointer sized-monotonic-buffer-allocator-pointer) (allocator sized-monotonic-buffer-allocator-allocator) (deallocator sized-monotonic-buffer-allocator-deallocator)) allocator-1 - (if (<= (+ offset size) buffer-size) - (prog1 (cffi:inc-pointer pointer offset) - (incf offset size)) - (prog1 (funcall (foreign-allocator-allocator upstream-allocator) size) - (setf offset buffer-size) - (setf deallocator (foreign-allocator-deallocator upstream-allocator)))))) + (let ((align-offset (mod (- align offset) align))) + (if (<= (+ offset align-offset size) buffer-size) + (prog1 (cffi:inc-pointer pointer (incf offset align-offset)) + (incf offset size)) + (if upstream + (prog1 (funcall (cobject-allocator-allocator upstream) type) + (setf offset buffer-size) + (setf deallocator (cobject-allocator-deallocator upstream))) + (error "Cannot allocate a space of ~D byte~:P with allocator ~A." size allocator-1)))))) :deallocator #'values :size size :pointer pointer))) (setf allocator-1 allocator-2) allocator-2)) -(defmacro with-monotonic-buffer-allocator ((&key (buffer-size 128)) &body body) - (with-gensyms (buffer pointer size allocator) - `(let* ((,size ,buffer-size) - (,buffer (cffi:make-shareable-byte-vector ,size))) - (declare (dynamic-extent ,buffer)) - (cffi:with-pointer-to-vector-data (,pointer ,buffer) - (let ((,allocator (make-sized-monotonic-buffer-allocator :pointer ,pointer :size ,size))) - (declare (dynamic-extent ,allocator)) - (let ((*foreign-allocator* ,allocator)) - ,@body)))))) +(defmacro with-monotonic-buffer-allocator ((&key + buffer pointer + (size (if buffer `(length ,buffer) 128)) + (upstream '*cobject-allocator*) + (values '#'values)) + &body body) + (with-gensyms (buffer-var pointer-var size-var allocator) + (flet ((wrap-with-buffer-var (form) + (cond + (buffer `(let ((,buffer-var ,buffer)) ,form)) + (pointer form) + (t `(let ((,buffer-var (cffi:make-shareable-byte-vector ,size-var))) + (declare (dynamic-extent ,buffer-var)) ,form)))) + (wrap-with-pointer-var (form) + (if pointer + `(let ((,pointer-var ,pointer)) ,form) + `(cffi:with-pointer-to-vector-data (,pointer-var ,buffer-var) ,form)))) + `(let ((,size-var ,size)) + ,(wrap-with-buffer-var + (wrap-with-pointer-var + `(let ((,allocator (make-sized-monotonic-buffer-allocator :pointer ,pointer-var :size ,size-var :upstream ,upstream))) + (declare (dynamic-extent ,allocator)) + (multiple-value-call ,values + (let ((*cobject-allocator* ,allocator)) + ,@body))))))))) + +(defmacro with-default-allocator (&body body) + `(let ((*cobject-allocator* *default-cobject-allocator*)) + ,@body)) diff --git a/array.lisp b/array.lisp index 76ca33b..60e1211 100644 --- a/array.lisp +++ b/array.lisp @@ -4,6 +4,15 @@ (:constructor %make-carray)) (dimensions '(0) :type (cons fixnum null))) +(defmethod cobject-type ((array carray)) + `(carray ,(carray-element-type array) ,(carray-dimensions array))) + +(defun cpointer-carray (cpointer dimensions) + (%make-carray :pointer (cpointer-pointer cpointer) + :shared-from (cpointer-shared-from cpointer) + :element-type (cpointer-element-type cpointer) + :dimensions (ensure-cons dimensions))) + (defun caref (array &rest subscripts &aux (subscript (first subscripts))) (unless (<= 0 subscript (1- (first (carray-dimensions array)))) (error "Index ~D is out of bound." subscript)) @@ -19,23 +28,71 @@ (defun clength (carray) (first (carray-dimensions carray))) +(defgeneric ccoerce (cobject type)) + +(defgeneric (setf ccoerce) (value cobject type)) + +(defmethod ccoerce ((array carray) (type (eql 'list))) + (declare (ignore type)) + (loop :for i :below (clength array) + :collect (caref array i))) + +(defmethod ccoerce ((cobject cobject) (type list)) + (ccoerce cobject (car type))) + +(defmethod ccoerce ((array carray) (type (eql 'simple-vector))) + (declare (ignore type)) + (make-array (clength array) :initial-contents (ccoerce array 'list))) + +(defmethod ccoerce ((array carray) (type (eql 'simple-array))) + (declare (ignore type)) + (if (symbolp (carray-element-type array)) + (make-array (clength array) :element-type (carray-element-type array) + :initial-contents (ccoerce array 'list)) + (ccoerce array 'simple-vector))) + +(defmethod ccoerce ((array carray) (type (eql 'vector))) + (declare (ignore type)) + (ccoerce array 'simple-array)) + +(defmethod ccoerce ((array carray) (type (eql 'array))) + (declare (ignore type)) + (ccoerce array 'simple-array)) + +(defmethod ccoerce ((array carray) (type (eql 'string))) + (declare (ignore type)) + (cffi:foreign-string-to-lisp (carray-pointer array))) + +(defmethod (setf ccoerce) ((value string) (array carray) (type (eql 'string))) + (declare (ignore type)) + (cffi:lisp-string-to-foreign value (carray-pointer array) (clength array))) + (defmethod print-object ((array carray) stream) - (print-unreadable-object (array stream) - (loop :named print-element-loop - :with length := (first (carray-dimensions array)) - :initially - (case (carray-element-type array) - (character (ignore-errors - (return-from print-element-loop - (print-object (carray-string array) stream))))) - :for i :below length - :if (< i 10) - :unless (zerop i) - :do (format stream "~% ") - :end - :and :do (prin1 (caref array i) stream) - :else - :return (format stream " ... [~D elements elided]" (- length 10))))) + (if *print-readably* + (progn + (format stream "#.") + (prin1 + `(make-carray + ',(carray-dimensions array) + :element-type ',(carray-element-type array) + :initial-contents ',(ccoerce array 'array)) + stream)) + (print-unreadable-object (array stream) + (loop :named print-element-loop + :with length := (first (carray-dimensions array)) + :initially + (case (carray-element-type array) + (character (ignore-errors + (return-from print-element-loop + (print-object (ccoerce array 'string) stream))))) + :for i :below length + :if (< i 10) + :unless (zerop i) + :do (format stream "~% ") + :end + :and :do (prin1 (caref array i) stream) + :else + :return (format stream " ... [~D elements elided]" (- length 10)))))) (defstruct (displaced-carray (:include carray) (:constructor %make-displaced-carray)) @@ -51,26 +108,22 @@ (displaced-carray-displaced-index-offset array))) (t (values nil nil)))) -(defun carray-string (carray) - (cffi:foreign-string-to-lisp (carray-pointer carray))) - -(defun (setf carray-string) (value carray) - (cffi:lisp-string-to-foreign value (carray-pointer carray) (clength carray))) - (defun make-carray (dimensions &key element-type initial-element initial-contents displaced-to (displaced-index-offset 0)) - (unless (listp dimensions) - (setf dimensions (list dimensions))) - (let* ((primitive-type-p (primitive-type-p element-type)) + (let* ((dimensions (ensure-cons dimensions)) + (primitive-type-p (primitive-type-p element-type)) (pointer-type-p (and (listp element-type) (eq (first element-type) 'cpointer))) (character-type-p (eq element-type 'character)) - (element-size (cobject-class-object-size element-type)) + (element-foreign-type (nth-value 1 (cobject-class-definition element-type))) + (element-size (cffi:foreign-type-size element-foreign-type)) (total-size (* element-size (reduce #'* dimensions))) (pointer (if displaced-to (cffi:inc-pointer (cobject-pointer displaced-to) (* element-size displaced-index-offset)) - (funcall (foreign-allocator-allocator *foreign-allocator*) total-size))) + (funcall (cobject-allocator-allocator *cobject-allocator*) (make-instance 'cffi::foreign-array-type + :element-type element-foreign-type + :dimensions dimensions)))) (array (if displaced-to (progn (assert (<= 0 displaced-index-offset (+ displaced-index-offset (first dimensions)) (first (carray-dimensions displaced-to)))) @@ -83,6 +136,8 @@ (manage-cobject (%make-carray :pointer pointer :dimensions dimensions :element-type element-type))))) + (declare (type non-negative-fixnum element-size total-size) + (type (cons non-negative-fixnum t) dimensions)) (when initial-element (assert (null initial-contents)) (assert (null displaced-to)) @@ -109,6 +164,7 @@ (unless character-type-p (assert (= (first dimensions) (length initial-contents)))) (let ((i 0)) + (declare (type non-negative-fixnum i)) (map nil (cond (character-type-p (cffi:lisp-string-to-foreign (coerce initial-contents 'string) pointer total-size) @@ -153,15 +209,3 @@ (unless (= (clength array1) (clength array2)) (return-from carray-equal nil)) (cpointer-equal array1 array2 (clength array1))) - -(declaim (ftype (function (carray) (values list)) carray-list)) -(defun carray-list (array) - (loop :for i :below (clength array) - :collect (caref array i))) - -(declaim (ftype (function (carray) (values simple-array)) carray-array)) -(defun carray-array (carray) - (if (symbolp (carray-element-type carray)) - (make-array (clength carray) :element-type (carray-element-type carray) - :initial-contents (carray-list carray)) - (make-array (clength carray) :initial-contents (carray-list carray)))) 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") diff --git a/defcfun.lisp b/defcfun.lisp index 9cc2417..b96197b 100644 --- a/defcfun.lisp +++ b/defcfun.lisp @@ -5,43 +5,172 @@ (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-)) +(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) (string= (symbol-name sym1) (symbol-name sym2))) +(defgeneric funcall-dynamic-extent-form (function args)) + +(defgeneric funcall-form-type (function args)) + (defconstant +defcfun+ (macro-function 'cffi:defcfun)) (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.")))) + +(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))) (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 - (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."))))) + (if return-object-from-argument-p + (let ((object-type (cffi-object-type-p (cadar args)))) + (multiple-value-bind (object-constructor object-copier object-internal-constructor) (cobject-type-constructor object-type) + `(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) + `(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)) + (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) + :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))))))))))) + (let ((result-wrapper + (with-gensyms (result) + `(lambda (,result) + ,(cond + ((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 + (frob-return-pointer-from-result return-pointer-from-result-p result)) + (t result)))))) `(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)))))) - `(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))))))))))) + (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) + ,(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))))))))))))) diff --git a/definition.lisp b/definition.lisp index a9c5610..5a873df 100644 --- a/definition.lisp +++ b/definition.lisp @@ -46,21 +46,27 @@ (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))) - `(:array ,(nth-value 1 (cobject-class-definition element-type)) . ,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) (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 @@ -71,27 +77,33 @@ ((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) (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 "Cannot find the CFFI object class for type ~A." (cffi::name 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::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)))))) + (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)))))))) diff --git a/global.lisp b/global.lisp index 7a771b2..a391b51 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) + :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) (let ((cobject (funcall constructor))) diff --git a/macros.lisp b/macros.lisp index 80724dd..280cf59 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))) @@ -54,100 +60,133 @@ (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 :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) + ,(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 + :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) + ,(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))) + (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 (foreign-allocator-allocator *foreign-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)) - :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 (foreign-allocator-allocator *foreign-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)) - ,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))))) - (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 @@ -196,10 +235,14 @@ (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))) + (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))))) diff --git a/object.lisp b/object.lisp index 4822aae..ec511c2 100644 --- a/object.lisp +++ b/object.lisp @@ -20,9 +20,13 @@ (defun manage-cobject (cobject) (let ((pointer (cobject-pointer cobject)) - (deallocator (foreign-allocator-deallocator *foreign-allocator*))) - (tg:finalize cobject (lambda () (funcall deallocator pointer))))) + (deallocator (cobject-allocator-deallocator *cobject-allocator*))) + (if (eq deallocator #'values) cobject (tg:finalize cobject (lambda () (funcall deallocator pointer)))))) (defun unmanage-cobject (cobject) (tg:cancel-finalization cobject) (cobject-pointer cobject)) + +(defgeneric cobject-type (object) + (:method (object) + (type-of object))) diff --git a/ops.lisp b/ops.lisp index 18f836e..1bfdffa 100644 --- a/ops.lisp +++ b/ops.lisp @@ -9,6 +9,13 @@ (defconstant +ctypes-slots+ (fdefinition 'cffi-ops::ctypes-slots)) +(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) (if (and (listp type) (eq (car type) :object)) @@ -16,6 +23,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 @@ -24,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:&)) diff --git a/package.lisp b/package.lisp index 15d5b36..2a19a8d 100644 --- a/package.lisp +++ b/package.lisp @@ -12,12 +12,11 @@ #:carray #:make-carray #:pointer-carray + #:cpointer-carray #:carray-dimensions #:carray-displacement #:carray-element-type - #:carray-list - #:carray-array - #:carray-string + #:ccoerce #:caref #:clength #:creplace @@ -30,6 +29,8 @@ #:manage-cobject #:unmanage-cobject #:with-monotonic-buffer-allocator + #:with-default-allocator + #:with-leaky-allocator #:defcobjfun)) (in-package #:cffi-object) diff --git a/pointer.lisp b/pointer.lisp index 773dfff..6d5b773 100644 --- a/pointer.lisp +++ b/pointer.lisp @@ -4,11 +4,22 @@ (: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) - (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 ea1f54f..3ccaf48 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 (ccoerce arr4 'list) + :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 (ccoerce arr4 'list) + :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)) @@ -265,32 +292,93 @@ :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 (:buffer-size 8) - (with-monotonic-buffer-allocator (:buffer-size 8) - (of-type cobj::sized-monotonic-buffer-allocator cobj::*foreign-allocator*) + (with-monotonic-buffer-allocator (:size 8) + (with-monotonic-buffer-allocator (:size 8) + (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)) + +(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)))))) + +(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*)))) + +(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))