From: Douglas K. <sn...@us...> - 2014-01-31 21:03:32
|
The branch "master" has been updated in SBCL: via 3d300d6b23877aef1a7db21dc951eb3c0ed10e66 (commit) from cbe0542269aa6b9dc899d901c49e2b5a36aa4f92 (commit) - Log ----------------------------------------------------------------- commit 3d300d6b23877aef1a7db21dc951eb3c0ed10e66 Author: Douglas Katzman <do...@go...> Date: Fri Jan 31 15:41:42 2014 -0500 Fix call_into_lisp on x86-64, reviewed by foom (jyknight) --- src/runtime/x86-64-assem.S | 9 +++-- tests/call-into-lisp.impure.lisp | 70 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 76 insertions(+), 3 deletions(-) diff --git a/src/runtime/x86-64-assem.S b/src/runtime/x86-64-assem.S index d808476..8552526 100644 --- a/src/runtime/x86-64-assem.S +++ b/src/runtime/x86-64-assem.S @@ -214,17 +214,20 @@ Lstack: xor %rdx,%rdx # clear any descriptor registers xor %rdi,%rdi # that we can't be sure we'll xor %rsi,%rsi # initialise properly. XX do r8-r15 too? - shl $(N_FIXNUM_TAG_BITS),%rcx # (fixnumize num-args) cmp $0,%rcx + # It's tempting to think 'cmov' for these assignments, but don't: + # cmov does a memory cycle whether or not it moves, succumbing to + # a classic buffer overrun bug if argv[] is "badly" placed. je Ldone mov 0(%rbx),%rdx # arg0 - cmp $8,%rcx + cmp $1,%rcx je Ldone mov 8(%rbx),%rdi # arg1 - cmp $16,%rcx + cmp $2,%rcx je Ldone mov 16(%rbx),%rsi # arg2 Ldone: + shl $(N_FIXNUM_TAG_BITS),%rcx # (fixnumize num-args) /* Registers rax, rcx, rdx, rdi, and rsi are now live. */ xor %rbx,%rbx # available diff --git a/tests/call-into-lisp.impure.lisp b/tests/call-into-lisp.impure.lisp new file mode 100644 index 0000000..4d40000 --- /dev/null +++ b/tests/call-into-lisp.impure.lisp @@ -0,0 +1,70 @@ + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package sb-vm) + +;; This test shows (well, sorta) that call_into_lisp didn't read beyond +;; the Nth item in its argument vector with N being the specified argc. +;; As it happens, we zeroize the unused passing registers, so can check for that. +(defun monkeybiz (a1 a2 a3) + ;; grr. what if a safety policy restriction is in effect? + (declare (optimize (safety 0))) + (declare (special monkeybiz-result)) + (setq monkeybiz-result (list a1 a2 a3))) +(compile 'monkeybiz) ; in case somebody runs this test with the interpreter + +(defun try-call-into-lisp (c-prog) ; er, assembly program, but whatever + (flet ((assemble-it (n) + (let ((segment (sb-assem:make-segment :type :regular))) + (dolist (instruction (subst n :ARGC c-prog) + (sb-assem::segment-buffer segment)) + (apply (symbolicate (car instruction) "-INST-EMITTER") + segment nil (cdr instruction)))))) + (dotimes (n-args 4) + (let ((the-code (assemble-it n-args))) + ;; in case we change the way the assembler output works ... + (assert (typep the-code '(simple-array (unsigned-byte 8) 1))) + (with-pinned-objects (the-code) + (let ((my-little-alien + (make-alien-value :type (parse-alien-type '(function long) nil) + :sap (vector-sap the-code))) + (expect (concatenate 'list (subseq '(#\A 311 T) 0 n-args) + (subseq '(0 0 0) n-args 3))) + (monkeybiz-result)) + (declare (special monkeybiz-result)) + (alien-funcall my-little-alien) + (format t "Call with ~D arg~:P: ~S~%" n-args monkeybiz-result) + (assert (equal monkeybiz-result expect)))))))) + +#+X86-64 +(test-util:with-test (:name :call-into-lisp) + ;; Obviously we need a C function to call the Lisp function, so here's one, + ;; carefully hand-crafted so as to need no input arguments, + ;; using only a static Lisp symbol, two non-pointers, and a pinned function. + (with-pinned-objects (#'monkeybiz) + (try-call-into-lisp + ;; Making room for 3 args aligns the stack to a 16-byte boundary + ;; presuming it was at CALL to me. Darwin requires the alignment, others don't care. + `((sub ,rsp-tn 24) + (mov ,(make-ea :qword :base rsp-tn :disp 16) ,(get-lisp-obj-address T)) + (mov ,(make-ea :qword :base rsp-tn :disp 8) ,(fixnumize 311)) + (mov ,(make-ea :qword :base rsp-tn :disp 0) ,(get-lisp-obj-address #\A)) + (mov ,rdi-tn ,(get-lisp-obj-address #'monkeybiz)) ; C arg 0 = Lisp function + (mov ,rsi-tn ,rsp-tn) ; C arg 1 = argv + (mov ,rdx-tn :ARGC) ; C arg 2 = argc + (mov ,rax-tn ,(sap-int + (alien-value-sap + (extern-alien "call_into_lisp" + (function long long long long))))) + (call ,rax-tn) + (add ,rsp-tn 24) + (ret))))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |