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 (%sap-alien (int-sap #x4000) 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              (sb-assem:assemble (segment)
  35                (dolist (instruction (subst n :ARGC c-prog)
  36                                     (sb-assem::segment-buffer segment))
  37                  (apply (sb-assem::op-encoder-name (car instruction))
  38                         (cdr instruction)))))))
  39     (dotimes (n-args 4)
  40       (let ((the-code (assemble-it n-args)))
  41         ;; in case we change the way the assembler output works ...
  42         (assert (typep the-code '(simple-array (unsigned-byte 8) 1)))
  43         (with-pinned-objects (the-code)
  44           (let ((my-little-alien
  45                  (%sap-alien (vector-sap the-code)
  46                              (parse-alien-type '(function long) nil)))
  47                 (expect  (concatenate 'list (subseq '(#\A 311 T) 0 n-args)
  48                                       (subseq '(0 0 0) n-args 3)))
  49                 (monkeybiz-result))
  50             (declare (special monkeybiz-result))
  51             (alien-funcall my-little-alien)
  52             (format t "Call with ~D arg~:P: ~S~%" n-args monkeybiz-result)
  53             (assert (equal monkeybiz-result expect))))))))
  54
  55 #+X86-64
  56 (test-util:with-test (:name :call-into-lisp)
  57   ;; Obviously we need a C function to call the Lisp function, so here's one,
  58   ;; carefully hand-crafted so as to need no input arguments,
  59   ;; using only a static Lisp symbol, two non-pointers, and a pinned function.
  60   (with-pinned-objects (#'monkeybiz)
  61     (try-call-into-lisp
  62      ;; Making room for 3 args aligns the stack to a 16-byte boundary
  63      ;; presuming it was at CALL to me. Darwin requires the alignment, others don't care.
  64      `((sub ,rsp-tn 24)
  65        (mov ,(make-ea :qword :base rsp-tn :disp 16) ,(get-lisp-obj-address T))
  66        (mov ,(make-ea :qword :base rsp-tn :disp 8) ,(fixnumize 311))
  67        (mov ,(make-ea :qword :base rsp-tn :disp 0) ,(get-lisp-obj-address #\A))
  68        (mov ,rdi-tn ,(get-lisp-obj-address #'monkeybiz)) ; C arg 0 = Lisp function
  69        (mov ,rsi-tn ,rsp-tn)                             ; C arg 1 = argv
  70        (mov ,rdx-tn :ARGC)                               ; C arg 2 = argc
  71        (mov ,rax-tn ,(sap-int
  72                       (alien-value-sap
  73                        (extern-alien "call_into_lisp"
  74                                      (function long long long long)))))
  75        (call ,rax-tn)
  76        (add ,rsp-tn 24)
  77        (ret)))))