Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Madhu critical fixes 2023 02 1 #94

Open
wants to merge 11 commits into
base: master
Choose a base branch
from
Open

Madhu critical fixes 2023 02 1 #94

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
11 commits
Select commit Hold shift + click to select a range
f6f0110
squash! Second Madhu patch. Fix for length-arg NOSQUASH
Apr 21, 2018
ae48bab
src/object.lisp: (object-setup-gc): serious logic bug
Sep 15, 2018
c27bfbe
src/function.lisp: (in-arg-clear): fix a bogus change
Sep 20, 2018
bbeb508
src/function.lisp: (initialize-copy): fix method combination
Nov 17, 2019
65c19ee
src/function.lisp: (alloc-foreign) bzero unitialized allocation
Nov 24, 2019
cadaa95
Fix some shared-initialize definitions
Dec 12, 2019
3035601
src/object.lisp: handle ParamSpec object creation
Apr 10, 2022
af21f78
Undo "object.lisp: support method invocation on fake-object-class obj…
Jan 15, 2023
307c502
fix typos in d440abe378 "Rework Gvalue"
Jan 15, 2023
5effec1
squash! Second Madhu patch. Fix for length-arg. NOSQUASH
Feb 12, 2023
46ec847
src/function.lisp: fix build-function to handle structs as "inout" ar…
Feb 14, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 2 additions & 1 deletion src/enum.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -13,6 +13,7 @@
(defmethod shared-initialize :after ((enum-desc enum-desc) slot-names
&key enum-info)
(declare (ignore slot-names))
(when enum-info
(with-slots (name values-dict methods-dict)
enum-desc
(setf name
Expand All @@ -26,7 +27,7 @@
(iter (for i below (g-enum-info-get-n-methods enum-info))
(let ((func-info (g-enum-info-get-method enum-info i)))
(collect (cons (info-get-name func-info)
(build-function func-info))))))))
(build-function func-info)))))))))

(defmethod build-interface-desc ((enum-info enum-info))
(make-instance 'enum-desc :enum-info enum-info))
Expand Down
7 changes: 4 additions & 3 deletions src/ffi.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -67,9 +67,10 @@
(defmethod shared-initialize :after ((namespace namespace) slot-names
&key name version)
(declare (ignore slot-names))
(repository-require nil name (if version version (cffi:null-pointer)))
(setf (slot-value namespace 'version)
(repository-get-version nil name)))
(when name ;don't handle calls from make-instances-obsolete
(repository-require nil name (if version version (cffi:null-pointer)))
(setf (slot-value namespace 'version)
(repository-get-version nil name))))

(defmethod nsget ((namespace namespace) name)
(let ((cname (c-name name)))
Expand Down
102 changes: 55 additions & 47 deletions src/function.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -80,6 +80,7 @@
:initform nil :type boolean)))

(defmethod initialize-copy ((obj freeable-type) (copy freeable-type))
(when (next-method-p) (call-next-method))
(copy-slots ((free-from-foreign free-to-foreign)) (obj copy)))

(defgeneric mem-size (type))
Expand All @@ -93,7 +94,9 @@

(defmethod alloc-foreign (type &key (initial-value nil initial-value-p))
(let* ((size (mem-size type))
(pos (cffi:foreign-alloc :uint8 :count size)))
(pos (if initial-value-p
(cffi:foreign-alloc :uint8 :count size)
(cffi:foreign-alloc :uint8 :count size :initial-element 0))))
(when initial-value-p
(mem-set pos initial-value type))
pos))
Expand Down Expand Up @@ -367,6 +370,9 @@
(defclass struct-type (interface-type)
())

(defmethod mem-alloc (pos (struct-type struct-type))
(setf (cffi:mem-ref pos :pointer) (alloc-foreign struct-type)))

(defmethod free-from-foreign-aggregated-p ((struct-type struct-type))
(declare (ignore struct-type)))

Expand Down Expand Up @@ -394,6 +400,9 @@
(defclass union-type ()
((size :initarg :size)))

(defmethod mem-alloc (pos (union-type union-type))
(setf (cffi:mem-ref pos :pointer) (alloc-foreign union-type)))

(defmethod free-from-foreign-aggregated-p ((union-type union-type))
(declare (ignore union-type)))

Expand Down Expand Up @@ -685,34 +694,34 @@
(direction :reader direction-of)
(for-array-length-p :initform nil :accessor for-array-length-p-of)
(array-length :reader array-length-of)
(ugly-offset :initform nil :accessor ugly-offset)
(caller-allocates)
(transfer)))

(defmethod shared-initialize :after ((arg-data arg-data)
slot-names &key arg-info)
(with-slots (name type is-array-type direction
array-length caller-allocates)
arg-data
(case arg-info
(:object-argument
(setf name :this
type (make-object/struct-pointer-type)
caller-allocates nil
direction :in
is-array-type nil
array-length nil))
(otherwise
(let ((type-info (arg-info-get-type arg-info))
(transfer (arg-info-get-ownership-transfer arg-info)))
(setf name (info-get-name arg-info)
caller-allocates (arg-info-is-caller-allocates arg-info)
type (build-argument-type type-info transfer
:force-pointer caller-allocates)
direction (arg-info-get-direction arg-info)
is-array-type
(find-object-with-class type (find-class 'c-array-type))
array-length (get-array-length type-info)))))))
(when arg-info ;don't handle calls from make-instances-obsolete
(with-slots (name type is-array-type direction
array-length caller-allocates)
arg-data
(case arg-info
(:object-argument
(setf name :this
type (make-object/struct-pointer-type)
caller-allocates nil
direction :in
is-array-type nil
array-length nil))
(otherwise
(let ((type-info (arg-info-get-type arg-info))
(transfer (arg-info-get-ownership-transfer arg-info)))
(setf name (info-get-name arg-info)
caller-allocates (arg-info-is-caller-allocates arg-info)
type (build-argument-type type-info transfer
:force-pointer caller-allocates)
direction (arg-info-get-direction arg-info)
is-array-type
(find-object-with-class type (find-class 'c-array-type))
array-length (get-array-length type-info))))))))

(let ((o-a-d-cache (make-instance 'arg-data
:arg-info :object-argument)))
Expand Down Expand Up @@ -775,9 +784,10 @@
(setf giarg inp)
(incf-giargs inp))
(:in-out
(setf giarg voutp)
(pointer->giarg inp voutp)
(pointer->giarg outp voutp)
(mem-alloc voutp type)
(setf giarg (cffi:mem-ref voutp :pointer))
(pointer->giarg inp (cffi:mem-ref voutp :pointer))
(pointer->giarg outp (cffi:mem-ref voutp :pointer))
(incf-giargs inp)
(incf-giargs outp)
(incf-giargs voutp))
Expand All @@ -800,12 +810,6 @@
:then (make-arg data inp outp voutp))
(collect arg)))

(defun ugly-nth (data array-length args)
(nth (if (ugly-offset data)
(1+ array-length)
array-length)
args))

(defun arg-setup-length (arg args methodp)
(with-slots (data length-arg)
arg
Expand All @@ -831,14 +835,16 @@
(defun out-arg->value (arg)
(with-slots (data giarg length-arg)
arg
(with-slots (type)
(with-slots (type direction)
data
(let ((real-type
(if length-arg
(copy-find-set-c-array-type-length type
(out-arg->value length-arg))
type)))
(mem-get giarg real-type)))))
(prog1 (mem-get giarg real-type)
(when (and (eql direction :in-out))
(mem-free giarg real-type)))))))

(defun in-arg-clear (arg)
(with-slots (data giarg length-arg (arg-value value))
Expand All @@ -850,8 +856,8 @@
(if is-array-type
(copy-find-set-c-array-type-length
type
(when length-arg (slot-value length-arg 'value)))
type)))
(length arg-value))
type)))
(mem-free giarg real-type))))))

(defun in/out-args (args)
Expand Down Expand Up @@ -882,16 +888,17 @@

(defmethod shared-initialize :after ((return-data return-data)
slot-names &key callable-info return-interface)
(with-slots (type array-length)
return-data
(let ((type-info (callable-info-get-return-type callable-info))
(transfer (callable-info-get-caller-owns callable-info)))
(setf type
(if return-interface
(let ((intf-ptr-type (make-interface-pointer-type return-interface :everything)))
(make-instance 'argument-type :contained-type intf-ptr-type :field 'v-pointer))
(build-argument-type type-info transfer))
array-length (get-array-length type-info)))))
(when callable-info ;don't handle calls from make-instances-obsolete
(with-slots (type array-length)
return-data
(let ((type-info (callable-info-get-return-type callable-info))
(transfer (callable-info-get-caller-owns callable-info)))
(setf type
(if return-interface
(let ((intf-ptr-type (make-interface-pointer-type return-interface :everything)))
(make-instance 'argument-type :contained-type intf-ptr-type :field 'v-pointer))
(build-argument-type type-info transfer))
array-length (get-array-length type-info))))))

(defclass return-value ()
((data :initarg :data)
Expand Down Expand Up @@ -1033,6 +1040,7 @@
#'c2mop:slot-definition-name
(c2mop:class-slots (class-of arg)))))

(assert (not (find-method #'print-object '(:around) (list t t))))
(defmethod print-object :around (obj stream)
(if (member (class-of obj) (mapcar 'find-class '(arg argument-type arg-data return-data return-value c-array-type pointer-type)))
(print-unreadable-object (obj stream :type t :identity t)
Expand Down
4 changes: 2 additions & 2 deletions src/gvalue.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -156,8 +156,8 @@
((eq type +g-type-ulong+) (g-value-set-ulong gvalue (round value)))
((eq type +g-type-int64+) (g-value-set-int64 gvalue (round value)))
((eq type +g-type-uint64+) (g-value-set-uint64 gvalue (round value)))
((eq type +g-type-enum+) (g-value-set-enum gvalue (ffi-enum value gtype)))
((eq type +g-type-flags+) (g-value-set-flags gvalue (ffi-enum value gtype)))
((eq type +g-type-enum+) (g-value-set-enum gvalue (ffi-enum value type)))
((eq type +g-type-flags+) (g-value-set-flags gvalue (ffi-enum value type)))
((eq type +g-type-float+) (g-value-set-float gvalue (coerce value 'single-float)))
((eq type +g-type-double+) (g-value-set-double gvalue (coerce value 'double-float)))
((eq type +g-type-string+) (g-value-set-string gvalue value))
Expand Down
57 changes: 53 additions & 4 deletions src/object.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -129,12 +129,53 @@
(cffi:defcfun g-object-ref :pointer (obj :pointer))
(cffi:defcfun g-object-unref :void (obj :pointer))

;; ParamSpecs need special treatement during object creation because
;; GParamSpecs (and their kin) are not GObjects but are some strange
;; subtypes of GTypeClass. E.g. G_IS_OBJECT ( g_param_spec_int(...)
;; ) is FALSE. However g_base_info_get_type
;; (g_irepository_find_by_name (repository, "GObject", "ParamSpec"))
;; == GI_INFO_TYPE_OBJECT, and so cl-gir tries to call
;; `build-object-ptr' when it comes across it. The problem is that
;; since it is not an GObject, calling `g-object-is-floating' on it
;; will fail. The following code attempts to work around that problem
;; by having `object-setup-gc' detect that it is dealing with a
;; ParamSpec and choose a different code path which calls
;; `param-spec-setup-gc'

;; given the above background perhaps the atrocious name
;; `g-object-is-param-spec' can be excused. also the call to
;; `g-type-fundamental' in this function makes object.lisp depend on
;; gvalue.lisp. note (%gtype :param) == 76

(defun g-object-is-param-spec (object)
(= (g-type-fundamental (gtype (this-of object))) 76))

(cffi:defcfun g-param-spec-ref :pointer (pspec :pointer))
(cffi:defcfun g-param-spec-ref-sink :pointer (pspec :pointer))
(cffi:defcfun g-param-spec-sink :void (pspec :pointer))
(cffi:defcfun g-param-spec-unref :void (pspec :pointer))

(defun param-spec-setup-gc (object transfer)
(let* ((this (this-of object))
(a (cffi:pointer-address this)))
(if (eq transfer :everything) ; a new ParamSpec is always floating
(g-param-spec-ref-sink this)
(g-param-spec-ref this))
(tg:finalize this (lambda () (g-param-spec-unref (cffi:make-pointer a)))))
object)


(defun object-setup-gc (object transfer)
(if (g-object-is-param-spec object)
(return-from object-setup-gc
(param-spec-setup-gc object transfer)))
(let* ((this (this-of object))
(floating? (g-object-is-floating this))
(a (cffi:pointer-address this)))
(if (eq transfer :everything)
(if floating? (g-object-ref-sink this))
(if floating?
(g-object-ref-sink this)
(g-object-ref this))
(g-object-ref this))
(tg:finalize this (lambda () (g-object-unref (cffi:make-pointer a)))))
object)
Expand Down Expand Up @@ -174,17 +215,25 @@
:name (cffi:foreign-funcall "g_type_name"
:ulong gtype :string)))))))

(defvar use-fake-objects nil)
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

What is the purpose of this variable?

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Commit 95c96a2 ("Second Madhu patch. Fix for length-arg") introduced a code path that created "fake-objects" for types that are not exposed through g-i. e.g. what is returned by (gir:invoke (gio "File" "new_for_path") "/etc/passwd"). - g_file_new_for_path is defined as returning an GFile which is GInterface, the actual type is some implementation dependent LocalFile type which is not available through g-i.

However I thought this code path may not be necessary , taking into account. Roman's commit 12f8910
if it were suitably extended. This patch implements the code path which Roman probably intended
to be the default behaviour, while retaining the fake-object creation code path.
this variable provides a way to toggle the codepath -- I still think
the fake-object code path may be necessary in some situations but I don't know what they are
yet.

I tried explaining this briefly in the commit message.


(defun gobject (gtype ptr)
(let* ((info (repository-find-by-gtype nil gtype))
(let* ((info (or (repository-find-by-gtype nil gtype)
(if (not use-fake-objects)
(some (lambda (gtype)
(repository-find-by-gtype nil gtype))
(g-type-interfaces gtype)))))
(info-type (and info (info-get-type info)))
(object-class (if (null info) (find-fake-object-class gtype))))
(when object-class
(return-from gobject (build-object-ptr object-class ptr)))
(if (member info-type '(:object :struct))
(if (member info-type '(:object :struct :interface))
(let ((object-class (find-build-interface info)))
(if (eq info-type :object)
(build-object-ptr object-class ptr)
(build-struct-ptr object-class ptr)))
(if (eq info-type :interface)
(build-object-ptr object-class ptr)
(build-struct-ptr object-class ptr))))
(error "gtype ~a not found in GI. Found ~a"
gtype info-type))))

Expand Down