Changeset 11553


Ignore:
Timestamp:
Dec 26, 2008, 6:04:30 PM (11 years ago)
Author:
rme
Message:

Use common x8632 FFI code where applicable.

Location:
trunk/source/lib
Files:
5 edited

Legend:

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

    r11360 r11553  
    1414      (not (member nbits '(8 16 32 64))))))
    1515
    16 ;;; All arguments are passed on the stack.
    17 ;;;
    18 ;;; (We don't support the __m64, __m128, __m128d, and __m128i types.)
    19 
     16;;; We don't support the __m64, __m128, __m128d, and __m128i types.
    2017(defun x86-darwin32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
    21   (let* ((result-type-spec (or (car (last args)) :void))
    22          (struct-by-value-p nil)
    23          (result-op nil)
    24          (result-temp nil)
    25          (result-form nil))
    26     (multiple-value-bind (result-type error)
    27         (ignore-errors (parse-foreign-type result-type-spec))
    28       (if error
    29         (setq result-type-spec :void result-type *void-foreign-type*)
    30         (setq args (butlast args)))
    31       (collect ((argforms))
    32         (when (typep result-type 'foreign-record-type)
    33           (setq result-form (pop args))
    34           (if (x86-darwin32::record-type-returns-structure-as-first-arg
    35                result-type)
    36             (progn
    37               (setq result-type *void-foreign-type*
    38                     result-type-spec :void)
    39               (argforms :address)
    40               (argforms result-form))
    41             (progn
    42               (ecase (foreign-type-bits result-type)
    43                 (8 (setq result-type-spec :unsigned-byte
    44                          result-op '%get-unsigned-byte))
    45                 (16 (setq result-type-spec :unsigned-halfword
    46                           result-op '%get-unsigned-word))
    47                 (32 (setq result-type-spec :unsigned-fullword
    48                           result-op '%get-unsigned-long))
    49                 (64 (setq result-type-spec :unsigned-doubleword
    50                           result-op '%%get-unsigned-longlong)))
    51               (setq result-type (parse-foreign-type result-type-spec))
    52               (setq result-temp (gensym))
    53               (setq struct-by-value-p t))))
    54         (unless (evenp (length args))
    55           (error "~s should be an even-length list of alternating foreign types and values" args))
    56         (do* ((args args (cddr args)))
    57              ((null args))
    58           (let* ((arg-type-spec (car args))
    59                  (arg-value-form (cadr args)))
    60             (if (or (member arg-type-spec *foreign-representation-type-keywords*
    61                             :test #'eq)
    62                     (typep arg-type-spec 'unsigned-byte))
    63               (progn
    64                 (argforms arg-type-spec)
    65                 (argforms arg-value-form))
    66               (let* ((ftype (parse-foreign-type arg-type-spec))
    67                      (bits (ensure-foreign-type-bits ftype)))
    68                 (if (typep ftype 'foreign-record-type)
    69                   (argforms (ceiling bits 32))
    70                   (argforms (foreign-type-to-representation-type ftype)))
    71                 (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))
    72           (argforms (foreign-type-to-representation-type result-type))
    73           (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
    74             (if struct-by-value-p
    75               `(let* ((,result-temp (%null-ptr)))
    76                  (declare (dynamic-extent ,result-temp)
    77                           (type macptr ,result-temp))
    78                  (%setf-macptr ,result-temp ,result-form)
    79                  (setf (,result-op ,result-temp 0)
    80                        ,call))
    81               call))))))
    82 
    83 ;;; Return 7 values:
    84 ;;; A list of RLET bindings
    85 ;;; A list of LET* bindings
    86 ;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
    87 ;;; A list of initializaton forms for (some) structure args (not used on x8632)
    88 ;;; A FOREIGN-TYPE representing the "actual" return type.
    89 ;;; A form which can be used to initialize FP-ARGS-PTR, relative
    90 ;;;  to STACK-PTR.  (This is unused on linuxppc32.)
    91 ;;; The byte offset of the foreign return address, relative to STACK-PTR
     18  (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce))
    9219
    9320(defun x86-darwin32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
    94   (declare (ignore fp-args-ptr))
    95   (collect ((lets)
    96             (rlets)
    97             (dynamic-extent-names))
    98     (let* ((rtype (parse-foreign-type result-spec)))
    99       (when (typep rtype 'foreign-record-type)
    100         (if (x86-darwin32::record-type-returns-structure-as-first-arg rtype)
    101           (setq argvars (cons struct-result-name argvars)
    102                 argspecs (cons :address argspecs)
    103                 rtype *void-foreign-type*)
    104           (rlets (list struct-result-name (foreign-record-type-name rtype)))))
    105       (do* ((argvars argvars (cdr argvars))
    106             (argspecs argspecs (cdr argspecs))
    107             (offset 8))
    108            ((null argvars)
    109             (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 4))
    110         (let* ((name (car argvars))
    111                (spec (car argspecs))
    112                (argtype (parse-foreign-type spec))
    113                (bits (require-foreign-type-bits argtype))
    114                (double nil))
    115           (if (typep argtype 'foreign-record-type)
    116             (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 offset
    117                                                            (incf offset (* 4 (ceiling bits 32)))))))
    118             (progn
    119               (lets (list name
    120                           `(,
    121                             (ecase (foreign-type-to-representation-type argtype)
    122                               (:single-float '%get-single-float)
    123                               (:double-float (setq double t) '%get-double-float)
    124                               (:signed-doubleword (setq double t)
    125                                                   '%%get-signed-longlong)
    126                               (:signed-fullword '%get-signed-long)
    127                               (:signed-halfword '%get-signed-word)
    128                               (:signed-byte '%get-signed-byte)
    129                               (:unsigned-doubleword (setq double t)
    130                                                     '%%get-unsigned-longlong)
    131                               (:unsigned-fullword '%get-unsigned-long)
    132                               (:unsigned-halfword '%get-unsigned-word)
    133                               (:unsigned-byte '%get-unsigned-byte)
    134                               (:address '%get-ptr))
    135                             ,stack-ptr
    136                             ,offset)))
    137               (incf offset 4)
    138               (when double (incf offset 4)))))))))
     21  (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name))
    13922
    14023(defun x86-darwin32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
    141   (declare (ignore fp-args-ptr))
    142   (unless (eq return-type *void-foreign-type*)
    143     (if (typep return-type 'foreign-record-type)
    144       ;; Would have been mapped to :VOID unless record-type was <= 64 bits
    145       (ecase (ensure-foreign-type-bits return-type)
    146         (8 `(setf (%get-unsigned-byte ,stack-ptr -8)
    147                   (%get-unsigned-byte ,struct-return-arg 0)))
    148         (16 `(setf (%get-unsigned-word ,stack-ptr -8)
    149                    (%get-unsigned-word ,struct-return-arg 0)))
    150         (32 `(setf (%get-unsigned-long ,stack-ptr -8)
    151                    (%get-unsigned-long ,struct-return-arg 0)))
    152         (64 `(setf (%%get-unsigned-longlong ,stack-ptr -8)
    153                (%%get-unsigned-longlong ,struct-return-arg 0))))
    154       (let* ((return-type-keyword (foreign-type-to-representation-type return-type)))
    155         (collect ((forms))
    156           (forms 'progn)
    157           (case return-type-keyword
    158             (:single-float
    159              (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 1)))
    160             (:double-float
    161              (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 2))))
    162           (forms
    163            `(setf (,
    164                    (case return-type-keyword
    165                      (:address '%get-ptr)
    166                      (:signed-doubleword '%%get-signed-longlong)
    167                      (:unsigned-doubleword '%%get-unsigned-longlong)
    168                      (:double-float '%get-double-float)
    169                      (:single-float '%get-single-float)
    170                      (:unsigned-fullword '%get-unsigned-long)
    171                      (t '%get-signed-long)
    172                      ) ,stack-ptr -8) ,result))
    173           (forms))))))
    174 
     24  (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg))
  • trunk/source/lib/ffi-freebsdx8632.lisp

    r11322 r11553  
    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.
    53(defun x86-freebsd32::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-freebsd32::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)))))
    23 
    24 ;;; All arguments are passed on the stack.
    25 ;;;
    26 ;;; (We don't support the __m64, __m128, __m128d, and __m128i types.)
     4  (x8632::record-type-returns-structure-as-first-arg rtype))
    275
    286(defun x86-freebsd32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
    29   (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))
    34     (multiple-value-bind (result-type error)
    35         (ignore-errors (parse-foreign-type result-type-spec))
    36       (if error
    37         (setq result-type-spec :void result-type *void-foreign-type*)
    38         (setq args (butlast args)))
    39       (collect ((argforms))
    40         (when (eq (car args) :monitor-exception-ports)
    41           (argforms (pop args)))
    42         (when (typep result-type 'foreign-record-type)
    43           (setq result-form (pop args)
    44                 struct-result-type result-type
    45                 result-type *void-foreign-type*
    46                 result-type-spec :void)
    47           (if (x86-freebsd32::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))))
    56         (unless (evenp (length args))
    57           (error "~s should be an even-length list of alternating foreign types and values" args))
    58         (do* ((args args (cddr args)))
    59              ((null args))
    60           (let* ((arg-type-spec (car args))
    61                  (arg-value-form (cadr args)))
    62             (if (or (member arg-type-spec *foreign-representation-type-keywords*
    63                             :test #'eq)
    64                     (typep arg-type-spec 'unsigned-byte))
    65               (progn
    66                 (argforms arg-type-spec)
    67                 (argforms arg-value-form))
    68               (let* ((ftype (parse-foreign-type arg-type-spec))
    69                      (bits (ensure-foreign-type-bits ftype)))
    70                     (when (and (typep ftype 'foreign-record-type)
    71                              (eq (foreign-record-type-kind ftype) :transparent-union))
    72                       (ensure-foreign-type-bits ftype)
    73                       (setq ftype (foreign-record-field-type
    74                                    (car (foreign-record-type-fields ftype)))
    75                             arg-type-spec (foreign-type-to-representation-type ftype)
    76                             bits (ensure-foreign-type-bits ftype)))
    77                     (if (and (typep ftype 'foreign-record-type)
    78                              (<= bits 32))
    79                       (argforms (ceiling bits 32))
    80                       (argforms (foreign-type-to-representation-type ftype)))
    81                 (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))
    82           (argforms (foreign-type-to-representation-type result-type))
    83           (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-freebsd32::struct-from-regbuf-values result-temp struct-result-type regbuf)))
    92               call))))))
    93 
    94 ;;; Return 7 values:
    95 ;;; A list of RLET bindings
    96 ;;; A list of LET* bindings
    97 ;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
    98 ;;; A list of initializaton forms for (some) structure args
    99 ;;; A FOREIGN-TYPE representing the "actual" return type.
    100 ;;; A form which can be used to initialize FP-ARGS-PTR, relative
    101 ;;;  to STACK-PTR.  (This is unused on freebsdppc32.)
    102 ;;; The byte offset of the foreign return address, relative to STACK-PTR
     7  (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce))
    1038
    1049(defun x86-freebsd32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
    105   (declare (ignore fp-args-ptr))
    106   (collect ((lets)
    107             (rlets)
    108             (inits)
    109             (dynamic-extent-names))
    110     (let* ((rtype (parse-foreign-type result-spec)))
    111       (when (typep rtype 'foreign-record-type)
    112         (if (x86-freebsd32::record-type-returns-structure-as-first-arg rtype)
    113           (setq argvars (cons struct-result-name argvars)
    114                 argspecs (cons :address argspecs)
    115                 rtype *void-foreign-type*)
    116           (rlets (list struct-result-name (foreign-record-type-name rtype)))))
    117       (do* ((argvars argvars (cdr argvars))
    118             (argspecs argspecs (cdr argspecs))
    119             (offset 8 (incf offset 4)))
    120            ((null argvars)
    121             (values (rlets) (lets) (dynamic-extent-names) (inits) rtype nil 4))
    122         (let* ((name (car argvars))
    123                (spec (car argspecs))
    124                (argtype (parse-foreign-type spec))
    125                (bits (require-foreign-type-bits argtype))
    126                (double nil))
    127           (if (typep argtype 'foreign-record-type)
    128             (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)))))))
     10  (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name))
    14911
    15012(defun x86-freebsd32::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")
    153   (unless (eq return-type *void-foreign-type*)
    154     (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)
    157       (let* ((return-type-keyword (foreign-type-to-representation-type return-type)))
    158         (ccl::collect ((forms))
    159           (forms 'progn)
    160           (case return-type-keyword
    161             (:single-float
    162              (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 1)))
    163             (:double-float
    164              (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 2))))
    165           (forms
    166            `(setf (,
    167                    (case return-type-keyword
    168                      (:address '%get-ptr)
    169                      (:signed-doubleword '%%get-signed-longlong)
    170                      (:unsigned-doubleword '%%get-unsigned-longlong)
    171                      (:double-float '%get-double-float)
    172                      (:single-float '%get-single-float)
    173                      (:unsigned-fullword '%get-unsigned-long)
    174                      (t '%get-signed-long)
    175                      ) ,stack-ptr -8) ,result))
    176           (forms))))))
     13  (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg))
    17714
  • trunk/source/lib/ffi-linuxx8632.lisp

    r11549 r11553  
    11(in-package "CCL")
    22
    3 ;; Always use the "hidden first arg" convention on linuxx8632
    43(defun x86-linux32::record-type-returns-structure-as-first-arg (rtype)
    5   (declare (ignore rtype))
    6   t)
    7 
    8 ;;; All arguments are passed on the stack.
    9 ;;;
    10 ;;; (We don't support the __m64, __m128, __m128d, and __m128i types.)
     4  (x8632::record-type-returns-structure-as-first-arg rtype))
    115
    126(defun x86-linux32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
    13   (let* ((result-type-spec (or (car (last args)) :void))
    14          (result-form nil))
    15     (multiple-value-bind (result-type error)
    16         (ignore-errors (parse-foreign-type result-type-spec))
    17       (if error
    18         (setq result-type-spec :void result-type *void-foreign-type*)
    19         (setq args (butlast args)))
    20       (collect ((argforms))
    21         (when (typep result-type 'foreign-record-type)
    22           (setq result-form (pop args)
    23                 result-type *void-foreign-type*
    24                 result-type-spec :void)
    25           (argforms :address)
    26           (argforms result-form))
    27         (unless (evenp (length args))
    28           (error "~s should be an even-length list of alternating foreign types and values" args))
    29         (do* ((args args (cddr args)))
    30              ((null args))
    31           (let* ((arg-type-spec (car args))
    32                  (arg-value-form (cadr args)))
    33             (if (or (member arg-type-spec *foreign-representation-type-keywords*
    34                             :test #'eq)
    35                     (typep arg-type-spec 'unsigned-byte))
    36               (progn
    37                 (argforms arg-type-spec)
    38                 (argforms arg-value-form))
    39               (let* ((ftype (parse-foreign-type arg-type-spec))
    40                      (bits (ensure-foreign-type-bits ftype)))
    41                     (when (and (typep ftype 'foreign-record-type)
    42                              (eq (foreign-record-type-kind ftype) :transparent-union))
    43                       (ensure-foreign-type-bits ftype)
    44                       (setq ftype (foreign-record-field-type
    45                                    (car (foreign-record-type-fields ftype)))
    46                             arg-type-spec (foreign-type-to-representation-type ftype)
    47                             bits (ensure-foreign-type-bits ftype)))
    48                     (if (typep ftype 'foreign-record-type)
    49                       (argforms (ceiling bits 32))
    50                       (argforms (foreign-type-to-representation-type ftype)))
    51                 (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))
    52           (argforms (foreign-type-to-representation-type result-type))
    53           (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
    54             call)))))
    55 
    56 ;;; Return 7 values:
    57 ;;; A list of RLET bindings
    58 ;;; A list of LET* bindings
    59 ;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
    60 ;;; A list of initializaton forms for (some) structure args (not used on x8632)
    61 ;;; A FOREIGN-TYPE representing the "actual" return type.
    62 ;;; A form which can be used to initialize FP-ARGS-PTR, relative
    63 ;;;  to STACK-PTR.  (This is unused on linuxppc32.)
    64 ;;; The byte offset of the foreign return address, relative to STACK-PTR
     7  (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce))
    658
    669(defun x86-linux32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
    67   (declare (ignore fp-args-ptr))
    68   (collect ((lets)
    69             (rlets)
    70             (dynamic-extent-names))
    71     (let* ((rtype (parse-foreign-type result-spec)))
    72       (when (typep rtype 'foreign-record-type)
    73         (if (x86-linux32::record-type-returns-structure-as-first-arg rtype)
    74           (setq argvars (cons struct-result-name argvars)
    75                 argspecs (cons :address argspecs)
    76                 rtype *void-foreign-type*)
    77           (rlets (list struct-result-name (foreign-record-type-name rtype)))))
    78       (do* ((argvars argvars (cdr argvars))
    79             (argspecs argspecs (cdr argspecs))
    80             (offset 8))
    81            ((null argvars)
    82             (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 4))
    83         (let* ((name (car argvars))
    84                (spec (car argspecs))
    85                (argtype (parse-foreign-type spec))
    86                (bits (require-foreign-type-bits argtype))
    87                (double nil))
    88           (if (typep argtype 'foreign-record-type)
    89             (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 offset
    90                                                            (incf offset (* 4 (ceiling bits 32)))))))
    91             (progn
    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)))))))))
     10  (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name))
    11211
    11312(defun x86-linux32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
    114   (declare (ignore fp-args-ptr struct-return-arg))
    115   (unless (eq return-type *void-foreign-type*)
    116     (if (typep return-type 'foreign-record-type)
    117       ;; Should have been mapped to :VOID
    118       (error "Shouldn't be trying to return a structure by value on linuxx8632")
    119       (let* ((return-type-keyword (foreign-type-to-representation-type return-type)))
    120         (collect ((forms))
    121           (forms 'progn)
    122           (case return-type-keyword
    123             (:single-float
    124              (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 1)))
    125             (:double-float
    126              (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 2))))
    127           (forms
    128            `(setf (,
    129                    (case return-type-keyword
    130                      (:address '%get-ptr)
    131                      (:signed-doubleword '%%get-signed-longlong)
    132                      (:unsigned-doubleword '%%get-unsigned-longlong)
    133                      (:double-float '%get-double-float)
    134                      (:single-float '%get-single-float)
    135                      (:unsigned-fullword '%get-unsigned-long)
    136                      (t '%get-signed-long)
    137                      ) ,stack-ptr -8) ,result))
    138           (forms))))))
     13  (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg))
    13914
  • trunk/source/lib/ffi-solarisx8632.lisp

    r11258 r11553  
    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.
    53(defun x86-solaris32::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-solaris32::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)))))
    23 
    24 ;;; All arguments are passed on the stack.
    25 ;;;
    26 ;;; (We don't support the __m64, __m128, __m128d, and __m128i types.)
     4  (x8632::record-type-returns-structure-as-first-arg rtype))
    275
    286(defun x86-solaris32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
    29   (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))
    34     (multiple-value-bind (result-type error)
    35         (ignore-errors (parse-foreign-type result-type-spec))
    36       (if error
    37         (setq result-type-spec :void result-type *void-foreign-type*)
    38         (setq args (butlast args)))
    39       (collect ((argforms))
    40         (when (eq (car args) :monitor-exception-ports)
    41           (argforms (pop args)))
    42         (when (typep result-type 'foreign-record-type)
    43           (setq result-form (pop args)
    44                 struct-result-type result-type
    45                 result-type *void-foreign-type*
    46                 result-type-spec :void)
    47           (if (x86-solaris32::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))))
    56         (unless (evenp (length args))
    57           (error "~s should be an even-length list of alternating foreign types and values" args))
    58         (do* ((args args (cddr args)))
    59              ((null args))
    60           (let* ((arg-type-spec (car args))
    61                  (arg-value-form (cadr args)))
    62             (if (or (member arg-type-spec *foreign-representation-type-keywords*
    63                             :test #'eq)
    64                     (typep arg-type-spec 'unsigned-byte))
    65               (progn
    66                 (argforms arg-type-spec)
    67                 (argforms arg-value-form))
    68               (let* ((ftype (parse-foreign-type arg-type-spec))
    69                      (bits (ensure-foreign-type-bits ftype)))
    70                     (when (and (typep ftype 'foreign-record-type)
    71                              (eq (foreign-record-type-kind ftype) :transparent-union))
    72                       (ensure-foreign-type-bits ftype)
    73                       (setq ftype (foreign-record-field-type
    74                                    (car (foreign-record-type-fields ftype)))
    75                             arg-type-spec (foreign-type-to-representation-type ftype)
    76                             bits (ensure-foreign-type-bits ftype)))
    77                     (if (and (typep ftype 'foreign-record-type)
    78                              (<= bits 32))
    79                       (argforms (ceiling bits 32))
    80                       (argforms (foreign-type-to-representation-type ftype)))
    81                 (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))
    82           (argforms (foreign-type-to-representation-type result-type))
    83           (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-solaris32::struct-from-regbuf-values result-temp struct-result-type regbuf)))
    92               call))))))
    93 
    94 ;;; Return 7 values:
    95 ;;; A list of RLET bindings
    96 ;;; A list of LET* bindings
    97 ;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
    98 ;;; A list of initializaton forms for (some) structure args
    99 ;;; A FOREIGN-TYPE representing the "actual" return type.
    100 ;;; A form which can be used to initialize FP-ARGS-PTR, relative
    101 ;;;  to STACK-PTR.  (This is unused on solarisppc32.)
    102 ;;; The byte offset of the foreign return address, relative to STACK-PTR
     7  (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce))
    1038
    1049(defun x86-solaris32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
    105   (declare (ignore fp-args-ptr))
    106   (collect ((lets)
    107             (rlets)
    108             (inits)
    109             (dynamic-extent-names))
    110     (let* ((rtype (parse-foreign-type result-spec)))
    111       (when (typep rtype 'foreign-record-type)
    112         (if (x86-solaris32::record-type-returns-structure-as-first-arg rtype)
    113           (setq argvars (cons struct-result-name argvars)
    114                 argspecs (cons :address argspecs)
    115                 rtype *void-foreign-type*)
    116           (rlets (list struct-result-name (foreign-record-type-name rtype)))))
    117       (do* ((argvars argvars (cdr argvars))
    118             (argspecs argspecs (cdr argspecs))
    119             (offset 8 (incf offset 4)))
    120            ((null argvars)
    121             (values (rlets) (lets) (dynamic-extent-names) (inits) rtype nil 4))
    122         (let* ((name (car argvars))
    123                (spec (car argspecs))
    124                (argtype (parse-foreign-type spec))
    125                (bits (require-foreign-type-bits argtype))
    126                (double nil))
    127           (if (typep argtype 'foreign-record-type)
    128             (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)))))))
     10  (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name))
    14911
    15012(defun x86-solaris32::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")
    153   (unless (eq return-type *void-foreign-type*)
    154     (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)
    157       (let* ((return-type-keyword (foreign-type-to-representation-type return-type)))
    158         (ccl::collect ((forms))
    159           (forms 'progn)
    160           (case return-type-keyword
    161             (:single-float
    162              (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 1)))
    163             (:double-float
    164              (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 2))))
    165           (forms
    166            `(setf (,
    167                    (case return-type-keyword
    168                      (:address '%get-ptr)
    169                      (:signed-doubleword '%%get-signed-longlong)
    170                      (:unsigned-doubleword '%%get-unsigned-longlong)
    171                      (:double-float '%get-double-float)
    172                      (:single-float '%get-single-float)
    173                      (:unsigned-fullword '%get-unsigned-long)
    174                      (t '%get-signed-long)
    175                      ) ,stack-ptr -8) ,result))
    176           (forms))))))
    177 
     13  (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg))
  • trunk/source/lib/ffi-win32.lisp

    r11188 r11553  
    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.
    53(defun win32::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 win32::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)))))
    23 
    24 ;;; All arguments are passed on the stack.
    25 ;;;
    26 ;;; (We don't support the __m64, __m128, __m128d, and __m128i types.)
     4  (x8632::record-type-returns-structure-as-first-arg rtype))
    275
    286(defun win32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
    29   (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))
    34     (multiple-value-bind (result-type error)
    35         (ignore-errors (parse-foreign-type result-type-spec))
    36       (if error
    37         (setq result-type-spec :void result-type *void-foreign-type*)
    38         (setq args (butlast args)))
    39       (collect ((argforms))
    40         (when (eq (car args) :monitor-exception-ports)
    41           (argforms (pop args)))
    42         (when (typep result-type 'foreign-record-type)
    43           (setq result-form (pop args)
    44                 struct-result-type result-type
    45                 result-type *void-foreign-type*
    46                 result-type-spec :void)
    47           (if (win32::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))))
    56         (unless (evenp (length args))
    57           (error "~s should be an even-length list of alternating foreign types and values" args))
    58         (do* ((args args (cddr args)))
    59              ((null args))
    60           (let* ((arg-type-spec (car args))
    61                  (arg-value-form (cadr args)))
    62             (if (or (member arg-type-spec *foreign-representation-type-keywords*
    63                             :test #'eq)
    64                     (typep arg-type-spec 'unsigned-byte))
    65               (progn
    66                 (argforms arg-type-spec)
    67                 (argforms arg-value-form))
    68               (let* ((ftype (parse-foreign-type arg-type-spec))
    69                      (bits (ensure-foreign-type-bits ftype)))
    70                     (when (and (typep ftype 'foreign-record-type)
    71                              (eq (foreign-record-type-kind ftype) :transparent-union))
    72                       (ensure-foreign-type-bits ftype)
    73                       (setq ftype (foreign-record-field-type
    74                                    (car (foreign-record-type-fields ftype)))
    75                             arg-type-spec (foreign-type-to-representation-type ftype)
    76                             bits (ensure-foreign-type-bits ftype)))
    77                     (if (and (typep ftype 'foreign-record-type)
    78                              (<= bits 32))
    79                       (argforms (ceiling bits 32))
    80                       (argforms (foreign-type-to-representation-type ftype)))
    81                 (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))
    82           (argforms (foreign-type-to-representation-type result-type))
    83           (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                    ,(win32::struct-from-regbuf-values result-temp struct-result-type regbuf)))
    92               call))))))
     7  (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce))
    938
    94 ;;; Return 8 values:
    95 ;;; A list of RLET bindings
    96 ;;; A list of LET* bindings
    97 ;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
    98 ;;; A list of initializaton forms for (some) structure args
    99 ;;; A FOREIGN-TYPE representing the "actual" return type.
    100 ;;; A form which can be used to initialize FP-ARGS-PTR, relative
    101 ;;;  to STACK-PTR.  (This is unused on linuxppc32.)
    102 ;;; The byte offset of the foreign return address, relative to STACK-PTR
    103 ;;; The number of argument bytes pushed on the stack by the caller, or NIL
    104 ;;; if this can't be determined.
    1059(defun win32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
    106   (declare (ignore fp-args-ptr))
    107   (collect ((lets)
    108             (rlets)
    109             (inits)
    110             (dynamic-extent-names))
    111     (let* ((rtype (parse-foreign-type result-spec)))
    112       (when (typep rtype 'foreign-record-type)
    113         (if (win32::record-type-returns-structure-as-first-arg rtype)
    114           (setq argvars (cons struct-result-name argvars)
    115                 argspecs (cons :address argspecs)
    116                 rtype *void-foreign-type*)
    117           (rlets (list struct-result-name (foreign-record-type-name rtype)))))
    118       (do* ((argvars argvars (cdr argvars))
    119             (argspecs argspecs (cdr argspecs))
    120             (offset 8 (incf offset 4)))
    121            ((null argvars)
    122             (values (rlets) (lets) (dynamic-extent-names) (inits) rtype nil 4 (- offset 8)))
    123         (let* ((name (car argvars))
    124                (spec (car argspecs))
    125                (argtype (parse-foreign-type spec))
    126                (bits (require-foreign-type-bits argtype))
    127                (double nil))
    128           (if (typep argtype 'foreign-record-type)
    129             (progn
    130               (format t "~& arg is some foreign type"))
    131             (lets (list name
    132                         `(,
    133                           (ecase (foreign-type-to-representation-type argtype)
    134                             (:single-float '%get-single-float)
    135                             (:double-float (setq double t) '%get-double-float)
    136                             (:signed-doubleword (setq double t)
    137                                                 '%%get-signed-longlong)
    138                             (:signed-fullword '%get-signed-long)
    139                             (:signed-halfword '%get-signed-word)
    140                             (:signed-byte '%get-signed-byte)
    141                             (:unsigned-doubleword (setq double t)
    142                                                   '%%get-unsigned-longlong)
    143                             (:unsigned-fullword '%get-unsigned-long)
    144                             (:unsigned-halfword '%get-unsigned-word)
    145                             (:unsigned-byte '%get-unsigned-byte)
    146                             (:address '%get-ptr))
    147                           ,stack-ptr
    148                           ,offset))))
    149           (when double (incf offset 4)))))))
     10  (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name))
    15011
    15112(defun win32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
    152   (declare (ignore fp-args-ptr))
    153   (format t "~&in generate-callback-return-value")
    154   (unless (eq return-type *void-foreign-type*)
    155     (if (typep return-type 'foreign-record-type)
    156       ;; Would have been mapped to :VOID unless record-type was <= 64 bits
    157       (format t "~&need to return structure ~s by value" return-type)
    158       (let* ((return-type-keyword (foreign-type-to-representation-type return-type)))
    159         (ccl::collect ((forms))
    160           (forms 'progn)
    161           (case return-type-keyword
    162             (:single-float
    163              (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 1)))
    164             (:double-float
    165              (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 2))))
    166           (forms
    167            `(setf (,
    168                    (case return-type-keyword
    169                      (:address '%get-ptr)
    170                      (:signed-doubleword '%%get-signed-longlong)
    171                      (:unsigned-doubleword '%%get-unsigned-longlong)
    172                      (:double-float '%get-double-float)
    173                      (:single-float '%get-single-float)
    174                      (:unsigned-fullword '%get-unsigned-long)
    175                      (t '%get-signed-long)
    176                      ) ,stack-ptr -8) ,result))
    177           (forms))))))
     13  (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg))
    17814
Note: See TracChangeset for help on using the changeset viewer.