Changeset 12694


Ignore:
Timestamp:
Aug 26, 2009, 6:34:01 PM (10 years ago)
Author:
gz
Message:

Merge r12579 r12590 r12591 r12594 r12600 from trunk - defcallback improvements

Location:
branches/working-0711/ccl
Files:
10 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/X86/X8632/x8632-backend.lisp

    r12198 r12694  
    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)))))))))
  • branches/working-0711/ccl/compiler/X86/X8664/x8664-backend.lisp

    r11054 r12694  
    8888                :target-arch x8664::*x8664-target-arch*
    8989                ;; Overload %gs until Apple straightens things out.
    90                 :lisp-context-register x8664::gs
     90                ;; Whoops; they never did.
     91                :lisp-context-register x8664::r11
    9192                ))
    9293
     
    590591                    (:float (if (< (decf fprs) 0) (setq first8 :memory)))))
    591592                (if (eq first8 :memory)
     593                  (let* ((form `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset
     594                                                                   (incf memory-arg-offset (* 8 (ceiling bits 64)))))))
     595                    (when name
     596                      (lets (list name form))
     597                      (dynamic-extent-names name)))
    592598                  (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)))))
     599                    (when name (rlets (list name (foreign-record-type-name argtype))))
     600                    (let* ((init1 `(setf (%%get-unsigned-longlong ,name 0)
     601                             (%%get-unsigned-longlong ,stack-ptr ,(if (eq first8 :integer) (next-gpr) (next-fpr))))))
     602                      (when name (inits init1)))
    600603                    (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))))))))))))
     604                      (let* ((init2 `(setf (%%get-unsigned-longlong ,name 8)
     605                               (%%get-unsigned-longlong ,stack-ptr ,(if (eq second8 :integer) (next-gpr) (next-fpr))))))
     606                        (when name (inits init2 )))))))
     607              (let* ((form`(,
     608                            (ecase (foreign-type-to-representation-type argtype)
     609                              (:single-float (setq fp t) '%get-single-float)
     610                              (:double-float (setq fp t) '%get-double-float)
     611                              (:signed-doubleword  '%%get-signed-longlong)
     612                              (:signed-fullword '%get-signed-long)
     613                              (:signed-halfword '%get-signed-word)
     614                              (:signed-byte '%get-signed-byte)
     615                              (:unsigned-doubleword '%%get-unsigned-longlong)
     616                              (:unsigned-fullword '%get-unsigned-long)
     617                              (:unsigned-halfword '%get-unsigned-word)
     618                              (:unsigned-byte '%get-unsigned-byte)
     619                              (:address
     620                               #+nil
     621                               (when name (dynamic-extent-names name))
     622                               '%get-ptr))
     623                            ,stack-ptr
     624                            ,(if fp (next-fpr) (next-gpr)))))               
     625                (if name (lets (list name form )))))))))))
    622626
    623627(defun x8664::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
  • branches/working-0711/ccl/compiler/X86/x862.lisp

    r12363 r12694  
    82978297
    82988298(defx862 x862-flet flet (seg vreg xfer vars afuncs body p2decls)
    8299   (x862-seq-fbind seg vreg xfer vars afuncs body p2decls))
     8299  (if (dolist (afunc afuncs)
     8300        (unless (eql 0 (afunc-fn-refcount afunc))
     8301          (return t)))
     8302    (x862-seq-fbind seg vreg xfer vars afuncs body p2decls)
     8303    (with-x86-p2-declarations p2decls
     8304      (x862-form seg vreg xfer body))))
    83008305
    83018306(defx862 x862-labels labels (seg vreg xfer vars afuncs body p2decls)
  • branches/working-0711/ccl/compiler/backend.lisp

    r12048 r12694  
    222222      (return (make-hard-crf-reg (the fixnum (ash bit 2)))))))
    223223
     224(defun single-float-reg-p (reg)
     225  (and (= (hard-regspec-class reg) hard-reg-class-fpr)
     226       (= (get-regspec-mode reg) hard-reg-class-fpr-mode-single)))
     227
    224228(defun use-fp-temp (n)
    225229    (setq *available-backend-fp-temps* (logand *available-backend-fp-temps* (lognot (ash 1 n))))
  • branches/working-0711/ccl/lib/ffi-darwinppc32.lisp

    r7376 r12694  
    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)
  • branches/working-0711/ccl/lib/ffi-darwinppc64.lisp

    r12301 r12694  
    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)
  • branches/working-0711/ccl/lib/ffi-linuxppc32.lisp

    r7376 r12694  
    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)
  • branches/working-0711/ccl/lib/ffi-linuxppc64.lisp

    r7135 r12694  
    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))
  • branches/working-0711/ccl/lib/ffi-win64.lisp

    r11278 r12694  
    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)
  • branches/working-0711/ccl/lib/macros.lisp

    r12585 r12694  
    26532653  (destructuring-bind (stack-ptr fp-args-ptr lets rlets inits dynamic-extent-decls other-decls body return-type struct-return-arg error-return error-delta) args
    26542654    (declare (ignorable dynamic-extent-decls))
    2655     (let* ((result (gensym))
    2656            (condition-name (if (atom error-return) 'error (car error-return)))
     2655    (let* ((condition-name (if (atom error-return) 'error (car error-return)))
    26572656           (error-return-function (if (atom error-return) error-return (cadr error-return)))
     2657           (result (if struct-return-arg (gensym)))
    26582658           (body
    26592659            `(rlet ,rlets
     
    26622662                ,@other-decls
    26632663                ,@inits
    2664                 (let ((,result (progn ,@body)))
    2665                   (declare (ignorable ,result)
    2666                            (dynamic-extent ,result))
    2667 
    2668                   ,(funcall (ftd-callback-return-value-function *target-ftd*)
    2669                             stack-ptr
    2670                             fp-args-ptr
    2671                             result
    2672                             return-type
    2673                             struct-return-arg)
    2674                   nil)))))
     2664                ,(if result
     2665                     `(let* ((,result ,@body))
     2666                       (declare (dynamic-extent ,result)
     2667                                (ignorable ,result))
     2668                       ,(funcall (ftd-callback-return-value-function *target-ftd*)
     2669                              stack-ptr
     2670                              fp-args-ptr
     2671                              result
     2672                              return-type
     2673                              struct-return-arg))
     2674                     (if (eq return-type *void-foreign-type*)
     2675                       `(progn ,@body)
     2676                       (funcall (ftd-callback-return-value-function *target-ftd*)
     2677                                stack-ptr
     2678                                fp-args-ptr
     2679                                `(progn ,@body)
     2680                                return-type
     2681                                struct-return-arg)))
     2682                nil))))
    26752683      (if error-return
    26762684        (let* ((cond (gensym))
     
    26792687          `(block ,block
    26802688            (let* ((,handler (lambda (,cond)
    2681                                            (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta))
    2682                                            (return-from ,block
    2683                                              nil))))
     2689                               (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta))
     2690                               (return-from ,block
     2691                                 nil))))
    26842692              (declare (dynamic-extent ,handler))
    2685             (handler-bind ((,condition-name ,handler))
    2686               (values ,body)))))
     2693              (handler-bind ((,condition-name ,handler))
     2694                (values ,body)))))
    26872695        body))))
    26882696
Note: See TracChangeset for help on using the changeset viewer.