Changeset 5803

Timestamp:

Jan 28, 2007, 8:47:27 PM (18 years ago)

Author:

Gary Byers

Message:

Flesh things out a bit more, change the API, get things working ... still
a moving target.

Location:

trunk/ccl/lib

Files:

• ffi-linuxppc32.lisp (modified) (4 diffs)
• ffi-linuxppc64.lisp (modified) (2 diffs)

trunk/ccl/lib/ffi-linuxppc32.lisp

@@ -86 +86 @@
             call))))))
 
-;;; Return N values:
+;;; Return 7 values:
 ;;; A list of RLET bindings
 ;;; A list of LET* bindings
@@ -92 +92 @@
 ;;; 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 +114 @@
                   (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 +193 @@
                   (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

trunk/ccl/lib/ffi-linuxppc64.lisp

@@ -20 +20 @@
 ;;; 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 +78 @@
         (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))))