Ignore:
Timestamp:
Aug 9, 2010, 6:59:18 AM (9 years ago)
Author:
gb
Message:

FF-CALL on win64 is sufficiently different from other x8664 platforms
that it's clearer to split off the compiler handling of it and the
runtime implementation (%FF-CALL and %DO-FF-CALL) into separate functions.

The cases that I was aware of that were handled incorrectly seem to be
handled correctly now.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-0/X86/x86-def.lisp

    r13067 r14156  
    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.