diff --git a/lisp/l/eusforeign.l b/lisp/l/eusforeign.l index 910790cee..0664e4a88 100644 --- a/lisp/l/eusforeign.l +++ b/lisp/l/eusforeign.l @@ -148,6 +148,12 @@ (setf (symbol-function (intern (string-upcase fname))) (make-foreign-code fname nil :integer ,mod)))) +; mprotect(addr, len, prot) -- used to make trampoline pages executable on x86_64 Linux +; wrapped in when because mprotect may not be in sysmod on non-Linux platforms (e.g. macOS) +#+:x86_64 +(when (system::find-entry "mprotect" (sys::sysmod)) + (defforeign c-mprotect (sys::sysmod) "mprotect" (:integer :integer :integer) :integer)) + ;(eval-when (compile) ; (defclass foreign-pod :super symbol :slots (podcode paramtypes resulttype))) @@ -370,6 +376,11 @@ :start1 100) (if *debug* (format t "PODCODE ADDR: ~x~%" (+ 16 (sys:address podcode)))) podcode) +#+:x86_64 + (when (fboundp 'c-mprotect) + (let* ((addr (sys:address podcode)) + (page-addr (* (floor (/ addr 4096)) 4096))) + (c-mprotect page-addr (* 2 4096) 7))) #+:sh4 (progn (setq podcode (byte-string diff --git a/test/test-foreign.l b/test/test-foreign.l index 9365c3365..9672d743e 100644 --- a/test/test-foreign.l +++ b/test/test-foreign.l @@ -549,22 +549,25 @@ test-testd = 1.23456 (assert (= (ret-eusinteger 123 645000) (+ 123 645000))) ) -#| -;; ret-int -;; ret-short -;; ret-char - -;; callback function +;; callback function -- Linux x86_64 only +;; trampoline machine code is x86_64-specific, and mprotect is needed to make +;; the GC heap executable (not available in sysmod on macOS) +#+(and :x86_64 :linux) (defun-c-callable LISP-IFUNC () :integer (format t "LISP-INTFUNC is called, return ~D~%" 1234) 1234) -;; -(format t "~%callback function test(integer)~%") -(format t " callback function is set~%") -(set-ifunc (pod-address 'LISP-IFUNC)) -(format t " expected result: LISP-INTFUNC is called, return 1234~%") -(format t " call-ifunc = ~A~%" (call-ifunc)) +#+(and :x86_64 :linux) +(deftest test-callback-integer () + (format t "~%callback function test(integer)~%") + (format t " callback function is set~%") + (set-ifunc (pod-address (intern "LISP-IFUNC"))) + (format t " expected result: LISP-INTFUNC is called, return 1234~%") + (let ((result (call-ifunc))) + (format t " call-ifunc = ~A~%" result) + (assert (= result 1234)))) + +#+(and :x86_64 :linux) (defun-c-callable LISP-FFUNC ((i0 :integer) (i1 :integer) (i2 :integer) (i3 :integer) (i4 :integer) (i5 :integer) (f0 :float) (f1 :float) (f2 :float) (f3 :float) @@ -580,10 +583,13 @@ test-testd = 1.23456 (format t "~A ~A~%" i6 i7) (format t "return ~A~%" 0.12345) 0.12345) -(format t "~%callback function test(float)~%") -(format t " callback function is set~%") -(set-ffunc (pod-address 'LISP-FFUNC)) -(format t " expected result: LISP-FFUNC is called + +#+(and :x86_64 :linux) +(deftest test-callback-float () + (format t "~%callback function test(float)~%") + (format t " callback function is set~%") + (set-ffunc (pod-address (intern "LISP-FFUNC"))) + (format t " expected result: LISP-FFUNC is called 100 101 102 103 104 105 1000.0 1010.0 1020.0 1030.0 @@ -591,8 +597,9 @@ test-testd = 1.23456 2080.0 2090.0 206 207 return 0.12345~%") -(format t "call-ffunc = ~A~%" (call-ffunc)) -|# + (let ((result (call-ffunc))) + (format t "call-ffunc = ~A~%" result) + (assert (< (abs (- result 0.12345)) 1e-4)))) (eval-when (load eval) (run-all-tests) diff --git a/test/test_foreign.c b/test/test_foreign.c index 48f62bd2f..a41477d0a 100644 --- a/test/test_foreign.c +++ b/test/test_foreign.c @@ -337,6 +337,7 @@ long set_ifunc(long (*f) ()) { g = f; printf("set_ifunc, g = %lX\n", g); + return 0; } long set_ffunc(double (*f) ()) @@ -348,6 +349,7 @@ long set_ffunc(double (*f) ()) double d8, double d9, long i6, long i7))f; printf("set_ffunc, gf = %lX\n", gf); + return 0; } long call_ifunc() {