Changeset 11549


Ignore:
Timestamp:
Dec 24, 2008, 7:35:26 AM (11 years ago)
Author:
rme
Message:

Merge fixes from ffi-darwinx8632 so that structure arg passing works.

We always return structures as a hidden first arg on Linux/x8632, so
update x86-linux32::record-type-returns-structure-as-first-arg to
return t always. Also update expand-ff-call and
generate-callback-return-value accordingly.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/ffi-linuxx8632.lisp

    r10790 r11549  
    11(in-package "CCL")
    22
    3 ;;; Some small structures are returned in EAX and EDX.  Otherwise,
    4 ;;; return values are placed at the address specified by the caller.
     3;; Always use the "hidden first arg" convention on linuxx8632
    54(defun x86-linux32::record-type-returns-structure-as-first-arg (rtype)
    6   (when (and rtype
    7              (not (typep rtype 'unsigned-byte))
    8              (not (member rtype *foreign-representation-type-keywords*
    9                           :test #'eq)))
    10     (let* ((ftype (if (typep rtype 'foreign-type)
    11                     rtype
    12                     (parse-foreign-type rtype)))
    13            (nbits (ensure-foreign-type-bits ftype)))
    14       (not (member nbits '(8 16 32 64))))))
    15 
    16 (defun x86-linux32::struct-from-regbuf-values (r rtype regbuf)
    17   (ecase (ensure-foreign-type-bits rtype)
    18     (8 `(setf (%get-unsigned-byte ,r 0) (%get-unsigned-byte ,regbuf 0)))
    19     (16 `(setf (%get-unsigned-word ,r 0) (%get-unsigned-word ,regbuf 0)))
    20     (32 `(setf (%get-unsigned-long ,r 0) (%get-unsigned-long ,regbuf 0)))
    21     (64 `(setf (%%get-unsigned-longlong ,r 0)
    22                (%%get-unsigned-longlong ,regbuf 0)))))
     5  (declare (ignore rtype))
     6  t)
    237
    248;;; All arguments are passed on the stack.
     
    2812(defun x86-linux32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
    2913  (let* ((result-type-spec (or (car (last args)) :void))
    30          (regbuf nil)
    31          (result-temp nil)
    32          (result-form nil)
    33          (struct-result-type nil))
     14         (result-form nil))
    3415    (multiple-value-bind (result-type error)
    3516        (ignore-errors (parse-foreign-type result-type-spec))
     
    3819        (setq args (butlast args)))
    3920      (collect ((argforms))
    40         (when (eq (car args) :monitor-exception-ports)
    41           (argforms (pop args)))
    4221        (when (typep result-type 'foreign-record-type)
    4322          (setq result-form (pop args)
    44                 struct-result-type result-type
    4523                result-type *void-foreign-type*
    4624                result-type-spec :void)
    47           (if (x86-linux32::record-type-returns-structure-as-first-arg result-type)
    48             (progn
    49               (argforms :address)
    50               (argforms result-form))
    51             (progn
    52               (setq regbuf (gensym)
    53                     result-temp (gensym))
    54               (argforms :registers)
    55               (argforms regbuf))))
     25          (argforms :address)
     26          (argforms result-form))
    5627        (unless (evenp (length args))
    5728          (error "~s should be an even-length list of alternating foreign types and values" args))
     
    7546                            arg-type-spec (foreign-type-to-representation-type ftype)
    7647                            bits (ensure-foreign-type-bits ftype)))
    77                     (if (and (typep ftype 'foreign-record-type)
    78                              (<= bits 32))
     48                    (if (typep ftype 'foreign-record-type)
    7949                      (argforms (ceiling bits 32))
    8050                      (argforms (foreign-type-to-representation-type ftype)))
     
    8252          (argforms (foreign-type-to-representation-type result-type))
    8353          (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
    84             (if regbuf
    85               `(let* ((,result-temp (%null-ptr)))
    86                  (declare (dynamic-extent ,result-temp)
    87                           (type macptr ,result-temp))
    88                  (%setf-macptr ,result-temp ,result-form)
    89                  (%stack-block ((,regbuf 8))
    90                    ,call
    91                    ,(x86-linux32::struct-from-regbuf-values result-temp struct-result-type regbuf)))
    92               call))))))
     54            call)))))
    9355
    9456;;; Return 7 values:
     
    9658;;; A list of LET* bindings
    9759;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
    98 ;;; A list of initializaton forms for (some) structure args
     60;;; A list of initializaton forms for (some) structure args (not used on x8632)
    9961;;; A FOREIGN-TYPE representing the "actual" return type.
    10062;;; A form which can be used to initialize FP-ARGS-PTR, relative
     
    10668  (collect ((lets)
    10769            (rlets)
    108             (inits)
    10970            (dynamic-extent-names))
    11071    (let* ((rtype (parse-foreign-type result-spec)))
     
    11778      (do* ((argvars argvars (cdr argvars))
    11879            (argspecs argspecs (cdr argspecs))
    119             (offset 8 (incf offset 4)))
     80            (offset 8))
    12081           ((null argvars)
    121             (values (rlets) (lets) (dynamic-extent-names) (inits) rtype nil 4))
     82            (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 4))
    12283        (let* ((name (car argvars))
    12384               (spec (car argspecs))
     
    12687               (double nil))
    12788          (if (typep argtype 'foreign-record-type)
     89            (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 offset
     90                                                           (incf offset (* 4 (ceiling bits 32)))))))
    12891            (progn
    129               (format t "~& arg is some foreign type"))
    130             (lets (list name
    131                         `(,
    132                           (ecase (foreign-type-to-representation-type argtype)
    133                             (:single-float '%get-single-float)
    134                             (:double-float (setq double t) '%get-double-float)
    135                             (:signed-doubleword (setq double t)
    136                                                 '%%get-signed-longlong)
    137                             (:signed-fullword '%get-signed-long)
    138                             (:signed-halfword '%get-signed-word)
    139                             (:signed-byte '%get-signed-byte)
    140                             (:unsigned-doubleword (setq double t)
    141                                                   '%%get-unsigned-longlong)
    142                             (:unsigned-fullword '%get-unsigned-long)
    143                             (:unsigned-halfword '%get-unsigned-word)
    144                             (:unsigned-byte '%get-unsigned-byte)
    145                             (:address '%get-ptr))
    146                           ,stack-ptr
    147                           ,offset))))
    148           (when double (incf offset 4)))))))
     92              (lets (list name
     93                          `(,
     94                            (ecase (foreign-type-to-representation-type argtype)
     95                              (:single-float '%get-single-float)
     96                              (:double-float (setq double t) '%get-double-float)
     97                              (:signed-doubleword (setq double t)
     98                                                  '%%get-signed-longlong)
     99                              (:signed-fullword '%get-signed-long)
     100                              (:signed-halfword '%get-signed-word)
     101                              (:signed-byte '%get-signed-byte)
     102                              (:unsigned-doubleword (setq double t)
     103                                                    '%%get-unsigned-longlong)
     104                              (:unsigned-fullword '%get-unsigned-long)
     105                              (:unsigned-halfword '%get-unsigned-word)
     106                              (:unsigned-byte '%get-unsigned-byte)
     107                              (:address '%get-ptr))
     108                            ,stack-ptr
     109                            ,offset)))
     110              (incf offset 4)
     111              (when double (incf offset 4)))))))))
    149112
    150113(defun x86-linux32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
    151   (declare (ignore fp-args-ptr))
    152   (format t "~&in generate-callback-return-value")
     114  (declare (ignore fp-args-ptr struct-return-arg))
    153115  (unless (eq return-type *void-foreign-type*)
    154116    (if (typep return-type 'foreign-record-type)
    155       ;; Would have been mapped to :VOID unless record-type was <= 64 bits
    156       (format t "~&need to return structure ~s by value" return-type)
     117      ;; Should have been mapped to :VOID
     118      (error "Shouldn't be trying to return a structure by value on linuxx8632")
    157119      (let* ((return-type-keyword (foreign-type-to-representation-type return-type)))
    158         (ccl::collect ((forms))
     120        (collect ((forms))
    159121          (forms 'progn)
    160122          (case return-type-keyword
Note: See TracChangeset for help on using the changeset viewer.