[Openmcl-cvs-notifications] r12590 - in /trunk/source: compiler/X86/X8632/x8632-backend.lisp compiler/X86/X8664/x8664-backend.lisp lib/ffi-darwinppc32.lisp lib/ffi-darwinppc64.lisp lib/ffi-linuxppc32.lisp lib/ffi-linuxppc64.lisp lib/ffi-win64.lisp
gb at clozure.com
gb at clozure.com
Sun Aug 16 17:17:03 EDT 2009
Author: gb
Date: Sun Aug 16 17:17:02 2009
New Revision: 12590
Log:
When generating binding forms for DEFCALLBACK, allow a parameter name
to be NIL. Don't actually generate a binding for such a parameter, but
do go through the macroexpand-time steps of determining its location
and size (and therefore the location of subsequent named parameters.)
This is intended to do what (DECLARE IGNORE) would do for a named parameter,
only it keeps the compiler from having to decide whether the variable's
initform is side-effect free. (We're generally trying to avoid the =
side-effects of having to cons a pointer that's subsequently unreferenced;
this happens with the _CMD argument to ObjC callbacks, for instance.)
Modified:
trunk/source/compiler/X86/X8632/x8632-backend.lisp
trunk/source/compiler/X86/X8664/x8664-backend.lisp
trunk/source/lib/ffi-darwinppc32.lisp
trunk/source/lib/ffi-darwinppc64.lisp
trunk/source/lib/ffi-linuxppc32.lisp
trunk/source/lib/ffi-linuxppc64.lisp
trunk/source/lib/ffi-win64.lisp
Modified: trunk/source/compiler/X86/X8632/x8632-backend.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/compiler/X86/X8632/x8632-backend.lisp (original)
+++ trunk/source/compiler/X86/X8632/x8632-backend.lisp Sun Aug 16 17:17:02 =
2009
@@ -382,8 +382,8 @@
;;; if this can't be determined. (Only meaningful on Windows.)
=
(defun x8632::generate-callback-bindings (stack-ptr fp-args-ptr argvars
- argspecs result-spec
- struct-result-name)
+ argspecs result-spec
+ struct-result-name)
(declare (ignore fp-args-ptr))
(collect ((lets)
(rlets)
@@ -408,30 +408,29 @@
(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
- (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)))
+ (let* ((form `(%inc-ptr ,stack-ptr
+ ,(prog1 offset
+ (incf offset
+ (* 4 (ceiling bits 32)))))))
+ (when name (lets (list name form))))
+ (let* ((form `(,
+ (ecase (foreign-type-to-representation-type arg=
type)
+ (:single-float '%get-single-float)
+ (:double-float (setq double t) '%get-double-f=
loat)
+ (: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-longlon=
g)
+ (:unsigned-fullword '%get-unsigned-long)
+ (:unsigned-halfword '%get-unsigned-word)
+ (:unsigned-byte '%get-unsigned-byte)
+ (:address '%get-ptr))
+ ,stack-ptr
+ ,offset)))
+ (when name (lets (list name form)))
(incf offset 4)
(when double (incf offset 4)))))))))
=
Modified: trunk/source/compiler/X86/X8664/x8664-backend.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/compiler/X86/X8664/x8664-backend.lisp (original)
+++ trunk/source/compiler/X86/X8664/x8664-backend.lisp Sun Aug 16 17:17:02 =
2009
@@ -589,36 +589,39 @@
(:integer (if (< (decf gprs) 0) (setq first8 :memory)))
(:float (if (< (decf fprs) 0) (setq first8 :memory)))))
(if (eq first8 :memory)
+ (let* ((form `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-of=
fset
+ (incf m=
emory-arg-offset (* 8 (ceiling bits 64)))))))
+ (when name
+ (lets (list name form))
+ (dynamic-extent-names name)))
(progn
- (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 memory-=
arg-offset
- (incf m=
emory-arg-offset (* 8 (ceiling bits 64)))))))
- (dynamic-extent-names name))
- (progn
- (rlets (list name (foreign-record-type-name argtype)))
- (inits `(setf (%%get-unsigned-longlong ,name 0)
- (%%get-unsigned-longlong ,stack-ptr ,(if (eq =
first8 :integer) (next-gpr) (next-fpr)))))
+ (when name (rlets (list name (foreign-record-type-name=
argtype))))
+ (let* ((init1 `(setf (%%get-unsigned-longlong ,name 0)
+ (%%get-unsigned-longlong ,stack-ptr ,(if (eq =
first8 :integer) (next-gpr) (next-fpr))))))
+ (when name (inits init1)))
(if second8
- (inits `(setf (%%get-unsigned-longlong ,name 8)
- (%%get-unsigned-longlong ,stack-ptr ,(if (eq =
second8 :integer) (next-gpr) (next-fpr)))))))))
- (lets (list name
- `(,
- (ecase (foreign-type-to-representation-type a=
rgtype)
- (:single-float (setq fp t) '%get-single-flo=
at)
- (:double-float (setq fp t) '%get-double-flo=
at)
- (:signed-doubleword '%%get-signed-longlong)
- (:signed-fullword '%get-signed-long)
- (:signed-halfword '%get-signed-word)
- (:signed-byte '%get-signed-byte)
- (:unsigned-doubleword '%%get-unsigned-longl=
ong)
- (:unsigned-fullword '%get-unsigned-long)
- (:unsigned-halfword '%get-unsigned-word)
- (:unsigned-byte '%get-unsigned-byte)
- (:address
- #+nil
- (dynamic-extent-names name)
- '%get-ptr))
- ,stack-ptr
- ,(if fp (next-fpr) (next-gpr))))))))))))
+ (let* ((init2 `(setf (%%get-unsigned-longlong ,name =
8)
+ (%%get-unsigned-longlong ,stack-ptr ,(if (e=
q second8 :integer) (next-gpr) (next-fpr))))))
+ (when name (inits init2 )))))))
+ (let* ((form`(,
+ (ecase (foreign-type-to-representation-type ar=
gtype)
+ (:single-float (setq fp t) '%get-single-floa=
t)
+ (:double-float (setq fp t) '%get-double-floa=
t)
+ (:signed-doubleword '%%get-signed-longlong)
+ (:signed-fullword '%get-signed-long)
+ (:signed-halfword '%get-signed-word)
+ (:signed-byte '%get-signed-byte)
+ (:unsigned-doubleword '%%get-unsigned-longlo=
ng)
+ (:unsigned-fullword '%get-unsigned-long)
+ (:unsigned-halfword '%get-unsigned-word)
+ (:unsigned-byte '%get-unsigned-byte)
+ (:address
+ #+nil
+ (when name (dynamic-extent-names name))
+ '%get-ptr))
+ ,stack-ptr
+ ,(if fp (next-fpr) (next-gpr))))) =
=
+ (if name (lets (list name form )))))))))))
=
(defun x8664::generate-callback-return-value (stack-ptr fp-args-ptr result=
return-type struct-return-arg)
(declare (ignore fp-args-ptr))
Modified: trunk/source/lib/ffi-darwinppc32.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-darwinppc32.lisp (original)
+++ trunk/source/lib/ffi-darwinppc32.lisp Sun Aug 16 17:17:02 2009
@@ -210,12 +210,16 @@
(let* ((type0 (darwin32::record-type-has-single-scalar-field=
argtype)))
(if type0
(progn
- (rlets (list name (foreign-record-type-name argtype)))
- (inits `(setf ,(%foreign-access-form name type0 0 nil)
+ (when name (rlets (list name (foreign-record-type-name=
argtype))))
+ (let* ((init `(setf ,(%foreign-access-form name type0 =
0 nil)
,(next-scalar-arg type0))))
- (progn (setq delta (* (ceiling (foreign-record-type-bits=
argtype) 32) 4))
- (lets (list name `(%inc-ptr ,stack-ptr ,offset ))))))
- (lets (list name (next-scalar-arg argtype))))
+ (when name (inits init))))
+ (progn
+ (setq delta (* (ceiling (foreign-record-type-bits argt=
ype) 32) 4))
+ (when name ; no side-efects hers =
+ (lets (list name `(%inc-ptr ,stack-ptr ,offset)))))))
+ (let* ((pair (list name (next-scalar-arg argtype))))
+ (when name (lets pair))))
#+nil
(when (or (typep argtype 'foreign-pointer-type)
(typep argtype 'foreign-array-type))
Modified: trunk/source/lib/ffi-darwinppc64.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-darwinppc64.lisp (original)
+++ trunk/source/lib/ffi-darwinppc64.lisp Sun Aug 16 17:17:02 2009
@@ -456,7 +456,7 @@
(if (or (darwin64::record-type-contains-union argtype)
(=3D bits 128))
(progn (setq delta (* (ceiling bits 64) 8))
- (lets (list name `(%inc-ptr ,stack-ptr ,offset )))
+ (when name (lets (list name `(%inc-ptr ,stack-ptr=
,offset ))))
(incf offset delta))
=
(let* ((flattened-fields (darwin64::flatten-fields argty=
pe)))
@@ -476,33 +476,40 @@
(typep (foreign-record-field-typ=
e field)
'foreign-single-float-typ=
e))
(return t))))))
- (rlets (list name (or (foreign-record-type-name argt=
ype)
- spec)))
+ (when name (rlets (list name (or (foreign-record-typ=
e-name argtype)
+ spec))))
(do* ((bit-offset 0 (+ bit-offset 64))
(byte-offset 0 (+ byte-offset 8)))
((>=3D bit-offset bits))
(if (double-float-at-offset bit-offset)
- (inits `(setf (%get-double-float ,name ,byte-off=
set)
- ,(next-scalar-arg (parse-foreign-type :=
double-float))))
+ (let* ((init `(setf (%get-double-float ,name ,by=
te-offset)
+ ,(next-scalar-arg (parse-foreign-type :=
double-float)))))
+ (when name
+ (inits init)))
(let* ((high-single (single-float-at-offset bit-=
offset))
- (low-single (single-float-at-offset (+ bi=
t-offset 32))))
- (inits `(setf (%%get-unsigned-longlong ,name ,=
byte-offset)
- ,(next-scalar-arg (parse-foreign-type=
'(:unsigned 64)))))
+ (low-single (single-float-at-offset (+ bi=
t-offset 32)))
+ (init `(setf (%%get-unsigned-longlong ,na=
me ,byte-offset)
+ ,(next-scalar-arg (parse-foreign-type=
'(:unsigned 64))))))
+ (when name (inits init))
(when high-single
(when (< (incf fp-arg-num) 14)
(set-fp-regs-form)
- (inits `(setf (%get-single-float ,name ,by=
te-offset)
+ (when name
+ (inits `(setf (%get-single-float ,name ,=
byte-offset)
(%get-single-float-from-double-ptr
,fp-args-ptr
- ,(* 8 (1- fp-arg-num)))))))
+ ,(* 8 (1- fp-arg-num))))))))
(when low-single
(when (< (incf fp-arg-num) 14)
(set-fp-regs-form)
- (inits `(setf (%get-single-float ,name ,(+=
4 byte-offset))
+ (when name
+ (inits `(setf (%get-single-float ,name ,=
(+ 4 byte-offset))
(%get-single-float-from-double-ptr
,fp-args-ptr
- ,(* 8 (1- fp-arg-num)))))))))))))
- (lets (list name (next-scalar-arg argtype))))
+ ,(* 8 (1- fp-arg-num))))))))))))=
))
+ (let* ((pair (list name (next-scalar-arg argtype))))
+ (when name =
+ (lets name))))
#+nil
(when (or (typep argtype 'foreign-pointer-type)
(typep argtype 'foreign-array-type))
Modified: trunk/source/lib/ffi-linuxppc32.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-linuxppc32.lisp (original)
+++ trunk/source/lib/ffi-linuxppc32.lisp Sun Aug 16 17:17:02 2009
@@ -186,7 +186,7 @@
(error "Don't know how to access forei=
gn argument of type ~s" (unparse-foreign-type argtype))))))
,stack-ptr
,(+ target bias))))
- (lets (list name access-form))
+ (when name (lets (list name access-form)))
#+nil
(when (eq spec :address)
(dynamic-extent-names name))
Modified: trunk/source/lib/ffi-linuxppc64.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-linuxppc64.lisp (original)
+++ trunk/source/lib/ffi-linuxppc64.lisp Sun Aug 16 17:17:02 2009
@@ -110,10 +110,10 @@
(if (and (typep argtype 'foreign-record-type)
(< bits 64))
(progn
- (rlets (list name (foreign-record-type-name argtype)))
- (inits `(setf (%%get-unsigned-longlong ,name 0)
- (ash (%%get-unsigned-longlong ,stack-ptr ,offset)
- ,(- 64 bits)))))
+ (when name (rlets (list name (foreign-record-type-name arg=
type))))
+ (when name (inits `(setf (%%get-unsigned-longlong ,name 0)
+ (ash (%%get-unsigned-longlong ,stack-p=
tr ,offset)
+ ,(- 64 bits))))))
(let* ((access-form
`(,(cond
((typep argtype 'foreign-single-float-type)
@@ -168,7 +168,8 @@
,(if use-fp-args fp-args-ptr stack-ptr)
,(if use-fp-args (* 8 (1- fp-arg-num))
`(+ ,offset ,bias)))))
- (lets (list name access-form))
+ (when name (lets (list name access-form)))
+ #+nil
(when (eq spec :address)
(dynamic-extent-names name))
(when use-fp-args (set-fp-regs-form))))))))))
Modified: trunk/source/lib/ffi-win64.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-win64.lisp (original)
+++ trunk/source/lib/ffi-win64.lisp Sun Aug 16 17:17:02 2009
@@ -136,8 +136,8 @@
(argtype (parse-foreign-type spec)))
(if (typep argtype 'foreign-record-type)
(setq argtype :address))
- (lets (list name
- `(,
+ (let* ((access-form
+ `(,
(ecase (foreign-type-to-representation-type argt=
ype)
(:single-float (setq fp t) '%get-single-float)
(:double-float (setq fp t) '%get-double-float)
@@ -154,7 +154,8 @@
(dynamic-extent-names name)
'%get-ptr))
,stack-ptr
- ,(if fp (next-fpr) (next-gpr)))))))))))
+ ,(if fp (next-fpr) (next-gpr)))))
+ (when name (lets (list name access-form))))))))))
=
(defun win64::generate-callback-return-value (stack-ptr fp-args-ptr result=
return-type struct-return-arg)
(declare (ignore fp-args-ptr))
More information about the Openmcl-cvs-notifications
mailing list