Changeset 14332 for release/1.5


Ignore:
Timestamp:
Oct 6, 2010, 12:39:20 PM (9 years ago)
Author:
gb
Message:

Propagate r14156 (win64 ff-call changes) to 1.5 branch.

Location:
release/1.5/source
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/1.5/source/compiler/X86/x862.lisp

    r13538 r14332  
    95999599    (^)))
    96009600
     9601
     9602(defun x862-x8664-ff-call-return (seg vreg resultspec)
     9603  (with-x86-local-vinsn-macros (seg vreg)
     9604    (when vreg
     9605      (cond ((eq resultspec :void) (<- nil))
     9606            ((eq resultspec :double-float)
     9607             (<- ($  x8664::fp0 :class :fpr :mode :double-float)))
     9608            ((eq resultspec :single-float)
     9609             (<- ($ x8664::fp0 :class :fpr :mode :single-float)))
     9610            ((eq resultspec :unsigned-doubleword)
     9611             (if (node-reg-p vreg)
     9612               (progn
     9613                 (! makeu64)
     9614                 (<- ($ x8664::arg_z)))
     9615               (<- ($  x8664::rax :class :gpr :mode :u64))))
     9616            ((eq resultspec :signed-doubleword)
     9617             (if (node-reg-p vreg)
     9618               (progn
     9619                 (! makes64)
     9620                 (<- ($ x8664::arg_z)))
     9621               (<- ($  x8664::rax :class :gpr :mode :s64))))
     9622            (t
     9623             (case resultspec
     9624               (:signed-byte (! sign-extend-s8 x8664::imm0 x8664::imm0))
     9625               (:signed-halfword (! sign-extend-s16 x8664::imm0 x8664::imm0))
     9626               (:signed-fullword (! sign-extend-s32 x8664::imm0 x8664::imm0))
     9627               (:unsigned-byte (! zero-extend-u8 x8664::imm0 x8664::imm0))
     9628               (:unsigned-halfword (! zero-extend-u16 x8664::imm0 x8664::imm0))
     9629               (:unsigned-fullword (! zero-extend-u32 x8664::imm0 x8664::imm0)))
     9630             (<- (make-wired-lreg x8664::imm0
     9631                                  :mode
     9632                                  (gpr-mode-name-value
     9633                                   (case resultspec
     9634                                     (:address :address)
     9635                                     (:signed-byte :s8)
     9636                                     (:unsigned-byte :u8)
     9637                                     (:signed-halfword :s16)
     9638                                     (:unsigned-halfword :u16)
     9639                                     (:signed-fullword :s32)
     9640                                     (t :u32))))))))))
     9641
     9642(defun x862-win64-ff-call (seg vreg xfer address argspecs argvals resultspec)
     9643  (with-x86-local-vinsn-macros (seg vreg xfer)
     9644    (let* ((*x862-vstack* *x862-vstack*)
     9645           (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)
     9646           (*x862-cstack* *x862-cstack*)
     9647           (nargwords 0)
     9648           (arg-offset 0)
     9649           (simple-foreign-args nil)
     9650           (fp-loads ()))
     9651      (declare (fixnum nargwords arg-offset))
     9652      (dolist (argspec argspecs)
     9653        (case argspec
     9654          (:double-float (incf nargwords))
     9655          (:single-float (incf nargwords))
     9656          (:registers (compiler-bug "Foreign argument type ~s not supported on Win64" argspec))
     9657          (t
     9658           (if (typep argspec 'unsigned-byte)
     9659             (incf nargwords argspec)
     9660             (incf nargwords)))))
     9661      (when (null argspecs)
     9662        (setq simple-foreign-args t))
     9663      (! alloc-c-frame nargwords)
     9664      (x862-open-undo $undo-x86-c-frame)
     9665      (unless simple-foreign-args
     9666        (x862-vpush-register seg (x862-one-untargeted-reg-form seg address x8664::arg_z)))
     9667      ;; Evaluate each form into the C frame, according to the
     9668      ;; matching argspec.  Remember type and arg offset of any FP
     9669      ;; args, since FP regs will have to be loaded later.
     9670      (do* ((specs argspecs (cdr specs))
     9671            (vals argvals (cdr vals)))
     9672           ((null specs))
     9673        (declare (list specs vals))
     9674        (let* ((valform (car vals))
     9675               (spec (car specs))
     9676               (absptr (acode-absolute-ptr-p valform)))
     9677          (case spec
     9678            (:double-float
     9679             (let* ((df ($ x8664::fp1 :class :fpr :mode :double-float)))
     9680               (x862-one-targeted-reg-form seg valform df )
     9681               (! set-double-c-arg df arg-offset)
     9682               (when (< arg-offset 4)
     9683                 (push (cons :double-float arg-offset) fp-loads))
     9684               (incf arg-offset)))
     9685            (:single-float
     9686             (let* ((sf ($ x8664::fp1 :class :fpr :mode :single-float)))
     9687               (x862-one-targeted-reg-form seg valform sf)
     9688               (! set-single-c-arg sf arg-offset)
     9689               (when (< arg-offset 4)
     9690                 (push (cons :single-float arg-offset) fp-loads))
     9691               (incf arg-offset)))
     9692            (:address
     9693             (with-imm-target () (ptr :address)
     9694               (if absptr
     9695                 (x862-lri seg ptr absptr)
     9696                 (x862-form seg ptr nil valform))
     9697               (! set-c-arg ptr arg-offset)
     9698               (incf arg-offset)))
     9699            (t
     9700             (if (typep spec 'unsigned-byte)
     9701               (progn
     9702                 (with-imm-target () (ptr :address)
     9703                   (x862-one-targeted-reg-form seg valform ptr)
     9704                   (with-imm-target (ptr) (r :natural)
     9705                     (dotimes (i spec)
     9706                       (! mem-ref-c-doubleword r ptr (ash i x8664::word-shift))
     9707                       (! set-c-arg r arg-offset)
     9708                       (incf arg-offset)))))               
     9709               (with-imm-target () (valreg :natural)
     9710                 (let* ((reg (x862-unboxed-integer-arg-to-reg seg valform valreg spec)))
     9711                   (! set-c-arg reg arg-offset)
     9712                   (incf arg-offset))))))))
     9713      (dolist (reload fp-loads)
     9714        (let* ((size (car reload))
     9715               (offset (cdr reload))
     9716               (fpr (+ x8664::fp0 offset)))
     9717          (if (eq size :double-float)
     9718            (! reload-double-c-arg ($ fpr :class :fpr :mode :double-float) offset)
     9719            (! reload-single-c-arg ($ fpr :class :fpr :mode :single-float) offset))))
     9720
     9721      (if simple-foreign-args
     9722        (x862-one-targeted-reg-form seg address x8664::arg_z)
     9723        (x862-vpop-register seg ($ x8664::arg_z)))
     9724      (! ff-call)
     9725      (x862-close-undo)
     9726      (x862-x8664-ff-call-return seg vreg resultspec)
     9727      (^))))
     9728   
    96019729(defx862 x862-ff-call ff-call (seg vreg xfer address argspecs argvals resultspec &optional monitor)
    96029730  (declare (ignore monitor))
    9603   (let* ((*x862-vstack* *x862-vstack*)
    9604          (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)
    9605          (*x862-cstack* *x862-cstack*)
    9606          (gpr-offset 0)
    9607          (other-offset 6)
    9608          (single-float-offset 6)
    9609          (double-float-offset 6)
    9610          (nsingle-floats 0)              ; F
    9611          (ndouble-floats 0)             ; D
    9612          (nother-words 0)
    9613          (nfpr-args 0)
    9614          (ngpr-args 0)
    9615          (simple-foreign-args nil)
    9616          (fp-loads ())
    9617          (return-registers ()))
     9731  (if (eq (backend-target-os *target-backend*) :win64)
     9732    (x862-win64-ff-call seg vreg xfer address argspecs argvals resultspec)
     9733    (let* ((*x862-vstack* *x862-vstack*)
     9734           (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)
     9735           (*x862-cstack* *x862-cstack*)
     9736           (gpr-offset 0)
     9737           (other-offset 6)
     9738           (single-float-offset 6)
     9739           (double-float-offset 6)
     9740           (nsingle-floats 0)           ; F
     9741           (ndouble-floats 0)           ; D
     9742           (nother-words 0)
     9743           (nfpr-args 0)
     9744           (ngpr-args 0)
     9745           (simple-foreign-args nil)
     9746           (fp-loads ())
     9747           (return-registers ()))
    96189748      (declare (fixnum  nsingle-floats ndouble-floats nfpr-args ngpr-args nother-words
    96199749                        gpr-offset other-offset single-float-offset double-float-offset))
     
    97379867        (! ff-call) )
    97389868      (x862-close-undo)
    9739       (when vreg
    9740         (cond ((eq resultspec :void) (<- nil))
    9741               ((eq resultspec :double-float)
    9742                (<- ($  x8664::fp0 :class :fpr :mode :double-float)))
    9743               ((eq resultspec :single-float)
    9744                (<- ($ x8664::fp0 :class :fpr :mode :single-float)))
    9745               ((eq resultspec :unsigned-doubleword)
    9746                (if (node-reg-p vreg)
    9747                  (progn
    9748                    (! makeu64)
    9749                    (<- ($ x8664::arg_z)))
    9750                  (<- ($  x8664::rax :class :gpr :mode :u64))))
    9751               ((eq resultspec :signed-doubleword)
    9752                (if (node-reg-p vreg)
    9753                  (progn
    9754                    (! makes64)
    9755                    (<- ($ x8664::arg_z)))
    9756                  (<- ($  x8664::rax :class :gpr :mode :s64))))
    9757               (t
    9758                (case resultspec
    9759                  (:signed-byte (! sign-extend-s8 x8664::imm0 x8664::imm0))
    9760                  (:signed-halfword (! sign-extend-s16 x8664::imm0 x8664::imm0))
    9761                  (:signed-fullword (! sign-extend-s32 x8664::imm0 x8664::imm0))
    9762                  (:unsigned-byte (! zero-extend-u8 x8664::imm0 x8664::imm0))
    9763                  (:unsigned-halfword (! zero-extend-u16 x8664::imm0 x8664::imm0))
    9764                  (:unsigned-fullword (! zero-extend-u32 x8664::imm0 x8664::imm0)))
    9765                (<- (make-wired-lreg x8664::imm0
    9766                                     :mode
    9767                                     (gpr-mode-name-value
    9768                                      (case resultspec
    9769                                        (:address :address)
    9770                                        (:signed-byte :s8)
    9771                                        (:unsigned-byte :u8)
    9772                                        (:signed-halfword :s16)
    9773                                        (:unsigned-halfword :u16)
    9774                                        (:signed-fullword :s32)
    9775                                        (t :u32))))))))
    9776       (^)))
     9869      (x862-x8664-ff-call-return seg vreg resultspec)
     9870      (^))))
    97779871
    97789872
  • release/1.5/source/level-0/X86/x86-def.lisp

    r13067 r14332  
    563563;;; (c) re-establish the same foreign stack frame and store the result regs
    564564;;;     (%rax/%xmm0) there
     565#-win64-target
    565566(defx86lapfunction %do-ff-call ((nfp 0) (frame arg_x) (fp-regs arg_y) (entry arg_z))
    566567  (popq (% ra0))
     
    589590  (single-value-return))
    590591
     592#+win64-target
     593(defx86lapfunction %do-ff-call ((frame arg_y) (entry arg_z))
     594  (save-simple-frame)
     595  (movq (@ 16 (% frame)) (% fp0))
     596  (movq (@ 24 (% frame)) (% fp1))
     597  (movq (@ 32 (% frame)) (% fp2))
     598  (movq (@ 40 (% frame)) (% fp3))
     599  (call-subprim .SPffcall)
     600  (movq (:rcontext x8664::tcr.foreign-sp) (% mm5))
     601  (movq (% mm5) (@ (% frame)))
     602  (movq (% frame) (:rcontext x8664::tcr.foreign-sp))
     603  (movq (% rax) (@ 8 (% frame)))
     604  (movq (% fp0) (@ 16 (% frame)))
     605  (movl ($ nil) (%l arg_z))
     606  (restore-simple-frame)
     607  (single-value-return))
     608
    591609(defx86lapfunction %do-ff-call-return-registers ((fp-regs 8)(nfp 0) (frame arg_x) (regbuf arg_y) (entry arg_z))
    592610  (popq (% ra0))
     
    614632  (single-value-return))
    615633 
    616 
     634#-win64-target
    617635(defun %ff-call (entry &rest specs-and-vals)
    618636  (declare (dynamic-extent specs-and-vals))
     
    731749                   (:single-float (%get-single-float argptr 16))
    732750                   (:double-float (%get-double-float argptr 16)))))))))))
     751
     752#+win64-target
     753(defun %ff-call (entry &rest specs-and-vals)
     754  (declare (dynamic-extent specs-and-vals))
     755  (let* ((len (length specs-and-vals))
     756         (total-words 0))
     757    (declare (fixnum len total-words))
     758    (let* ((result-spec (or (car (last specs-and-vals)) :void))
     759           (nargs (ash (the fixnum (1- len)) -1)))
     760      (declare (fixnum nargs))
     761      (ecase result-spec
     762        ((:address :unsigned-doubleword :signed-doubleword
     763                   :single-float :double-float
     764                   :signed-fullword :unsigned-fullword
     765                   :signed-halfword :unsigned-halfword
     766                   :signed-byte :unsigned-byte
     767                   :void)
     768         (do* ((i 0 (1+ i))
     769               (specs specs-and-vals (cddr specs))
     770               (spec (car specs) (car specs)))
     771              ((= i nargs))
     772           (declare (fixnum i))
     773           (case spec
     774             ((:address :unsigned-doubleword :signed-doubleword
     775                        :single-float :double-float
     776                        :signed-fullword :unsigned-fullword
     777                        :signed-halfword :unsigned-halfword
     778                        :signed-byte :unsigned-byte)
     779              (incf total-words))
     780             (t (if (typep spec 'unsigned-byte)
     781                  (incf total-words spec)
     782                  (error "unknown arg spec ~s" spec)))))
     783         ;; It's necessary to ensure that the C frame is the youngest thing on
     784         ;; the foreign stack here.
     785         (with-macptrs ((argptr))
     786             (with-variable-c-frame
     787                 total-words frame
     788                 (%setf-macptr-to-object argptr frame)
     789                 (let* ((arg-offset 16))
     790                   (declare (fixnum arg-offset))
     791                   (do* ((i 0 (1+ i))
     792                         (specs specs-and-vals (cddr specs))
     793                         (spec (car specs) (car specs))
     794                         (val (cadr specs) (cadr specs)))
     795                        ((= i nargs))
     796                     (declare (fixnum i))
     797                     (case spec
     798                       (:address
     799                        (setf (%get-ptr argptr arg-offset) val)
     800                        (incf arg-offset 8))
     801                       ((:signed-doubleword :signed-fullword :signed-halfword
     802                                            :signed-byte)
     803                        (setf (%%get-signed-longlong argptr arg-offset) val)
     804                        (incf arg-offset 8))
     805                       ((:unsigned-doubleword :unsigned-fullword :unsigned-halfword
     806                                              :unsigned-byte)
     807                        (setf (%%get-unsigned-longlong argptr arg-offset) val)
     808                        (incf arg-offset 8))
     809                       (:double-float
     810                        (setf (%get-double-float argptr arg-offset) val)
     811                        (incf arg-offset 8))
     812                       (:single-float
     813                        (setf (%get-single-float argptr arg-offset) val)
     814                        (incf arg-offset 8))
     815                       (t
     816                        (let* ((p 0))
     817                          (declare (fixnum p))
     818                          (dotimes (i (the fixnum spec))
     819                            (setf (%get-ptr argptr arg-offset) (%get-ptr val p))
     820                            (incf p 8)
     821                            (incf arg-offset 8)))))))
     822                 (%do-ff-call frame entry)
     823                 (ecase result-spec
     824                   (:void nil)
     825                   (:address (%get-ptr argptr 8))
     826                   (:unsigned-byte (%get-unsigned-byte argptr 8))
     827                   (:signed-byte (%get-signed-byte argptr 8))
     828                   (:unsigned-halfword (%get-unsigned-word argptr 8))
     829                   (:signed-halfword (%get-signed-word argptr 8))
     830                   (:unsigned-fullword (%get-unsigned-long argptr 8))
     831                   (:signed-fullword (%get-signed-long argptr 8))
     832                   (:unsigned-doubleword (%get-natural argptr 8))
     833                   (:signed-doubleword (%get-signed-natural argptr 8))
     834                   (:single-float (%get-single-float argptr 16))
     835                   (:double-float (%get-double-float argptr 16))))))))))
     836
     837
    733838                                 
    734839
Note: See TracChangeset for help on using the changeset viewer.