Changeset 11357


Ignore:
Timestamp:
Nov 13, 2008, 4:33:19 AM (11 years ago)
Author:
rme
Message:

Try to improve handling of small structs returned by value a little bit
more.

File:
1 edited

Legend:

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

    r11346 r11357  
    2020(defun x86-darwin32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
    2121  (let* ((result-type-spec (or (car (last args)) :void))
    22          (result-in-registers-p nil)
     22         (struct-by-value-p nil)
     23         (result-op nil)
    2324         (result-temp nil)
    2425         (result-form nil))
     
    3940              (argforms result-form))
    4041            (progn
    41               ;; We're going to get either 32 bits in EAX, or
    42               ;; 64 bits in EDX:EAX.
    43               (setq result-type (parse-foreign-type :signed-doubleword)
    44                     result-type-spec :signed-doubleword)
     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))
    4552              (setq result-temp (gensym))
    46               (setq result-in-registers-p t))))
     53              (setq struct-by-value-p t))))
    4754        (unless (evenp (length args))
    4855          (error "~s should be an even-length list of alternating foreign types and values" args))
     
    6673          (argforms (foreign-type-to-representation-type result-type))
    6774          (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
    68             (if result-in-registers-p
     75            (if struct-by-value-p
    6976              `(let* ((,result-temp (%null-ptr)))
    7077                 (declare (dynamic-extent ,result-temp)
    7178                          (type macptr ,result-temp))
    7279                 (%setf-macptr ,result-temp ,result-form)
    73                  (setf (%%get-signed-longlong ,result-temp 0)
     80                 (setf (,result-op ,result-temp 0)
    7481                       ,call))
    7582              call))))))
     
    100107      (do* ((argvars argvars (cdr argvars))
    101108            (argspecs argspecs (cdr argspecs))
    102             (offset 8 (incf offset 4)))
     109            (offset 8))
    103110           ((null argvars)
    104111            (values (rlets) (lets) (dynamic-extent-names) (inits) rtype nil 4))
     
    109116               (double nil))
    110117          (if (typep argtype 'foreign-record-type)
     118            (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 offset
     119                                                           (incf offset (* 4 (ceiling bits 32)))))))
    111120            (progn
    112               (format t "~& arg is some foreign type"))
    113             (lets (list name
    114                         `(,
    115                           (ecase (foreign-type-to-representation-type argtype)
    116                             (:single-float '%get-single-float)
    117                             (:double-float (setq double t) '%get-double-float)
    118                             (:signed-doubleword (setq double t)
    119                                                 '%%get-signed-longlong)
    120                             (:signed-fullword '%get-signed-long)
    121                             (:signed-halfword '%get-signed-word)
    122                             (:signed-byte '%get-signed-byte)
    123                             (:unsigned-doubleword (setq double t)
    124                                                   '%%get-unsigned-longlong)
    125                             (:unsigned-fullword '%get-unsigned-long)
    126                             (:unsigned-halfword '%get-unsigned-word)
    127                             (:unsigned-byte '%get-unsigned-byte)
    128                             (:address '%get-ptr))
    129                           ,stack-ptr
    130                           ,offset))))
    131           (when double (incf offset 4)))))))
     121              (lets (list name
     122                          `(,
     123                            (ecase (foreign-type-to-representation-type argtype)
     124                              (:single-float '%get-single-float)
     125                              (:double-float (setq double t) '%get-double-float)
     126                              (:signed-doubleword (setq double t)
     127                                                  '%%get-signed-longlong)
     128                              (:signed-fullword '%get-signed-long)
     129                              (:signed-halfword '%get-signed-word)
     130                              (:signed-byte '%get-signed-byte)
     131                              (:unsigned-doubleword (setq double t)
     132                                                    '%%get-unsigned-longlong)
     133                              (:unsigned-fullword '%get-unsigned-long)
     134                              (:unsigned-halfword '%get-unsigned-word)
     135                              (:unsigned-byte '%get-unsigned-byte)
     136                              (:address '%get-ptr))
     137                            ,stack-ptr
     138                            ,offset)))
     139              (incf offset 4)
     140              (when double (incf offset 4)))))))))
    132141
    133142(defun x86-darwin32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
    134143  (declare (ignore fp-args-ptr))
    135   (format t "~&in generate-callback-return-value")
    136144  (unless (eq return-type *void-foreign-type*)
    137145    (if (typep return-type 'foreign-record-type)
    138146      ;; Would have been mapped to :VOID unless record-type was <= 64 bits
    139       (format t "~&need to return structure ~s by value" return-type)
     147      (ecase (ensure-foreign-type-bits return-type)
     148        (8 `(setf (%get-unsigned-byte ,stack-ptr -8)
     149                  (%get-unsigned-byte ,struct-return-arg 0)))
     150        (16 `(setf (%get-unsigned-word ,stack-ptr -8)
     151                   (%get-unsigned-word ,struct-return-arg 0)))
     152        (32 `(setf (%get-unsigned-long ,stack-ptr -8)
     153                   (%get-unsigned-long ,struct-return-arg 0)))
     154        (64 `(setf (%%get-unsigned-longlong ,stack-ptr -8)
     155               (%%get-unsigned-longlong ,struct-return-arg 0))))
    140156      (let* ((return-type-keyword (foreign-type-to-representation-type return-type)))
    141         (ccl::collect ((forms))
     157        (collect ((forms))
    142158          (forms 'progn)
    143159          (case return-type-keyword
Note: See TracChangeset for help on using the changeset viewer.