Changeset 11552


Ignore:
Timestamp:
Dec 26, 2008, 5:52:34 PM (11 years ago)
Author:
rme
Message:

Finish unifiying x8632 FFI stuff.

Most operating systems use the vanilla i386 ABI conventions.

Darwin uses a special rule for returning small structures. Call the
CALL-STRUCT-RETURN-BY-IMPLICIT-ARG-FUNCTION (from the FTD) in
EXPAND-FF-CALL and GENERATE-CALLBACK-BINDINGS in order to tell when we
need to deal with Darwin struct return.

In GENERATE-CALLBACK-BINDINGS, return an 8th value (number of bytes of
outgoing arguments pushed) for Windows's benefit; other backends
should just ignore it.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/X86/X8632/x8632-backend.lisp

    r11550 r11552  
    285285(pushnew *x8632-backend* *known-backends* :key #'backend-name)
    286286
    287 ;;; FFI stuff.  Shared by several backends (Darwin notably excepted.)
    288 
    289 ;;; A returned structure is always passed as a "hidden" first argument.
     287;;; FFI stuff.  Most operating systems use the same vanilla i386 ABI.
     288;;; Darwin uses a variant that returns small (<= 64 bit) structures in
     289;;; registers.  (There are some other Darwin exceptions too, but they
     290;;; don't concern us here).
     291
     292;;; A returned structure is passed as a hidden first argument.
    290293(defun x8632::record-type-returns-structure-as-first-arg (rtype)
    291294  (declare (ignore rtype))
     
    293296
    294297;;; All arguments are passed on the stack.
    295 ;;;
    296 ;;; (We don't support the __m64, __m128, __m128d, and __m128i types.)
    297 
    298298(defun x8632::expand-ff-call (callform args
    299299                              &key (arg-coerce #'null-coerce-foreign-arg)
    300300                              (result-coerce #'null-coerce-foreign-result))
    301301  (let* ((result-type-spec (or (car (last args)) :void))
     302         (struct-by-value-p nil)
     303         (result-op nil)
     304         (result-temp nil)
    302305         (result-form nil))
    303306    (multiple-value-bind (result-type error)
     
    308311      (collect ((argforms))
    309312        (when (typep result-type 'foreign-record-type)
    310           (setq result-form (pop args)
    311                 result-type *void-foreign-type*
    312                 result-type-spec :void)
    313           (argforms :address)
    314           (argforms result-form))
     313          (setq result-form (pop args))
     314          (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function
     315                        *target-ftd*) result-type)
     316            (progn
     317              (setq result-type *void-foreign-type*
     318                    result-type-spec :void)
     319              (argforms :address)
     320              (argforms result-form))
     321            (progn
     322              ;; for Darwin
     323              (ecase (foreign-type-bits result-type)
     324                (8 (setq result-type-spec :unsigned-byte
     325                         result-op '%get-unsigned-byte))
     326                (16 (setq result-type-spec :unsigned-halfword
     327                          result-op '%get-unsigned-word))
     328                (32 (setq result-type-spec :unsigned-fullword
     329                          result-op '%get-unsigned-long))
     330                (64 (setq result-type-spec :unsigned-doubleword
     331                          result-op '%%get-unsigned-longlong)))
     332              (setq result-type (parse-foreign-type result-type-spec))
     333              (setq result-temp (gensym))
     334              (setq struct-by-value-p t))))
    315335        (unless (evenp (length args))
    316336          (error "~s should be an even-length list of alternating foreign types and values" args))
     
    336356                                       ftype)
    337357                        bits (ensure-foreign-type-bits ftype)))
    338                     (if (typep ftype 'foreign-record-type)
    339                       (argforms (ceiling bits 32))
    340                       (argforms (foreign-type-to-representation-type ftype)))
     358                (if (typep ftype 'foreign-record-type)
     359                  (argforms (ceiling bits 32))
     360                  (argforms (foreign-type-to-representation-type ftype)))
    341361                (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))
    342           (argforms (foreign-type-to-representation-type result-type))
    343           (funcall result-coerce result-type-spec
    344                    `(,@callform ,@(argforms)))))))
    345 
    346 
    347 ;;; Return 7 values:
     362        (argforms (foreign-type-to-representation-type result-type))
     363        (let* ((call (funcall result-coerce result-type-spec
     364                              `(,@callform ,@(argforms)))))
     365          (if struct-by-value-p
     366            `(let* ((,result-temp (%null-ptr)))
     367               (declare (dynamic-extent ,result-temp)
     368                        (type macptr ,result-temp))
     369               (%setf-macptr ,result-temp ,result-form)
     370               (setf (,result-op ,result-temp 0)
     371                     ,call))
     372            call))))))
     373
     374;;; Return 8 values:
    348375;;; A list of RLET bindings
    349376;;; A list of LET* bindings
     
    352379;;; A FOREIGN-TYPE representing the "actual" return type.
    353380;;; A form which can be used to initialize FP-ARGS-PTR, relative
    354 ;;;  to STACK-PTR.  (This is unused on x8632.)
     381;;;  to STACK-PTR.  (not used on x8632)
    355382;;; The byte offset of the foreign return address, relative to STACK-PTR
     383;;; The number of argument bytes pushed on the stack by the caller, or NIL
     384;;;  if this can't be determined. (Only meaningful on Windows.)
    356385
    357386(defun x8632::generate-callback-bindings (stack-ptr fp-args-ptr argvars
     
    360389  (declare (ignore fp-args-ptr))
    361390  (collect ((lets)
     391            (rlets)
    362392            (dynamic-extent-names))
    363393    (let* ((rtype (parse-foreign-type result-spec)))
    364394      (when (typep rtype 'foreign-record-type)
    365         (setq argvars (cons struct-result-name argvars)
    366               argspecs (cons :address argspecs)
    367               rtype *void-foreign-type*))
     395        (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function
     396                      *target-ftd*) rtype)
     397          (setq argvars (cons struct-result-name argvars)
     398                argspecs (cons :address argspecs)
     399                rtype *void-foreign-type*)
     400          (rlets (list struct-result-name (foreign-record-type-name rtype)))))
    368401      (do* ((argvars argvars (cdr argvars))
    369402            (argspecs argspecs (cdr argspecs))
    370403            (offset 8))
    371404           ((null argvars)
    372             (values nil (lets) (dynamic-extent-names) nil rtype nil 4))
     405            (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 4
     406                    (- offset 8)))
    373407        (let* ((name (car argvars))
    374408               (spec (car argspecs))
     
    406440(defun x8632::generate-callback-return-value (stack-ptr fp-args-ptr result
    407441                                              return-type struct-return-arg)
    408   (declare (ignore fp-args-ptr struct-return-arg))
     442  (declare (ignore fp-args-ptr))
    409443  (unless (eq return-type *void-foreign-type*)
    410     (let* ((return-type-keyword (foreign-type-to-representation-type
    411                                  return-type)))
     444    (if (typep return-type 'foreign-record-type)
     445      ;; On non-Darwin systems, the result type would have been mapped
     446      ;; to :VOID.  On Darwin, small (<= 64 bits) structs are returned
     447      ;; by value.
     448      (ecase (ensure-foreign-type-bits return-type)
     449        (8 `(setf (%get-unsigned-byte ,stack-ptr -8)
     450                  (%get-unsigned-byte ,struct-return-arg 0)))
     451        (16 `(setf (%get-unsigned-word ,stack-ptr -8)
     452                   (%get-unsigned-word ,struct-return-arg 0)))
     453        (32 `(setf (%get-unsigned-long ,stack-ptr -8)
     454                   (%get-unsigned-long ,struct-return-arg 0)))
     455        (64 `(setf (%%get-unsigned-longlong ,stack-ptr -8)
     456               (%%get-unsigned-longlong ,struct-return-arg 0))))
     457      (let* ((return-type-keyword (foreign-type-to-representation-type
     458                                   return-type)))
    412459        (collect ((forms))
    413460          (forms 'progn)
     
    428475                     (t '%get-signed-long)
    429476                     ) ,stack-ptr -8) ,result))
    430           (forms)))))
     477          (forms))))))
    431478
    432479
Note: See TracChangeset for help on using the changeset viewer.