[Openmcl-cvs-notifications] r11357 - /trunk/source/lib/ffi-darwinx8632.lisp
rme at clozure.com
rme at clozure.com
Wed Nov 12 23:33:19 EST 2008
Author: rme
Date: Wed Nov 12 23:33:19 2008
New Revision: 11357
Log:
Try to improve handling of small structs returned by value a little bit
more.
Modified:
trunk/source/lib/ffi-darwinx8632.lisp
Modified: trunk/source/lib/ffi-darwinx8632.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/ffi-darwinx8632.lisp (original)
+++ trunk/source/lib/ffi-darwinx8632.lisp Wed Nov 12 23:33:19 2008
@@ -19,7 +19,8 @@
=
(defun x86-darwin32::expand-ff-call (callform args &key (arg-coerce #'null=
-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
(let* ((result-type-spec (or (car (last args)) :void))
- (result-in-registers-p nil)
+ (struct-by-value-p nil)
+ (result-op nil)
(result-temp nil)
(result-form nil))
(multiple-value-bind (result-type error)
@@ -38,12 +39,18 @@
(argforms :address)
(argforms result-form))
(progn
- ;; We're going to get either 32 bits in EAX, or
- ;; 64 bits in EDX:EAX.
- (setq result-type (parse-foreign-type :signed-doubleword)
- result-type-spec :signed-doubleword)
+ (ecase (foreign-type-bits result-type)
+ (8 (setq result-type-spec :unsigned-byte
+ result-op '%get-unsigned-byte))
+ (16 (setq result-type-spec :unsigned-halfword
+ result-op '%get-unsigned-word))
+ (32 (setq result-type-spec :unsigned-fullword
+ result-op '%get-unsigned-long))
+ (64 (setq result-type-spec :unsigned-doubleword
+ result-op '%%get-unsigned-longlong)))
+ (setq result-type (parse-foreign-type result-type-spec))
(setq result-temp (gensym))
- (setq result-in-registers-p t))))
+ (setq struct-by-value-p t))))
(unless (evenp (length args))
(error "~s should be an even-length list of alternating foreign types a=
nd values" args))
(do* ((args args (cddr args)))
@@ -65,12 +72,12 @@
(argforms (funcall arg-coerce arg-type-spec arg-value-form))))))
(argforms (foreign-type-to-representation-type result-type))
(let* ((call (funcall result-coerce result-type-spec `(, at callform ,@(ar=
gforms)))))
- (if result-in-registers-p
+ (if struct-by-value-p
`(let* ((,result-temp (%null-ptr)))
(declare (dynamic-extent ,result-temp)
(type macptr ,result-temp))
(%setf-macptr ,result-temp ,result-form)
- (setf (%%get-signed-longlong ,result-temp 0)
+ (setf (,result-op ,result-temp 0)
,call))
call))))))
=
@@ -99,7 +106,7 @@
(rlets (list struct-result-name (foreign-record-type-name rtype)))))
(do* ((argvars argvars (cdr argvars))
(argspecs argspecs (cdr argspecs))
- (offset 8 (incf offset 4)))
+ (offset 8))
((null argvars)
(values (rlets) (lets) (dynamic-extent-names) (inits) rtype nil 4))
(let* ((name (car argvars))
@@ -108,37 +115,46 @@
(bits (require-foreign-type-bits argtype))
(double nil))
(if (typep argtype 'foreign-record-type)
+ (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 offset
+ (incf offset (* 4 (ceiling bits 32)))))))
(progn
- (format t "~& arg is some foreign type"))
- (lets (list name
- `(,
- (ecase (foreign-type-to-representation-type argtype)
- (:single-float '%get-single-float)
- (:double-float (setq double t) '%get-double-float)
- (:signed-doubleword (setq double t)
- '%%get-signed-longlong)
- (:signed-fullword '%get-signed-long)
- (:signed-halfword '%get-signed-word)
- (:signed-byte '%get-signed-byte)
- (:unsigned-doubleword (setq double t)
- '%%get-unsigned-longlong)
- (:unsigned-fullword '%get-unsigned-long)
- (:unsigned-halfword '%get-unsigned-word)
- (:unsigned-byte '%get-unsigned-byte)
- (:address '%get-ptr))
- ,stack-ptr
- ,offset))))
- (when double (incf offset 4)))))))
+ (lets (list name
+ `(,
+ (ecase (foreign-type-to-representation-type argtype)
+ (:single-float '%get-single-float)
+ (:double-float (setq double t) '%get-double-float)
+ (:signed-doubleword (setq double t)
+ '%%get-signed-longlong)
+ (:signed-fullword '%get-signed-long)
+ (:signed-halfword '%get-signed-word)
+ (:signed-byte '%get-signed-byte)
+ (:unsigned-doubleword (setq double t)
+ '%%get-unsigned-longlong)
+ (:unsigned-fullword '%get-unsigned-long)
+ (:unsigned-halfword '%get-unsigned-word)
+ (:unsigned-byte '%get-unsigned-byte)
+ (:address '%get-ptr))
+ ,stack-ptr
+ ,offset)))
+ (incf offset 4)
+ (when double (incf offset 4)))))))))
=
(defun x86-darwin32::generate-callback-return-value (stack-ptr fp-args-ptr=
result return-type struct-return-arg)
(declare (ignore fp-args-ptr))
- (format t "~&in generate-callback-return-value")
(unless (eq return-type *void-foreign-type*)
(if (typep return-type 'foreign-record-type)
;; Would have been mapped to :VOID unless record-type was <=3D 64 bi=
ts
- (format t "~&need to return structure ~s by value" return-type)
+ (ecase (ensure-foreign-type-bits return-type)
+ (8 `(setf (%get-unsigned-byte ,stack-ptr -8)
+ (%get-unsigned-byte ,struct-return-arg 0)))
+ (16 `(setf (%get-unsigned-word ,stack-ptr -8)
+ (%get-unsigned-word ,struct-return-arg 0)))
+ (32 `(setf (%get-unsigned-long ,stack-ptr -8)
+ (%get-unsigned-long ,struct-return-arg 0)))
+ (64 `(setf (%%get-unsigned-longlong ,stack-ptr -8)
+ (%%get-unsigned-longlong ,struct-return-arg 0))))
(let* ((return-type-keyword (foreign-type-to-representation-type ret=
urn-type)))
- (ccl::collect ((forms))
+ (collect ((forms))
(forms 'progn)
(case return-type-keyword
(:single-float
More information about the Openmcl-cvs-notifications
mailing list