;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB-IMPL")
+(in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.)
(declaim #.*optimize-byte-compilation*)
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB-IMPL")
+(in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.)
(macrolet ((force-delayed-def!methods ()
`(progn
-;;;; support for dynamically loading foreign object files
+;;;; support for dynamically loading foreign object files and
+;;;; resolving symbols therein
;;;; 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-SYS")
+(in-package "SB-SYS") ; (SB-SYS, not SB!SYS, since we're built in warm load.)
(defun pick-temporary-file-name (&optional
;; KLUDGE: There are various security
;;; (On any OS which *does* support foreign object file loading, this
;;; placeholder implementation is overwritten by a subsequent real
;;; implementation.)
+;;;
+;;; You may want to use sb-sys:foreign-symbol-address instead of
+;;; calling this directly; see code/target-load.lisp.
(defun get-dynamic-foreign-symbol-address (symbol)
(declare (type simple-string symbol) (ignore symbol))
nil)
-;;; Linux implementation of GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS
-;;; and functions (e.g. LOAD-FOREIGN) which affect it
+;;; 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)
#+(or linux FreeBSD)
(progn
; obj file were linked directly
; into the program)?
-;;; a list of tables returned from dlopen(3) (or possibly some
+;;; a list of handles returned from dlopen(3) (or possibly some
;;; bogus value temporarily during initialization)
-(defvar *tables-from-dlopen* nil)
+(defvar *handles-from-dlopen* nil)
+
;;; 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
-;;; *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.
+;;; *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,
;;; 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.
-(push (lambda () (setq *tables-from-dlopen* nil))
+
+;;; dan 2001.05.10 suspects that objection (1) is bogus for
+;;; dlsym()-enabled systems
+
+(push (lambda () (setq *handles-from-dlopen* nil))
*after-save-initializations*)
(defvar *dso-linker* "/usr/bin/ld")
(name sb-c-call:c-string))
(sb-alien:def-alien-routine dlerror sb-c-call:c-string)
-;;; Ensure that we've opened our own binary so we can resolve global
-;;; variables in the Lisp image that come from libraries. 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
-;;; *TABLES-FROM-DLOPEN*, as well as in
-;;; GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS.
-(defun ensure-lisp-table-opened ()
- (unless *tables-from-dlopen*
+;;; 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 *tables-from-dlopen* (int-sap 0))
- (setf *tables-from-dlopen* (list (dlopen nil rtld-lazy)))
- (when (zerop (sb-sys:sap-int (first *tables-from-dlopen*)))
- (error "can't open global symbol table: ~S" (dlerror)))))
+ (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 load-1-foreign (file)
"the primitive upon which the more general LOAD-FOREIGN is built: load
(DEF-ALIEN-ROUTINE SUMMISH INT (X INT) (Y INT))
Now running (SUMMISH 10 20) should return 31.
"
- (ensure-lisp-table-opened)
+ (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.
(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 *tables-from-dlopen* :test #'sap=)))
+ (pushnew sap *handles-from-dlopen* :test #'sap=)))
(values))
(defun get-dynamic-foreign-symbol-address (symbol)
- (ensure-lisp-table-opened)
+ (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.
;;
;; 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 (table *tables-from-dlopen*)
+ (dolist (handle *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 table symbol))))
+ (let ((possible-result (sap-int (dlsym handle symbol))))
(unless (zerop possible-result)
(return possible-result)))))
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB-IMPL")
+(in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.)
(declaim #.*optimize-byte-compilation*)
(fill *fop-stack* nil :end *fop-stack-pointer-on-entry*)
(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 linux freebsd) #("" "ldso_stub__")
+ #!+openbsd #("" "_")))
+ (some (lambda (prefix)
+ (gethash (concatenate 'string prefix name)
+ table
+ nil))
+ prefixes)))
+
\f
;;;; stuff for debugging/tuning by collecting statistics on FOPs (?)
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB-DEBUG")
+(in-package "SB-DEBUG") ; (SB-, not SB!, since we're built in warm load.)
;;; FIXME: Why, oh why, doesn't the SB-DEBUG package use the SB-DI
;;; package? That would let us get rid of a whole lot of stupid
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB-PROFILE")
+(in-package "SB-PROFILE") ; (SB-, not SB!, since we're built in warm load.)
\f
;;;; reading internal run time with high resolution and low overhead
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB-IMPL")
+(in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.)
\f
;;;; hacking the Unix environment
;;;;
(let ((results (multiple-value-list (eval sexpr))))
(load-fresh-line)
(format t "~{~S~^, ~}~%" results))
- (eval sexpr))))
+ (eval sexpr))))
\f
;;;; LOAD itself
(declaim (ftype (function (string) sb!vm:word)
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 (foreign-symbol)
- (or (gethash foreign-symbol *static-foreign-symbols*)
- (gethash (concatenate 'simple-string
- #!+linux "ldso_stub__"
- #!+openbsd "_"
- #!+freebsd "ldso_stub__"
- foreign-symbol)
- *static-foreign-symbols*)
+ (or (find-foreign-symbol-in-table foreign-symbol *static-foreign-symbols*)
(sb!sys:get-dynamic-foreign-symbol-address foreign-symbol)
(error "unknown foreign symbol: ~S" foreign-symbol)))
(error "undefined assembler routine: ~S" name)))
(:foreign
(aver (stringp name))
- (or (sb!impl::foreign-symbol-address-as-integer name)
+ (or (foreign-symbol-address-as-integer name)
(error "unknown foreign symbol: ~S")))
#!+x86
(:code-object
\f
;;;; representation of spaces in the core
+;;; If there is more than one dynamic space in memory (i.e., if a
+;;; copying GC is in use), then only the active dynamic space gets
+;;; dumped to core.
(defvar *dynamic*)
(defconstant dynamic-space-id 1)
(write-wordindexed fdefn
sb!vm:fdefn-raw-addr-slot
(make-random-descriptor
- (lookup-foreign-symbol "undefined_tramp"))))
+ (cold-foreign-symbol-address-as-integer "undefined_tramp"))))
fdefn))))
(defun cold-fset (cold-name defn)
sb!vm:word-shift))))
(#.sb!vm:closure-header-type
(make-random-descriptor
- (lookup-foreign-symbol "closure_tramp")))))
+ (cold-foreign-symbol-address-as-integer "closure_tramp")))))
fdefn))
(defun initialize-static-fns ()
(defvar *cold-foreign-symbol-table*)
(declaim (type hash-table *cold-foreign-symbol-table*))
-(defun load-foreign-symbol-table (filename)
+;;; Read the sbcl.nm file to find the addresses for foreign-symbols in
+;;; the C runtime.
+(defun load-cold-foreign-symbol-table (filename)
(with-open-file (file filename)
(loop
(let ((line (read-line file nil nil)))
(setf (gethash name *cold-foreign-symbol-table*) value))))))
(values)))
-;;; FIXME: the relation between #'lookup-foreign-symbol and
-;;; #'lookup-maybe-prefix-foreign-symbol seems more than slightly
-;;; illdefined
-
-(defun lookup-foreign-symbol (name)
- #!+(or alpha x86)
- (let ((prefixes
- #!+linux #(;; FIXME: How many of these are actually
- ;; needed? The first four are taken from rather
- ;; disorganized CMU CL code, which could easily
- ;; have had redundant values in it..
- "_"
- "__"
- "__libc_"
- "ldso_stub__"
- ;; ..and the fifth seems to match most
- ;; actual symbols, at least in RedHat 6.2.
- "")
- #!+freebsd #("" "ldso_stub__")
- #!+openbsd #("_")))
- (or (some (lambda (prefix)
- (gethash (concatenate 'string prefix name)
- *cold-foreign-symbol-table*
- nil))
- prefixes)
- *foreign-symbol-placeholder-value*
- (progn
- (format *error-output* "~&The foreign symbol table is:~%")
- (maphash (lambda (k v)
- (format *error-output* "~&~S = #X~8X~%" k v))
- *cold-foreign-symbol-table*)
- (format *error-output* "~&The prefix table is: ~S~%" prefixes)
- (error "The foreign symbol ~S is undefined." name))))
- #!-(or x86 alpha) (error "non-x86/alpha unsupported in SBCL (but see old CMU CL code)"))
+(defun cold-foreign-symbol-address-as-integer (name)
+ (or (find-foreign-symbol-in-table name *cold-foreign-symbol-table*)
+ *foreign-symbol-placeholder-value*
+ (progn
+ (format *error-output* "~&The foreign symbol table is:~%")
+ (maphash (lambda (k v)
+ (format *error-output* "~&~S = #X~8X~%" k v))
+ *cold-foreign-symbol-table*)
+ (error "The foreign symbol ~S is undefined." name))))
(defvar *cold-assembler-routines*)
(when value
(do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))
+;;; *COLD-FOREIGN-SYMBOL-TABLE* becomes *!INITIAL-FOREIGN-SYMBOLS* in
+;;; 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 ()
(let ((result *nil-descriptor*))
- (maphash #'(lambda (symbol value)
- (cold-push (cold-cons (string-to-core symbol)
- (number-to-core value))
- result))
+ (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))
(let ((result *nil-descriptor*))
\f
;;;; general machinery for cold-loading FASL files
-(defvar *cold-fop-functions* (replace (make-array 256) *fop-functions*)
- #!+sb-doc
- "FOP functions for cold loading")
+;;; FOP functions for cold loading
+(defvar *cold-fop-functions*
+ ;; We start out with a copy of the ordinary *FOP-FUNCTIONS*. The
+ ;; ones which aren't appropriate for cold load will be destructively
+ ;; modified.
+ (copy-seq *fop-functions*))
(defvar *normal-fop-functions*)
(sym (make-string len)))
(read-string-as-bytes *fasl-input-stream* sym)
(let ((offset (read-arg 4))
- (value (lookup-foreign-symbol sym)))
+ (value (cold-foreign-symbol-address-as-integer sym)))
(do-cold-fixup code-object offset value kind))
code-object))
;; Read symbol table, if any.
(when symbol-table-file-name
- (load-foreign-symbol-table symbol-table-file-name))
+ (load-cold-foreign-symbol-table symbol-table-file-name))
;; Now that we've successfully read our only input file (by
;; loading the symbol table, if any), it's a good time to ensure
LINKFLAGS = -v -g -Wl,-T -Wl,ld-script.alpha-linux
NM = nm -p
-ASSEM_SRC = alpha-assem.S #linux-stubs.S
+ASSEM_SRC = alpha-assem.S ldso-stubs.S
ARCH_SRC = alpha-arch.c
-OS_SRC = linux-os.c os-common.c undefineds.c alpha-linux-os.c
-LINKFLAGS+=-static -rdynamic
+OS_SRC = linux-os.c alpha-linux-os.c os-common.c
+LINKFLAGS+=-rdynamic # -static
OS_LIBS= -ldl
GC_SRC= gc.c
/* [1] This behaviour can be changed with osf_setsysinfo, but cmucl
* didn't use that */
-#ifdef linux
+#ifdef __linux__
*os_context_register_addr(context,reg_ALLOC) |= (1L<<63);
#else
*os_context_register_addr(context,reg_ALLOC) |= 2;
#endif
/**/
#ifdef alpha
-#ifdef linux
+#ifdef __linux__
#define EXTERN(name,bytes) .globl name
#endif
#endif
/*
- * stubs for C-linkage library functions used by the runtime
+ * stubs for C-linkage library functions which we need to refer to
+ * from Lisp
*
- * These are needed because the locations of the libraries are
- * filled in by the dynamic linker ld.so at runtime.
+ * These exist for the benefit of Lisp code that needs to refer to
+ * foreign symbols when dlsym() is not available (i.e. when dumping
+ * cold-sbcl.core, when we may be running in a host that's not SBCL,
+ * or on platforms that don't have it at all). If the runtime is
+ * dynamically linked, library functions won't be linked into it, so
+ * the map file won't show them. So, we need a bunch of stubs that
+ * nm(1) _can_ see.
*/
/*
gcc2_compiled.:
.text
-#define LDSO_STUBIFY(fct) \
- .align 16 ; \
-.globl ldso_stub__ ## fct ; \
+#if defined __i386__
+
+#define LDSO_STUBIFY(fct) \
+ .align 16 ; \
+.globl ldso_stub__ ## fct ; \
.type ldso_stub__ ## fct,@function ; \
-ldso_stub__ ## fct: ; \
- jmp fct ; \
-.L ## fct ## e1: ; \
+ldso_stub__ ## fct: ; \
+ jmp fct ; \
+.L ## fct ## e1: ; \
.size ldso_stub__ ## fct,.L ## fct ## e1-ldso_stub__ ## fct ;
+#elif defined alpha
+
+ /* I _hope_ this is correct - I haven't checked in the manual
+ * yet. It works to the point of building and passing tests,
+ * at any rate - dan 2001.05.10 */
+#define LDSO_STUBIFY(fct) \
+.globl ldso_stub__ ## fct ; \
+ .type ldso_stub__ ## fct,@function ; \
+ldso_stub__ ## fct: ; \
+ jmp fct ; \
+.L ## fct ## e1: ; \
+ .size ldso_stub__ ## fct,.L ## fct ## e1-ldso_stub__ ## fct ;
+
+#else
+#error unsupported CPU architecture
+#endif
+
LDSO_STUBIFY(accept)
LDSO_STUBIFY(access)
LDSO_STUBIFY(acos)
LDSO_STUBIFY(utimes)
LDSO_STUBIFY(wait3)
LDSO_STUBIFY(write)
+
+/*
+ * These aren't needed on the X86 because they're microcoded into the
+ * FPU, so the Lisp VOPs can implement them directly without having to
+ * call C code.
+ *
+ * Note: There might be some other functions in this category as well.
+ * E.g. I notice tanh() and acos() in the list above.. -- WHN 2001-06-07
+ */
+#if !defined __i386__
+ LDSO_STUBIFY(sin)
+ LDSO_STUBIFY(cos)
+ LDSO_STUBIFY(tan)
+ LDSO_STUBIFY(atan)
+ LDSO_STUBIFY(atan2)
+ LDSO_STUBIFY(exp)
+ LDSO_STUBIFY(log)
+ LDSO_STUBIFY(log10)
+ LDSO_STUBIFY(sqrt)
+#endif
\ No newline at end of file
* that SBCL runs on as of 0.6.7. If we port to the Alpha or some
* other non-32-bit machine we'll probably need real machine-dependent
* and OS-dependent definitions again. */
-#if ((defined alpha) && !(defined linux))
+#if ((defined alpha) && !(defined __linux__))
#error No u32,s32 definitions for this platform. Write some.
#else
/* int happens to be 4 bytes on linux/alpha. long is longer. */
F(symlink)
F(sync)
F(syscall)
-#if defined(hpux) || defined(SVR4) || defined(linux)
+#if defined(hpux) || defined(SVR4) || defined(__linux__)
F(closedir)
F(opendir)
#if defined(readdir)
(assert (subtypep 'ratio 'real))
(assert (subtypep 'ratio 'number))
+;;; Pierre Mai rewrote the CMU CL type test system to allow inline
+;;; type tests for CONDITIONs and STANDARD-OBJECTs, and generally be
+;;; nicer, and Martin Atzmueller ported the patches. They look nice
+;;; but they're nontrivial enough that it's not obvious from
+;;; inspection that everything is OK. Let's make sure that things
+;;; still basically work.
+(defstruct foo1)
+(defstruct (foo2 (:include foo1))
+ x)
+(defstruct (foo3 (:include foo2)))
+(defstruct (foo4 (:include foo3))
+ y z)
+(assert (typep (make-foo3) 'foo2))
+(assert (not (typep (make-foo1) 'foo4)))
+(assert (null (ignore-errors (setf (foo2-x (make-foo1)) 11))))
+;;; (More tests here would be nice before merging the patches. More
+;;; tests for STRUCTURE-OBJECT, tests for CONDITION, tests for
+;;; STANDARD-OBJECT, compiled tests to make sure that the inline
+;;; versions of the tests work..)
+
;;; success
(quit :unix-status 104)
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.12.23"
+"0.6.12.24"
projects / sbcl.git / commitdiff