mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
79 lines
3.7 KiB
Common Lisp
79 lines
3.7 KiB
Common Lisp
|
|
;;;; 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)
|
|
|
|
(test-util:with-test (:name :unparse-alien-niladic-function)
|
|
(let* ((type (parse-alien-type '(function long) nil))
|
|
(val (%sap-alien (int-sap #x4000) type)))
|
|
(assert (not (search "#'" (write-to-string type :pretty t))))
|
|
(assert (not (search "#'" (write-to-string val :pretty t))))))
|
|
|
|
;; 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)))
|
|
(sb-assem:assemble (segment)
|
|
(dolist (instruction (subst n :ARGC c-prog)
|
|
(sb-assem:segment-buffer segment))
|
|
(apply #'sb-assem:inst* (car instruction) (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
|
|
(%sap-alien (vector-sap the-code)
|
|
(parse-alien-type '(function long) nil)))
|
|
(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 ,rdi-tn ,(get-lisp-obj-address T)) ; in case T is above #x7fffffff
|
|
(mov :qword ,(ea 16 rsp-tn) ,rdi-tn)
|
|
(mov :qword ,(ea 8 rsp-tn) ,(fixnumize 311))
|
|
(mov :qword ,(ea 0 rsp-tn) ,(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 ,rcx-tn ,thread-tn) ; C arg 3 = thread
|
|
(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)))))
|