Changeset 11550


Ignore:
Timestamp:
Dec 24, 2008, 8:12:40 AM (11 years ago)
Author:
rme
Message:

Start to factor out of some the x8632 ffi stuff that's shared by
multiple platforms.

File:
1 edited

Legend:

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

    r11326 r11550  
    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.
     290(defun x8632::record-type-returns-structure-as-first-arg (rtype)
     291  (declare (ignore rtype))
     292  t)
     293
     294;;; All arguments are passed on the stack.
     295;;;
     296;;; (We don't support the __m64, __m128, __m128d, and __m128i types.)
     297
     298(defun x8632::expand-ff-call (callform args
     299                              &key (arg-coerce #'null-coerce-foreign-arg)
     300                              (result-coerce #'null-coerce-foreign-result))
     301  (let* ((result-type-spec (or (car (last args)) :void))
     302         (result-form nil))
     303    (multiple-value-bind (result-type error)
     304        (ignore-errors (parse-foreign-type result-type-spec))
     305      (if error
     306        (setq result-type-spec :void result-type *void-foreign-type*)
     307        (setq args (butlast args)))
     308      (collect ((argforms))
     309        (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))
     315        (unless (evenp (length args))
     316          (error "~s should be an even-length list of alternating foreign types and values" args))
     317        (do* ((args args (cddr args)))
     318             ((null args))
     319          (let* ((arg-type-spec (car args))
     320                 (arg-value-form (cadr args)))
     321            (if (or (member arg-type-spec *foreign-representation-type-keywords*
     322                            :test #'eq)
     323                    (typep arg-type-spec 'unsigned-byte))
     324              (progn
     325                (argforms arg-type-spec)
     326                (argforms arg-value-form))
     327              (let* ((ftype (parse-foreign-type arg-type-spec))
     328                     (bits (ensure-foreign-type-bits ftype)))
     329                (when (and (typep ftype 'foreign-record-type)
     330                           (eq (foreign-record-type-kind ftype)
     331                               :transparent-union))
     332                  (ensure-foreign-type-bits ftype)
     333                  (setq ftype (foreign-record-field-type
     334                               (car (foreign-record-type-fields ftype)))
     335                        arg-type-spec (foreign-type-to-representation-type
     336                                       ftype)
     337                        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)))
     341                (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:
     348;;; A list of RLET bindings
     349;;; A list of LET* bindings
     350;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
     351;;; A list of initializaton forms for (some) structure args (not used on x8632)
     352;;; A FOREIGN-TYPE representing the "actual" return type.
     353;;; A form which can be used to initialize FP-ARGS-PTR, relative
     354;;;  to STACK-PTR.  (This is unused on x8632.)
     355;;; The byte offset of the foreign return address, relative to STACK-PTR
     356
     357(defun x8632::generate-callback-bindings (stack-ptr fp-args-ptr argvars
     358                                          argspecs result-spec
     359                                          struct-result-name)
     360  (declare (ignore fp-args-ptr))
     361  (collect ((lets)
     362            (dynamic-extent-names))
     363    (let* ((rtype (parse-foreign-type result-spec)))
     364      (when (typep rtype 'foreign-record-type)
     365        (setq argvars (cons struct-result-name argvars)
     366              argspecs (cons :address argspecs)
     367              rtype *void-foreign-type*))
     368      (do* ((argvars argvars (cdr argvars))
     369            (argspecs argspecs (cdr argspecs))
     370            (offset 8))
     371           ((null argvars)
     372            (values nil (lets) (dynamic-extent-names) nil rtype nil 4))
     373        (let* ((name (car argvars))
     374               (spec (car argspecs))
     375               (argtype (parse-foreign-type spec))
     376               (bits (require-foreign-type-bits argtype))
     377               (double nil))
     378          (if (typep argtype 'foreign-record-type)
     379            (lets (list name
     380                        `(%inc-ptr ,stack-ptr
     381                                   ,(prog1 offset
     382                                           (incf offset
     383                                                 (* 4 (ceiling bits 32)))))))
     384            (progn
     385              (lets (list name
     386                          `(,
     387                            (ecase (foreign-type-to-representation-type argtype)
     388                              (:single-float '%get-single-float)
     389                              (:double-float (setq double t) '%get-double-float)
     390                              (:signed-doubleword (setq double t)
     391                                                  '%%get-signed-longlong)
     392                              (:signed-fullword '%get-signed-long)
     393                              (:signed-halfword '%get-signed-word)
     394                              (:signed-byte '%get-signed-byte)
     395                              (:unsigned-doubleword (setq double t)
     396                                                    '%%get-unsigned-longlong)
     397                              (:unsigned-fullword '%get-unsigned-long)
     398                              (:unsigned-halfword '%get-unsigned-word)
     399                              (:unsigned-byte '%get-unsigned-byte)
     400                              (:address '%get-ptr))
     401                            ,stack-ptr
     402                            ,offset)))
     403              (incf offset 4)
     404              (when double (incf offset 4)))))))))
     405
     406(defun x8632::generate-callback-return-value (stack-ptr fp-args-ptr result
     407                                              return-type struct-return-arg)
     408  (declare (ignore fp-args-ptr struct-return-arg))
     409  (unless (eq return-type *void-foreign-type*)
     410    (let* ((return-type-keyword (foreign-type-to-representation-type
     411                                 return-type)))
     412        (collect ((forms))
     413          (forms 'progn)
     414          (case return-type-keyword
     415            (:single-float
     416             (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 1)))
     417            (:double-float
     418             (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 2))))
     419          (forms
     420           `(setf (,
     421                   (case return-type-keyword
     422                     (:address '%get-ptr)
     423                     (:signed-doubleword '%%get-signed-longlong)
     424                     (:unsigned-doubleword '%%get-unsigned-longlong)
     425                     (:double-float '%get-double-float)
     426                     (:single-float '%get-single-float)
     427                     (:unsigned-fullword '%get-unsigned-long)
     428                     (t '%get-signed-long)
     429                     ) ,stack-ptr -8) ,result))
     430          (forms)))))
     431
     432
     433
    287434#+x8632-target
    288435(require "X8632-VINSNS")
Note: See TracChangeset for help on using the changeset viewer.