Index: /trunk/ccl/lib/ffi-linuxppc32.lisp =================================================================== --- /trunk/ccl/lib/ffi-linuxppc32.lisp (revision 5802) +++ /trunk/ccl/lib/ffi-linuxppc32.lisp (revision 5803) @@ -86,5 +86,5 @@ call)))))) -;;; Return N values: +;;; Return 7 values: ;;; A list of RLET bindings ;;; A list of LET* bindings @@ -92,5 +92,9 @@ ;;; A list of initializaton forms for (some) structure args ;;; A FOREIGN-TYPE representing the "actual" return type. -(defun linux32::generate-callback-bindings (stack-ptr argvars argspecs result-spec struct-result-name) +;;; A form which can be used to initialize FP-ARGS-PTR, relative +;;; to STACK-PTR. (This is unused on linuxppc32.) +;;; The byte offset of the foreign return address, relative to STACK-PTR +(defun linux32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (declare (ignore fp-args-ptr)) (collect ((lets) (rlets) @@ -110,5 +114,5 @@ (argspecs argspecs (cdr argspecs))) ((null argvars) - (values (rlets) (lets) (dynamic-extent-names) nil rtype)) + (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 0 #|wrong|#)) (let* ((name (car argvars)) (spec (car argspecs)) @@ -189,5 +193,6 @@ (setq gpr nextgpr fpr nextfpr offset nextoffset)))))))) -(defun linux32::generate-callback-return-value (stack-ptr result return-type struct-return-arg) +(defun linux32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (declare (ignore fp-args-ptr)) (unless (eq return-type *void-foreign-type*) (let* ((return-type-keyword Index: /trunk/ccl/lib/ffi-linuxppc64.lisp =================================================================== --- /trunk/ccl/lib/ffi-linuxppc64.lisp (revision 5802) +++ /trunk/ccl/lib/ffi-linuxppc64.lisp (revision 5803) @@ -20,5 +20,5 @@ ;;; Structures whose size is less than 64 bits are passed "right-justified" ;;; in a GPR. -;;; Structures passed by value are passed in GPRs as N doublewords. +;;; Larger structures passed by value are passed in GPRs as N doublewords. ;;; If the structure would require > 64-bit alignment, this might result ;;; in some GPRs/parameter area words being skipped. (We don't handle this). @@ -78,2 +78,116 @@ (argforms (foreign-type-to-representation-type result-type)) (funcall result-coerce result-type-spec `(,@callform ,@(argforms))))))) + +(defun linux64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (collect ((lets) + (rlets) + (inits) + (dynamic-extent-names)) + (let* ((rtype (parse-foreign-type result-spec)) + (fp-regs-form nil)) + (flet ((set-fp-regs-form () + (unless fp-regs-form + (setq fp-regs-form `(%get-ptr ,stack-ptr ,(- ppc64::c-frame.unused-1 ppc64::c-frame.param0)))))) + (when (typep rtype 'foreign-record-type) + (setq argvars (cons struct-result-name argvars) + argspecs (cons :address argspecs) + rtype *void-foreign-type*)) + (when (typep rtype 'foreign-float-type) + (set-fp-regs-form)) + (do* ((argvars argvars (cdr argvars)) + (argspecs argspecs (cdr argspecs)) + (fp-arg-num 0) + (offset 0 (+ offset delta)) + (delta 8 8) + (bias 0 0) + (use-fp-args nil nil)) + ((null argvars) + (values (rlets) (lets) (dynamic-extent-names) (inits) rtype fp-regs-form (- ppc64::c-frame.savelr ppc64::c-frame.param0))) + (let* ((name (car argvars)) + (spec (car argspecs)) + (argtype (parse-foreign-type spec)) + (bits (ensure-foreign-type-bits argtype))) + (if (and (typep argtype 'foreign-record-type) + (< bits 63)) + (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))))) + (let* ((access-form + `(,(cond + ((typep argtype 'foreign-single-float-type) + (if (< (incf fp-arg-num) 14) + (progn + (setq use-fp-args t) + '%get-single-float-from-double-ptr) + (progn + (setq bias 4) + '%get-single-float))) + ((typep argtype 'foreign-double-float-type) + (if (< (incf fp-arg-num) 14) + (setq use-fp-args t)) + '%get-double-float) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (foreign-integer-type-signed argtype)) + '%%get-signed-longlong) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (not (foreign-integer-type-signed argtype))) + '%%get-unsigned-longlong) + ((or (typep argtype 'foreign-pointer-type) + (typep argtype 'foreign-array-type)) + '%get-ptr) + (t + (cond ((typep argtype 'foreign-integer-type) + (let* ((bits (foreign-integer-type-bits argtype)) + (signed (foreign-integer-type-signed argtype))) + (cond ((<= bits 8) + (setq bias 7) + (if signed + '%get-signed-byte ' + '%get-unsigned-byte)) + ((<= bits 16) + (setq bias 6) + (if signed + '%get-signed-word + '%get-unsigned-word)) + ((<= bits 32) + (setq bias 4) + (if signed + '%get-signed-long + '%get-unsigned-long)) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + ,(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 (eq spec :address) + (dynamic-extent-names name)) + (when use-fp-args (set-fp-regs-form)))))))))) + + +;;; All structures are "returned" via the implicit first argument; we'll have +;;; already translated the return type to :void in that case. +(defun linux64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (declare (ignore struct-return-arg)) + (unless (eq return-type *void-foreign-type*) + (let* ((return-type-keyword (foreign-type-to-representation-type return-type)) + (result-ptr (case return-type-keyword + ((:single-float :double-float) + fp-args-ptr) + (t stack-ptr)))) + `(setf (, + (case return-type-keyword + (:address '%get-ptr) + (:signed-doubleword '%%get-signed-longlong) + (:unsigned-doubleword '%%get-unsigned-longlong) + ((:double-float :single-float) + (setq stack-ptr `(%get-ptr ,stack-ptr ,(- ppc64::c-frame.unused-1 ppc64::c-frame.param0))) + '%get-double-float) + (t '%%get-signed-longlong ) + ) ,result-ptr 0) ,result))))