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