faster in the typical case than the old optimizations in PCL and
less buggy.
+Timothy Moore:
+ He designed and implemented the original CMUCL linkage-table, on
+ which the SBCL implementation thereof is based.
+
William ("Bill") Newman:
He continued to maintain SBCL after the fork, increasing ANSI
compliance, fixing bugs, regularizing the internals of the
Nikodemus Siivola:
He provided build fixes, in particular to tame the SunOS toolchain,
- implemented package locks, and has fixed many (stream-related and
- other) bugs besides.
+ implemented package locks, ported the linkage-table code from CMUCL,
+ and has fixed many (stream-related and other) bugs besides.
Juho Snellman:
He provided several performance enhancements, including a better hash
Raymond Toy:
He continued to work on CMU CL after the SBCL fork, especially on
floating point stuff. Various patches and fixes of his have been
- ported to SBCL.
+ ported to SBCL, including his Sparc port of linkage-table.
Peter Van Eynde:
He wrestled the CLISP test suite into a mostly portable test suite
changes in sbcl-0.8.15 relative to sbcl-0.8.14:
+ * incompatible change: SB-INT:*BEFORE-SAVE-INITIALIZATIONS* and
+ SB-INT:*AFTER-SAVE-INITIALIZATIONS* have been renamed
+ SB-EXT:*SAVE-HOOKS* and SB-EXT:*INIT-HOOKS*, and are now
+ part of the supported interface.
+ * new feature: saving cores with foreign code loaded is now
+ supported on x86/FreeBSD, x86/Linux, and sparc/SunOS. (based
+ on Timothy Moore's work for CMUCL)
* bug fix: incorrect expansion of defgeneric that caused
a style warning. (thanks for Zach Beane)
("src/code/thread")
("src/code/load")
+ #!+linkage-table ("src/code/linkage-table" :not-host)
+ #!+os-provides-dlopen ("src/code/foreign-load" :not-host)
+ ("src/code/foreign")
+
("src/code/fop") ; needs macros from code/load.lisp
("src/compiler/ctype")
(sb-alien:addr size)))
(socket-error "getsockopt")
(,mangle-return buffer size)))
- `(error 'unsupported-operator :name ',lisp-name)))
+ `(error 'unsupported-operator
+ :format-control "Socket option ~S is not supported in this platform."
+ :format-arguments (list ',lisp-name))))
(defun (setf ,lisp-name) (new-val socket)
,(if supportedp
`(sb-alien:with-alien ((buffer ,buffer-type))
`(length new-val)
`(sb-alien:alien-size ,buffer-type :bytes))))
(socket-error "setsockopt")))
- `(error 'unsupported-operator :name `(setf ,lisp-name)))))))
+ `(error 'unsupported-operator
+ :format-control "Socket option ~S is not supported on this platform."
+ :format-arguments (list ',lisp-name)))))))
;;; sockopts that have integer arguments
(intern (substitute #\- #\_ (string-upcase s)) :sb-posix))
(defmacro define-call-internally (lisp-name c-name return-type error-predicate &rest arguments)
- (if (sb-fasl::foreign-symbol-address-as-integer-or-nil
- (sb-vm:extern-alien-name c-name))
+ (if (sb-sys:foreign-symbol-address-as-integer-or-nil c-name)
`(progn
(declaim (inline ,lisp-name))
(defun ,lisp-name ,(mapcar #'car arguments)
SBCL has the ability to save its state as a file for later
execution. This functionality is important for its bootstrapping
-process, and is also provided as an extension to the user. Note that
-foreign libraries loaded via @code{load-shared-object} don't survive
-this process; a core should not be saved in this case.
+process, and is also provided as an extension to the user.
+
+Note that foreign libraries loaded via @code{load-shared-object} don't
+survive this process on all platforms; a core should not be saved in
+this case. Platforms where this is supported as of SBCL 0.8.14.5 are
+x86/Linux, x86/FreeBSD and sparc/SunOS.
@emph{FIXME: what should be done for foreign libraries?}
esac
cd $original_dir
+# FIXME: Things like :c-stack-grows-..., etc, should be
+# *derived-target-features* or equivalent, so that there was a nicer
+# way to specify them then sprinkling them in this file. They should
+# still be tweakable by advanced users, though, but probably not
+# appear in *features* of target. #!+/- should be adjusted to take
+# them in account as well. At minimum the nicer specification stuff,
+# though:
+#
+# (define-feature :dlopen (features)
+# (union '(:bsd :linux :darwin :sunos) features))
+#
+# (define-feature :c-stack-grows-downwards-not-upwards (features)
+# (member :x86 features))
+
# KLUDGE: currently the x86 only works with the generational garbage
# collector (indicated by the presence of :GENCGC in *FEATURES*) and
# alpha, sparc and ppc with the stop'n'copy collector (indicated by
# base-target-features.lisp-expr, we add it into local-target-features
# if we're building for x86. -- CSR, 2002-02-21 Then we do something
# similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03
-if [ "$sbcl_arch" = "x86" ] ; then
+if [ "$sbcl_arch" = "x86" ]; then
printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack' >> $ltf
-elif [ "$sbcl_arch" = "mips" ] ; then
+ if [ "$sbcl_os" = "linux" ] || [ "$sbcl_os" = "freebsd" ]; then
+ printf ' :linkage-table' >> $ltf
+ fi
+elif [ "$sbcl_arch" = "mips" ]; then
# Use a little C program to try to guess the endianness. Ware
# cross-compilers!
- $GNUMAKE -C tools-for-build determine-endianness
+ #
+ # FIXME: integrate to grovel-features, mayhaps
+ $GNUMAKE -C tools-for-build determine-endianness -I src/runtime
tools-for-build/determine-endianness >> $ltf
elif [ "$sbcl_arch" = "ppc" -a "$sbcl_os" = "linux" ]; then
# Use a C program to detect which kind of glibc we're building on,
# to bandage across the break in source compatibility between
# versions 2.3.1 and 2.3.2
- $GNUMAKE -C tools-for-build where-is-mcontext
+ #
+ # FIXME: integrate to grovel-features., maypahps
+ $GNUMAKE -C tools-for-build where-is-mcontext -I src/runtime
tools-for-build/where-is-mcontext > src/runtime/ppc-linux-mcontext.h
elif [ "$sbcl_arch" = "ppc" -a "$sbcl_os" = "darwin" ]; then
+ # We provide a dlopen shim, so a little lie won't hurt
+ printf " :os-provides-dlopen" >> $ltf
# The default stack ulimit under darwin is too small to run PURIFY.
# Best we can do is complain and exit at this stage
if [ "`ulimit -s`" = "512" ]; then
# FUNCDEF macro for assembler. No harm in running this on sparc-linux
# as well.
sh tools-for-build/sparc-funcdef.sh > src/runtime/sparc-funcdef.h
+ if [ "$sbcl_os" = "sunos" ]; then
+ printf ' :linkage-table' >> $ltf
+ fi
else
# Nothing need be done in this case, but sh syntax wants a placeholder.
echo > /dev/null
fi
+export sbcl_os sbcl_arch
sh tools-for-build/grovel-features.sh >> $ltf
echo //finishing $ltf
# provided with absolutely no warranty. See the COPYING and CREDITS
# files for more information.
+. ./find-gnumake.sh
+find_gnumake
+
# usually SBCL_HOME refers to the installed root of SBCL, not the
# build directory. Right now, however, where there are dependencies
# between contrib packages, we want the _uninstalled_ versions to be
# Sometimes people used to see the "No tests failed." output from the last
# DEFTEST in contrib self-tests and think that's all that is. So...
-FLAG=false
+FLAG=true
for dir in contrib/*
do
if [ -d "$dir" -a -e "$dir/Makefile" -a ! -e "$dir/test-passed" ]; then
- $FLAG || (echo "Failed contribs:" && FLAG=true)
+ if $FLAG; then
+ echo > /dev/null
+ else
+ echo "Failed contribs:"
+ FLAG=false
+ fi
echo " `basename $dir`"
fi
done
"ENUM" "EXTERN-ALIEN"
"FREE-ALIEN"
"GET-ERRNO"
- "INT"
+ "INT"
"LOAD-1-FOREIGN" "LOAD-FOREIGN" "LOAD-SHARED-OBJECT" "LONG"
"MAKE-ALIEN"
"NULL-ALIEN"
basic stuff like BACKTRACE and ARG. For now, the actual supported interface
is still mixed indiscriminately with low-level internal implementation stuff
like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
- :use ("CL" "SB!EXT" "SB!INT" "SB!SYS")
+ :use ("CL" "SB!EXT" "SB!INT" "SB!SYS" "SB!KERNEL")
:export ("*DEBUG-BEGINNER-HELP-P*"
"*DEBUG-CONDITION*"
"*DEBUG-PRINT-LENGTH*" "*DEBUG-PRINT-LEVEL*"
"READ-ONLY-CORE-SPACE-ID"
"*!REVERSED-COLD-TOPLEVELS*"
"STATIC-CORE-SPACE-ID"
- "*STATIC-FOREIGN-SYMBOLS*"
"VERSION-CORE-ENTRY-TYPE-CODE"))
;; This package is a grab bag for things which used to be internal
"*GC-RUN-TIME*"
"PURIFY"
+ ;; Hooks into init & save sequences
+ "*INIT-HOOKS*" "*SAVE-HOOKS*"
+
;; There is no one right way to report progress on
;; hairy compiles.
"*COMPILE-PROGRESS*"
the stuff in here originated in CMU CL's EXTENSIONS package and is
retained, possibly temporariliy, because it might be used internally."
:use ("CL" "SB!ALIEN" "SB!GRAY" "SB!FASL" "SB!SYS")
- :export ("*AFTER-SAVE-INITIALIZATIONS*"
- "*BEFORE-SAVE-INITIALIZATIONS*"
-
- ;; lambda list keyword extensions
+ :export (;; lambda list keyword extensions
"&MORE"
;; INFO stuff doesn't belong in a user-visible package, we
;; and cross-compiling
"DEFMACRO-MUNDANELY"
"DEFCONSTANT-EQX"
+ "DEFINE-UNSUPPORTED-FUN"
;; messing with PATHNAMEs
"MAKE-TRIVIAL-DEFAULT-PATHNAME"
"!COLD-INIT" "!UNINTERN-INIT-ONLY-STUFF"
"!GLOBALDB-COLD-INIT" "!FDEFN-COLD-INIT"
- "!FUNCTION-NAMES-COLD-INIT"
+ "!FOREIGN-COLD-INIT" "!FUNCTION-NAMES-COLD-INIT"
"!TYPE-CLASS-COLD-INIT" "!TYPEDEFS-COLD-INIT"
"!ALIEN-TYPE-COLD-INIT" "!CLASSES-COLD-INIT"
"!EARLY-TYPE-COLD-INIT" "!LATE-TYPE-COLD-INIT"
"!FIXUP-TYPE-COLD-INIT" "!TARGET-TYPE-COLD-INIT"
"!RANDOM-COLD-INIT" "!READER-COLD-INIT"
- "!TYPECHECKFUNS-COLD-INIT"
- "STREAM-COLD-INIT-OR-RESET" "!LOADER-COLD-INIT"
+ "!TYPECHECKFUNS-COLD-INIT" "!LOADER-COLD-INIT"
"!EXHAUST-COLD-INIT" "!PACKAGE-COLD-INIT"
- "SIGNAL-COLD-INIT-OR-REINIT"
"!POLICY-COLD-INIT-OR-RESANIFY"
"!VM-TYPE-COLD-INIT" "!BACKQ-COLD-INIT"
"!SHARPM-COLD-INIT" "!EARLY-PROCLAIM-COLD-INIT"
"!LATE-PROCLAIM-COLD-INIT" "!CLASS-FINALIZE"
+
"GC-REINIT"
+ "SIGNAL-COLD-INIT-OR-REINIT"
+ "STREAM-COLD-INIT-OR-RESET"
+
+ ;; Cleanups to run before saving a core
+ "DEBUG-DEINIT" "FOREIGN-DEINIT" "PROFILE-DEINIT"
;; Note: These are out of lexicographical order
;; because in CMU CL they were defined as
;; SB!KERNEL.)
"%PRIMITIVE"
"%STANDARD-CHAR-P"
+ "*LINKAGE-INFO*"
"*LONG-SITE-NAME*" "*SHORT-SITE-NAME*"
+ "*RUNTIME-DLHANDLE*"
+ "*SHARED-OBJECTS*"
+ "*STATIC-FOREIGN-SYMBOLS*"
"*STDERR*" "*STDIN*"
"*STDOUT*" "*TASK-DATA*"
"*TASK-NOTIFY*" "*TASK-SELF*" "*TTY*" "*TYPESCRIPTPORT*"
"ALLOCATE-SYSTEM-MEMORY"
"BEEP" "BITS"
"BYTES" "C-PROCEDURE"
+ "CLOSE-SHARED-OBJECTS"
"COMPILER-VERSION"
"DEALLOCATE-SYSTEM-MEMORY"
"DEFAULT-INTERRUPT"
"DEPORT-BOOLEAN" "DEPORT-INTEGER"
+ "DLOPEN-OR-LOSE"
"FROB-DO-BODY"
"ENABLE-INTERRUPT" "ENUMERATION"
"FD-STREAM-FD" "FD-STREAM-P"
- "FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-ADDRESS-AS-INTEGER"
+ "FIND-FOREIGN-SYMBOL-IN-TABLE"
+ "FOREIGN-SYMBOL-ADDRESS"
+ "FOREIGN-SYMBOL-ADDRESS-AS-INTEGER"
+ "FOREIGN-SYMBOL-ADDRESS-AS-INTEGER-OR-NIL"
+ "FOREIGN-SYMBOL-DATAREF-ADDRESS"
"FOREIGN-SYMBOL-IN-ADDRESS"
"GET-PAGE-SIZE" "GET-SYSTEM-INFO"
"IGNORE-INTERRUPT"
"POINTER" "POINTER<" "POINTER>"
"READ-N-BYTES" "REALLOCATE-SYSTEM-MEMORY" "RECORD-SIZE"
"REMOVE-FD-HANDLER"
+ "REOPEN-SHARED-OBJECTS"
"RESOLVE-LOADED-ASSEMBLER-REFERENCES"
"SAP+" "SAP-" "SAP-INT"
"SAP-REF-16" "SAP-REF-32" "SAP-REF-64" "SAP-REF-8"
"READ-ONLY-SPACE-START" "READ-ONLY-SPACE-END"
"TARGET-BYTE-ORDER" "TARGET-HEAP-ADDRESS-SPACE"
"STATIC-SPACE-START" "STATIC-SPACE-END"
+ #!+linkage-table "LINKAGE-TABLE-SPACE-START"
+ #!+linkage-table "LINKAGE-TABLE-SPACE-END"
+ #!+linkage-table "LINKAGE-TABLE-ENTRY-SIZE"
"TRACE-TABLE-CALL-SITE"
"TRACE-TABLE-FUN-EPILOGUE" "TRACE-TABLE-FUN-PROLOGUE"
"TRACE-TABLE-NORMAL" "N-WIDETAG-BITS" "WIDETAG-MASK"
(show-and-call stream-cold-init-or-reset)
(show-and-call !loader-cold-init)
+ (show-and-call !foreign-cold-init)
(show-and-call signal-cold-init-or-reinit)
+ (/show0 "enabling internal errors")
(setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
;; FIXME: This list of modes should be defined in one place and
(unix-code 0 unix-code-p)
(unix-status unix-code))
#!+sb-doc
- "Terminate the current Lisp. Things are cleaned up (with UNWIND-PROTECT
- and so forth) unless RECKLESSLY-P is non-NIL. On UNIX-like systems,
- UNIX-STATUS is used as the status code."
+ "Terminate the current Lisp. Things are cleaned up (with
+UNWIND-PROTECT and so forth) unless RECKLESSLY-P is non-NIL. On
+UNIX-like systems, UNIX-STATUS is used as the status code."
(declare (type (signed-byte 32) unix-status unix-code))
(/show0 "entering QUIT")
;; FIXME: UNIX-CODE was deprecated in sbcl-0.6.8, after having been
(set-floating-point-modes
:traps '(:overflow #!-netbsd :invalid :divide-by-zero))
(sb!thread::maybe-install-futex-functions)))
- (gc-on)
- (gc))
+ (foreign-reinit)
+ (gc-reinit)
+ (mapc #'funcall *init-hooks*))
\f
;;;; some support for any hapless wretches who end up debugging cold
;;;; init code
;;; regression tests cheerfully passed because they assumed that
;;; unFBOUNDPness meant they were running on an system which didn't
;;; support the extension.)
-(define-condition unsupported-operator (cell-error) ()
- (:report
- (lambda (condition stream)
- (format stream
- "unsupported on this platform (OS, CPU, whatever): ~S"
- (cell-error-name condition)))))
+(define-condition unsupported-operator (simple-error) ())
+
\f
;;; (:ansi-cl :function remove)
;;; (:ansi-cl :section (a b c))
(#.lra-save-offset
(setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))
-(defun foreign-function-debug-name (sap)
- (multiple-value-bind (name file base offset) (foreign-symbol-in-address sap)
+(defun foreign-function-backtrace-name (sap)
+ (let ((name (foreign-symbol-in-address sap)))
(if name
- (format nil "foreign function: ~A [~A: #x~X + #x~X]" name file base offset)
+ (format nil "foreign function: ~A" name)
(format nil "foreign function: #x~X" (sap-int sap)))))
;;; This returns a frame for the one existing in time immediately
"undefined function"))
(:foreign-function
(make-bogus-debug-fun
- (foreign-function-debug-name (int-sap (get-lisp-obj-address lra)))))
+ (foreign-function-backtrace-name
+ (int-sap (get-lisp-obj-address lra)))))
((nil)
(make-bogus-debug-fun
"bogus stack frame"))
(make-bogus-debug-fun
"undefined function"))
(:foreign-function
- (make-bogus-debug-fun (foreign-function-debug-name ra)))
+ (make-bogus-debug-fun
+ (foreign-function-backtrace-name ra)))
((nil)
(make-bogus-debug-fun
"bogus stack frame"))
;;; instruction.
(defun make-bogus-lra (real-lra &optional known-return-p)
(without-gcing
+ ;; These are really code labels, not variables: but this way we get
+ ;; their addresses.
(let* ((src-start (foreign-symbol-address "fun_end_breakpoint_guts"))
(src-end (foreign-symbol-address "fun_end_breakpoint_end"))
(trap-loc (foreign-symbol-address "fun_end_breakpoint_trap"))
(defvar *cached-readtable* nil)
(declaim (type (or readtable null) *cached-readtable*))
-(pushnew (lambda ()
- (setq *cached-debug-source* nil *cached-source-stream* nil
- *cached-readtable* nil))
- *before-save-initializations*)
+;;; Stuff to clean up before saving a core
+(defun debug-deinit ()
+ (setf *cached-debug-source* nil
+ *cached-source-stream* nil
+ *cached-readtable* nil))
;;; We also cache the last toplevel form that we printed a source for
;;; so that we don't have to do repeated reads and calls to
;;; Assembler routines are named by full Lisp symbols: they
;;; have packages and that sort of native Lisp stuff associated
;;; with them. We can compare them with EQ.
-;;; Foreign symbols are named by Lisp STRINGs: the Lisp package
-;;; system doesn't extend out to symbols in languages like C.
-;;; We want to use EQUAL to compare them.
-;;; *STATIC-FOREIGN-SYMBOLS* are static as opposed to "dynamic" (not
-;;; as opposed to C's "extern"). The table contains symbols known at
-;;; the time that the program was built, but not symbols defined
-;;; in object files which have been loaded dynamically since then.
-(declaim (type hash-table *assembler-routines* *static-foreign-symbols*))
+(declaim (type hash-table *assembler-routines*))
(defvar *assembler-routines* (make-hash-table :test 'eq))
-(defvar *static-foreign-symbols* (make-hash-table :test 'equal))
+
\f
;;;; the FOP database
\f
;;;; assemblerish fops
+(define-fop (fop-assembler-code 144)
+ (error "cannot load assembler code except at cold load"))
+
+(define-fop (fop-assembler-routine 145)
+ (error "cannot load assembler code except at cold load"))
+
(define-fop (fop-foreign-fixup 147)
(let* ((kind (pop-stack))
(code-object (pop-stack))
kind)
code-object))
-(define-fop (fop-assembler-code 144)
- (error "cannot load assembler code except at cold load"))
-
-(define-fop (fop-assembler-routine 145)
- (error "cannot load assembler code except at cold load"))
-
(define-fop (fop-assembler-fixup 148)
(let ((routine (pop-stack))
(kind (pop-stack))
(sb!vm:fixup-code-object code-object (read-word-arg)
(get-lisp-obj-address code-object) kind)
code-object))
+
+#!+linkage-table
+(define-fop (fop-foreign-dataref-fixup 150)
+ (let* ((kind (pop-stack))
+ (code-object (pop-stack))
+ (len (read-byte-arg))
+ (sym (make-string len)))
+ (read-n-bytes *fasl-input-stream* sym 0 len)
+ (sb!vm:fixup-code-object code-object
+ (read-word-arg)
+ (foreign-symbol-address-as-integer sym t)
+ kind)
+ code-object))
--- /dev/null
+;;;; Loading shared object files
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!ALIEN")
+
+(define-unsupported-fun load-foreign
+ "Unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
+ "~S is unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
+ (load-foreign))
+
+(define-unsupported-fun load-1-foreign
+ "Unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
+ "~S is unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
+ (load-1-foreign))
+
+(define-alien-routine dlopen system-area-pointer
+ (file c-string) (mode int))
+
+(define-alien-routine dlclose int
+ (handle system-area-pointer))
+
+(define-alien-routine dlerror c-string)
+
+(define-alien-routine dlsym system-area-pointer
+ (handle system-area-pointer)
+ (symbol c-string))
+
+(defvar *runtime-dlhandle*)
+(defvar *shared-objects*)
+
+(defstruct shared-object file sap)
+
+(defun dlopen-or-lose (filename)
+ (dlerror) ; clear old errors
+ (let ((sap (dlopen filename (logior rtld-global rtld-now))))
+ (when (zerop (sap-int sap))
+ (error "Could not open ~:[runtime~;~:*shared object ~S~]: ~A"
+ filename (dlerror)))
+ sap))
+
+(defun load-shared-object (file)
+ "Load a shared library/dynamic shared object file/general
+dlopenable alien container.
+
+To use LOAD-SHARED-OBJECT, at the Unix command line do this:
+
+ echo 'int summish(int x, int y) { return 1 + x + y; }' > /tmp/ffi-test.c
+ make /tmp/ffi-test.o # i.e. cc -c -o /tmp/ffi-test.o /tmp/ffi-test.c
+ ld -shared -o /tmp/ffi-test.so /tmp/ffi-test.o
+
+Then in SBCL do this:
+
+ (load-shared-object \"/tmp/ffi-test.so\")
+ (define-alien-routine summish int (x int) (y int))
+
+Now running (summish 10 20) should return 31."
+ (let* ((real-file (or (unix-namestring file) file))
+ (sap (dlopen-or-lose real-file))
+ (obj (make-shared-object :file real-file :sap sap)))
+ (unless (member sap *shared-objects*
+ :test #'sap= :key #'shared-object-sap)
+ (setf *shared-objects* (append *shared-objects* (list obj))))
+ (pathname real-file)))
+
+(defun try-reopen-shared-object (obj)
+ (restart-case
+ (let ((sap (dlopen-or-lose (shared-object-file obj))))
+ (setf (shared-object-sap obj) sap)
+ obj)
+ (skip ()
+ :report "Skip this shared object and continue. References to ~
+ foreign symbols in this shared object will fail, ~
+ causing potential corruption."
+ *runtime-dlhandle*)))
+
+;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during
+;;; initialization.
+(defun reopen-shared-objects ()
+ ;; Ensure that the runtime is present in the list
+ (setf *runtime-dlhandle* (dlopen-or-lose nil)
+ *shared-objects* (mapcar #'try-reopen-shared-object *shared-objects*)))
+
+;;; Close all dlopened libraries and clear out sap entries in
+;;; *SHARED-OBJECTS*.
+(defun close-shared-objects ()
+ (dolist (obj (reverse *shared-objects*))
+ (dlclose (shared-object-sap obj))
+ (setf (shared-object-sap obj) nil))
+ (dlclose *runtime-dlhandle*)
+ (setf *runtime-dlhandle* nil))
+
+(defun get-dynamic-foreign-symbol-address (symbol)
+ (dlerror) ; clear old errors
+ (let ((result (sap-int (dlsym *runtime-dlhandle* symbol)))
+ (err (dlerror)))
+ (if (or (not (zerop result)) (not err))
+ result
+ (dolist (obj *shared-objects*)
+ (setf result (sap-int (dlsym (shared-object-sap obj) symbol))
+ err (dlerror))
+ (when (or (not (zerop result)) (not err))
+ (return result))))))
-;;;; support for dynamically loading foreign object files and
-;;;; resolving symbols therein
+;;;; Foreign symbol linkage
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB-ALIEN") ; (SB-ALIEN, not SB!ALIEN, since we're in warm load.)
+(in-package "SB!IMPL")
-;;; On any OS where we don't support foreign object file loading, any
-;;; query of a foreign symbol value is answered with "no definition
-;;; known", i.e. NIL.
-#-(or linux sunos FreeBSD OpenBSD NetBSD darwin)
-(defun get-dynamic-foreign-symbol-address (symbol)
- (declare (type simple-string symbol) (ignore symbol))
- nil)
+;;; *STATIC-FOREIGN-SYMBOLS* are static as opposed to "dynamic" (not
+;;; as opposed to C's "extern"). The table contains symbols known at
+;;; the time that the program was built, but not symbols defined in
+;;; object files which have been loaded dynamically since then.
+(declaim (type hash-table *static-foreign-symbols*))
+(defvar *static-foreign-symbols* (make-hash-table :test 'equal))
-;;; dlsym()-based implementation of GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS
-;;; and functions (e.g. LOAD-FOREIGN) which affect it. This should
-;;; work on any ELF system with dlopen(3) and dlsym(3)
-;;; It also works on OpenBSD, which isn't ELF, but is otherwise modern
-;;; enough to have a fairly well working dlopen/dlsym implementation.
-(macrolet ((define-unsupported-fun (fun-name &optional (error-message "unsupported on this system"))
- `(defun ,fun-name (&rest rest)
- ,error-message
- (declare (ignore rest))
- (error 'unsupported-operator :name ',fun-name))))
- #-(or linux sunos FreeBSD OpenBSD NetBSD darwin)
- (define-unsupported-fun load-shared-object)
- #+(or linux sunos FreeBSD OpenBSD NetBSD darwin)
- (progn
+(defun find-foreign-symbol-in-table (name table)
+ (some (lambda (prefix)
+ (gethash (concatenate 'string prefix name) table))
+ #("" "ldso_stub__")))
- (define-unsupported-fun load-foreign "Unsupported as of SBCL 0.8.13.")
- (define-unsupported-fun load-1-foreign "Unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT.")
+(defun foreign-symbol-address-as-integer-or-nil (name &optional datap)
+ (declare (ignorable datap))
+ (or (find-foreign-symbol-in-table name *static-foreign-symbols*)
+ #!+os-provides-dlopen
+ (progn
+ #-sb-xc-host
+ (values #!-linkage-table
+ (get-dynamic-foreign-symbol-address name)
+ #!+linkage-table
+ (ensure-foreign-symbol-linkage name datap)
+ t))))
-;;; a list of handles returned from dlopen(3) (or possibly some
-;;; bogus value temporarily during initialization)
- (defvar *handles-from-dlopen* nil)
+(defun foreign-symbol-address-as-integer (name &optional datap)
+ (or (foreign-symbol-address-as-integer-or-nil name datap)
+ (error "Unknown foreign symbol: ~S" name)))
-;;; Dynamically loaded stuff isn't there upon restoring from a save.
-;;; Clearing the variable this way was originally done primarily for
-;;; Irix, which resolves tzname at runtime, resulting in
-;;; *HANDLES-FROM-DLOPEN* (which was then called *TABLES-FROM-DLOPEN*)
-;;; being set in the saved core image, resulting in havoc upon
-;;; restart; but it seems harmless and tidy for other OSes too.
-;;;
-;;; Of course, it can be inconvenient that dynamically loaded stuff
-;;; goes away when we save and restore. However,
-;;; (1) trying to avoid it by system programming here could open a
-;;; huge can of worms, since e.g. now we would need to worry about
-;;; libraries possibly being in different locations (file locations
-;;; or memory locations) at restore time than at save time; and
-;;; (2) by the time the application programmer is so deep into the
-;;; the use of hard core extension features as to be doing
-;;; dynamic loading of foreign files and saving/restoring cores,
-;;; he probably has the sophistication to write his own after-save
-;;; code to reload the libraries without much difficulty.
+(defun foreign-symbol-address (symbol &optional datap)
+ (declare (ignorable datap))
+ (let ((name (sb!vm:extern-alien-name symbol)))
+ #!-linkage-table
+ (int-sap (foreign-symbol-address-as-integer name))
+ #!+linkage-table
+ (multiple-value-bind (addr sharedp)
+ (foreign-symbol-address-as-integer name datap)
+ #+sb-xc-host
+ (aver (not sharedp))
+ ;; If the address is from linkage-table and refers to data
+ ;; we need to do a bit of juggling.
+ (if (and sharedp datap)
+ ;; FIXME: 64bit badness here
+ (int-sap (sap-ref-32 (int-sap addr) 0))
+ (int-sap addr)))))
-;;; dan 2001.05.10 suspects that objection (1) is bogus for
-;;; dlsym()-enabled systems
+(defun foreign-reinit ()
+ #!+os-provides-dlopen
+ (reopen-shared-objects)
+ #!+linkage-table
+ (linkage-table-reinit))
- (push (lambda () (setq *handles-from-dlopen* nil))
- *after-save-initializations*)
+;;; Cleanups before saving a core
+(defun foreign-deinit ()
+ #!+(and os-provides-dlopen (not linkage-table))
+ (let ((shared (remove-if #'null (mapcar #'sb!alien::shared-object-file
+ *shared-objects*))))
+ (when shared
+ (warn "~@<Saving cores with shared objects loaded is unsupported on ~
+ this platform: calls to foreign functions in shared objects ~
+ from the restarted core will not work. You may be able to ~
+ work around this limitation by reloading all foreign definitions ~
+ and code using them in the restarted core, but no guarantees.~%~%~
+ Shared objects in this image:~% ~{~A~^, ~}~:@>"
+ shared)))
+ #!+os-provides-dlopen
+ (close-shared-objects))
- (define-alien-routine dlopen system-area-pointer
- (file c-string) (mode int))
-
- (define-alien-routine dlsym system-area-pointer
- (lib system-area-pointer) (name c-string))
-
- (define-alien-routine dlerror c-string)
-
-;;; Ensure that we've opened our own binary so we can dynamically resolve
-;;; symbols in the C runtime.
-;;;
-;;; Old comment: This used to happen only in
-;;; GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS, and only if no libraries were
-;;; dlopen()ed already, but that didn't work if something was
-;;; dlopen()ed before any problem global vars were used. So now we do
-;;; this in any function that can add to the *HANDLES-FROM-DLOPEN*, as
-;;; well as in GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS.
-;;;
-;;; FIXME: It would work just as well to do it once at startup, actually.
-;;; Then at least we know it's done. -dan 2001.05.10
- (defun ensure-runtime-symbol-table-opened ()
- (unless *handles-from-dlopen*
- ;; Prevent recursive call if dlopen() isn't defined.
- (setf *handles-from-dlopen* (int-sap 0))
- (setf *handles-from-dlopen* (list (dlopen nil rtld-lazy)))
- (when (zerop (sb-sys:sap-int (first *handles-from-dlopen*)))
- (error "can't open our own binary's symbol table: ~S" (dlerror)))))
+(defun foreign-symbol-in-address (sap)
+ (declare (ignorable sap))
+ #-sb-xc-host
+ (let ((addr (sap-int sap)))
+ (declare (ignorable addr))
+ #!+linkage-table
+ (when (<= sb!vm:linkage-table-space-start
+ addr
+ sb!vm:linkage-table-space-end)
+ (maphash (lambda (name info)
+ (let ((table-addr (linkage-info-address info)))
+ (when (<= table-addr
+ addr
+ (+ table-addr sb!vm:linkage-table-entry-size))
+ (return-from foreign-symbol-in-address name))))
+ *linkage-info*))
+ #!+os-provides-dladdr
+ (with-alien ((info (struct dl-info
+ (filename c-string)
+ (base unsigned)
+ (symbol c-string)
+ (symbol-address unsigned)))
+ (dladdr (function unsigned unsigned (* (struct dl-info)))
+ :extern "dladdr"))
+ (let ((err (alien-funcall dladdr addr (addr info))))
+ (if (zerop err)
+ nil
+ (slot info 'symbol))))
+ ;; FIXME: Even in the absence of dladdr we could search the
+ ;; static foreign symbols (and *linkage-info*, for that matter).
+ ))
- (defun load-shared-object (file)
- "Load a shared library/dynamic shared object file/general
- dlopenable alien container.
+;;; How we learn about foreign symbols and dlhandles initially
+(defvar *!initial-foreign-symbols*)
- To use LOAD-SHARED-OBJECT, at the Unix command line do this:
- echo 'int summish(int x, int y) { return 1 + x + y; }' > /tmp/ffi-test.c
- make /tmp/ffi-test.o # i.e. cc -c -o /tmp/ffi-test.o /tmp/ffi-test.c
- ld -shared -o /tmp/ffi-test.so /tmp/ffi-test.o
- then in SBCL do this:
- (LOAD-SHARED-OBJECT \"/tmp/ffi-test.so\")
- (DEFINE-ALIEN-ROUTINE SUMMISH INT (X INT) (Y INT))
- Now running (SUMMISH 10 20) should return 31.
-"
- (ensure-runtime-symbol-table-opened)
- ;; Note: We use RTLD-GLOBAL so that it can find all the symbols
- ;; previously loaded. We use RTLD-NOW so that dlopen() will fail if
- ;; not all symbols are defined.
- (let* ((real-file (or (unix-namestring file) file))
- (sap (dlopen real-file (logior rtld-now rtld-global))))
- (if (zerop (sap-int sap))
- (error "can't open object ~S: ~S" real-file (dlerror))
- (pushnew sap *handles-from-dlopen* :test #'sap=)))
- (values))
+(defun !foreign-cold-init ()
+ (dolist (symbol *!initial-foreign-symbols*)
+ (setf (gethash (car symbol) *static-foreign-symbols*) (cdr symbol)))
+ #!+os-provides-dlopen
+ (setf *runtime-dlhandle* (dlopen-or-lose nil)
+ *shared-objects* nil))
- (defun get-dynamic-foreign-symbol-address (symbol)
- (ensure-runtime-symbol-table-opened)
- ;; Find the symbol in any of the loaded object files. Search in
- ;; reverse order of loading, so that later loadings take precedence.
- ;;
- ;; FIXME: The way that we use PUSHNEW SAP in LOAD-SHARED-OBJECT means
- ;; that the list isn't guaranteed to be in reverse order of loading,
- ;; at least not if a file is loaded more than once. Is this the
- ;; right thing? (In what cases does it matter?)
- (dolist (handle (reverse *handles-from-dlopen*))
- ;; KLUDGE: We implicitly exclude the possibility that the variable
- ;; could actually be NULL, but the man page for dlsym(3)
- ;; recommends doing a more careful test. -- WHN 20000825
- (let ((possible-result (sap-int (dlsym handle symbol))))
- (unless (zerop possible-result)
- (return possible-result)))))
-
- #+os-provides-dladdr
- ;;; Override the early definition in target-load.lisp
- (defun foreign-symbol-in-address (sap)
- (let ((addr (sap-int sap)))
- (with-alien ((info
- (struct dl-info
- (filename c-string)
- (base unsigned)
- (symbol c-string)
- (symbol-address unsigned)))
- (dladdr
- (function unsigned
- unsigned (* (struct dl-info)))
- :extern "dladdr"))
- (let ((err (alien-funcall dladdr addr (addr info))))
- (if (zerop err)
- nil
- (values (slot info 'symbol)
- (slot info 'filename)
- addr
- (- addr (slot info 'symbol-address))))))))
-
- )) ; PROGN, MACROLET
+#!-os-provides-dlopen
+(define-unsupported-fun load-shared-object)
;;; allocated and never freed.)
(declaim (type unsigned-byte *n-bytes-freed-or-purified*))
(defvar *n-bytes-freed-or-purified* 0)
-(push (lambda ()
- (setf *n-bytes-freed-or-purified* 0))
- ;; KLUDGE: It's probably not quite safely right either to do
- ;; this in *BEFORE-SAVE-INITIALIZATIONS* (since consing, or even
- ;; worse, something which depended on (GET-BYTES-CONSED), might
- ;; happen after that) or in *AFTER-SAVE-INITIALIZATIONS*. But
- ;; it's probably not a big problem, and there seems to be no
- ;; other obvious time to do it. -- WHN 2001-07-30
- *after-save-initializations*)
+(defun gc-reinit ()
+ (gc-on)
+ (gc)
+ (setf *n-bytes-freed-or-purified* 0))
(declaim (ftype (function () unsigned-byte) get-bytes-consed))
(defun get-bytes-consed ()
--- /dev/null
+;;;; Linkage table specifics
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+;;;; Linkage table itself is a mmapped memory area in C-land, which is
+;;;; initialized by INIT-LINKAGE-TABLE once all shared objects have
+;;;; been reopened, based on the information stored in *LINKAGE-INFO*.
+;;;;
+;;;; For data entries the linkage table holds the real address
+;;;; of the foreign symbol, and for code the entries are jumps
+;;;; to the real addresses.
+
+(in-package "SB!IMPL")
+
+;;; Used to serialize modifications to *linkage-info* and the linkage-table
+;;; proper. Calls thru linkage-table are unaffected.
+(defvar *linkage-table-lock*
+ (sb!thread:make-mutex :name "linkage-table lock"))
+
+(define-alien-routine arch-write-linkage-table-jmp void
+ (table-address system-area-pointer)
+ (real-address system-area-pointer))
+
+(define-alien-routine arch-write-linkage-table-ref void
+ (table-address system-area-pointer)
+ (real-address system-area-pointer))
+
+(defvar *linkage-info* (make-hash-table :test 'equal))
+
+(defstruct linkage-info datap address)
+
+(defun write-linkage-table-entry (table-address real-address datap)
+ (/show0 "write-linkage-table-entry")
+ (let ((reloc (int-sap table-address))
+ (target (int-sap real-address)))
+ (if datap
+ (arch-write-linkage-table-ref reloc target)
+ (arch-write-linkage-table-jmp reloc target))))
+
+;;; Add the linkage information about a foreign symbol in the
+;;; persistent table, and write the linkage-table entry.
+(defun link-foreign-symbol (name datap)
+ (/show0 "link-foreign-symbol")
+ (let ((table-address (+ (* (hash-table-count *linkage-info*)
+ sb!vm:linkage-table-entry-size)
+ sb!vm:linkage-table-space-start))
+ (real-address (get-dynamic-foreign-symbol-address name)))
+ (when real-address
+ (unless (< table-address sb!vm:linkage-table-space-end)
+ (error "Linkage-table full (~D entries): cannot link ~S."
+ (hash-table-count *linkage-info*)
+ name))
+ (write-linkage-table-entry table-address real-address datap)
+ (setf (gethash name *linkage-info*)
+ (make-linkage-info :address table-address :datap datap)))))
+
+;;; Add a foreign linkage entry if none exists, return the address
+;;; in the linkage table.
+(defun ensure-foreign-symbol-linkage (name datap)
+ (/show0 "ensure-foreign-symbol-linkage")
+ (sb!thread:with-mutex (*linkage-table-lock*)
+ (let ((info (or (gethash name *linkage-info*)
+ (link-foreign-symbol name datap))))
+ (when info
+ (linkage-info-address info)))))
+
+;;; Initialize the linkage-table. Called during initialization after
+;;; all shared libraries have been reopened.
+(defun linkage-table-reinit ()
+ (/show0 "linkage-table-reinit")
+ ;; No locking here, as this should be done just once per image initialization,
+ ;; before any threads user are spawned.
+ (maphash (lambda (name info)
+ (let ((datap (linkage-info-datap info))
+ (table-address (linkage-info-address info))
+ (real-address (get-dynamic-foreign-symbol-address name)))
+ (cond (real-address
+ (write-linkage-table-entry table-address
+ real-address
+ datap))
+ (t
+ (/show0 "oops")
+ (cerror "Ignore. Attempts to access this foreign symbol ~
+ will lead to badness characterized by ~
+ segfaults, and potential corruption."
+ "Could not resolve foreign function ~S for ~
+ linkage-table." name)))))
+ *linkage-info*))
(defvar *software-version* nil)
+;;; FIXME: More duplicated logic here vrt. other oses. Abstract into
+;;; uname-software-version?
(defun software-version ()
#!+sb-doc
"Return a string describing version of the supporting software, or NIL
(sb!ext:run-program "/bin/uname" `("-r")
:output stream))))))
+;;; FIXME: This logic is duplicated in other backends:
+;;; abstract, abstract. OS-COMMON-COLD-INIT-OR-REINIT, mayhaps?
(defun os-cold-init-or-reinit () ; KLUDGE: don't know what to do here
(/show0 "entering linux-os.lisp OS-COLD-INIT-OR-REINIT")
(setf *software-version* nil)
;; that this would go away?
(fill *current-fop-table* nil))))
t)
-
-;;; This is used in in target-load and also genesis, using
-;;; *COLD-FOREIGN-SYMBOL-TABLE*. All the speculative prefix-adding
-;;; code for foreign symbol lookup should be here.
-(defun find-foreign-symbol-in-table (name table)
- (let ((prefixes
- #!+(or osf1 sunos linux freebsd netbsd darwin) #("" "ldso_stub__")
- #!+openbsd #("")))
- (declare (notinline some)) ; to suppress bug 117 bogowarning
- (some (lambda (prefix)
- (gethash (concatenate 'string prefix name)
- table
- nil))
- prefixes)))
\f
;;;; stuff for debugging/tuning by collecting statistics on FOPs (?)
0)
(1- max))))
(t nil)))
+
+;;; Helpers for defining error-signalling NOP's for "not supported
+;;; here" operations.
+(defmacro define-unsupported-fun (name &optional
+ (doc "Unsupported on this platform.")
+ (control
+ "~S is unsupported on this platform ~
+ (OS, CPU, whatever)."
+ controlp)
+ arguments)
+ `(defun ,name (&rest args)
+ ,doc
+ (declare (ignore args))
+ (error 'unsupported-operator
+ :format-control ,control
+ :format-arguments (if ,controlp ',arguments (list ',name)))))
;;; then load the old *OVERHEAD* value from the .core file into a
;;; different machine running at a different speed. We avoid this by
;;; erasing *CALL-OVERHEAD* whenever we save a .core file.
-(pushnew (lambda ()
- (without-package-locks
- (makunbound '*overhead*)))
- *before-save-initializations*)
+(defun profile-deinit ()
+ (without-package-locks
+ (makunbound '*overhead*)))
\f
;;;; SAVE-LISP-AND-DIE itself
-(sb!alien:define-alien-routine "save" (sb!alien:boolean)
- (file sb!alien:c-string)
- (initial-fun (sb!alien:unsigned #.sb!vm:n-word-bits)))
+(define-alien-routine "save" (boolean)
+ (file c-string)
+ (initial-fun (unsigned #.sb!vm:n-word-bits)))
;;; FIXME: When this is run without the PURIFY option,
;;; it seems to save memory all the way up to the high-water mark,
(environment-name "auxiliary"))
#!+sb-doc
"Save a \"core image\", i.e. enough information to restart a Lisp
- process later in the same state, in the file of the specified name.
+process later in the same state, in the file of the specified name.
- This implementation is not as polished and painless as you might like:
- * It corrupts the current Lisp image enough that the current process
- needs to be killed afterwards.
- * It will not work if multiple threads are in use.
- * There is absolutely no binary compatibility of core images between
- different runtime support programs. Even runtimes built from the same
- sources at different times are treated as incompatible for this purpose.
- This isn't because we like it this way, but just because there don't
- seem to be good quick fixes for either limitation and no one has been
- sufficiently motivated to do lengthy fixes.
+This implementation is not as polished and painless as you might
+like:
+ * It corrupts the current Lisp image enough that the current process
+ needs to be killed afterwards. This can be worked around by forking
+ another process that saves the core.
+ * It will not work if multiple threads are in use.
+ * There is absolutely no binary compatibility of core images between
+ different runtime support programs. Even runtimes built from the same
+ sources at different times are treated as incompatible for this
+ purpose.
+This isn't because we like it this way, but just because there don't
+seem to be good quick fixes for either limitation and no one has been
+sufficiently motivated to do lengthy fixes.
- The following &KEY arguments are defined:
- :TOPLEVEL
- The function to run when the created core file is resumed.
- The default function handles command line toplevel option
- processing and runs the top level read-eval-print loop. This
- function should not return.
- :PURIFY
- If true (the default), do a purifying GC which moves all dynamically
- allocated objects into static space so that they stay pure. This takes
- somewhat longer than the normal GC which is otherwise done, but it's
- only done once, and subsequent GC's will be done less often and will
- take less time in the resulting core file. See the PURIFY function.
- :ROOT-STRUCTURES
- This should be a list of the main entry points in any newly loaded
- systems. This need not be supplied, but locality and/or GC performance
- may be better if they are. Meaningless if :PURIFY is NIL. See the
- PURIFY function.
- :ENVIRONMENT-NAME
- This is also passed to the PURIFY function when :PURIFY is T.
- (rarely used)
+The following &KEY arguments are defined:
+ :TOPLEVEL
+ The function to run when the created core file is resumed. The
+ default function handles command line toplevel option processing
+ and runs the top level read-eval-print loop. This function should
+ not return.
+ :PURIFY
+ If true (the default), do a purifying GC which moves all
+ dynamically allocated objects into static space. This takes
+ somewhat longer than the normal GC which is otherwise done, but
+ it's only done once, and subsequent GC's will be done less often
+ and will take less time in the resulting core file. See the PURIFY
+ function.
+ :ROOT-STRUCTURES
+ This should be a list of the main entry points in any newly loaded
+ systems. This need not be supplied, but locality and/or GC performance
+ may be better if they are. Meaningless if :PURIFY is NIL. See the
+ PURIFY function.
+ :ENVIRONMENT-NAME
+ This is also passed to the PURIFY function when :PURIFY is T.
+ (rarely used)
- The save/load process changes the values of some global variables:
- *STANDARD-OUTPUT*, *DEBUG-IO*, etc.
- Everything related to open streams is necessarily changed, since
- the OS won't let us preserve a stream across save and load.
- *DEFAULT-PATHNAME-DEFAULTS*
- This is reinitialized to reflect the working directory where the
- saved core is loaded."
-
- (when (fboundp 'cancel-finalization)
- (cancel-finalization sb!sys:*tty*))
+The save/load process changes the values of some global variables:
+ *STANDARD-OUTPUT*, *DEBUG-IO*, etc.
+ Everything related to open streams is necessarily changed, since
+ the OS won't let us preserve a stream across save and load.
+ *DEFAULT-PATHNAME-DEFAULTS*
+ This is reinitialized to reflect the working directory where the
+ saved core is loaded."
+ (deinit)
;; FIXME: Would it be possible to unmix the PURIFY logic from this
;; function, and just do a GC :FULL T here? (Then if the user wanted
;; a PURIFYed image, he'd just run PURIFY immediately before calling
(if purify
(purify :root-structures root-structures
:environment-name environment-name)
- #!-gencgc (gc) #!+gencgc (gc :full t))
- ;; FIXME: Wouldn't it be more correct to go through this list backwards
- ;; instead of forwards?
- (dolist (f *before-save-initializations*)
- (funcall f))
+ #-gencgc (gc) #+gencgc (gc :full t))
(flet ((restart-lisp ()
(handling-end-of-the-world
- (reinit)
- (dolist (f *after-save-initializations*)
- (funcall f))
- (funcall toplevel))))
+ (reinit)
+ (funcall toplevel))))
;; FIXME: Perhaps WITHOUT-GCING should be wrapped around the
;; LET as well, to avoid the off chance of an interrupt triggering
;; GC and making our saved RESTART-LISP address invalid?
(without-gcing
- (save (unix-namestring core-file-name nil)
- (get-lisp-obj-address #'restart-lisp)))))
+ (save (unix-namestring core-file-name nil)
+ (get-lisp-obj-address #'restart-lisp)))))
+
+(defun deinit ()
+ (mapc #'funcall *save-hooks*)
+ (when (fboundp 'cancel-finalization)
+ (cancel-finalization sb!sys:*tty*))
+ (profile-deinit)
+ (debug-deinit)
+ (foreign-deinit))
(clear-info :variable :constant-value lisp-name)
(setf (info :variable :alien-info lisp-name)
(make-heap-alien-info :type type
- :sap-form `(foreign-symbol-address
- ',alien-name)))))
+ :sap-form `(foreign-symbol-address ',alien-name t)))))
(defmacro extern-alien (name type &environment env)
#!+sb-doc
"Access the alien variable named NAME, assuming it is of type TYPE. This
is SETFable."
- (let ((alien-name (etypecase name
- (symbol (guess-alien-name-from-lisp-name name))
- (string name))))
+ (let* ((alien-name (etypecase name
+ (symbol (guess-alien-name-from-lisp-name name))
+ (string name)))
+ (alien-type (parse-alien-type type env))
+ (datap (not (alien-fun-type-p alien-type))))
`(%heap-alien ',(make-heap-alien-info
- :type (parse-alien-type type env)
- :sap-form `(foreign-symbol-address ',alien-name)))))
+ :type alien-type
+ :sap-form `(foreign-symbol-address ',alien-name ,datap)))))
(defmacro with-alien (bindings &body body &environment env)
#!+sb-doc
(symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
binding
(/show symbol type opt1 opt2)
- (let ((alien-type (parse-alien-type type env)))
+ (let* ((alien-type (parse-alien-type type env))
+ (datap (not (alien-fun-type-p alien-type))))
(/show alien-type)
(multiple-value-bind (allocation initial-value)
(if opt2p
(let ((info (make-heap-alien-info
:type alien-type
:sap-form `(foreign-symbol-address
- ',initial-value))))
+ ',initial-value
+ ,datap))))
`((symbol-macrolet
((,symbol (%heap-alien ',info)))
,@body))))
(in-package "SB!IMPL")
\f
-;;;; variables related to saving core files
-;;;;
-;;;; (Most of the save-a-core functionality is defined later, in its
-;;;; own file, but we'd like to have these symbols declared special
-;;;; and initialized ASAP.)
+;;;; variables initialization and shutdown sequences
-(defvar *before-save-initializations* nil
+;; (Most of the save-a-core functionality is defined later, in its
+;; own file, but we'd like to have these symbols declared special
+;; and initialized ASAP.)
+(defvar *save-hooks* nil
#!+sb-doc
- "This is a list of functions which are called before creating a saved core
- image. These functions are executed in the child process which has no ports,
- so they cannot do anything that tries to talk to the outside world.")
+ "This is a list of functions which are called in an unspecified
+order before creating a saved core image. Unused by SBCL itself:
+reserved for user and applications.")
-(defvar *after-save-initializations* nil
+(defvar *init-hooks* nil
#!+sb-doc
- "This is a list of functions which are called when a saved core image starts
- up. The system itself should be initialized at this point, but applications
- might not be.")
+ "This is a list of functions which are called in an unspecified
+order when a saved core image starts up, after the system itself has
+been initialized. Unused by SBCL itself: reserved for user and
+applications.")
\f
;;; like LISTEN, but any whitespace in the input stream will be flushed
(defun listen-skip-whitespace (&optional (stream *standard-input*))
\f
;;;; linkage fixups
-;;; how we learn about assembler routines and foreign symbols at startup
+;;; how we learn about assembler routines at startup
(defvar *!initial-assembler-routines*)
-(defvar *!initial-foreign-symbols*)
+
(defun !loader-cold-init ()
+ (/show0 "/!loader-cold-init")
(dolist (routine *!initial-assembler-routines*)
- (setf (gethash (car routine) *assembler-routines*) (cdr routine)))
- (dolist (symbol *!initial-foreign-symbols*)
- (setf (gethash (car symbol) *static-foreign-symbols*) (cdr symbol))))
-
-(declaim (ftype (function (string) (unsigned-byte #.sb!vm:n-machine-word-bits))
- foreign-symbol-address-as-integer))
-
-
-;;; SB!SYS:GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS is in foreign.lisp, on
-;;; platforms that have dynamic loading
-(defun foreign-symbol-address-as-integer-or-nil (foreign-symbol)
- (or (find-foreign-symbol-in-table foreign-symbol *static-foreign-symbols*)
- (sb!sys:get-dynamic-foreign-symbol-address foreign-symbol)))
-
-(defun foreign-symbol-address-as-integer (foreign-symbol)
- (or (foreign-symbol-address-as-integer-or-nil foreign-symbol)
- (error "unknown foreign symbol: ~S" foreign-symbol)))
-
-(defun foreign-symbol-address (symbol)
- (int-sap (foreign-symbol-address-as-integer
- (sb!vm:extern-alien-name symbol))))
-
-;;; Overridden in foreign.lisp once we're running on target
-(defun foreign-symbol-in-address (sap)
- (declare (ignore sap)))
+ (setf (gethash (car routine) *assembler-routines*) (cdr routine))))
(defun enable-interrupt (signal handler)
(declare (type (or function fixnum (member :default :ignore)) handler))
+ (/show0 "enable-interrupt")
(without-gcing
(let ((result (install-handler signal
(case handler
"SRC;CODE;INSPECT"
"SRC;CODE;PROFILE"
"SRC;CODE;NTRACE"
- "SRC;CODE;FOREIGN"
"SRC;CODE;RUN-PROGRAM"
;; Code derived from PCL's pre-ANSI DESCRIBE-OBJECT
(dump-object name fasl-output))
(dump-fop 'fop-maybe-cold-load fasl-output)
(dump-fop 'fop-assembler-fixup fasl-output))
- (:foreign
+ ((:foreign :foreign-dataref)
(aver (stringp name))
- (dump-fop 'fop-foreign-fixup fasl-output)
+ (ecase flavor
+ (:foreign
+ (dump-fop 'fop-foreign-fixup fasl-output))
+ #!+linkage-table
+ (:foreign-dataref
+ (dump-fop 'fop-foreign-dataref-fixup fasl-output)))
(let ((len (length name)))
(aver (< len 256)) ; (limit imposed by fop definition)
(dump-byte len fasl-output)
(defknown sb!vm::push-word-on-c-stack (system-area-pointer) (values) (unsafe))
(defknown sb!vm::pop-words-from-c-stack (index) (values) ())
+#!+linkage-table
+(defknown foreign-symbol-dataref-address (simple-string)
+ system-area-pointer
+ (movable flushable))
+
+(defknown foreign-symbol-address (simple-string &optional boolean)
+ system-area-pointer
+ (movable flushable))
+
+(defknown foreign-symbol-address-as-integer (simple-string &optional boolean)
+ integer
+ (movable flushable))
+
;;;; miscellaneous internal utilities
(defknown %fun-name (function) t (flushable))
(error "undefined assembler routine: ~S" name)))
(:foreign
(aver (stringp name))
- (or (foreign-symbol-address-as-integer name)
- (error "unknown foreign symbol: ~S" name)))
+ ;; FOREIGN-SYMBOL-ADDRESS-AS-INTEGER signals an error
+ ;; if the symbol isn't found.
+ (foreign-symbol-address-as-integer name))
+ #!+linkage-table
+ (:foreign-dataref
+ (aver (stringp name))
+ (foreign-symbol-address-as-integer name t))
#!+x86
(:code-object
(aver (null name))
(defun cold-fdefinition-object (cold-name &optional leave-fn-raw)
(declare (type descriptor cold-name))
+ (/show0 "/cold-fdefinition-object")
(let ((warm-name (warm-fun-name cold-name)))
(or (gethash warm-name *cold-fdefn-objects*)
(let ((fdefn (allocate-boxed-object (or *cold-fdefn-gspace* *dynamic*)
sb!vm:fdefn-raw-addr-slot
(ecase type
(#.sb!vm:simple-fun-header-widetag
+ (/show0 "static-fset (simple-fun)")
#!+sparc
defn
#!-sparc
(ash sb!vm:simple-fun-code-offset
sb!vm:word-shift))))
(#.sb!vm:closure-header-widetag
+ (/show0 "/static-fset (closure)")
(make-random-descriptor
(cold-foreign-symbol-address-as-integer
(sb!vm:extern-alien-name "closure_tramp"))))))
(desired (sb!vm:static-fun-offset sym)))
(unless (= offset desired)
;; FIXME: should be fatal
- (warn "Offset from FDEFN ~S to ~S is ~W, not ~W."
- sym nil offset desired))))))
+ (error "Offset from FDEFN ~S to ~S is ~W, not ~W."
+ sym nil offset desired))))))
(defun list-all-fdefn-objects ()
(let ((result *nil-descriptor*))
(defvar *cold-foreign-symbol-table*)
(declaim (type hash-table *cold-foreign-symbol-table*))
-;;; Read the sbcl.nm file to find the addresses for foreign-symbols in
-;;; the C runtime.
+;; Read the sbcl.nm file to find the addresses for foreign-symbols in
+;; the C runtime.
(defun load-cold-foreign-symbol-table (filename)
+ (/show "load-cold-foreign-symbol-table" filename)
(with-open-file (file filename)
- (loop
- (let ((line (read-line file nil nil)))
- (unless line
- (return))
- ;; UNIX symbol tables might have tabs in them, and tabs are
- ;; not in Common Lisp STANDARD-CHAR, so there seems to be no
- ;; nice portable way to deal with them within Lisp, alas.
- ;; Fortunately, it's easy to use UNIX command line tools like
- ;; sed to remove the problem, so it's not too painful for us
- ;; to push responsibility for converting tabs to spaces out to
- ;; the caller.
- ;;
- ;; Other non-STANDARD-CHARs are problematic for the same reason.
- ;; Make sure that there aren't any..
- (let ((ch (find-if (lambda (char)
- (not (typep char 'standard-char)))
- line)))
- (when ch
- (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S"
- ch
- line)))
- (setf line (string-trim '(#\space) line))
- (let ((p1 (position #\space line :from-end nil))
- (p2 (position #\space line :from-end t)))
- (if (not (and p1 p2 (< p1 p2)))
- ;; KLUDGE: It's too messy to try to understand all
- ;; possible output from nm, so we just punt the lines we
- ;; don't recognize. We realize that there's some chance
- ;; that might get us in trouble someday, so we warn
- ;; about it.
- (warn "ignoring unrecognized line ~S in ~A" line filename)
- (multiple-value-bind (value name)
- (if (string= "0x" line :end2 2)
- (values (parse-integer line :start 2 :end p1 :radix 16)
- (subseq line (1+ p2)))
- (values (parse-integer line :end p1 :radix 16)
- (subseq line (1+ p2))))
- (multiple-value-bind (old-value found)
- (gethash name *cold-foreign-symbol-table*)
- (when (and found
- (not (= old-value value)))
- (warn "redefining ~S from #X~X to #X~X"
- name old-value value)))
- (setf (gethash name *cold-foreign-symbol-table*) value))))))
- (values)))
+ (loop for line = (read-line file nil nil)
+ while line do
+ ;; UNIX symbol tables might have tabs in them, and tabs are
+ ;; not in Common Lisp STANDARD-CHAR, so there seems to be no
+ ;; nice portable way to deal with them within Lisp, alas.
+ ;; Fortunately, it's easy to use UNIX command line tools like
+ ;; sed to remove the problem, so it's not too painful for us
+ ;; to push responsibility for converting tabs to spaces out to
+ ;; the caller.
+ ;;
+ ;; Other non-STANDARD-CHARs are problematic for the same reason.
+ ;; Make sure that there aren't any..
+ (let ((ch (find-if (lambda (char)
+ (not (typep char 'standard-char)))
+ line)))
+ (when ch
+ (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S"
+ ch
+ line)))
+ (setf line (string-trim '(#\space) line))
+ (let ((p1 (position #\space line :from-end nil))
+ (p2 (position #\space line :from-end t)))
+ (if (not (and p1 p2 (< p1 p2)))
+ ;; KLUDGE: It's too messy to try to understand all
+ ;; possible output from nm, so we just punt the lines we
+ ;; don't recognize. We realize that there's some chance
+ ;; that might get us in trouble someday, so we warn
+ ;; about it.
+ (warn "ignoring unrecognized line ~S in ~A" line filename)
+ (multiple-value-bind (value name)
+ (if (string= "0x" line :end2 2)
+ (values (parse-integer line :start 2 :end p1 :radix 16)
+ (subseq line (1+ p2)))
+ (values (parse-integer line :end p1 :radix 16)
+ (subseq line (1+ p2))))
+ (multiple-value-bind (old-value found)
+ (gethash name *cold-foreign-symbol-table*)
+ (when (and found
+ (not (= old-value value)))
+ (warn "redefining ~S from #X~X to #X~X"
+ name old-value value)))
+ (/show "adding to *cold-foreign-symbol-table*:" name value)
+ (setf (gethash name *cold-foreign-symbol-table*) value))))))
+ (values)) ;; PROGN
(defun cold-foreign-symbol-address-as-integer (name)
(or (find-foreign-symbol-in-table name *cold-foreign-symbol-table*)
;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to
;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in
;;; target-load.lisp refers to.
-(defun linkage-info-to-core ()
+(defun foreign-symbols-to-core ()
(let ((result *nil-descriptor*))
(maphash (lambda (symbol value)
(cold-push (cold-cons (string-to-core symbol)
(number-to-core value))
result))
*cold-foreign-symbol-table*)
- (cold-set (cold-intern '*!initial-foreign-symbols*) result))
+ (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result))
(let ((result *nil-descriptor*))
(dolist (rtn *cold-assembler-routines*)
(cold-push (cold-cons (cold-intern (car rtn))
(number-to-core (cdr rtn)))
result))
(cold-set (cold-intern '*!initial-assembler-routines*) result)))
+
\f
;;;; general machinery for cold-loading FASL files
sb!vm:array-elements-slot
(make-fixnum-descriptor total-elements)))
result))
+
\f
;;;; cold fops for loading numbers
(let ((offset (read-word-arg))
(value (cold-foreign-symbol-address-as-integer sym)))
(do-cold-fixup code-object offset value kind))
- code-object))
+ code-object))
+
+(define-cold-fop (fop-foreign-dataref-fixup)
+ (let* ((kind (pop-stack))
+ (code-object (pop-stack))
+ (len (read-byte-arg))
+ (sym (make-string len)))
+ (read-string-as-bytes *fasl-input-stream* sym)
+ (maphash (lambda (k v)
+ (format *error-output* "~&~S = #X~8X~%" k v))
+ *cold-foreign-symbol-table*)
+ (error "shared foreign symbol in cold load: ~S (~S)" sym kind)))
(define-cold-fop (fop-assembler-code)
(let* ((length (read-word-arg))
(maybe-record-with-munged-name "-TRAP" "trap_" 3)
(maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4)
(maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5)
- (maybe-record-with-translated-name '("-START" "-END") 6)
+ (maybe-record-with-translated-name '("-START" "-END" "-SIZE") 6)
(maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 7)
(maybe-record-with-translated-name '("-CORE-SPACE-ID") 8))))))
;; KLUDGE: these constants are sort of important, but there's no
map-file-name
c-header-dir-name)
- (when (and core-file-name
- (not symbol-table-file-name))
- (error "can't output a core file without symbol table file input"))
-
(format t
"~&beginning GENESIS, ~A~%"
(if core-file-name
;; create a core.
(format nil "creating core ~S" core-file-name)
(format nil "creating headers in ~S" c-header-dir-name)))
- (let* ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
+
+ (let ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
- ;; Read symbol table, if any.
- (when symbol-table-file-name
- (load-cold-foreign-symbol-table symbol-table-file-name))
+ (when core-file-name
+ (if symbol-table-file-name
+ (load-cold-foreign-symbol-table symbol-table-file-name)
+ (error "can't output a core file without symbol table file input")))
;; Now that we've successfully read our only input file (by
;; loading the symbol table, if any), it's a good time to ensure
;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
(resolve-assembler-fixups)
#!+x86 (output-load-time-code-fixups)
- (linkage-info-to-core)
+ (foreign-symbols-to-core)
(finish-symbols)
(/show "back from FINISH-SYMBOLS")
(finalize-load-time-value-noise)
\f
;;;; DEFKNOWNs
-(defknown foreign-symbol-address (simple-string) system-area-pointer
- (movable flushable))
+#!+linkage-table
+(deftransform foreign-symbol-address-as-integer ((symbol &optional datap)
+ (simple-string boolean))
+ (if (and (constant-lvar-p symbol) (constant-lvar-p datap))
+ `(sap-int (foreign-symbol-address symbol datap))
+ (give-up-ir1-transform)))
+
+(deftransform foreign-symbol-address ((symbol &optional datap)
+ (simple-string &optional boolean))
+ #!-linkage-table
+ (if (null datap)
+ (give-up-ir1-transform)
+ `(foreign-symbol-address symbol))
+ #!+linkage-table
+ (if (and (constant-lvar-p symbol) (constant-lvar-p datap))
+ (let ((name (lvar-value symbol))
+ (datap (lvar-value datap)))
+ (if (or #+sb-xc-host t ; only static symbols on host
+ (not datap)
+ (find-foreign-symbol-in-table name *static-foreign-symbols*))
+ `(foreign-symbol-address ,name) ; VOP
+ `(foreign-symbol-dataref-address ,name))) ; VOP
+ (give-up-ir1-transform)))
(defknown (sap< sap<= sap= sap>= sap>)
(system-area-pointer system-area-pointer) boolean
,@(new-args))))))
(sb!c::give-up-ir1-transform))))
-
(define-vop (foreign-symbol-address)
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
- (:arg-types (:constant simple-base-string))
+ (:arg-types (:constant simple-string))
+ (:info foreign-symbol)
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:generator 2
+ (inst li res (make-fixup (extern-alien-name foreign-symbol)
+ :foreign))))
+
+#!+linkage-table
+(define-vop (foreign-symbol-dataref-address)
+ (:translate foreign-symbol-dataref-address)
+ (:policy :fast-safe)
+ (:args)
+ (:arg-types (:constant simple-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
+ (:temporary (:scs (non-descriptor-reg)) addr)
(:generator 2
- (inst li res (make-fixup (extern-alien-name foreign-symbol)
- :foreign))))
+ (inst li addr (make-fixup (extern-alien-name foreign-symbol)
+ :foreign-dataref))
+ (loadw res addr)))
(define-vop (call-out)
(:args (function :scs (sap-reg) :target cfunc)
;;; Where to put the different spaces. Must match the C code!
#!+linux
(progn
- (def!constant read-only-space-start #x10000000)
- (def!constant read-only-space-end #x15000000)
+ (def!constant linkage-table-space-start #x0f800000)
+ (def!constant linkage-table-space-end #x10000000)
+
+ (def!constant read-only-space-start #x10000000)
+ (def!constant read-only-space-end #x15000000)
- (def!constant static-space-start #x28000000)
- (def!constant static-space-end #x2c000000)
+ (def!constant static-space-start #x28000000)
+ (def!constant static-space-end #x2c000000)
;; From alpha/parms.lisp:
;; this is used in PURIFY as part of a sloppy check to see if a pointer
(def!constant dynamic-space-start #x30000000)
(def!constant dynamic-space-end #x38000000)
- (def!constant dynamic-0-space-start #x30000000)
- (def!constant dynamic-0-space-end #x38000000)
+ (def!constant dynamic-0-space-start #x30000000)
+ (def!constant dynamic-0-space-end #x38000000)
- (def!constant dynamic-1-space-start #x40000000)
- (def!constant dynamic-1-space-end #x48000000))
+ (def!constant dynamic-1-space-start #x40000000)
+ (def!constant dynamic-1-space-end #x48000000))
#!+sunos ; might as well start by trying the same numbers
(progn
- (def!constant read-only-space-start #x10000000)
- (def!constant read-only-space-end #x15000000)
+ (def!constant linkage-table-space-start #x0f800000)
+ (def!constant linkage-table-space-end #x10000000)
+
+ (def!constant read-only-space-start #x10000000)
+ (def!constant read-only-space-end #x15000000)
- (def!constant static-space-start #x28000000)
- (def!constant static-space-end #x2c000000)
+ (def!constant static-space-start #x28000000)
+ (def!constant static-space-end #x2c000000)
- (def!constant dynamic-space-start #x30000000)
- (def!constant dynamic-space-end #x38000000)
+ (def!constant dynamic-space-start #x30000000)
+ (def!constant dynamic-space-end #x38000000)
- (def!constant dynamic-0-space-start #x30000000)
- (def!constant dynamic-0-space-end #x38000000)
+ (def!constant dynamic-0-space-start #x30000000)
+ (def!constant dynamic-0-space-end #x38000000)
- (def!constant dynamic-1-space-start #x40000000)
- (def!constant dynamic-1-space-end #x48000000))
+ (def!constant dynamic-1-space-start #x40000000)
+ (def!constant dynamic-1-space-end #x48000000))
+
+;; Size of one linkage-table entry in bytes. See comment in
+;; src/runtime/sparc-arch.c
+(def!constant linkage-table-entry-size 16)
\f
;;;; other random constants.
(setf *assembler-routines-by-addr*
(invert-address-hash sb!fasl:*assembler-routines*))
(setf *assembler-routines-by-addr*
- (invert-address-hash sb!fasl:*static-foreign-symbols*
+ (invert-address-hash sb!sys:*static-foreign-symbols*
*assembler-routines-by-addr*)))
(gethash address *assembler-routines-by-addr*))
\f
(declare (type disassem-state dstate))
(unless (typep address 'address)
(return-from maybe-note-assembler-routine nil))
- (let ((name (find-assembler-routine address)))
+ (let ((name (or
+ #!+linkage-table
+ (sb!sys:foreign-symbol-in-address (sb!sys:int-sap address))
+ (find-assembler-routine address))))
(unless (null name)
(note (lambda (stream)
(if note-address-p
,@(new-args))))))
(sb!c::give-up-ir1-transform))))
-
-
-
(define-vop (foreign-symbol-address)
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:generator 2
(inst lea res (make-fixup (extern-alien-name foreign-symbol) :foreign))))
+#!+linkage-table
+(define-vop (foreign-symbol-dataref-address)
+ (:translate foreign-symbol-dataref-address)
+ (:policy :fast-safe)
+ (:args)
+ (:arg-types (:constant simple-string))
+ (:info foreign-symbol)
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:generator 2
+ (inst mov res (make-fixup (extern-alien-name foreign-symbol) :foreign-dataref))))
+
(define-vop (call-out)
(:args (function :scs (sap-reg))
(args :more t))
#!+linux
(progn
+ (def!constant read-only-space-start #x01000000)
+ (def!constant read-only-space-end #x037ff000)
- (def!constant read-only-space-start #x01000000)
- (def!constant read-only-space-end #x037ff000)
+ (def!constant static-space-start #x05000000)
+ (def!constant static-space-end #x07fff000)
- (def!constant static-space-start #x05000000)
- (def!constant static-space-end #x07fff000)
+ (def!constant dynamic-space-start #x09000000)
+ (def!constant dynamic-space-end #x29000000)
- (def!constant dynamic-space-start #x09000000)
- (def!constant dynamic-space-end #x29000000))
+ (def!constant linkage-table-space-start #x70000000)
+ (def!constant linkage-table-space-end #x7ffff000))
-#!+(or freebsd openbsd)
+#!+freebsd
(progn
+ (def!constant read-only-space-start #x10000000)
+ (def!constant read-only-space-end #x1ffff000)
- (def!constant read-only-space-start
- #!+freebsd #x10000000
- #!+openbsd #x40000000)
- (def!constant read-only-space-end
- #!+freebsd #x1ffff000
- #!+openbsd #x47fff000)
-
- (def!constant static-space-start
- #!+freebsd #x30000000
- #!+openbsd #x50000000)
- (def!constant static-space-end
- #!+freebsd #x37fff000
- #!+openbsd #x5ffff000)
-
- (def!constant dynamic-space-start
- #!+freebsd #x48000000
- #!+openbsd #x80000000)
- (def!constant dynamic-space-end
- #!+freebsd #x88000000
- #!+openbsd #xA0000000))
+ (def!constant static-space-start #x30000000)
+ (def!constant static-space-end #x37fff000)
+
+ (def!constant dynamic-space-start #x48000000)
+ (def!constant dynamic-space-end #x88000000)
+
+ ;; In CMUCL: 0xB0000000->0xB1000000
+ (def!constant linkage-table-space-start #x90000000)
+ (def!constant linkage-table-space-end #x91000000))
+
+#!+openbsd
+(progn
+ (def!constant read-only-space-start #x40000000)
+ (def!constant read-only-space-end #x47fff000)
+
+ (def!constant static-space-start #x50000000)
+ (def!constant static-space-end #x5ffff000)
+
+ (def!constant dynamic-space-start #x80000000)
+ (def!constant dynamic-space-end #xA0000000)
+
+ ;; In CMUCL: 0xB0000000->0xB1000000
+ (def!constant linkage-table-space-start #xA0000000)
+ (def!constant linkage-table-space-end #xA1000000))
#!+netbsd
(progn
+ (def!constant read-only-space-start #x20000000)
+ (def!constant read-only-space-end #x2ffff000)
- (def!constant read-only-space-start #x20000000)
- (def!constant read-only-space-end #x2ffff000)
+ (def!constant static-space-start #x30000000)
+ (def!constant static-space-end #x37fff000)
- (def!constant static-space-start #x30000000)
- (def!constant static-space-end #x37fff000)
+ (def!constant dynamic-space-start #x60000000)
+ (def!constant dynamic-space-end #x98000000)
- (def!constant dynamic-space-start #x60000000)
- (def!constant dynamic-space-end #x98000000))
+ ;; In CMUCL: 0xB0000000->0xB1000000
+ (def!constant linkage-table-space-start #xA0000000)
+ (def!constant linkage-table-space-end #xA1000000))
+;;; Size of one linkage-table entry in bytes.
+(def!constant linkage-table-entry-size 8)
;;; Given that NIL is the first thing allocated in static space, we
;;; know its value at compile time:
;; FIXME: In SBCL, the CLOS code has become sufficiently tightly
;; integrated into the system that it'd probably make sense to use
;; the ordinary unbound marker for this.
- sb!pcl::..slot-unbound..))
+ sb!pcl::..slot-unbound..
+ ))
(defparameter *static-funs*
'(length
return call_into_lisp(function, args, 3);
}
+#ifdef LISP_FEATURE_LINKAGE_TABLE
+
+/* This a naive port from CMUCL/sparc, which was mostly stolen from the
+ * CMUCL/x86 version, with adjustments for sparc
+ *
+ * Linkage entry size is 16, because we need at least 3 instruction to
+ * implement a jump:
+ *
+ * sethi %hi(addr), %g4
+ * jmpl [%g4 + %lo(addr)], %g5
+ * nop
+ *
+ * The Sparc V9 ABI seems to use 8 words for its jump tables. Maybe
+ * we should do the same?
+ */
+
+/*
+ * Define the registers to use in the linkage jump table. Can be the
+ * same. Some care must be exercised when choosing these. It has to be
+ * a register that is not otherwise being used. reg_L0 is a good
+ * choice. call_into_c trashes reg_L0 without preserving it, so we can
+ * trash it in the linkage jump table.
+ */
+#define LINKAGE_TEMP_REG reg_L0
+#define LINKAGE_ADDR_REG reg_L0
+
+/*
+ * Insert the necessary jump instructions at the given address.
+ */
+void
+arch_write_linkage_table_jmp(void* reloc_addr, void *target_addr)
+{
+ /*
+ * Make JMP to function entry.
+ *
+ * The instruction sequence is:
+ *
+ * sethi %hi(addr), temp_reg
+ * jmp %temp_reg + %lo(addr), %addr_reg
+ * nop
+ * nop
+ *
+ */
+ int* inst_ptr;
+ unsigned long hi; /* Top 22 bits of address */
+ unsigned long lo; /* Low 10 bits of address */
+ unsigned int inst;
+
+ inst_ptr = (int*) reloc_addr;
+
+ /*
+ * Split the target address into hi and lo parts for the sethi
+ * instruction. hi is the top 22 bits. lo is the low 10 bits.
+ */
+ hi = (unsigned long) target_addr;
+ lo = hi & 0x3ff;
+ hi >>= 10;
+
+ /*
+ * sethi %hi(addr), temp_reg
+ */
+
+ inst = (0 << 30) | (LINKAGE_TEMP_REG << 25) | (4 << 22) | hi;
+ *inst_ptr++ = inst;
+
+ /*
+ * jmpl [temp_reg + %lo(addr)], addr_reg
+ */
+
+ inst = (2U << 30) | (LINKAGE_ADDR_REG << 25) | (0x38 << 19)
+ | (LINKAGE_TEMP_REG << 14) | (1 << 13) | lo;
+ *inst_ptr++ = inst;
+
+ /* nop (really sethi 0, %g0) */
+
+ inst = (0 << 30) | (0 << 25) | (4 << 22) | 0;
+
+ *inst_ptr++ = inst;
+ *inst_ptr++ = inst;
+
+ os_flush_icache((os_vm_address_t) reloc_addr, (char*) inst_ptr - (char*) reloc_addr);
+}
+
+void
+arch_write_linkage_table_ref(void * reloc_addr, void *target_addr)
+{
+ *(unsigned long *)reloc_addr = (unsigned long)target_addr;
+}
+
+#endif
ret
nop
+/* Lisp calling convention. notice the first .byte line.
+ */
.global undefined_tramp
FUNCDEF(undefined_tramp)
.align 8
jmp reg_CODE+SIMPLE_FUN_CODE_OFFSET
nop
+/* Lisp calling convention. Notice the first .byte line.
+ */
.global closure_tramp
FUNCDEF(closure_tramp)
.align 8
ta ST_FLUSH_WINDOWS ! flush register windows
retl ! return from leaf routine
nop
-
ensure_space( (lispobj *)DYNAMIC_1_SPACE_START , DYNAMIC_SPACE_SIZE);
#endif
+#ifdef LISP_FEATURE_LINKAGE_TABLE
+ ensure_space( (lispobj *)LINKAGE_TABLE_SPACE_START, LINKAGE_TABLE_SPACE_SIZE);
+#endif
+
#ifdef PRINTNOISE
printf(" done.\n");
#endif
#define STATIC_SPACE_SIZE ( STATIC_SPACE_END - STATIC_SPACE_START)
#define THREAD_CONTROL_STACK_SIZE (2*1024*1024) /* eventually this'll be choosable per-thread */
+#ifdef LISP_FEATURE_LINKAGE_TABLE
+#define LINKAGE_TABLE_SPACE_SIZE (LINKAGE_TABLE_SPACE_END - LINKAGE_TABLE_SPACE_START)
+#endif
+
#if !defined(LANGUAGE_ASSEMBLY)
#include <thread.h>
#ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
args[2] = arg2;
return call_into_lisp(function, args, 3);
}
+
+#ifdef LISP_FEATURE_LINKAGE_TABLE
+/* FIXME: It might be cleaner to generate these from the lisp side of
+ * things.
+ */
+
+void
+arch_write_linkage_table_jmp(char * reloc, void * fun)
+{
+ /* Make JMP to function entry. JMP offset is calculated from next
+ * instruction.
+ */
+ long offset = (char *)fun - (reloc + 5);
+ int i;
+
+ *reloc++ = 0xe9; /* opcode for JMP rel32 */
+ for (i = 0; i < 4; i++) {
+ *reloc++ = offset & 0xff;
+ offset >>= 8;
+ }
+
+ /* write a nop for good measure. */
+ *reloc = 0x90;
+}
+
+void
+arch_write_linkage_table_ref(void * reloc, void * data)
+{
+ *(unsigned long *)reloc = (unsigned long)data;
+}
+
+#endif
echo //entering foreign.test.sh
+# simple way to make sure we're not punting by accident:
+# setting PUNT to anything other than 104 will make non-dlopen
+# and non-linkage-table platforms fail this
+PUNT=104
+
testfilestem=${TMPDIR:-/tmp}/sbcl-foreign-test-$$
# Make a little shared object file to test with.
echo 'int summish(int x, int y) { return 1 + x + y; }' > $testfilestem.c
+echo 'int numberish = 42;' >> $testfilestem.c
+echo 'int nummish(int x) { return numberish + x; }' >> $testfilestem.c
cc -c $testfilestem.c -o $testfilestem.o
ld -shared -o $testfilestem.so $testfilestem.o
-# Test interaction with the shared object file.
-${SBCL:-sbcl} <<EOF
+# Foreign definitions & load
+cat > $testfilestem.deflisp <<EOF
(define-alien-variable environ (* c-string))
(defvar *environ* environ)
(handler-case
;; At least as of sbcl-0.7.0.5, LOAD-SHARED-OBJECT isn't
;; supported on every OS. In that case, there's nothing to test,
;; and we can just fall through to success.
- (sb-ext:quit :unix-status 52))) ; success convention for Lisp program
+ (sb-ext:quit :unix-status 22))) ; catch that
+ (define-alien-routine summish int (x int) (y int))
+ (define-alien-variable numberish int)
+ (define-alien-routine nummish int (x int))
+
;; Test that loading an object file didn't screw up our records
;; of variables visible in runtime. (This was a bug until
;; Nikodemus Siivola's patch in sbcl-0.8.5.50.)
+ ;;
+ ;; This cannot be tested in a saved core, as there is no guarantee
+ ;; that the location will be the same.
(assert (= (sb-sys:sap-int (alien-sap *environ*))
(sb-sys:sap-int (alien-sap environ))))
- (define-alien-routine summish int (x int) (y int))
+EOF
+
+# Test code
+cat > $testfilestem.testlisp <<EOF
(assert (= (summish 10 20) 31))
+ (assert (= 42 numberish))
+ (setf numberish 13)
+ (assert (= 13 numberish))
+ (assert (= 14 (nummish 1)))
(sb-ext:quit :unix-status 52) ; success convention for Lisp program
EOF
+
+${SBCL:-sbcl} --load $testfilestem.deflisp --load $testfilestem.testlisp
+if [ $? = 22 ]; then
+ rm $testfilestem.*
+ exit $PUNT # success -- load-shared-object not supported
+elif [ $? != 52]; then
+ rm $testfilestem.*
+ echo test failed: $?
+ exit 1
+fi
+
+${SBCL:-sbcl} --load $testfilestem.deflisp --eval "(when (member :linkage-table *features*) (save-lisp-and-die \"$testfilestem.core\"))" <<EOF
+ (sb-ext:quit :unix-status 22) ; catch this
+EOF
+if [ $? = 22 ]; then
+ rm $testfilestem.*
+ exit $PUNT # success -- linkage-table not available
+fi
+
+$SBCL_ALLOWING_CORE --core $testfilestem.core --load $testfilestem.testlisp
if [ $? != 52 ]; then
+ rm $testfilestem.*
echo test failed: $?
- exit 1
+ exit 1 # Failure
fi
-echo //cleanup: removing $testfilestem.*
rm $testfilestem.*
# success convention for script
# provided with absolutely no warranty. See the COPYING and CREDITS
# files for more information.
--include ../src/runtime/Config
+-include Config
-CPPFLAGS=-I../src/runtime
+CPPFLAGS:=-I../src/runtime
+LDFLAGS:=$(LDFLAGS) $(OS_LIBS)
all: grovel-headers determine-endianness where-is-mcontext modify-ldt-struct-name
# Automated platform feature testing
-
-DIR=tools-for-build
+cd tools-for-build
# FIXME: Use this to test for dlopen presence and hence
# load-shared-object buildability
-# $1 feature
-# $2 additional flags
-#
# Assumes the presence of $1-test.c, which when built and
# run should return with 104 if the feature is present.
-#
featurep() {
- bin="$DIR/$1-test"
+ bin="$1-test"
rm -f $bin
- cc $DIR/$1-test.c $2 -o $bin > /dev/null 2>&1 && $bin > /dev/null 2>&1
+ $GNUMAKE $bin -I ../src/runtime > /dev/null 2>&1 && ./$bin > /dev/null 2>&1
if [ "$?" = 104 ]
then
printf " :$1"
rm -f $bin
}
-featurep os-provides-dladdr -ldl
+# KLUDGE: ppc/darwin dlopen is special cased in make-config.sh, as
+# we fake it with a shim.
+featurep os-provides-dlopen
+
+featurep os-provides-dladdr
--- /dev/null
+/* test to build and run so that we know if we have dlopen
+ */
+
+#include <dlfcn.h>
+
+int main ()
+{
+ void * handle = dlopen((void*)0, RTLD_GLOBAL | RTLD_NOW);
+ void * addr = dlsym(handle, "printf");
+ if (addr) {
+ return 104;
+ } else {
+ return 0;
+ }
+}
TMP=sparc-funcdef.S
-SUN_FUNCDEF="#define FUNCDEF(x) .type x,#function"
+SUN_FUNCDEF="#define FUNCDEF(x) .type x, #function"
GNU_FUNCDEF="#define FUNCDEF(x) .type x,@function"
echo $SUN_FUNCDEF > $TMP
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.14.4"
+"0.8.14.5"
projects / sbcl.git / commitdiff