Changeset 8653


Ignore:
Timestamp:
Mar 4, 2008, 4:30:05 PM (12 years ago)
Author:
rme
Message:

Half-baked work-in-progress.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/ia32/lib/ffi-darwinx8632.lisp

    r7818 r8653  
    11(in-package "CCL")
    22
    3 ;;; When a function returns a structure or union larger than 8 bytes,
    4 ;;; the caller passes a pointer to appropriate storage as the first
    5 ;;; argument to the function.
     3;;; Some small structures are returned in EAX and EDX.  Otherwise,
     4;;; return values are placed at the address specified by the caller.
    65(defun x86-darwin32::record-type-returns-structure-as-first-arg (rtype)
    76  (when (and rtype
     
    1110    (let* ((ftype (if (typep rtype 'foreign-type)
    1211                    rtype
    13                     (parse-foreign-type rtype))))
    14       (> (ensure-foreign-type-bits ftype) 64))))
     12                    (parse-foreign-type rtype)))
     13           (nbits (ensure-foreign-type-bits ftype)))
     14      (not (member nbits '(8 16 32 64))))))
    1515
     16(defun x86-darwin32::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)))))
    1623
    17 ;;; All arguments are passed on the stack, except for MMX and XMM
    18 ;;; vectors (which aren't supported here).  As mentioned above,
    19 ;;; we pass a pointer to appropriate storage as the first argument
    20 ;;; to the function if it returns a structure or union larger than
    21 ;;; 8 bytes.
     24;;; All arguments are passed on the stack.
    2225;;;
    23 ;;; Structures 1 or 2 bytes in size are returned in EAX
    24 ;;; Structures 4 or 8 bytes in size are returned in EAX and EDX
     26;;; (We don't support the __m64, __m128, __m128d, and __m128i types.)
    2527
    2628(defun x86-darwin32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
    2729  (let* ((result-type-spec (or (car (last args)) :void))
     30         (regbuf nil)
     31         (result-temp nil)
    2832         (result-form nil)
    29          (structure-arg-temp nil)
    3033         (struct-result-type nil))
    3134    (multiple-value-bind (result-type error)
     
    3841          (argforms (pop args)))
    3942        (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)
    4047          (if (x86-darwin32::record-type-returns-structure-as-first-arg result-type)
    4148            (progn
    42               (setq struct-result-type result-type
    43                     result-type *void-foreign-type*
    44                     result-type-spec :void
    45                     result-form (pop args))
    4649              (argforms :address)
    47               (argforms result-form))))
     50              (argforms result-form))
     51            (progn
     52              (setq regbuf (gensym)
     53                    result-temp (gensym))
     54              (argforms :registers)
     55              (argforms regbuf))))
    4856        (unless (evenp (length args))
    49             (error "~s should be an even-length list of alternating foreign types and values" args))
    50           (do* ((args args (cddr args)))
    51                ((null args))
    52             (let* ((arg-type-spec (car args))
    53                    (arg-value-form (cadr args)))
    54               (if (or (member arg-type-spec *foreign-representation-type-keywords*
    55                               :test #'eq)
    56                       (typep arg-type-spec 'unsigned-byte))
    57                 (progn
    58                   (argforms arg-type-spec)
    59                   (argforms arg-value-form))
    60                 (let* ((ftype (parse-foreign-type arg-type-spec)))
    61                   (if (typep ftype 'foreign-record-type)
    62                     (let* ((bits (ensure-foreign-type-bits ftype)))
    63                       (argforms (ceiling bits 32))
    64                       (argforms arg-value-form))
    65                     (progn
    66                       (argforms (foreign-type-to-representation-type ftype))
    67                       (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
     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                (argforms (foreign-type-to-representation-type ftype))
     70                (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))
    6871          (argforms (foreign-type-to-representation-type result-type))
    6972          (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
    70             ;;(format t "~&call = ~s" call)
    71             call)))))
     73            (if regbuf
     74              `(let* ((,result-temp (%null-ptr)))
     75                 (declare (dynamic-extent ,result-temp)
     76                          (type macptr ,result-temp))
     77                 (%setf-macptr ,result-temp ,result-form)
     78                 (%stack-block ((,regbuf 8))
     79                   ,call
     80                   ,(x86-darwin32::struct-from-regbuf-values result-temp struct-result-type regbuf)))
     81              call))))))
    7282
    7383;;; Return 7 values:
Note: See TracChangeset for help on using the changeset viewer.