Changeset 5754

Timestamp:

Jan 20, 2007, 8:55:20 PM (18 years ago)

Author:

Gary Byers

Message:

Pretty simple. 3 down, 4 to go.

File:

• trunk/ccl/lib/ffi-linuxppc32.lisp (modified) (1 diff)

trunk/ccl/lib/ffi-linuxppc32.lisp

@@ -15 +15 @@
 ;;;   http://opensource.franz.com/preamble.html
 
+(in-package "CCL")
+
+;;; LinuxPPC32:
+;;; Structures are never actually passed by value; the caller
+;;; instead passes a pointer to the structure or a copy of it.
+;;; Structures whose size is 8 bytes or less are returned in r3/r4;
+;;; this happens rarely enough that we can probably get away with
+;;; boxing an :UNSIGNED-DOUBLEWORD and storing it in the structure-return
+;;; argument.
+
+(defun linux32::record-type-returns-structure-as-first-arg (rtype)
+  (when (and rtype
+             (not (typep rtype 'unsigned-byte))
+             (not (member rtype *foreign-representation-type-keywords*
+                          :test #'eq)))
+    (let* ((ftype (if (typep rtype 'foreign-type)
+                    rtype
+                    (parse-foreign-type rtype))))
+      (and (typep ftype 'foreign-record-type)
+           (> (ensure-foreign-type-bits ftype) 64)))))
+
+
+(defun linux32::expand-ff-call (callform args)
+  (let* ((result-type-spec (or (car (last args)) :void))
+         (enclosing-form nil)
+         (result-form nil))
+    (multiple-value-bind (result-type error)
+        (parse-foreign-type result-type-spec)
+      (if error
+        (setq result-type-spec :void result-type *void-foreign-type*)
+        (setq args (butlast args)))
+      (collect ((argforms))
+        (when (eq (car args) :monitor-exception-ports)
+          (argforms (pop args)))
+        (when (typep result-type 'foreign-record-type)
+          (if (linux32::record-type-returns-structure-as-first-arg result-type)
+            (progn
+              (setq result-type *void-foreign-type*
+                    result-type-spec :void)
+              (argforms :address)
+              (argforms result-form))
+            (progn
+              (setq result-type (parse-foreign-type :unsigned-doubleword)
+                    result-type-spec :unsigned-doubleword
+                    enclosing-form `(setf (%%get-unsigned-longlong ,result-form))))))
+        (unless (evenp (length args))
+          (error "~s should be an even-length list of alternating foreign types and values" args))        
+                (do* ((args args (cddr args)))
+             ((null args))
+          (let* ((arg-type-spec (car args))
+                 (arg-value-form (cadr args)))
+            (if (or (member arg-type-spec *foreign-representation-type-keywords*
+                           :test #'eq)
+                    (typep arg-type-spec 'unsigned-byte))
+              (progn
+                (argforms arg-type-spec)
+                (argforms arg-value-form))
+              (let* ((ftype (parse-foreign-type arg-type-spec)))
+                (if (typep ftype 'foreign-record-type)
+                  (progn
+                    (argforms :address)
+                    (argforms arg-value-form))
+                  (progn
+                    (argforms (foreign-type-to-representation-type ftype))
+                    (argforms arg-value-form)))))))
+        (argforms (foreign-type-to-representation-type result-type))
+        (let* ((call `(,@callform ,@(argforms))))
+          (if enclosing-form
+            `(,@enclosing-form ,call)
+            call))))))