Changeset 8656


Ignore:
Timestamp:
Mar 4, 2008, 4:48:29 PM (12 years ago)
Author:
rme
Message:

A lot of half-baked lexpr/ffi stuff.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/ia32/level-0/X86/X8632/x8632-def.lisp

    r8374 r8656  
    272272  (single-value-return))
    273273
     274#+fix
    274275(defx8632lapfunction %apply-lexpr-with-method-context ((magic 4)
    275276                                                       #|(ra 0)|#
     
    282283  ;; * Set nargs to 0, then spread "args" on stack (clobbers arg_y,
    283284  ;;   arg_z, but preserves x8632::xfn/x8632::next-method-context. Note
    284   ;;   that nargs and imm0 are the same register on x8632.
     285  ;;   that nargs and temp1 are the same register on x8632.
    285286  ;; * Jump to the function in x8632::xfn.
    286287  ;; These steps are done in a mixed up order on x8632 because of
    287288  ;; the small number of registers.
    288   (popl (@ (% :rcontext) x8632::tcr.save0))     ;save return address
    289   (popl (@ (% :rcontext) x8632::tcr.save1))     ; and magic arg in the spill area
    290   (movl (% function) (% xfn))           ;aka temp1
    291   (movl (@ (% args)) (% imm0))          ;lexpr-count
    292   (movd (% imm0) (% mm0))               ;save nargs
    293   (mark-as-imm temp0)
    294   (leal (@ x8632::node-size (% arg_z) (% imm0)) (% temp0))
     289  (popl (@ (% :rcontext) x8632::tcr.save0))     ;save return address,
     290  (popl (@ (% :rcontext) x8632::tcr.save1))     ;magic arg, and
     291  (movl (% function) (@ (% :rcontext) x8632::tcr.save2)) ;function in spill area
     292  (set-nargs 0)
     293  (movl (@ (% args)) (% temp0))         ;lexpr-count
     294  (movl (% temp0) (% nargs))
     295  (leal (@ x8632::node-size (% arg_z) (% temp0)) (% imm0))
    295296  (subl ($ '2) (% imm0))
    296297  (jbe @reg-only)
     
    299300  (pushl ($ x8632::reserved-frame-marker))
    300301  @pushloop
    301   (pushl (@ (- x8632::node-size) (% temp0)))
     302  (pushl (@ (- x8632::node-size) (% imm0)))
     303  (subl ($ x8632::node-size) (% imm0))
    302304  (subl ($ x8632::node-size) (% temp0))
    303   (subl ($ x8632::node-size) (% imm0))
    304305  (jne @pushloop)
    305306  @two
     
    309310  (jmp @go)
    310311  @reg-only
    311   (movd (% mm0) (% imm0))               ;note that imm0 is nargs
    312   (rcmp (% nargs) ($ '1))
     312  (rcmp (% nargs) ($ '1))               ;note that nargs is temp1
    313313  (je @one)
    314314  (jb @go)
    315315  (jmp @two)
    316316  @go
    317   (mark-as-node temp0)
    318317  (movl (@ (% :rcontext) x8632::tcr.save1) (% next-method-context)) ;aka temp0
    319318  (pushl (@ (% :rcontext) x8632::tcr.save0))     ;return address
    320   (movapd (% fpzero) (@ (% :rcontext) x8632::tcr.save0)) ;clear out spill area
    321   ;; magic arg in next-method-context: check
    322   ;; function in xfn: check
    323   ;; nargs/imm0 set: check
    324   (jmp (% xfn)))
    325 
     319  (movsd (% fpzero) (@ (% :rcontext) x8632::tcr.save0)) ;clear out save0/save1
     320  (movl (@ (% :rcontext) x8632::tcr.save2) (% imm0))
     321  ;; xxx if otherwise garbage, function might stick around until someone else
     322  ;; zeroes the spill area
     323  (jmp (% imm0)))
     324
     325#+fix
    326326(defx8632lapfunction %apply-with-method-context ((magic 4)
    327327                                                 #|(ra 0)|#
     
    384384;;; must have been tail-called, and the frame built on lexpr
    385385;;; entry must be in %rbp.
     386#+fix
    386387(defx8632lapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z))
    387388  (addl ($ x8632::node-size) (% esp))   ; discard extra return address
     
    432433   (movl (% arg_y) (% arg_z))           ; butlast
    433434   (subl ($ '2) (% nargs))              ; remove count for butlast & last
    434    (movd (% imm0) (% mm0))              ;save nargs (aka imm0) for later
     435   (movd (% temp1) (% mm0))             ;save nargs (aka temp1) for later
    435436   ;; Do .SPspreadargz inline here
    436    (xorl (%l imm0) (%l imm0))
     437   (xorl (%l temp1) (%l temp1))
    437438   (movl (% arg_z) (@ (% :rcontext) x8632::tcr.save1)) ; save in case of error
    438439   (cmp-reg-to-nil arg_z)
    439440   (je @done)
    440    (mark-as-imm temp1)
     441   ;;(mark-as-imm temp1)
    441442   @loop
    442    (extract-fulltag arg_z temp1)
    443    (cmpb ($ x8664::fulltag-cons) (%b temp1))
     443   (extract-fulltag arg_z imm0)
     444   (cmpb ($ x8632::fulltag-cons) (%b imm0))
    444445   (jne @bad)
    445446   (%car arg_z arg_y)
    446447   (%cdr arg_z arg_z)
    447    (addl ($ '1) (%l imm0))
     448   (addl ($ '1) (%l temp1))
    448449   (cmp-reg-to-nil arg_z)   
    449450   (push (% arg_y))
    450451   (jne @loop)
    451    (mark-as-node temp1)
    452452   @done
    453453   ;; nargs was at least 1 when we started spreading, and can't have gotten
    454454   ;; any smaller.
    455455   (movd (% mm0) (% arg_y))             ;nargs from before loop
    456    (addl (% arg_y) (% imm0))            ;did I mention nargs is imm0?
     456   (addl (% arg_y) (% temp1))           ;did I mention nargs is temp1?
    457457   (movl (% temp0) (% arg_z))
    458458   (pop (% arg_y))
     
    462462   (movapd (% fpzero) (@ (% :rcontext) x8632::tcr.save0)) ;clear out spill area
    463463   (jmp-subprim .SPfuncall)
    464    @bad                                 ; error spreading list.
    465    (mark-as-node temp1)
    466    (add (% imm0) (% esp))               ; discard whatever's been pushed
     464   @bad                               ;error spreading list.
     465   (add (% temp1) (% esp))            ;discard whatever's been pushed
    467466   (movl (@ (% :rcontext) x8632::tcr.save1) (% arg_z))
    468467   (movl ($ '#.$XNOSPREAD) (% arg_y))
     
    473472
    474473;;; This needs to:
    475 ;;; (a) load FP arg regs from the FP-REGS argument
    476474;;; (b) call the .SPffcall subprimitive, which will discard the foreign stack frame
    477475;;;     allocated by WITH-VARIABLE-C-FRAME in %FF-CALL
    478476;;; (c) re-establish the same foreign stack frame and store the result regs
    479 ;;;     (%rax/%xmm0) there
     477;;;     (%eax/%xmm0) there (not really xmm0, but .SPffcall will pop the x87
     478;;;     stack and put the value in there for us.
    480479#+notyet
    481 (defx86lapfunction %do-ff-call ((nfp 0) (frame arg_x) (fp-regs arg_y) (entry arg_z))
    482   (popq (% ra0))
    483   (popq (% rax))
    484   (movq (% rbp) (@  (% rsp)))
    485   (movq (% rsp) (% rbp))
    486   (movq (% ra0) (@ 8 (% rbp)))
    487   (macptr-ptr fp-regs temp0)
    488   (sarq ($ x8664::fixnumshift) (% rax))
    489   (movq (@ (% temp0)) (% fp0))
    490   (movq (@ 8 (% temp0)) (% fp1))
    491   (movq (@ 16 (% temp0)) (% fp2))
    492   (movq (@ 24 (% temp0)) (% fp3))
    493   (movq (@ 32 (% temp0)) (% fp4))
    494   (movq (@ 40 (% temp0)) (% fp5))
    495   (movq (@ 48 (% temp0)) (% fp6))
    496   (movq (@ 56 (% temp0)) (% fp7))
     480(defx86lapfunction %do-ff-call ((frame arg_y) (entry arg_z))
     481  (pop (% ra0))
     482  (movl (% ebp) (@  (% esp)))
     483  (movl (% esp) (% ebp))
     484  (movl (% ra0) (@ 4 (% ebp)))
    497485  (call-subprim .SPffcall)
    498   (movq (@ (% :rcontext) x8664::tcr.foreign-sp) (% mm5))
    499   (movq (% mm5) (@ (% frame)))
    500   (movq (% frame) (@ (% :rcontext) x8664::tcr.foreign-sp))
    501   (movq (% rax) (@ 8 (% frame)))
    502   (movq (% fp0) (@ 16 (% frame)))
    503   (movl ($ nil) (%l arg_z))
     486  (movd (@ (% :rcontext) x8664::tcr.foreign-sp) (% mm5))
     487  (movd (% mm5) (@ (% frame)))
     488  (movl (% frame) (@ (% :rcontext) x8664::tcr.foreign-sp))
     489  (movl (% eax) (@ 4 (% frame)))
     490  ;; .SPffcall will have popped the fp result from the x87 stack
     491  ;; and stashed it in fp0.
     492  (movq (% fp0) (@ 8 (% frame)))
     493  (movl ($ nil) (% arg_z))
    504494  (restore-simple-frame)
    505495  (single-value-return))
     
    512502    (declare (fixnum len total-words))
    513503    (let* ((result-spec (or (car (last specs-and-vals)) :void))
    514            (nargs (ash (the fixnum (1- len)) -1))
    515            (n-fp-args 0))
    516       (declare (fixnum nargs n-fp-args))
     504           (nargs (ash (the fixnum (1- len)) -1)))
     505      (declare (fixnum nargs))
    517506      (ecase result-spec
    518         ((:address :unsigned-doubleword :signed-doubleword
    519                    :single-float :double-float
    520                    :signed-fullword :unsigned-fullword
    521                    :signed-halfword :unsigned-halfword
    522                    :signed-byte :unsigned-byte
    523                    :void)
    524          (do* ((i 0 (1+ i))
    525                (specs specs-and-vals (cddr specs))
    526                (spec (car specs) (car specs)))
    527               ((= i nargs))
    528            (declare (fixnum i))
    529            (case spec
    530              ((:address :unsigned-doubleword :signed-doubleword
    531                         :single-float :double-float
    532                         :signed-fullword :unsigned-fullword
    533                         :signed-halfword :unsigned-halfword
    534                         :signed-byte :unsigned-byte)
     507        ((:address :unsigned-doubleword :signed-doubleword
     508                   :single-float :double-float
     509                   :signed-fullword :unsigned-fullword
     510                   :signed-halfword :unsigned-halfword
     511                   :signed-byte :unsigned-byte
     512                   :void)
     513         (do* ((i 0 (1+ i))
     514               (specs specs-and-vals (cddr specs))
     515               (spec (car specs) (car specs)))
     516              ((= i nargs))
     517           (declare (fixnum i))
     518           (case spec
     519             ((:double-float :unsigned-doubleword :signed-doubleword)
     520              (incf total-words 2))
     521             ((:address :single-float
     522                        :signed-fullword :unsigned-fullword
     523                        :signed-halfword :unsigned-halfword
     524                        :signed-byte :unsigned-byte)
    535525              (incf total-words))
    536              (t (if (typep spec 'unsigned-byte)
    537                   (incf total-words spec)
    538                   (error "unknown arg spec ~s" spec)))))
    539          ;; It's necessary to ensure that the C frame is the youngest thing on
    540          ;; the foreign stack here.
    541          (%stack-block ((fp-args (* 8 8)))
    542            (with-macptrs ((argptr))
    543              (with-variable-c-frame
    544                  total-words frame
    545                  (%setf-macptr-to-object argptr frame)
    546                  (let* ((gpr-offset 16)
    547                         (other-offset (+ gpr-offset (* 6 8))))
    548                    (declare (fixnum gpr-offset other-offset))
    549                    (do* ((i 0 (1+ i))
    550                          (ngpr-args 0)
    551                          (specs specs-and-vals (cddr specs))
    552                          (spec (car specs) (car specs))
    553                          (val (cadr specs) (cadr specs)))
    554                         ((= i nargs))
    555                      (declare (fixnum i))
    556                      (case spec
    557                        (:address
    558                         (incf ngpr-args)
    559                         (cond ((<= ngpr-args 6)
    560                                (setf (%get-ptr argptr gpr-offset) val)
    561                                (incf gpr-offset 8))
    562                               (t
    563                                (setf (%get-ptr argptr other-offset) val)
    564                                (incf other-offset 8))))
    565                        ((:signed-doubleword :signed-fullword :signed-halfword
    566                                             :signed-byte)
    567                         (incf ngpr-args)
    568                         (cond ((<= ngpr-args 6)
    569                                (setf (%%get-signed-longlong argptr gpr-offset) val)
    570                                (incf gpr-offset 8))
    571                               (t
    572                                (setf (%%get-signed-longlong argptr other-offset) val)
    573                                (incf other-offset 8))))
    574                        ((:unsigned-doubleword :unsigned-fullword :unsigned-halfword
    575                                               :unsigned-byte)
    576                         (incf ngpr-args)
    577                         (cond ((<= ngpr-args 6)
    578                                (setf (%%get-unsigned-longlong argptr gpr-offset) val)
    579                                (incf gpr-offset 8))
    580                               (t
    581                                (setf (%%get-unsigned-longlong argptr other-offset) val)
    582                                (incf other-offset 8))))
    583                        (:double-float
    584                         (cond ((< n-fp-args 8)
    585                                (setf (%get-double-float fp-args (* n-fp-args 8)) val)
    586                                (incf n-fp-args))
    587                               (t
    588                                (setf (%get-double-float argptr other-offset) val)
    589                                (incf other-offset 8))))
    590                        (:single-float
    591                         (cond ((< n-fp-args 8)
    592                                (setf (%get-single-float fp-args (* n-fp-args 8))
    593                                      val)
    594                                (incf n-fp-args))
    595                               (t
    596                                (setf (%get-single-float argptr other-offset) val)
    597                                (incf other-offset 8))))
    598                        (t
    599                         (let* ((p 0))
    600                           (declare (fixnum p))
    601                           (dotimes (i (the fixnum spec))
    602                             (setf (%get-ptr argptr other-offset) (%get-ptr val p))
    603                             (incf p 8)
    604                             (incf other-offset 8)))))))
    605                  (%do-ff-call (min n-fp-args 8) frame fp-args entry)
    606                  (ecase result-spec
    607                    (:void nil)
    608                    (:address (%get-ptr argptr 8))
    609                    (:unsigned-byte (%get-unsigned-byte argptr 8))
    610                    (:signed-byte (%get-signed-byte argptr 8))
    611                    (:unsigned-halfword (%get-unsigned-word argptr 8))
    612                    (:signed-halfword (%get-signed-word argptr 8))
    613                    (:unsigned-fullword (%get-unsigned-long argptr 8))
    614                    (:signed-fullword (%get-signed-long argptr 8))
    615                    (:unsigned-doubleword (%get-natural argptr 8))
    616                    (:signed-doubleword (%get-signed-natural argptr 8))
    617                    (:single-float (%get-single-float argptr 16))
    618                    (:double-float (%get-double-float argptr 16)))))))))))
    619                                  
     526             (t (if (typep spec 'unsigned-byte)
     527                  (incf total-words spec)
     528                  (error "Invalid argument spec ~s" spec)))))
     529         ;; It's necessary to ensure that the C frame is the youngest thing on
     530         ;; the foreign stack here.
     531         (with-macptrs ((argptr))
     532           (with-variable-c-frame
     533               total-words frame
     534               (%setf-macptr-to-object argptr frame)
     535               (let* ((offset 0))
     536                 (do* ((i 0 (1+ i))
     537                       (specs specs-and-vals (cddr specs))
     538                       (spec (car specs) (car specs))
     539                       (val (cadr specs) (cadr specs)))
     540                      ((= i nargs))
     541                   (declare (fixnum i))
     542                   (case spec
     543                     (:double-float
     544                      (setf (%get-double-float argptr offset) val)
     545                      (incf offset 8))
     546                     (:single-float
     547                      (setf (%get-single-float argptr offset) val)
     548                      (incf offset 4))
     549                     (:signed-doubleword
     550                      (setf (%%get-signed-longlong argptr offset) val)
     551                      (incf offset 8))
     552                     (:unsigned-doubleword
     553                      (setf (%%get-unsigned-longlong argptr offset) val)
     554                      (incf offset 8))
     555                     (:address
     556                      (setf (%get-ptr argptr offset) val)
     557                      (incf offset 4))
     558                     ((:signed-fullword :signed-halfword :signed-byte)
     559                      (setf (%get-signed-natural argptr offset) val)
     560                      (incf offset 4))
     561                     ((:unsigned-fullword :unsigned-halfword :unsigned-byte)
     562                      (setf (%get-natural argptr offset) val)
     563                      (incf offset 4))
     564                     (t
     565                      (let* ((p 0))
     566                        (declare (fixnum p))
     567                        (dotimes (i (the fixnum spec))
     568                          (setf (%get-ptr argptr offset) (%get-ptr val p))
     569                          (incf p 4)
     570                          (incf offset 4))))))
     571                 (%do-ff-call frame entry)
     572                 (ecase result-spec
     573                   (:void nil)
     574                   (:address (%get-ptr argptr 4))
     575                   (:unsigned-byte (%get-unsigned-byte argptr 4))
     576                   (:signed-byte (%get-signed-byte argptr 4))
     577                   (:unsigned-halfword (%get-unsigned-word argptr 4))
     578                   (:signed-halfword (%get-signed-word argptr 4))
     579                   (:unsigned-fullword (%get-natural argptr 4))
     580                   (:signed-fullword (%get-signed-natural argptr 4))
     581                   (:unsigned-doubleword (%%get-unsigned-longlong argptr 4))
     582                   (:signed-doubleword (%%get-signed-longlong argptr 4))
     583                   (:single-float (%get-single-float argptr 8))
     584                   (:double-float (%get-double-float argptr 8)))))))))))
    620585
    621586;;; end of x86-def.lisp
Note: See TracChangeset for help on using the changeset viewer.