From: Nikodemus Siivola Date: Thu, 9 Sep 2004 12:10:11 +0000 (+0000) Subject: 0.8.14.5: Join the foreign legion! X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=75b52379bdc2269961af6a1308eca63610f38ac3;p=sbcl.git 0.8.14.5: Join the foreign legion! * x86/FreeBSD, x86/Linux and Sparc/SunOS now have linkage-table support, allowing SAVE-LISP-AND-DIE to function properly in the presence of loaded shared objects. * As a related cleanup automate testing for dlopen support on the plaform, and conditionalize LOAD-SHARED-OBJECT support on the resulting :os-provides-dlopen feature. --- diff --git a/CREDITS b/CREDITS index cbde409..d93bbae 100644 --- a/CREDITS +++ b/CREDITS @@ -627,6 +627,10 @@ Gerd Moellman: 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 @@ -670,8 +674,8 @@ Rudi Schlatte: 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 @@ -687,7 +691,7 @@ Brian Spilsbury: 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 diff --git a/NEWS b/NEWS index 3c77c9d..eb417ce 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,11 @@ 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) diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 7a25279..3d7eb1e 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -455,6 +455,10 @@ ("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") diff --git a/contrib/sb-bsd-sockets/sockopt.lisp b/contrib/sb-bsd-sockets/sockopt.lisp index 3eb9398..88e83b6 100644 --- a/contrib/sb-bsd-sockets/sockopt.lisp +++ b/contrib/sb-bsd-sockets/sockopt.lisp @@ -58,7 +58,9 @@ Code for options that not every system has should be conditionalised: (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)) @@ -72,7 +74,9 @@ Code for options that not every system has should be conditionalised: `(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 diff --git a/contrib/sb-posix/macros.lisp b/contrib/sb-posix/macros.lisp index 248db20..5cfa2e9 100644 --- a/contrib/sb-posix/macros.lisp +++ b/contrib/sb-posix/macros.lisp @@ -47,8 +47,7 @@ (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) diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index 97231fe..b4606f5 100644 --- a/doc/manual/beyond-ansi.texinfo +++ b/doc/manual/beyond-ansi.texinfo @@ -112,9 +112,12 @@ the @code{inspect} prompt. 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?} diff --git a/make-config.sh b/make-config.sh index aba3e2a..c1d49be 100644 --- a/make-config.sh +++ b/make-config.sh @@ -161,6 +161,20 @@ case `uname` in 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 @@ -169,20 +183,29 @@ cd $original_dir # 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 @@ -196,11 +219,15 @@ elif [ "$sbcl_arch" = "sparc" ]; 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 diff --git a/make-target-contrib.sh b/make-target-contrib.sh index d541ea9..96ea610 100644 --- a/make-target-contrib.sh +++ b/make-target-contrib.sh @@ -13,6 +13,9 @@ # 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 diff --git a/make.sh b/make.sh index f2e259b..fb7ce14 100755 --- a/make.sh +++ b/make.sh @@ -109,11 +109,16 @@ time sh make-target-contrib.sh || exit 1 # 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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index a611ff5..28ee3c8 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -56,7 +56,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "ENUM" "EXTERN-ALIEN" "FREE-ALIEN" "GET-ERRNO" - "INT" + "INT" "LOAD-1-FOREIGN" "LOAD-FOREIGN" "LOAD-SHARED-OBJECT" "LONG" "MAKE-ALIEN" "NULL-ALIEN" @@ -360,7 +360,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" 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*" @@ -519,7 +519,6 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "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 @@ -552,6 +551,9 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "*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*" @@ -735,10 +737,7 @@ Lisp extension proposal by David N. Gray" 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 @@ -785,6 +784,7 @@ retained, possibly temporariliy, because it might be used internally." ;; and cross-compiling "DEFMACRO-MUNDANELY" "DEFCONSTANT-EQX" + "DEFINE-UNSUPPORTED-FUN" ;; messing with PATHNAMEs "MAKE-TRIVIAL-DEFAULT-PATHNAME" @@ -1439,21 +1439,25 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "!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 @@ -1733,7 +1737,11 @@ SB-KERNEL) have been undone, but probably more remain." ;; 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*" @@ -1741,14 +1749,20 @@ SB-KERNEL) have been undone, but probably more remain." "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" @@ -1760,6 +1774,7 @@ SB-KERNEL) have been undone, but probably more remain." "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" @@ -2124,6 +2139,9 @@ structure representations" "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" diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 9757734..222256e 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -214,7 +214,9 @@ (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 @@ -263,9 +265,9 @@ (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 @@ -298,8 +300,9 @@ instead (which is another name for the same thing).")) (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*)) ;;;; some support for any hapless wretches who end up debugging cold ;;;; init code diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 7d3f7a7..1ade61d 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -775,12 +775,8 @@ ;;; 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) ()) + ;;; (:ansi-cl :function remove) ;;; (:ansi-cl :section (a b c)) diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 320c7c3..d839476 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -780,10 +780,10 @@ (#.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 @@ -832,7 +832,8 @@ "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")) @@ -877,7 +878,8 @@ (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")) @@ -3265,6 +3267,8 @@ register." ;;; 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")) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 1ec043b..dd34fc4 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -1502,10 +1502,11 @@ reset to ~S." (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 diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index 029d24a..9e95f1c 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -121,16 +121,9 @@ ;;; 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)) + ;;;; the FOP database diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 74b5984..ea97330 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -629,6 +629,12 @@ bug.~:@>") ;;;; 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)) @@ -641,12 +647,6 @@ bug.~:@>") 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)) @@ -666,3 +666,16 @@ bug.~:@>") (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)) diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp new file mode 100644 index 0000000..62ae303 --- /dev/null +++ b/src/code/foreign-load.lisp @@ -0,0 +1,110 @@ +;;;; 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)))))) diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index 3102c08..3456a8a 100644 --- a/src/code/foreign.lisp +++ b/src/code/foreign.lisp @@ -1,5 +1,4 @@ -;;;; 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. @@ -10,152 +9,116 @@ ;;;; 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 "~@" + 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) diff --git a/src/code/gc.lisp b/src/code/gc.lisp index db65ac7..98c4e4c 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -120,15 +120,10 @@ ;;; 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 () diff --git a/src/code/linkage-table.lisp b/src/code/linkage-table.lisp new file mode 100644 index 0000000..49bf3ba --- /dev/null +++ b/src/code/linkage-table.lisp @@ -0,0 +1,95 @@ +;;;; 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*)) diff --git a/src/code/linux-os.lisp b/src/code/linux-os.lisp index 2bfe083..3ce6930 100644 --- a/src/code/linux-os.lisp +++ b/src/code/linux-os.lisp @@ -22,6 +22,8 @@ (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 @@ -33,6 +35,8 @@ (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) diff --git a/src/code/load.lisp b/src/code/load.lisp index 06655dd..2c3371b 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -413,20 +413,6 @@ ;; 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))) ;;;; stuff for debugging/tuning by collecting statistics on FOPs (?) diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 7b10afd..1ed66e7 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -333,3 +333,19 @@ 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))))) diff --git a/src/code/profile.lisp b/src/code/profile.lisp index 30bd69d..48cd92a 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -516,7 +516,6 @@ Lisp process." ;;; 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*))) diff --git a/src/code/save.lisp b/src/code/save.lisp index 76b7b95..b38cbca 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -17,9 +17,9 @@ ;;;; 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, @@ -33,50 +33,52 @@ (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 @@ -84,20 +86,22 @@ (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)) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index a25d4b9..a2e8324 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -73,19 +73,20 @@ (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 @@ -109,7 +110,8 @@ (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 @@ -141,7 +143,8 @@ (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)))) diff --git a/src/code/target-extensions.lisp b/src/code/target-extensions.lisp index cbaab4d..625c514 100644 --- a/src/code/target-extensions.lisp +++ b/src/code/target-extensions.lisp @@ -17,23 +17,23 @@ (in-package "SB!IMPL") -;;;; 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.") ;;; like LISTEN, but any whitespace in the input stream will be flushed (defun listen-skip-whitespace (&optional (stream *standard-input*)) diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index c16eaba..05d1e95 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -283,33 +283,10 @@ ;;;; 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)))) diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index c492023..5a43e17 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -55,6 +55,7 @@ (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 diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index bd355bf..03bf05b 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -167,7 +167,6 @@ "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 diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index e498999..ed4c7b1 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -1003,9 +1003,14 @@ (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) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 49c58a3..1f39e62 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1468,6 +1468,19 @@ (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)) diff --git a/src/compiler/generic/core.lisp b/src/compiler/generic/core.lisp index 7e03a24..c4b2f7f 100644 --- a/src/compiler/generic/core.lisp +++ b/src/compiler/generic/core.lisp @@ -57,8 +57,13 @@ (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)) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 9e17337..6f1140e 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1468,6 +1468,7 @@ (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*) @@ -1499,6 +1500,7 @@ sb!vm:fdefn-raw-addr-slot (ecase type (#.sb!vm:simple-fun-header-widetag + (/show0 "static-fset (simple-fun)") #!+sparc defn #!-sparc @@ -1508,6 +1510,7 @@ (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")))))) @@ -1524,8 +1527,8 @@ (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*)) @@ -1541,55 +1544,55 @@ (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*) @@ -1851,20 +1854,21 @@ ;;; 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))) + ;;;; general machinery for cold-loading FASL files @@ -2213,6 +2217,7 @@ sb!vm:array-elements-slot (make-fixnum-descriptor total-elements))) result)) + ;;;; cold fops for loading numbers @@ -2482,7 +2487,18 @@ (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)) @@ -2637,7 +2653,7 @@ (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 @@ -3032,10 +3048,6 @@ initially undefined function references:~2%") 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 @@ -3045,11 +3057,13 @@ initially undefined function references:~2%") ;; 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 @@ -3159,7 +3173,7 @@ initially undefined function references:~2%") ;; 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) diff --git a/src/compiler/saptran.lisp b/src/compiler/saptran.lisp index 1d6d4ee..64f067b 100644 --- a/src/compiler/saptran.lisp +++ b/src/compiler/saptran.lisp @@ -13,8 +13,29 @@ ;;;; 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 diff --git a/src/compiler/sparc/c-call.lisp b/src/compiler/sparc/c-call.lisp index 7c9eb6e..bcb126c 100644 --- a/src/compiler/sparc/c-call.lisp +++ b/src/compiler/sparc/c-call.lisp @@ -183,18 +183,32 @@ ,@(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) diff --git a/src/compiler/sparc/parms.lisp b/src/compiler/sparc/parms.lisp index 666a84f..63576d7 100644 --- a/src/compiler/sparc/parms.lisp +++ b/src/compiler/sparc/parms.lisp @@ -92,11 +92,14 @@ ;;; 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 @@ -105,28 +108,35 @@ (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) ;;;; other random constants. diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 6e07407..4ad3656 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1774,7 +1774,7 @@ (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*)) @@ -1907,7 +1907,10 @@ (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 diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index e3fd9d0..3c954f5 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -181,9 +181,6 @@ ,@(new-args)))))) (sb!c::give-up-ir1-transform)))) - - - (define-vop (foreign-symbol-address) (:translate foreign-symbol-address) (:policy :fast-safe) @@ -195,6 +192,18 @@ (: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)) diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp index cb4d029..f1328b6 100644 --- a/src/compiler/x86/parms.lisp +++ b/src/compiler/x86/parms.lisp @@ -149,52 +149,65 @@ #!+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: @@ -310,7 +323,8 @@ ;; 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 diff --git a/src/runtime/sparc-arch.c b/src/runtime/sparc-arch.c index 92b7228..9cc1780 100644 --- a/src/runtime/sparc-arch.c +++ b/src/runtime/sparc-arch.c @@ -394,3 +394,93 @@ lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2) 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 diff --git a/src/runtime/sparc-assem.S b/src/runtime/sparc-assem.S index cd710f1..9107951 100644 --- a/src/runtime/sparc-assem.S +++ b/src/runtime/sparc-assem.S @@ -200,6 +200,8 @@ call_into_c: ret nop +/* Lisp calling convention. notice the first .byte line. + */ .global undefined_tramp FUNCDEF(undefined_tramp) .align 8 @@ -222,6 +224,8 @@ undefined_tramp = . + 1 jmp reg_CODE+SIMPLE_FUN_CODE_OFFSET nop +/* Lisp calling convention. Notice the first .byte line. + */ .global closure_tramp FUNCDEF(closure_tramp) .align 8 @@ -287,4 +291,3 @@ save_context: ta ST_FLUSH_WINDOWS ! flush register windows retl ! return from leaf routine nop - diff --git a/src/runtime/validate.c b/src/runtime/validate.c index f9b6ab1..a7e9a3d 100644 --- a/src/runtime/validate.c +++ b/src/runtime/validate.c @@ -53,6 +53,10 @@ validate(void) 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 diff --git a/src/runtime/validate.h b/src/runtime/validate.h index 0d82b3f..36c973c 100644 --- a/src/runtime/validate.h +++ b/src/runtime/validate.h @@ -19,6 +19,10 @@ #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 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD diff --git a/src/runtime/x86-arch.c b/src/runtime/x86-arch.c index ec468cc..fab9d1f 100644 --- a/src/runtime/x86-arch.c +++ b/src/runtime/x86-arch.c @@ -356,3 +356,35 @@ funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2) 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 diff --git a/tests/foreign.test.sh b/tests/foreign.test.sh index 10bc613..ac7ebcc 100644 --- a/tests/foreign.test.sh +++ b/tests/foreign.test.sh @@ -16,15 +16,22 @@ 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} < $testfilestem.deflisp < $testfilestem.testlisp < /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" @@ -22,4 +17,8 @@ featurep() { 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 diff --git a/tools-for-build/os-provides-dlopen-test.c b/tools-for-build/os-provides-dlopen-test.c new file mode 100644 index 0000000..9296b12 --- /dev/null +++ b/tools-for-build/os-provides-dlopen-test.c @@ -0,0 +1,15 @@ +/* test to build and run so that we know if we have dlopen + */ + +#include + +int main () +{ + void * handle = dlopen((void*)0, RTLD_GLOBAL | RTLD_NOW); + void * addr = dlsym(handle, "printf"); + if (addr) { + return 104; + } else { + return 0; + } +} diff --git a/tools-for-build/sparc-funcdef.sh b/tools-for-build/sparc-funcdef.sh index d723935..054ced5 100644 --- a/tools-for-build/sparc-funcdef.sh +++ b/tools-for-build/sparc-funcdef.sh @@ -2,7 +2,7 @@ cd tools-for-build 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 diff --git a/version.lisp-expr b/version.lisp-expr index df7aa03..e16c51c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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"