Changeset 12590


Ignore:
Timestamp:
Aug 16, 2009, 9:17:02 PM (10 years ago)
Author:
gb
Message:

When generating binding forms for DEFCALLBACK, allow a parameter name
to be NIL. Don't actually generate a binding for such a parameter, but
do go through the macroexpand-time steps of determining its location
and size (and therefore the location of subsequent named parameters.)

This is intended to do what (DECLARE IGNORE) would do for a named parameter,
only it keeps the compiler from having to decide whether the variable's
initform is side-effect free. (We're generally trying to avoid the
side-effects of having to cons a pointer that's subsequently unreferenced;
this happens with the _CMD argument to ObjC callbacks, for instance.)

Location:
trunk/source
Files:
7 edited

Legend:

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

    r11590 r12590  
    383383
    384384(defun x8632::generate-callback-bindings (stack-ptr fp-args-ptr argvars
    385                                           argspecs result-spec
    386                                           struct-result-name)
     385                                                    argspecs result-spec
     386                                                    struct-result-name)
    387387  (declare (ignore fp-args-ptr))
    388388  (collect ((lets)
     
    409409               (double nil))
    410410          (if (typep argtype 'foreign-record-type)
    411             (lets (list name
    412                         `(%inc-ptr ,stack-ptr
    413                                    ,(prog1 offset
    414                                            (incf offset
    415                                                  (* 4 (ceiling bits 32)))))))
    416             (progn
    417               (lets (list name
    418                           `(,
    419                             (ecase (foreign-type-to-representation-type argtype)
    420                               (:single-float '%get-single-float)
    421                               (:double-float (setq double t) '%get-double-float)
    422                               (:signed-doubleword (setq double t)
    423                                                   '%%get-signed-longlong)
    424                               (:signed-fullword '%get-signed-long)
    425                               (:signed-halfword '%get-signed-word)
    426                               (:signed-byte '%get-signed-byte)
    427                               (:unsigned-doubleword (setq double t)
    428                                                     '%%get-unsigned-longlong)
    429                               (:unsigned-fullword '%get-unsigned-long)
    430                               (:unsigned-halfword '%get-unsigned-word)
    431                               (:unsigned-byte '%get-unsigned-byte)
    432                               (:address '%get-ptr))
    433                             ,stack-ptr
    434                             ,offset)))
     411            (let* ((form `(%inc-ptr ,stack-ptr
     412                           ,(prog1 offset
     413                                   (incf offset
     414                                         (* 4 (ceiling bits 32)))))))
     415              (when name (lets (list name form))))
     416            (let* ((form `(,
     417                           (ecase (foreign-type-to-representation-type argtype)
     418                             (:single-float '%get-single-float)
     419                             (:double-float (setq double t) '%get-double-float)
     420                             (:signed-doubleword (setq double t)
     421                                                 '%%get-signed-longlong)
     422                             (:signed-fullword '%get-signed-long)
     423                             (:signed-halfword '%get-signed-word)
     424                             (:signed-byte '%get-signed-byte)
     425                             (:unsigned-doubleword (setq double t)
     426                                                   '%%get-unsigned-longlong)
     427                             (:unsigned-fullword '%get-unsigned-long)
     428                             (:unsigned-halfword '%get-unsigned-word)
     429                             (:unsigned-byte '%get-unsigned-byte)
     430                             (:address '%get-ptr))
     431                           ,stack-ptr
     432                           ,offset)))
     433              (when name (lets (list name form)))
    435434              (incf offset 4)
    436435              (when double (incf offset 4)))))))))
  • trunk/source/compiler/X86/X8664/x8664-backend.lisp

    r10645 r12590  
    590590                    (:float (if (< (decf fprs) 0) (setq first8 :memory)))))
    591591                (if (eq first8 :memory)
     592                  (let* ((form `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset
     593                                                                   (incf memory-arg-offset (* 8 (ceiling bits 64)))))))
     594                    (when name
     595                      (lets (list name form))
     596                      (dynamic-extent-names name)))
    592597                  (progn
    593                     (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset
    594                                                                    (incf memory-arg-offset (* 8 (ceiling bits 64)))))))
    595                          (dynamic-extent-names name))
    596                   (progn
    597                     (rlets (list name (foreign-record-type-name argtype)))
    598                     (inits `(setf (%%get-unsigned-longlong ,name 0)
    599                              (%%get-unsigned-longlong ,stack-ptr ,(if (eq first8 :integer) (next-gpr) (next-fpr)))))
     598                    (when name (rlets (list name (foreign-record-type-name argtype))))
     599                    (let* ((init1 `(setf (%%get-unsigned-longlong ,name 0)
     600                             (%%get-unsigned-longlong ,stack-ptr ,(if (eq first8 :integer) (next-gpr) (next-fpr))))))
     601                      (when name (inits init1)))
    600602                    (if second8
    601                       (inits `(setf (%%get-unsigned-longlong ,name 8)
    602                              (%%get-unsigned-longlong ,stack-ptr ,(if (eq second8 :integer) (next-gpr) (next-fpr)))))))))
    603                 (lets (list name
    604                             `(,
    605                              (ecase (foreign-type-to-representation-type argtype)
    606                                (:single-float (setq fp t) '%get-single-float)
    607                                (:double-float (setq fp t) '%get-double-float)
    608                                (:signed-doubleword  '%%get-signed-longlong)
    609                                (:signed-fullword '%get-signed-long)
    610                                (:signed-halfword '%get-signed-word)
    611                                (:signed-byte '%get-signed-byte)
    612                                (:unsigned-doubleword '%%get-unsigned-longlong)
    613                                (:unsigned-fullword '%get-unsigned-long)
    614                                (:unsigned-halfword '%get-unsigned-word)
    615                                (:unsigned-byte '%get-unsigned-byte)
    616                                (:address
    617                                 #+nil
    618                                 (dynamic-extent-names name)
    619                                 '%get-ptr))
    620                              ,stack-ptr
    621                              ,(if fp (next-fpr) (next-gpr))))))))))))
     603                      (let* ((init2 `(setf (%%get-unsigned-longlong ,name 8)
     604                               (%%get-unsigned-longlong ,stack-ptr ,(if (eq second8 :integer) (next-gpr) (next-fpr))))))
     605                        (when name (inits init2 )))))))
     606              (let* ((form`(,
     607                            (ecase (foreign-type-to-representation-type argtype)
     608                              (:single-float (setq fp t) '%get-single-float)
     609                              (:double-float (setq fp t) '%get-double-float)
     610                              (:signed-doubleword  '%%get-signed-longlong)
     611                              (:signed-fullword '%get-signed-long)
     612                              (:signed-halfword '%get-signed-word)
     613                              (:signed-byte '%get-signed-byte)
     614                              (:unsigned-doubleword '%%get-unsigned-longlong)
     615                              (:unsigned-fullword '%get-unsigned-long)
     616                              (:unsigned-halfword '%get-unsigned-word)
     617                              (:unsigned-byte '%get-unsigned-byte)
     618                              (:address
     619                               #+nil
     620                               (when name (dynamic-extent-names name))
     621                               '%get-ptr))
     622                            ,stack-ptr
     623                            ,(if fp (next-fpr) (next-gpr)))))               
     624                (if name (lets (list name form )))))))))))
    622625
    623626(defun x8664::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
  • trunk/source/lib/ffi-darwinppc32.lisp

    r7376 r12590  
    211211                (if type0
    212212                  (progn
    213                     (rlets (list name (foreign-record-type-name argtype)))
    214                     (inits `(setf ,(%foreign-access-form name type0 0 nil)
     213                    (when name (rlets (list name (foreign-record-type-name argtype))))
     214                    (let* ((init `(setf ,(%foreign-access-form name type0 0 nil)
    215215                             ,(next-scalar-arg type0))))
    216                   (progn (setq delta (* (ceiling (foreign-record-type-bits argtype) 32) 4))
    217                     (lets (list name `(%inc-ptr ,stack-ptr ,offset ))))))
    218               (lets (list name (next-scalar-arg argtype))))
     216                      (when name (inits init))))
     217                  (progn
     218                    (setq delta (* (ceiling (foreign-record-type-bits argtype) 32) 4))
     219                    (when name ; no side-efects hers     
     220                    (lets (list name `(%inc-ptr ,stack-ptr ,offset)))))))
     221              (let* ((pair (list name (next-scalar-arg argtype))))
     222                (when name (lets pair))))
    219223            #+nil
    220224            (when (or (typep argtype 'foreign-pointer-type)
  • trunk/source/lib/ffi-darwinppc64.lisp

    r12293 r12590  
    457457                        (= bits 128))
    458458                  (progn (setq delta (* (ceiling bits 64) 8))
    459                          (lets (list name `(%inc-ptr ,stack-ptr ,offset )))
     459                         (when name (lets (list name `(%inc-ptr ,stack-ptr ,offset ))))
    460460                         (incf offset delta))
    461461
     
    477477                                                 'foreign-single-float-type))
    478478                                   (return t))))))
    479                       (rlets (list name (or (foreign-record-type-name argtype)
    480                                             spec)))
     479                      (when name (rlets (list name (or (foreign-record-type-name argtype)
     480                                            spec))))
    481481                      (do* ((bit-offset 0 (+ bit-offset 64))
    482482                            (byte-offset 0 (+ byte-offset 8)))
    483483                           ((>= bit-offset bits))
    484484                        (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))))
     485                          (let* ((init `(setf (%get-double-float ,name ,byte-offset)
     486                                   ,(next-scalar-arg (parse-foreign-type :double-float)))))
     487                            (when name
     488                              (inits init)))
    487489                          (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)))))
     490                                 (low-single (single-float-at-offset (+ bit-offset 32)))
     491                                 (init `(setf (%%get-unsigned-longlong ,name ,byte-offset)
     492                                     ,(next-scalar-arg (parse-foreign-type '(:unsigned 64))))))
     493                            (when name (inits init))
    491494                            (when high-single
    492495                              (when (< (incf fp-arg-num) 14)
    493496                                (set-fp-regs-form)
    494                                 (inits `(setf (%get-single-float ,name ,byte-offset)
     497                                (when name
     498                                  (inits `(setf (%get-single-float ,name ,byte-offset)
    495499                                         (%get-single-float-from-double-ptr
    496500                                          ,fp-args-ptr
    497                                           ,(* 8 (1- fp-arg-num)))))))
     501                                          ,(* 8 (1- fp-arg-num))))))))
    498502                            (when low-single
    499503                              (when (< (incf fp-arg-num) 14)
    500504                                (set-fp-regs-form)
    501                                 (inits `(setf (%get-single-float ,name ,(+ 4 byte-offset))
     505                                (when name
     506                                  (inits `(setf (%get-single-float ,name ,(+ 4 byte-offset))
    502507                                         (%get-single-float-from-double-ptr
    503508                                          ,fp-args-ptr
    504                                           ,(* 8 (1- fp-arg-num)))))))))))))
    505                 (lets (list name (next-scalar-arg argtype))))
     509                                          ,(* 8 (1- fp-arg-num))))))))))))))
     510                (let* ((pair (list name (next-scalar-arg argtype))))
     511                  (when name
     512                    (lets name))))
    506513              #+nil
    507514              (when (or (typep argtype 'foreign-pointer-type)
  • trunk/source/lib/ffi-linuxppc32.lisp

    r7376 r12590  
    187187                          ,stack-ptr
    188188                          ,(+ target bias))))
    189                   (lets (list name access-form))
     189                  (when name (lets (list name access-form)))
    190190                  #+nil
    191191                  (when (eq spec :address)
  • trunk/source/lib/ffi-linuxppc64.lisp

    r7135 r12590  
    111111                     (< bits 64))
    112112              (progn
    113                 (rlets (list name (foreign-record-type-name argtype)))
    114                 (inits `(setf (%%get-unsigned-longlong ,name 0)
    115                          (ash (%%get-unsigned-longlong ,stack-ptr ,offset)
    116                           ,(- 64 bits)))))
     113                (when name (rlets (list name (foreign-record-type-name argtype))))
     114                (when name (inits `(setf (%%get-unsigned-longlong ,name 0)
     115                                    (ash (%%get-unsigned-longlong ,stack-ptr ,offset)
     116                                     ,(- 64 bits))))))
    117117              (let* ((access-form
    118118                      `(,(cond
     
    169169                        ,(if use-fp-args (* 8 (1- fp-arg-num))
    170170                             `(+ ,offset ,bias)))))
    171                 (lets (list name access-form))
     171                (when name (lets (list name access-form)))
     172                #+nil
    172173                (when (eq spec :address)
    173174                  (dynamic-extent-names name))
  • trunk/source/lib/ffi-win64.lisp

    r10826 r12590  
    137137            (if (typep argtype 'foreign-record-type)
    138138              (setq argtype :address))
    139             (lets (list name
    140                         `(,
     139            (let* ((access-form
     140                    `(,
    141141                          (ecase (foreign-type-to-representation-type argtype)
    142142                            (:single-float (setq fp t) '%get-single-float)
     
    155155                             '%get-ptr))
    156156                          ,stack-ptr
    157                           ,(if fp (next-fpr) (next-gpr)))))))))))
     157                          ,(if fp (next-fpr) (next-gpr)))))
     158              (when name (lets (list name access-form))))))))))
    158159
    159160(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.