tests/call-into-lisp.impure.lisp

   1
   2 ;;;; This software is part of the SBCL system. See the README file for
   3 ;;;; more information.
   4 ;;;;
   5 ;;;; While most of SBCL is derived from the CMU CL system, the test
   6 ;;;; files (like this one) were written from scratch after the fork
   7 ;;;; from CMU CL.
   8 ;;;;
   9 ;;;; This software is in the public domain and is provided with
  10 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  11 ;;;; more information.
  12
  13 (in-package sb-vm)
  14
  15 (test-util:with-test (:name :unparse-alien-niladic-function)
  16   (let* ((type (parse-alien-type '(function long) nil))
  17          (val (make-alien-value :sap (int-sap #x4000) :type type)))
  18     (assert (not (search "#'" (write-to-string type :pretty t))))
  19     (assert (not (search "#'" (write-to-string val :pretty t))))))
  20
  21 ;; This test shows (well, sorta) that call_into_lisp didn't read beyond
  22 ;; the Nth item in its argument vector with N being the specified argc.
  23 ;; As it happens, we zeroize the unused passing registers, so can check for that.
  24 (defun monkeybiz (a1 a2 a3)
  25   ;; grr. what if a safety policy restriction is in effect?
  26   (declare (optimize (safety 0)))
  27   (declare (special monkeybiz-result))
  28   (setq monkeybiz-result (list a1 a2 a3)))
  29 (compile 'monkeybiz) ; in case somebody runs this test with the interpreter
  30
  31 (defun try-call-into-lisp (c-prog) ; er, assembly program, but whatever
  32   (flet ((assemble-it (n)
  33            (let ((segment (sb-assem:make-segment :type :regular)))
  34              (dolist (instruction (subst n :ARGC c-prog)
  35                       (sb-assem::segment-buffer segment))
  36                (apply (symbolicate (car instruction) "-INST-EMITTER")
  37                       segment nil (cdr instruction))))))
  38     (dotimes (n-args 4)
  39       (let ((the-code (assemble-it n-args)))
  40         ;; in case we change the way the assembler output works ...
  41         (assert (typep the-code '(simple-array (unsigned-byte 8) 1)))
  42         (with-pinned-objects (the-code)
  43           (let ((my-little-alien
  44                  (make-alien-value :type (parse-alien-type '(function long) nil)
  45                                    :sap (vector-sap the-code)))
  46                 (expect  (concatenate 'list (subseq '(#\A 311 T) 0 n-args)
  47                                       (subseq '(0 0 0) n-args 3)))
  48                 (monkeybiz-result))
  49             (declare (special monkeybiz-result))
  50             (alien-funcall my-little-alien)
  51             (format t "Call with ~D arg~:P: ~S~%" n-args monkeybiz-result)
  52             (assert (equal monkeybiz-result expect))))))))
  53
  54 #+X86-64
  55 (test-util:with-test (:name :call-into-lisp)
  56   ;; Obviously we need a C function to call the Lisp function, so here's one,
  57   ;; carefully hand-crafted so as to need no input arguments,
  58   ;; using only a static Lisp symbol, two non-pointers, and a pinned function.
  59   (with-pinned-objects (#'monkeybiz)
  60     (try-call-into-lisp
  61      ;; Making room for 3 args aligns the stack to a 16-byte boundary
  62      ;; presuming it was at CALL to me. Darwin requires the alignment, others don't care.
  63      `((sub ,rsp-tn 24)
  64        (mov ,(make-ea :qword :base rsp-tn :disp 16) ,(get-lisp-obj-address T))
  65        (mov ,(make-ea :qword :base rsp-tn :disp 8) ,(fixnumize 311))
  66        (mov ,(make-ea :qword :base rsp-tn :disp 0) ,(get-lisp-obj-address #\A))
  67        (mov ,rdi-tn ,(get-lisp-obj-address #'monkeybiz)) ; C arg 0 = Lisp function
  68        (mov ,rsi-tn ,rsp-tn)                             ; C arg 1 = argv
  69        (mov ,rdx-tn :ARGC)                               ; C arg 2 = argc
  70        (mov ,rax-tn ,(sap-int
  71                       (alien-value-sap
  72                        (extern-alien "call_into_lisp"
  73                                      (function long long long long)))))
  74        (call ,rax-tn)
  75        (add ,rsp-tn 24)
  76        (ret)))))