Changeset 8954


Ignore:
Timestamp:
Mar 30, 2008, 8:05:12 AM (11 years ago)
Author:
gb
Message:

Callback stuff.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/win64/lib/ffi-win64.lisp

    r8711 r8954  
    9191;;; A FOREIGN-TYPE representing the "actual" return type.
    9292;;; A form which can be used to initialize FP-ARGS-PTR, relative
    93 ;;;  to STACK-PTR.  (This is unused on linuxppc32.)
     93;;;  to STACK-PTR.
    9494;;; The byte offset of the foreign return address, relative to STACK-PTR
    9595(defun win64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
     
    9797  (collect ((lets)
    9898            (rlets)
    99             (dynamic-extent-names))
     99            (inits))
    100100    (let* ((rtype (parse-foreign-type result-spec)))
    101101      (when (typep rtype 'foreign-record-type)
    102         (let* ((bits (ensure-foreign-type-bits rtype)))
    103           (if (<= bits 64)
    104             (rlets (list struct-result-name (foreign-record-type-name rtype)))
    105             (setq argvars (cons struct-result-name argvars)
    106                   argspecs (cons :address argspecs)
    107                   rtype *void-foreign-type*))))
    108           (let* ((offset  96)
    109                  (gpr 0)
    110                  (fpr 32))
    111             (do* ((argvars argvars (cdr argvars))
    112                   (argspecs argspecs (cdr argspecs)))
    113                  ((null argvars)
    114                   (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 0 #|wrong|#))
    115               (let* ((name (car argvars))
    116                      (spec (car argspecs))
    117                      (nextgpr gpr)
    118                      (nextfpr fpr)
    119                      (nextoffset offset)
    120                      (target gpr)
    121                      (bias 0)
    122                      (argtype (parse-foreign-type spec)))
    123                 (if (typep argtype 'foreign-record-type)
    124                   (setq argtype (parse-foreign-type :address)))
    125                 (let* ((access-form
    126                         `(,(cond
    127                             ((typep argtype 'foreign-single-float-type)
    128                              (incf nextfpr 8)
    129                              (if (< fpr 96)
    130                                (setq target fpr)
    131                                (setq target (+ offset (logand offset 4))
    132                                      nextoffset (+ target 8)))
    133                              '%get-single-float-from-double-ptr)
    134                             ((typep argtype 'foreign-double-float-type)
    135                              (incf nextfpr 8)
    136                              (if (< fpr 96)
    137                                (setq target fpr)
    138                                (setq target (+ offset (logand offset 4))
    139                                      nextoffset (+ target 8)))
    140                              '%get-double-float)
    141                             ((and (typep argtype 'foreign-integer-type)
    142                                   (= (foreign-integer-type-bits argtype) 64)
    143                                   (foreign-integer-type-signed argtype))
    144                              (if (< gpr 56)
    145                                      (setq target (+ gpr (logand gpr 4))
    146                                            nextgpr (+ 8 target))
    147                                      (setq target (+ offset (logand offset 4))
    148                                            nextoffset (+ 8 offset)))
    149                                    '%%get-signed-longlong)
    150                             ((and (typep argtype 'foreign-integer-type)
    151                                   (= (foreign-integer-type-bits argtype) 64)
    152                                   (not (foreign-integer-type-signed argtype)))
    153                              (if (< gpr 56)
    154                                (setq target (+ gpr (logand gpr 4))
    155                                      nextgpr (+ 8 target))
    156                                (setq target (+ offset (logand offset 4))
    157                                      nextoffset (+ 8 offset)))
    158                              '%%get-unsigned-longlong)
    159                             (t
    160                              (incf nextgpr 4)
    161                              (if (< gpr 64)
    162                                (setq target gpr)
    163                                (setq target offset nextoffset (+ offset 4)))
    164                              (cond ((typep argtype 'foreign-pointer-type) '%get-ptr)
    165                                    ((typep argtype 'foreign-integer-type)
    166                                     (let* ((bits (foreign-integer-type-bits argtype))
    167                                            (signed (foreign-integer-type-signed argtype)))
    168                                       (cond ((<= bits 8)
    169                                              (setq bias 3)
    170                                              (if signed
    171                                                '%get-signed-byte '
    172                                                '%get-unsigned-byte))
    173                                             ((<= bits 16)
    174                                              (setq bias 2)
    175                                              (if signed
    176                                                '%get-signed-word
    177                                                '%get-unsigned-word))
    178                                             ((<= bits 32)
    179                                              (if signed
    180                                                '%get-signed-long
    181                                                '%get-unsigned-long))
    182                                             (t
    183                                              (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
    184                                    (t
    185                                     (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
     102        (if (win64::record-type-returns-structure-as-first-arg rtype)
     103          (setq argvars (cons struct-result-name argvars)
     104                argspecs (cons :address argspecs)
     105                rtype :address)
     106          (rlets (list struct-result-name (foreign-record-type-name rtype)))))
     107      (do* ((argvars argvars (cdr argvars))
     108            (argspecs argspecs (cdr argspecs))
     109            (arg-num 0)
     110            (gpr-arg-offset -8)
     111            (fpr-arg-offset -40)
     112            (memory-arg-offset 16)
     113            (fp nil nil))
     114           ((null argvars)
     115            (values (rlets) (lets) nil (inits) rtype nil 8))
     116        (flet ((next-gpr ()
     117                 (if (<= (incf arg-num) 4)
     118                   (prog1
     119                       gpr-arg-offset
     120                     (decf gpr-arg-offset 8)
     121                     (decf fpr-arg-offset 8))
     122                   (prog1
     123                       memory-arg-offset
     124                     (incf memory-arg-offset 8))))
     125               (next-fpr ()
     126                 (if (<= (incf arg-num) 4)
     127                   (prog1
     128                       fpr-arg-offset
     129                     (decf fpr-arg-offset 8)
     130                     (decf gpr-arg-offset 8))
     131                   (prog1
     132                       memory-arg-offset
     133                     (incf memory-arg-offset 8)))))
     134          (let* ((name (car argvars))
     135                 (spec (car argspecs))
     136                 (argtype (parse-foreign-type spec)))
     137            (if (typep argtype 'foreign-record-type)
     138              (setq argtype :address))
     139            (lets (list name
     140                        `(,
     141                          (ecase (foreign-type-to-representation-type argtype)
     142                            (:single-float (setq fp t) '%get-single-float)
     143                            (:double-float (setq fp t) '%get-double-float)
     144                            (:signed-doubleword  '%%get-signed-longlong)
     145                            (:signed-fullword '%get-signed-long)
     146                            (:signed-halfword '%get-signed-word)
     147                            (:signed-byte '%get-signed-byte)
     148                            (:unsigned-doubleword '%%get-unsigned-longlong)
     149                            (:unsigned-fullword '%get-unsigned-long)
     150                            (:unsigned-halfword '%get-unsigned-word)
     151                            (:unsigned-byte '%get-unsigned-byte)
     152                            (:address
     153                             #+nil
     154                             (dynamic-extent-names name)
     155                             '%get-ptr))
    186156                          ,stack-ptr
    187                           ,(+ target bias))))
    188                   (lets (list name access-form))
    189                   #+nil
    190                   (when (eq spec :address)
    191                     (dynamic-extent-names name))
    192                   (setq gpr nextgpr fpr nextfpr offset nextoffset))))))))
     157                          ,(if fp (next-fpr) (next-gpr)))))))))))
    193158
    194159(defun win64::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.