c-call.lisp

开源跨平台Lisp编译器

                               (let ((sb!alien::*values-type-okay* t))
                                 (parse-alien-type
                                  (if (alien-integer-type-signed result-type)
                                      '(values (signed 32) (unsigned 32))
                                      '(values (unsigned 32) (unsigned 32)))
                                  (sb!kernel:make-null-lexenv)))))
                          `(lambda (function type ,@(lambda-vars))
                            (declare (ignore type))
                            (multiple-value-bind (high low)
                                (%alien-funcall function
                                                ',(make-alien-fun-type
                                                   :arg-types (new-arg-types)
                                                   :result-type new-result-type)
                                                ,@(new-args))
                              (logior low (ash high 32))))))
                       (t
                        `(lambda (function type ,@(lambda-vars))
                          (declare (ignore type))
                          (%alien-funcall function
                           ',(make-alien-fun-type
                              :arg-types (new-arg-types)
                              :result-type result-type)
                           ,@(new-args))))))
        (sb!c::give-up-ir1-transform))))

#!+darwin
(deftransform %alien-funcall ((function type &rest args))
  (aver (sb!c::constant-lvar-p type))
  (let* ((type (sb!c::lvar-value type))
         (arg-types (alien-fun-type-arg-types type))
         (result-type (alien-fun-type-result-type type)))
    (aver (= (length arg-types) (length args)))
    ;; We need to do something special for 64-bit integer arguments
    ;; and results.
    (if (or (some #'(lambda (type)
                      (and (alien-integer-type-p type)
                           (> (sb!alien::alien-integer-type-bits type) 32)))
                  arg-types)
            (and (alien-integer-type-p result-type)
                 (> (sb!alien::alien-integer-type-bits result-type) 32)))
        (collect ((new-args) (lambda-vars) (new-arg-types))
                 (dolist (type arg-types)
                   (let ((arg (gensym)))
                     (lambda-vars arg)
                     (cond ((and (alien-integer-type-p type)
                                 (> (sb!alien::alien-integer-type-bits type) 32))
                            ;; 64-bit long long types are stored in
                            ;; consecutive locations, most significant word
                            ;; first (big-endian).
                            (new-args `(ash ,arg -32))
                            (new-args `(logand ,arg #xffffffff))
                            (if (alien-integer-type-signed type)
                                (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
                                (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
                            (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
                           (t
                            (new-args arg)
                            (new-arg-types type)))))
                 (cond ((and (alien-integer-type-p result-type)
                             (> (sb!alien::alien-integer-type-bits result-type) 32))
                        (let ((new-result-type
                               (let ((sb!alien::*values-type-okay* t))
                                 (parse-alien-type
                                  (if (alien-integer-type-signed result-type)
                                      '(values (signed 32) (unsigned 32))
                                      '(values (unsigned 32) (unsigned 32)))
                                  (sb!kernel:make-null-lexenv)))))
                          `(lambda (function type ,@(lambda-vars))
                            (declare (ignore type))
                            (multiple-value-bind (high low)
                                (%alien-funcall function
                                                ',(make-alien-fun-type
                                                   :arg-types (new-arg-types)
                                                   :result-type new-result-type)
                                                ,@(new-args))
                              (logior low (ash high 32))))))
                       (t
                        `(lambda (function type ,@(lambda-vars))
                          (declare (ignore type))
                          (%alien-funcall function
                           ',(make-alien-fun-type
                              :arg-types (new-arg-types)
                              :result-type result-type)
                           ,@(new-args))))))
        (sb!c::give-up-ir1-transform))))

(define-vop (foreign-symbol-sap)
  (:translate foreign-symbol-sap)
  (:policy :fast-safe)
  (:args)
  (:arg-types (:constant simple-string))
  (:info foreign-symbol)
  (:results (res :scs (sap-reg)))
  (:result-types system-area-pointer)
  (:generator 2
    (inst lr res  (make-fixup foreign-symbol :foreign))))

#!+linkage-table
(define-vop (foreign-symbol-dataref-sap)
  (:translate foreign-symbol-dataref-sap)
  (:policy :fast-safe)
  (:args)
  (:arg-types (:constant simple-string))
  (:info foreign-symbol)
  (:results (res :scs (sap-reg)))
  (:result-types system-area-pointer)
  (:temporary (:scs (non-descriptor-reg)) addr)
  (:generator 2
    (inst lr addr (make-fixup foreign-symbol :foreign-dataref))
    (loadw res addr)))

(define-vop (call-out)
  (:args (function :scs (sap-reg) :target cfunc)
         (args :more t))
  (:results (results :more t))
  (:ignore args results)
  (:save-p t)
  (:temporary (:sc any-reg :offset cfunc-offset
                   :from (:argument 0) :to (:result 0)) cfunc)
  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
  (:temporary (:scs (non-descriptor-reg)) temp)
  (:vop-var vop)
  (:generator 0
    (let ((cur-nfp (current-nfp-tn vop)))
      (when cur-nfp
        (store-stack-tn nfp-save cur-nfp))
      (inst lr temp (make-fixup "call_into_c" :foreign))
      (inst mtctr temp)
      (move cfunc function)
      (inst bctrl)
      (when cur-nfp
        (load-stack-tn cur-nfp nfp-save)))))


(define-vop (alloc-number-stack-space)
  (:info amount)
  (:results (result :scs (sap-reg any-reg)))
  (:result-types system-area-pointer)
  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
  (:generator 0
    (unless (zerop amount)
      ;; FIXME: I don't understand why we seem to be adding
      ;; NUMBER-STACK-DISPLACEMENT twice here.  Weird.  -- CSR,
      ;; 2003-08-20
      (let ((delta (- (logandc2 (+ amount number-stack-displacement
                                   +stack-alignment-bytes+)
                                +stack-alignment-bytes+))))
        (cond ((>= delta (ash -1 16))
               (inst stwu nsp-tn nsp-tn delta))
              (t
               (inst lr temp delta)
               (inst stwux  nsp-tn nsp-tn temp)))))
    (unless (location= result nsp-tn)
      ;; They are only location= when the result tn was allocated by
      ;; make-call-out-tns above, which takes the number-stack-displacement
      ;; into account itself.
      (inst addi result nsp-tn number-stack-displacement))))

(define-vop (dealloc-number-stack-space)
  (:info amount)
  (:policy :fast-safe)
  (:generator 0
    (unless (zerop amount)
      (let ((delta (logandc2 (+ amount number-stack-displacement
                                +stack-alignment-bytes+)
                             +stack-alignment-bytes+)))
        (cond ((< delta (ash 1 16))
               (inst addi nsp-tn nsp-tn delta))
              (t
               (inst lwz nsp-tn nsp-tn 0)))))))

#-sb-xc-host
(progn
  (defun alien-callback-accessor-form (type sap offset)
    (let ((parsed-type
           (sb!alien::parse-alien-type type (sb!kernel:make-null-lexenv))))
      (cond ((sb!alien::alien-integer-type-p parsed-type)
             ;; Unaligned access is slower, but possible, so this is nice and
             ;; simple. Also, we're a big-endian machine, so we need to get
             ;; byte offsets correct.
             (let ((bits (sb!alien::alien-type-bits parsed-type)))
               (let ((byte-offset
                      (cond ((< bits n-word-bits)
                             (- n-word-bytes
                                (ceiling bits n-byte-bits)))
                            (t 0))))
                 `(deref (sap-alien (sap+ ,sap
                                          ,(+ byte-offset offset))
                                    (* ,type))))))
            (t
             `(deref (sap-alien (sap+ ,sap ,offset) (* ,type)))))))

  ;;; The "Mach-O Runtime Conventions" document for OS X almost
  ;;; specifies the calling convention (it neglects to mention that
  ;;; the linkage area is 24 bytes).
  #!+darwin
  (defconstant n-foreign-linkage-area-bytes 24)

  ;;; On linux only use 8 bytes for LR and Back chain.  JRXR
  ;;; 2006/11/10.
  #!-darwin
  (defconstant n-foreign-linkage-area-bytes 8)

  ;;; Returns a vector in static space containing machine code for the
  ;;; callback wrapper.  Linux version.  JRXR.  2006/11/13
  #!-darwin
  (defun alien-callback-assembler-wrapper (index result-type argument-types)
    (flet ((make-gpr (n)
             (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
           (make-fpr (n)
             (make-random-tn :kind :normal :sc (sc-or-lose
                                                'double-reg) :offset
                                                n)))
      (let* ((segment (make-segment)))
        (assemble (segment)
          ;; Copy args from registers or stack to new position
          ;; on stack.
          (let* (
                 ;; Argument store.
                 (arg-store-size
                  (* n-word-bytes
                     (apply '+
                         (mapcar (lambda (type)
                                   (ceiling (alien-type-bits type)
                                            n-word-bits))
                                 argument-types ))))
                 ;; Return area allocation.
                 (n-return-area-words
                  (ceiling (or (alien-type-bits result-type) 0) n-word-bits))
                 (n-return-area-bytes (* n-return-area-words
                                         n-word-bytes))
                 ;; FIXME: magic constant, and probably n-args-bytes
                 ;; JRXR: What's this for?  Copied from Darwin.
                 (args-size (* 3 n-word-bytes))
                 (frame-size (logandc2
                              (+ arg-store-size
                                 n-return-area-bytes
                                 args-size
                                 SB!VM::NUMBER-STACK-DISPLACEMENT
                                 +stack-alignment-bytes+)
                              +stack-alignment-bytes+))
                 (return-area-pos (- frame-size
                                     SB!VM::NUMBER-STACK-DISPLACEMENT
                                     args-size))
                 (arg-store-pos (- return-area-pos
                                   n-return-area-bytes))
                 (stack-pointer (make-gpr 1))
                 (r0 (make-gpr 0))
                 (f0 (make-fpr 0))
                 (in-words-processed 0)
                 (out-words-processed 0)
                 (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
                 (fprs (mapcar #'make-fpr
                               '(1 2 3 4 5 6 7 8))) )
            ;; Setup useful functions and then copy all args.
            (flet ((load-address-into (reg addr)
                       (let ((high (ldb (byte 16 16) addr))
                             (low (ldb (byte 16 0) addr)))
                         (inst lis reg high)
                         (inst ori reg reg low)))
                   (save-arg (type words)
                     (let ((integerp (not (alien-float-type-p type)))
                           (in-offset (+ (* in-words-processed n-word-bytes)
                                         n-foreign-linkage-area-bytes))
                           (out-offset (- (* out-words-processed n-word-bytes)
                                          arg-store-pos)))
                       (cond (integerp
                              (if (and
                                   ;; Only upto long longs are passed
                                   ;; in registers.
                                   (<= words 2)
                                   ;; And needs space for whole arg,
                                   ;; including alignment.
                                   (<= (+ words
                                          (rem (length gprs) words))
                                       (length gprs)))
                                  (progn
                                    (if (/= 0
                                            (rem (length gprs) words))
                                        (pop gprs))
                                    (dotimes (k words)
                                      (let ((gpr (pop gprs)))
                                        (inst stw gpr stack-pointer
                                              out-offset))
                                      (incf out-words-processed)
                                      (incf out-offset n-word-bytes)))
                                  (progn
                                    ;; First ensure alignment.
                                    ;; FIXME!  If passing structures
                                    ;; becomes allowable, then this is