Reverse the logic in break-vicious-metacircle.
[sbcl.git] / tests / foreign-stack-alignment.impure.lisp
blobaaeabc82875ad40162e4093360e60dca2470bef8
1 ;;;; Testing the stack alignment of foreign calls. Uses stack-alignment-offset.c.
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; from CMU CL.
9 ;;;;
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (use-package :sb-alien)
16 ;;; Callbacks are not part of the exported interface yet -- when they are this can
17 ;;; go away.
18 (import 'sb-alien::alien-lambda)
20 (defun run (program &rest arguments)
21 (let* ((stringstream (make-string-output-stream))
22 (proc (run-program program arguments
23 :output stringstream :error sb-sys:*tty*
24 :search (or #+win32 t)))
25 (output (get-output-stream-string stringstream)))
26 (unless (zerop (process-exit-code proc))
27 (error "Bad exit code: ~S~%Output:~% ~S"
28 (process-exit-code proc)
29 output))
30 output))
31 (defun cc (&rest arguments)
32 (apply #'run #+unix "./run-compiler.sh" #+win32 "gcc" arguments))
34 (defvar *required-alignment*
35 (or #+arm 8
36 #+mips 8
37 #+(and ppc darwin) 16
38 #+(and ppc (not darwin)) 8
39 #+(or arm64 x86 x86-64 riscv ppc64) 16
40 #+sparc 8
41 (error "Unknown platform")))
43 ;;;; Build the offset-tool as regular excutable, and run it with
44 ;;;; fork/exec, so that no lisp is on the stack. This is our known-good
45 ;;;; number.
47 (defvar *exename* (scratch-file-name (or #+win32 "exe" nil)))
48 (defvar *soname* (scratch-file-name (or #+win32 "dll" "so")))
50 (progn
51 (cc #+unix "-sbcl-pic" "-o" *exename* "stack-alignment-offset.c")
53 (defparameter *good-offset*
54 (parse-integer (run *exename*
55 (princ-to-string *required-alignment*))))
56 (format t "~s is ~d~%" '*good-offset* *good-offset*)
57 ;; Build the tool again, this time as a shared object, and load it
59 #+unix (cc "-sbcl-shared" "-sbcl-pic" "-o" *soname* "stack-alignment-offset.c")
60 #+win32 (cc "-shared" "-o" *soname* "stack-alignment-offset.c")
62 (load-shared-object *soname*)
64 (define-alien-routine stack-alignment-offset int (alignment int))
65 #+alien-callbacks
66 (define-alien-routine trampoline int (callback (function int))))
68 ;;;; Now get the offset by calling from lisp, first with a regular foreign function
69 ;;;; call, then with an intervening callback.
71 (with-test (:name :regular)
72 (assert (= *good-offset* (stack-alignment-offset *required-alignment*))))
74 #+alien-callbacks
75 (with-test (:name :callback)
76 (assert (= *good-offset*
77 (trampoline (alien-lambda int ()
78 (stack-alignment-offset *required-alignment*))))))
80 (ignore-errors (delete-file *exename*))
81 (ignore-errors (delete-file *soname*))
83 ;;;; success!