Changeset 6209


Ignore:
Timestamp:
Apr 8, 2007, 4:41:13 AM (13 years ago)
Author:
gb
Message:

Structures are basically passed as 64-bit word components, with
FP fields passed in registers. This requires some special handling
("hybrid" parameters) in the compiler and %FF-CALL.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/lib/ffi-darwinppc64.lisp

    r5907 r6209  
    2222;;; by value.
    2323;;; Structures which contain unions are passed in N GPRs when passed
    24 ;;; by value
     24;;; by value.
    2525;;; All other structures passed by value are passed by passing their
    26 ;;; constituent elements as scalars.  (For bitfields, the containing
    27 ;;; integer counts as a constituent element.)
     26;;; constituent elements as scalars.  (Sort of.)  GPR's are "consumed"
     27;;; for and possibly/partly loaded with the contents of each 64-bit
     28;;; word; FPRs (and vector registers) are consumed/loaded for each
     29;;; field of the indicated type.
    2830;;; Structures whose size is exactly 16 bytes are returned in GPR3
    2931;;; and GPR4.
     
    7577           (darwin64::record-type-contains-union ftype)))))
    7678
     79
     80
     81
     82
    7783;;; Generate code to set the fields in a structure R of record-type
    7884;;; RTYPE, based on the register values in REGBUF (8 64-bit GPRs,
     
    8490    (collect ((forms))
    8591      (cond ((= bits 128)               ;(and (eql day 'tuesday) ...)
    86              (forms `(setf (ccl::%%get-signed-longlong ,r 0)
    87                       (ccl::%%get-signed-longlong ,regbuf 0)
    88                       (ccl::%%get-signed-longlong ,r 8)
    89                       (ccl::%%get-signed-longlong ,regbuf 8))))
     92             (forms `(setf (ccl::%get-signed-long ,r 0)
     93                      (ccl::%get-signed-long ,regbuf 0)
     94                      (ccl::%get-signed-long ,r 4)
     95                      (ccl::%get-signed-long ,regbuf 4)
     96                      (ccl::%get-signed-long ,r 8)
     97                      (ccl::%get-signed-long ,regbuf 8)
     98                      (ccl::%get-signed-long ,r 12)
     99                      (ccl::%get-signed-long ,regbuf 12))))
     100            ;;; One (slightly naive) way to do this is to just
     101            ;;; copy GPRs into the structure until it's full,
     102            ;;; then go back and overwrite float-typed fields
     103            ;;; with FPRs.  That'd be very naive if all fields
     104            ;;; were float-typed, slightly naive if some fields
     105            ;;; were properly-aligned DOUBLE-FLOATs or if two
     106            ;;; SINGLE-FLOATs were packed inro a 64-bit word,
     107            ;;; and not that bad if a SINGLE-FLOAT shared a
     108            ;;; 64-bit word with a non-FP field.
    90109            (t
    91              (let* ((gpr-offset 0)
    92                     (fpr-offset (* 8 8)))
    93                (flet ((next-gpr-offset ()
    94                         (prog1 gpr-offset
    95                           (incf gpr-offset 8)))
    96                       (next-fpr-offset ()
     110             (let* ((fpr-offset (* 8 8))
     111                    (fields (foreign-record-type-fields rtype)))
     112               (flet ((next-fpr-offset ()
    97113                        (prog1 fpr-offset
    98                           (incf gpr-offset 8)
    99114                          (incf fpr-offset 8))))
    100                  (labels ((do-fields (fields accessors)
     115                 (unless (all-floats-in-field-list fields)
     116                   (do* ((b 0 (+ b 32))
     117                         (w 0 (+ w 4)))
     118                        ((>= b bits))
     119                     (declare (fixnum b 0))
     120                     (forms `(setf (%get-unsigned-long ,r ,w)
     121                              (%get-unsigned-long ,regbuf ,w)))))
     122                 (when (some-floats-in-field-list fields)
     123                   (labels ((do-fp-fields (fields accessors)
     124                              (dolist (field fields)
     125                                (let* ((field-type (foreign-record-field-type field))
     126                                       (field-accessor-list (append accessors (list (foreign-record-field-name field))))
     127                                       (valform ()))
     128                                  (etypecase field-type
     129                                    (foreign-record-type
     130                                     (do-fp-fields (foreign-record-type-fields field-type)
     131                                       field-accessor-list))
     132                                    (foreign-double-float-type
     133                                     (setq valform
     134                                           `(%get-double-float  ,regbuf ,(next-fpr-offset))))
     135                                    (foreign-single-float-type
     136                                     (setq valform
     137                                           `(%get-single-float-from-double-ptr
     138                                             ,regbuf ,(next-fpr-offset))))
     139                                    (foreign-array-type
     140                                     (error "Embedded array-type."))
     141                                    )
     142                                  (when valform
     143                                    (forms `(setf ,(%foreign-access-form
     144                                                    r
     145                                                    rtype
     146                                                    0
     147                                                    field-accessor-list)
     148                                             ,valform)))))))
     149                     (do-fp-fields (foreign-record-type-fields rtype) nil )))))))
     150      `(progn ,@(forms) nil))))
     151
     152;;; "Return" the structure R of foreign type RTYPE, by storing the
     153;;; values of its fields in STACK-PTR and FP-ARG-PTR
     154(defun darwin64::return-struct-to-registers (r rtype stack-ptr fp-args-ptr)
     155  (let* ((bits (require-foreign-type-bits rtype)))
     156    (collect ((forms))
     157      (cond ((= bits 128)               ;(and (eql day 'tuesday) ...)
     158             (forms `(setf (ccl::%get-unsigned-long ,stack-ptr 0)
     159                      (ccl::%get-unsigned-long ,r 0)
     160                      (ccl::%get-unsigned-long ,stack-ptr 4)
     161                      (ccl::%get-unsigned-long ,r 4)
     162                      (ccl::%get-unsigned-long ,stack-ptr 8)
     163                      (ccl::%get-unsigned-long ,r 8)
     164                      (ccl::%get-unsigned-long ,stack-ptr 12)
     165                      (ccl::%get-unsigned-long ,r 12))))
     166            (t
     167             (let* ((fpr-offset 0)
     168                    (fields (foreign-record-type-fields rtype)))
     169               (unless (all-floats-in-field-list fields)
     170                   (do* ((b 0 (+ b 32))
     171                         (w 0 (+ w 4)))
     172                        ((>= b bits))
     173                     (declare (fixnum b 0))
     174                     (forms `(setf (%get-unsigned-long ,stack-ptr ,w)
     175                              (%get-unsigned-long ,r ,w)))))
     176               (when (some-floats-in-field-list fields)
     177               (flet ((next-fpr-offset ()
     178                        (prog1 fpr-offset
     179                          (incf fpr-offset 8))))
     180                 (labels ((do-fp-fields (fields accessors)
    101181                            (dolist (field fields)
    102182                              (let* ((field-type (foreign-record-field-type field))
     
    105185                                (etypecase field-type
    106186                                  (foreign-record-type
    107                                    (do-fields (foreign-record-type-fields field-type)
     187                                   (do-fp-fields (foreign-record-type-fields field-type)
    108188                                     field-accessor-list))
    109                                   (foreign-pointer-type
    110                                    (setq valform
    111                                          `(%get-ptr ,regbuf ,(next-gpr-offset))))
    112                                   (foreign-double-float-type
    113                                    (setq valform
    114                                          `(%get-double-float  ,regbuf ,(next-fpr-offset))))
    115                                   (foreign-single-float-type
    116                                    (setq valform
    117                                          `(%get-single-float-from-double-ptr
    118                                            ,regbuf ,(next-fpr-offset))))
    119                                   (foreign-integer-type
    120                                    (let* ((bits (foreign-integer-type-bits field-type))
    121                                           (signed (foreign-integer-type-signed field-type)))
    122                                      (case bits
    123                                        (64
    124                                         (setq valform
    125                                               `(,(if signed
    126                                                      '%%get-signed-longlong
    127                                                      '%%get-unsigned-longlong)
    128                                                 ,regbuf
    129                                                 ,(next-gpr-offset))))
    130                                        (32
    131                                         (setq valform
    132                                               `(,(if signed
    133                                                      '%get-signed-long
    134                                                      '%get-unsigned-long)
    135                                                 ,regbuf
    136                                                 (+ 4 ,(next-gpr-offset)))))
    137                                        (16
    138                                         (setq valform
    139                                               `(,(if signed
    140                                                      '%get-signed-word
    141                                                      '%get-unsigned-word)
    142                                                 ,regbuf
    143                                                 (+ 6 ,(next-gpr-offset)))))
    144                                        (8
    145                                         (setq valform
    146                                               `(,(if signed
    147                                                      '%get-signed-byte
    148                                                      '%get-unsigned-byte)
    149                                                 ,regbuf
    150                                                 (+ 7 ,(next-gpr-offset))))))))
    151                                   (foreign-array-type
    152                                    (error "Embedded array-type."))
    153                                   )
    154                                 (when valform
    155                                   (forms `(setf ,(%foreign-access-form
    156                                                   r
    157                                                   rtype
    158                                                   0
    159                                                   field-accessor-list)
    160                                            ,valform)))))))
    161                    (do-fields (foreign-record-type-fields rtype) nil ))))))
    162       `(progn ,@(forms) nil))))
    163 
    164 ;;; "Return" the structure R of foreign type RTYPE, by storing the
    165 ;;; values of its fields in STACK-PTR and FP-ARG-PTR
    166 (defun darwin64::return-struct-to-registers (r rtype stack-ptr fp-args-ptr)
    167   (let* ((bits (require-foreign-type-bits rtype)))
    168     (collect ((forms))
    169       (cond ((= bits 128)               ;(and (eql day 'tuesday) ...)
    170              (forms `(setf (ccl::%%get-signed-longlong ,stack-ptr 0)
    171                       (ccl::%%get-signed-longlong ,r 0)
    172                       (ccl::%%get-signed-longlong ,stack-ptr 8)
    173                       (ccl::%%get-signed-longlong ,r 8))))
    174             (t
    175              (let* ((gpr-offset 0)
    176                     (fpr-offset 0))
    177                (flet ((next-gpr-offset ()
    178                         (prog1 gpr-offset
    179                           (incf gpr-offset 8)))
    180                       (next-fpr-offset ()
    181                         (prog1 fpr-offset
    182                           (incf gpr-offset 8)
    183                           (incf fpr-offset 8))))
    184                  (labels ((do-fields (fields accessors)
    185                             (dolist (field fields)
    186                               (let* ((field-type (foreign-record-field-type field))
    187                                      (field-accessor-list (append accessors (list (foreign-record-field-name field))))
    188                                      (valform ()))
    189                                 (etypecase field-type
    190                                   (foreign-record-type
    191                                    (do-fields (foreign-record-type-fields field-type)
    192                                      field-accessor-list))
    193                                   (foreign-pointer-type
    194                                    (setq valform
    195                                          `(%get-ptr ,stack-ptr ,(next-gpr-offset))))
    196189                                  (foreign-double-float-type
    197190                                   (setq valform
     
    200193                                   (setq valform
    201194                                         `(%get-double-float  ,fp-args-ptr ,(next-fpr-offset))))
    202                                   (foreign-integer-type
    203                                    (let* ((bits (foreign-integer-type-bits field-type))
    204                                           (signed (foreign-integer-type-signed field-type)))
    205                                      (case bits
    206                                        (64
    207                                         (setq valform
    208                                               `(,(if signed
    209                                                      '%%get-signed-longlong
    210                                                      '%%get-unsigned-longlong)
    211                                                 ,stack-ptr
    212                                                 ,(next-gpr-offset))))
    213                                        (32
    214                                         (setq valform
    215                                               `(,(if signed
    216                                                      '%get-signed-long
    217                                                      '%get-unsigned-long)
    218                                                 ,stack-ptr
    219                                                 (+ 4 ,(next-gpr-offset)))))
    220                                        (16
    221                                         (setq valform
    222                                               `(,(if signed
    223                                                      '%get-signed-word
    224                                                      '%get-unsigned-word)
    225                                                 ,stack-ptr
    226                                                 (+ 6 ,(next-gpr-offset)))))
    227                                        (8
    228                                         (setq valform
    229                                               `(,(if signed
    230                                                      '%get-signed-byte
    231                                                      '%get-unsigned-byte)
    232                                                 ,stack-ptr
    233                                                 (+ 7 ,(next-gpr-offset))))))))
     195
    234196                                  (foreign-array-type
    235197                                   (error "Embedded array-type."))
     
    241203                                                      0
    242204                                                      field-accessor-list)))
    243                                     (when (typep field-form 'foreign-single-float-type)
     205                                    (when (typep field-type 'foreign-single-float-type)
    244206                                      (setq field-form `(float ,field-form 0.0d0)))
    245207                                    (forms `(setf ,valform ,field-form))))))))
    246                    (do-fields (foreign-record-type-fields rtype) nil ))))))
     208                   (do-fp-fields fields nil )))))))
    247209      `(progn ,@(forms) nil))))
    248                                  
     210
     211;;; Return an ordered list of all scalar fields in the record type FTYPE.
     212(defun darwin64::flatten-fields (ftype)
     213  (if (darwin64::record-type-contains-union ftype)
     214    (error "Can't flatten fields in ~s: contains union" ftype))
     215  (collect ((fields))
     216    (labels ((flatten (field-list bit-offset)
     217               (dolist (field field-list)
     218                 (let* ((field-type (foreign-record-field-type field))
     219                        (next-offset (+ bit-offset (foreign-record-field-offset field))))
     220                   (typecase field-type
     221                     (foreign-record-type
     222                      (flatten (foreign-record-type-fields field-type) next-offset))
     223                     (foreign-array-type
     224                      (let* ((element-type (foreign-array-type-element-type field-type))
     225                             (nbits (foreign-type-bits element-type))
     226                             (align (foreign-type-alignment  element-type))
     227                             (dims (foreign-array-type-dimensions field-type))
     228                             (n (or (and (null (cdr dims)) (car dims))
     229                                    (error "Can't handle multidimensional foreign arrays")))
     230                             (pos next-offset))
     231                        (dotimes (i n)
     232                          (fields (make-foreign-record-field :type element-type
     233                                                             :bits nbits
     234                                                             :offset pos))
     235                          (setq pos (align-offset (+ pos nbits) align)))))
     236                     (t
     237                      (fields (make-foreign-record-field :type field-type
     238                                                         :bits (foreign-record-field-bits field)
     239                                                         :offset next-offset))))))))
     240      (flatten (foreign-record-type-fields ftype) 0)
     241      (fields))))
     242
     243               
     244             
    249245
    250246(defun darwin64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
     
    278274              (argforms regbuf))))
    279275        (let* ((valform nil))
    280           (labels ((do-fields (rtype fields accessors)
    281                      (dolist (field fields)
    282                        (let* ((field-type (foreign-record-field-type field))
    283                               (field-accessor-list (append accessors (list (foreign-record-field-name field))))
    284                               (access-form ()))
    285                          (typecase field-type
    286                            (foreign-record-type
    287                             (do-fields rtype (foreign-record-type-fields field-type) field-accessor-list))
    288                            ((or foreign-pointer-type foreign-integer-type
    289                                 foreign-single-float-type foreign-double-float-type)
    290                             (setq access-form
    291                                   (%foreign-access-form valform rtype 0 field-accessor-list))))
    292                          (when access-form
    293                            (argforms (foreign-type-to-representation-type field-type))
    294                            (argforms access-form)
    295                            (setq valform structure-arg-temp))))))
    296             (unless (evenp (length args))
    297               (error "~s should be an even-length list of alternating foreign types and values" args))
    298             (do* ((args args (cddr args)))
    299                  ((null args))
    300               (let* ((arg-type-spec (car args))
    301                      (arg-value-form (cadr args)))
    302                 (if (or (member arg-type-spec *foreign-representation-type-keywords*
    303                                 :test #'eq)
    304                         (typep arg-type-spec 'unsigned-byte))
    305                   (progn
    306                     (argforms arg-type-spec)
    307                     (argforms arg-value-form))
    308                   (let* ((ftype (parse-foreign-type arg-type-spec)))
    309                     (if (typep ftype 'foreign-record-type)
    310                       (if (darwin64::record-type-contains-union ftype)
    311                         (progn
    312                           (argforms (ceiling (foreign-record-type-bits ftype) 64))
    313                           (argforms arg-value-form))
    314                         (progn
    315                           (unless structure-arg-temp
    316                             (setq structure-arg-temp (gensym)))
    317                           (setq valform `(%setf-macptr ,structure-arg-temp ,arg-value-form))
    318                           (do-fields ftype (foreign-record-type-fields ftype) nil)))
     276          (unless (evenp (length args))
     277            (error "~s should be an even-length list of alternating foreign types and values" args))
     278          (do* ((args args (cddr args)))
     279               ((null args))
     280            (let* ((arg-type-spec (car args))
     281                   (arg-value-form (cadr args)))
     282              (if (or (member arg-type-spec *foreign-representation-type-keywords*
     283                              :test #'eq)
     284                      (typep arg-type-spec 'unsigned-byte))
     285                (progn
     286                  (argforms arg-type-spec)
     287                  (argforms arg-value-form))
     288                (let* ((ftype (parse-foreign-type arg-type-spec))
     289                       (bits (foreign-type-bits ftype)))
     290                  (if (typep ftype 'foreign-record-type)
     291                    (if (or (darwin64::record-type-contains-union ftype)
     292                            (= bits 128))
    319293                      (progn
    320                         (argforms (foreign-type-to-representation-type ftype))
    321                         (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
    322             (argforms (foreign-type-to-representation-type result-type))
    323             (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
    324               (when structure-arg-temp
    325                 (setq call `(let* ((,structure-arg-temp (%null-ptr)))
    326                              (declare (dynamic-extent ,structure-arg-temp)
    327                                       (type macptr ,structure-arg-temp))
    328                              ,call)))
    329               (if regbuf
    330                 `(let* ((,result-temp (%null-ptr)))
    331                   (declare (dynamic-extent ,result-temp)
    332                            (type macptr ,result-temp))
    333                   (%setf-macptr ,result-temp ,result-form)
    334                   (%stack-block ((,regbuf (+ (* 8 8) (* 8 13))))
    335                     ,call
    336                     ,(darwin64::struct-from-regbuf-values result-temp struct-result-type regbuf)))
    337                 call))))))))
     294                        (argforms (ceiling (foreign-record-type-bits ftype) 64))
     295                        (argforms arg-value-form))
     296                      (let* ((flattened-fields (darwin64::flatten-fields ftype)))
     297
     298                        (flet ((single-float-at-offset (offset)
     299                                 (dolist (field flattened-fields)
     300                                   (let* ((field-offset (foreign-record-field-offset field)))
     301                                     (when (> field-offset offset)
     302                                       (return nil))
     303                                     (if (and (= field-offset offset)
     304                                              (typep (foreign-record-field-type field)
     305                                                     'foreign-single-float-type))
     306                                       (return t)))))
     307                               (double-float-at-offset (offset)
     308                                 (dolist (field flattened-fields)
     309                                   (let* ((field-offset (foreign-record-field-offset field)))
     310                                     (when (> field-offset offset)
     311                                       (return nil))
     312                                     (if (and (= field-offset offset)
     313                                              (typep (foreign-record-field-type field)
     314                                                     'foreign-double-float-type))
     315                                       (return t))))))
     316                        (unless structure-arg-temp
     317                          (setq structure-arg-temp (gensym)))
     318                        (setq valform `(%setf-macptr ,structure-arg-temp ,arg-value-form))
     319                        (do* ((bit-offset 0 (+ bit-offset 64))
     320                              (byte-offset 0 (+ byte-offset 8)))
     321                             ((>= bit-offset bits))
     322                          (if (double-float-at-offset bit-offset)
     323                            (progn
     324                              (argforms :double-float)
     325                              (argforms `(%get-double-float ,valform ,byte-offset)))
     326                            (let* ((high-single (single-float-at-offset bit-offset))
     327                                   (low-single (single-float-at-offset (+ bit-offset 32))))
     328                              (if high-single
     329                                (if low-single
     330                                  (argforms :hybrid-float-float)
     331                                  (argforms :hybrid-float-int))
     332                                (if low-single
     333                                  (argforms :hybrid-int-float)
     334                                  (argforms :unsigned-doubleword)))
     335                              (argforms `(%%get-unsigned-longlong ,valform ,byte-offset))))
     336                          (setq valform structure-arg-temp)))))
     337                    (progn
     338                      (argforms (foreign-type-to-representation-type ftype))
     339                      (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
     340          (argforms (foreign-type-to-representation-type result-type))
     341          (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
     342            (when structure-arg-temp
     343              (setq call `(let* ((,structure-arg-temp (%null-ptr)))
     344                           (declare (dynamic-extent ,structure-arg-temp)
     345                                    (type macptr ,structure-arg-temp))
     346                           ,call)))
     347            (if regbuf
     348              `(let* ((,result-temp (%null-ptr)))
     349                (declare (dynamic-extent ,result-temp)
     350                         (type macptr ,result-temp))
     351                (%setf-macptr ,result-temp ,result-form)
     352                (%stack-block ((,regbuf (+ (* 8 8) (* 8 13))))
     353                  ,call
     354                  ,(darwin64::struct-from-regbuf-values result-temp struct-result-type regbuf)))
     355              call)))))))
    338356           
    339357           
     
    363381                  argspecs (cons :address argspecs)
    364382                  rtype *void-foreign-type*)
    365             (rlets (list struct-result-name (foreign-record-type-name rtype)))))
     383            (rlets (list struct-result-name (or (foreign-record-type-name rtype)
     384                                                result-spec)))))
    366385        (when (typep rtype 'foreign-float-type)
    367386          (set-fp-regs-form))
     
    430449                              (+ offset bias)))
    431450                     (incf offset delta))))
    432           (let* ((name (car argvars))
    433                  (spec (car argspecs))
    434                  (argtype (parse-foreign-type spec)))
    435             (if (typep argtype 'foreign-record-type)
    436               (if (darwin64::record-type-contains-union argtype)
    437                 (progn (setq delta (* (ceiling (foreign-record-type-bits argtype) 64) 8))
    438                        (lets (list name `(%inc-ptr ,stack-ptr ,offset )))
    439                        (incf offset delta))
    440 
    441                  (labels ((do-fields (fields accessors)
    442                             (dolist (field fields)
    443                               (let* ((field-type (foreign-record-field-type field))
    444                                      (field-accessor-list (append accessors (list (foreign-record-field-name field))))
    445                                      (valform ()))
    446                                 (typecase field-type
    447                                   (foreign-record-type
    448                                    (do-fields (foreign-record-type-fields field-type)
    449                                      field-accessor-list))
    450                                   (foreign-array-type
    451                                    (error "Embedded array type"))
    452                                   (t
    453                                    (setq valform (next-scalar-arg field-type))))
    454                                 (when valform
    455                                   (inits `(setf ,(%foreign-access-form
    456                                                       name
    457                                                       argtype
    458                                                       0
    459                                                       field-accessor-list)
    460                                            ,valform)))))))
    461                    (rlets (list name (foreign-record-type-name argtype)))
    462                    (do-fields (foreign-record-type-fields argtype) nil)))
    463               (lets (list name (next-scalar-arg argtype))))
    464             (when (or (typep argtype 'foreign-pointer-type)
    465                       (typep argtype 'foreign-array-type))
    466               (dynamic-extent-names name))
    467             (when use-fp-args (set-fp-regs-form)))))))))
     451            (let* ((name (car argvars))
     452                   (spec (car argspecs))
     453                   (argtype (parse-foreign-type spec))
     454                   (bits (foreign-type-bits argtype)))
     455              (if (typep argtype 'foreign-record-type)
     456                (if (or (darwin64::record-type-contains-union argtype)
     457                        (= bits 128))
     458                  (progn (setq delta (* (ceiling bits 64) 8))
     459                         (lets (list name `(%inc-ptr ,stack-ptr ,offset )))
     460                         (incf offset delta))
     461
     462                  (let* ((flattened-fields (darwin64::flatten-fields argtype)))
     463                    (flet ((double-float-at-offset (offset)
     464                             (dolist (field flattened-fields)
     465                               (let* ((field-offset (foreign-record-field-offset field)))
     466                                 (when (> field-offset offset) (return))
     467                                 (if (and (= field-offset offset)
     468                                          (typep (foreign-record-field-type field)
     469                                                 'foreign-double-float-type))
     470                                   (return t)))))
     471                           (single-float-at-offset (offset)
     472                             (dolist (field flattened-fields)
     473                               (let* ((field-offset (foreign-record-field-offset field)))
     474                                 (when (> field-offset offset) (return))
     475                                 (if (and (= field-offset offset)
     476                                          (typep (foreign-record-field-type field)
     477                                                 'foreign-single-float-type))
     478                                   (return t))))))
     479                      (rlets (list name (or (foreign-record-type-name argtype)
     480                                            spec)))
     481                      (do* ((bit-offset 0 (+ bit-offset 64))
     482                            (byte-offset 0 (+ byte-offset 8)))
     483                           ((>= bit-offset bits))
     484                        (if (double-float-at-offset bit-offset)
     485                          (inits `(setf (%get-double-float ,name ,byte-offset)
     486                                   ,(next-scalar-arg (parse-foreign-type :double-float))))
     487                          (let* ((high-single (single-float-at-offset bit-offset))
     488                                 (low-single (single-float-at-offset (+ bit-offset 32))))
     489                            (inits `(setf (%%get-unsigned-longlong ,name ,byte-offset)
     490                                     ,(next-scalar-arg (parse-foreign-type '(:unsigned 64)))))
     491                            (when high-single
     492                              (when (< (incf fp-arg-num) 14)
     493                                (set-fp-regs-form)
     494                                (inits `(setf (%get-single-float ,name ,byte-offset)
     495                                         (%get-single-float-from-double-ptr
     496                                          ,fp-args-ptr
     497                                          ,(* 8 (1- fp-arg-num)))))))
     498                            (when low-single
     499                              (when (< (incf fp-arg-num) 14)
     500                                (set-fp-regs-form)
     501                                (inits `(setf (%get-single-float ,name ,(+ 4 byte-offset))
     502                                         (%get-single-float-from-double-ptr
     503                                          ,fp-args-ptr
     504                                          ,(* 8 (1- fp-arg-num)))))))))))))
     505                (lets (list name (next-scalar-arg argtype))))
     506              (when (or (typep argtype 'foreign-pointer-type)
     507                        (typep argtype 'foreign-array-type))
     508                (dynamic-extent-names name))
     509              (when use-fp-args (set-fp-regs-form)))))))))
    468510
    469511(defun darwin64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
Note: See TracChangeset for help on using the changeset viewer.