support for (AND ..) types, among other things)
changes in sbcl-0.6.13 relative to sbcl-0.6.12:
-* The system has now been ported to the Alpha CPU, thanks to Dan Barlow.
+* a port to the Alpha CPU, thanks to Dan Barlow
+* better error handling in CLOS method combination, thanks to
+ Martin Atzmueller and Pierre Mai
planned incompatible changes in 0.7.x:
* The debugger prompt sequence now goes "5]", "5[2]", "5[3]", etc.
# distribution, we automatically clean up after it here in the
# standard clean.sh file.)
-# Within other directories, remove things which don't look like source
+# Ask some other directories to clean themselves up.
+pwd=`pwd`
+for d in tools-for-build; do
+ cd $d
+ make clean
+ cd $pwd
+done
+
+# Within all directories, remove things which don't look like source
# files. Some explanations:
# (symlinks)
# are never in the sources; they must've been created
# *.htm, *.html
# probably machine-generated translation of DocBook (*.sgml) files
# core
-# probably a core dump -- not part of the sources anyway
+# probably a Unix core dump -- not part of the sources anyway
+# *.o, *.lib, *.nm
+# results of C-style linking, assembling, etc.
+# *.core, *.map
+# looks like SBCL SAVE-LISP-AND-DIE or GENESIS output, and
+# certainly not source
# *~, #*#, TAGS
# common names for editor temporary files
+# *.htm, *.html
+# The system doc sources are SGML, any HTML is automatically
+# generated output.
+# depend
+# made by "make depend" (or "gmake depend" or some such thing)
+# *.x86f, *.axpf, *.lbytef, *.fasl
+# typical extensions for fasl files
find . \( \
-type l -or \
-name '*~' -or \
-name '?*.x86f' -or \
-name '?*.axpf' -or \
-name '?*.lbytef' -or \
+ -name '?*.fasl' -or \
-name 'core' -or \
-name '?*.core' -or \
-name '*.map' -or \
ltf=`pwd`/local-target-features.lisp-expr
echo //initializing $ltf
echo ';;;; This is a machine-generated file.' > $ltf
-echo ';;;; Please do not edit it by hand.' > $ltf
-echo ';;;; See make-config.sh.' > $ltf
+echo ';;;; Please do not edit it by hand.' >> $ltf
+echo ';;;; See make-config.sh.' >> $ltf
echo -n '(' >> $ltf
echo //guessing default target CPU architecture from host architecture
echo //setting up CPU-architecture-dependent information
sbcl_arch=${SBCL_ARCH:-$guessed_sbcl_arch}
+echo sbcl_arch=\"$sbcl_arch\"
if [ "$sbcl_arch" = "" ] ; then
echo "can't guess target SBCL architecture, need SBCL_ARCH environment var"
exit 1
--- /dev/null
+#!/bin/sh
+
+# This is a script to be run as part of make.sh. The only time you'd
+# want to run it by itself is if you're trying to cross-compile the
+# system or if you're doing some kind of troubleshooting.
+
+# 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.
+
+echo //entering make-genesis-2.sh
+
+# In a fresh host Lisp invocation, load the cross-compiler (in order
+# to get various definitions that GENESIS needs, not in order to
+# cross-compile GENESIS, then load and run GENESIS. (We use a fresh
+# host Lisp invocation here for basically the same reasons we did
+# before when loading and running the cross-compiler.)
+#
+# (Why do we need this second invocation of GENESIS? In order to
+# create a .core file, as opposed to just a .h file, GENESIS needs
+# symbol table data on the C runtime. And we can get that symbol
+# data only after the C runtime has been built. Therefore, even
+# though we ran GENESIS earlier, we couldn't get it to make a .core
+# file at that time; but we needed to run it earlier in order to
+# get to where we can write a .core file.)
+echo //loading and running GENESIS to create cold-sbcl.core
+$SBCL_XC_HOST <<-'EOF' || exit 1
+ (setf *print-level* 5 *print-length* 5)
+ (load "src/cold/shared.lisp")
+ (in-package "SB-COLD")
+ (setf *host-obj-prefix* "obj/from-host/"
+ *target-obj-prefix* "obj/from-xc/")
+ (load "src/cold/set-up-cold-packages.lisp")
+ (load "src/cold/defun-load-or-cload-xcompiler.lisp")
+ (load-or-cload-xcompiler #'host-load-stem)
+ (defparameter *target-object-file-names*
+ (with-open-file (s "output/object-filenames-for-genesis.lisp-expr"
+ :direction :input)
+ (read s)))
+ (host-load-stem "src/compiler/generic/genesis")
+ (sb!vm:genesis :object-file-names *target-object-file-names*
+ :c-header-file-name "output/sbcl2.h"
+ :symbol-table-file-name "src/runtime/sbcl.nm"
+ :core-file-name "output/cold-sbcl.core"
+ ;; The map file is not needed by the system, but can
+ ;; be very handy when debugging cold init problems.
+ :map-file-name "output/cold-sbcl.map")
+ EOF
+
+echo //testing for consistency of first and second GENESIS passes
+if cmp src/runtime/sbcl.h output/sbcl2.h; then
+ echo //sbcl2.h matches sbcl.h -- good.
+else
+ echo error: sbcl2.h does not match sbcl.h.
+ exit 1
+fi
echo //entering make-host-2.sh
+# In some cases, a debugging build of the system will creates a core
+# file output/after-xc.core in the next step. In cases where it
+# doesn't, it's confusing and basically useless to have any old copies
+# lying around, so delete:
+rm -f output/after-xc.core
+
# In a fresh host Lisp invocation, load and run the cross-compiler to
# create the target object files describing the target SBCL.
#
;; this can be a good time to run it. The resulting core isn't
;; used in the normal build, but can be handy for experimenting
;; with the system.
- (when (find :sb-show *shebang-features*)
+
+ ;; REMOVEME: should be conditional on :SB-SHOW again
+ ;;(when (find :sb-show *shebang-features*)
#+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil)
- #+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core"))
- EOF
-
-# Run GENESIS again in order to create cold-sbcl.core.
-#
-# In a fresh host Lisp invocation, load the cross-compiler (in order
-# to get various definitions that GENESIS needs, not in order to
-# cross-compile GENESIS, then load and run GENESIS. (We use a fresh
-# host Lisp invocation here for basically the same reasons we did
-# before when loading and running the cross-compiler.)
-#
-# (Why do we need this second invocation of GENESIS? In order to
-# create a .core file, as opposed to just a .h file, GENESIS needs
-# symbol table data on the C runtime. And we can get that symbol
-# data only after the C runtime has been built. Therefore, even
-# though we ran GENESIS earlier, we couldn't get it to make a .core
-# file at that time; but we needed to run it earlier in order to
-# get to where we can write a .core file.)
-echo //loading and running GENESIS to create cold-sbcl.core
-$SBCL_XC_HOST <<-'EOF' || exit 1
- (setf *print-level* 5 *print-length* 5)
- (load "src/cold/shared.lisp")
- (in-package "SB-COLD")
- (setf *host-obj-prefix* "obj/from-host/"
- *target-obj-prefix* "obj/from-xc/")
- (load "src/cold/set-up-cold-packages.lisp")
- (load "src/cold/defun-load-or-cload-xcompiler.lisp")
- (load-or-cload-xcompiler #'host-load-stem)
- (defparameter *target-object-file-names*
- (with-open-file (s "output/object-filenames-for-genesis.lisp-expr"
- :direction :input)
- (read s)))
- (host-load-stem "src/compiler/generic/genesis")
- (sb!vm:genesis :object-file-names *target-object-file-names*
- :c-header-file-name "output/sbcl2.h"
- :symbol-table-file-name "src/runtime/sbcl.nm"
- :core-file-name "output/cold-sbcl.core"
- ;; The map file is not needed by the system, but can
- ;; be very handy when debugging cold init problems.
- :map-file-name "output/cold-sbcl.map")
+ #+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core")
+ ;;)
EOF
-echo //testing for consistency of first and second GENESIS passes
-if cmp src/runtime/sbcl.h output/sbcl2.h; then
- echo //sbcl2.h matches sbcl.h -- good.
-else
- echo error: sbcl2.h does not match sbcl.h.
- exit 1
-fi
+# Run GENESIS (again) (The first time was before we ran the
+# cross-compiler.) in order to create cold-sbcl.core.
+sh make-genesis-2.sh
cd ../..
# Use a little C program to grab stuff from the C header files and
-# smash it into Lisp source code, so that we won't get all stressed
-# and careworn like the CMU CL maintainers.
+# smash it into Lisp source code.
cd tools-for-build
$gnumake grovel_headers
cd ..
;; not wanted by default after build is complete. (And if it's
;; wanted, it can easily be turned back on.)
#+sb-show (setf sb-int:*/show* nil)
- (sb-ext:save-lisp-and-die "output/sbcl.core" :purify t)
-
+ ;; REMOVEME: This is supposed to be :PURIFY T, the :PURIFY NIL
+ ;; is a hopefully-very-short-lived workaround for a bug in
+ ;; sbcl-0.6.12.8.
+ (sb-ext:save-lisp-and-die "output/sbcl.core" :purify nil)
EOF
--- /dev/null
+#!/bin/sh
+
+# a quick and dirty way of partially rebuilding the system after a
+# change
+#
+# This script is not a reliable way to build the system, but it is
+# fast.:-| It can be useful if you are trying to debug a low-level
+# problem, e.g. a problem in src/runtime/*.c or in src/code/unix.lisp,
+# and you find yourself wanting to make a small change and test it
+# without going through the entire build-the-system-from-scratch
+# cycle.
+#
+# You probably don't want to be using this script unless you
+# understand the system build process to be able to guess when it
+# won't work.
+
+
+# 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.
+
+
+export SBCL_XC_HOST="${1:-sbcl --noprogrammer}"
+
+# (We don't do make-host-1.sh at all. Hopefully nothing relevant has
+# changed.)
+
+sh make-target-1.sh || exit 1
+
+# Instead of doing the full make-host-2.sh, we (1) use after-xc.core
+# to rebuild only the specifically-requested Lisp files (or skip
+# after-xc.core completely if no Lisp files are specifically
+# requested), then (2) run GENESIS.
+#
+# Our command line arguments are the stems that we'll use
+# after-xc.core to recompile. If there are no command line arguments,
+# though, make a point of not calling after-xc.core, since it might
+# not exist, and there's no point in causing a fatal failure (by
+# unsuccessfully trying to execute it) unnecessarily.
+if [ "$*" != "" ] ; then
+ # Actually, I wrote this script when I needed to do a lot of
+ # tweaking in src/runtime/*.c, and I haven't tried to make it
+ # work for src/code/*.c yet. -- WHN 2001-05-12
+ echo stub: no support yet for after-xc.core
+ exit 1
+fi
+sh make-genesis-2.sh || exit 1
+
+sh make-target-2.sh || exit 1
+
+echo /ordinary termination of slam.sh
(/show0 "entering !COLD-INIT")
+ (%primitive print "//entering !COLD-INIT") ; REMOVEME
+
;; FIXME: It'd probably be cleaner to have most of the stuff here
;; handled by calls like !GC-COLD-INIT, !ERROR-COLD-INIT, and
;; !UNIX-COLD-INIT. And *TYPE-SYSTEM-INITIALIZED* could be changed to
(setf *cold-init-complete-p* nil)
(setf *type-system-initialized* nil)
+ (%primitive print "//done with SETFs") ; REMOVEME
+
;; Anyone might call RANDOM to initialize a hash value or something;
;; and there's nothing which needs to be initialized in order for
;; this to be initialized, so we initialize it right away.
;; functions are called in the same relative order as the toplevel
;; forms of the corresponding source files.
+ (%primitive print "//about to !POLICY-COLD-INIT-OR-RESANIFY") ; REMOVEME
+
;;(show-and-call !package-cold-init)
(show-and-call !policy-cold-init-or-resanify)
(/show0 "back from !POLICY-COLD-INIT-OR-RESANIFY")
(/primitive-print hexstr)))
(let (#!+sb-show (index-in-cold-toplevels 0))
#!+sb-show (declare (type fixnum index-in-cold-toplevels))
+ (%primitive print "//about to DOLIST TOPLEVEL-THING") ; REMOVEME
+
(dolist (toplevel-thing (prog1
(nreverse *!reversed-cold-toplevels*)
;; (Now that we've NREVERSEd it, it's
(!cold-lose "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*"))))
(t (!cold-lose "bogus function in *!REVERSED-COLD-TOPLEVELS*")))))
(/show0 "done with loop over cold toplevel forms and fixups")
+ (%primitive print "//done with DOLIST TOPLEVEL-THING") ; REMOVEME
;; Set sane values again, so that the user sees sane values instead
;; of whatever is left over from the last DECLAIM/PROCLAIM.
:invalid
:divide-by-zero))
+ (%primitive print "//about to !CLASS-FINALIZE") ; REMOVEME
(show-and-call !class-finalize)
;; The reader and printer are initialized very late, so that they
(/show0 "done initializing")
(setf *cold-init-complete-p* t)
+ (%primitive print "//set *COLD-INIT-COMPLETE-P*") ; REMOVEME
;; The system is finally ready for GC.
#!-gengc (setf *already-maybe-gcing* nil)
(gc :full t)
(/show0 "back from first GC")
+ (%primitive print "//back from first GC") ; REMOVEME
+
;; The show is on.
(terpri)
(/show0 "going into toplevel loop")
(:charpos
(fd-stream-char-pos fd-stream))
(:file-length
+ ;; FIXME: This is broken on OpenBSD until the FFI, or at least
+ ;; UNIX-FSTAT, learns to extract 64-bit values. (As of sbcl-0.6.12.8,
+ ;; UNIX-FSTAT returns a 0 placeholder instead.)
+ #!+openbsd
+ (error "FIXME: internal error, FILE-LENGTH is broken on OpenBSD")
+ #!-openbsd
(multiple-value-bind (okay dev ino mode nlink uid gid rdev size
atime mtime ctime blksize blocks)
(sb!unix:unix-fstat (fd-stream-fd fd-stream))
(delete-original (eq if-exists :rename-and-delete))
(mode #o666))
(when original
- ;; We are doing a :RENAME or :RENAME-AND-DELETE.
- ;; Determine whether the file already exists, make sure the original
+ ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
+ ;; whether the file already exists, make sure the original
;; file is not a directory, and keep the mode.
(let ((exists
(and namestring
(do-old-rename namestring original))
(setf original nil)
(setf delete-original nil)
- ;; In order to use :SUPERSEDE instead, we have to make sure
- ;; SB!UNIX:O_CREAT corresponds to IF-DOES-NOT-EXIST.
- ;; SB!UNIX:O_CREAT was set before because of IF-EXISTS being
- ;; :RENAME.
+ ;; In order to use :SUPERSEDE instead, we have to make
+ ;; sure SB!UNIX:O_CREAT corresponds to
+ ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before
+ ;; because of IF-EXISTS being :RENAME.
(unless (eq if-does-not-exist :create)
(setf mask
(logior (logandc2 mask sb!unix:o_creat)
(let* ((fhsss sb!c:*fasl-header-string-start-string*)
(fhsss-length (length fhsss)))
(unless (= byte (char-code (schar fhsss 0)))
- (error "illegal fasl file header: first byte"))
+ (error "illegal first byte in fasl file header"))
(do ((byte (read-byte stream) (read-byte stream))
(count 1 (1+ count)))
((= byte sb!c:*fasl-header-string-stop-char-code*)
(declare (fixnum byte count))
(when (and (< count fhsss-length)
(not (eql byte (char-code (schar fhsss count)))))
- (error "illegal fasl file header: subsequent byte"))))
+ (error
+ "illegal subsequent (not first) byte in fasl file header"))))
;; Read and validate implementation and version, or die.
(let* ((implementation-length (read-arg 4))
;; don't. (CMU CL did, but implemented it in a non-ANSI way, and I
;; just disabled that instead of rewriting it.) -- WHN 20000131
(declare (ignore print))
+
+ ;; FIXME: In sbcl-0.6.12.8 the OpenBSD implementation of FILE-LENGTH
+ ;; broke because changed handling of Unix stat(2) stuff couldn't
+ ;; deal with OpenBSD's 64-bit size slot. Once that's fixed, this
+ ;; code can be restored.
+ #!-openbsd
(when (zerop (file-length stream))
(error "attempt to load an empty FASL file:~% ~S" (namestring stream)))
+
(do-load-verbose stream verbose)
(let* ((*fasl-file* stream)
(*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000)))
(file sb!c-call:c-string)
(initial-function (sb!alien:unsigned #.sb!vm: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,
-;;; not just what's currently used; and then after loading the
-;;; image to make a running Lisp, the memory never gets reclaimed.
-;;; (But with the PURIFY option it seems to work OK.)
+;;; FIXME: When this is run without the PURIFY option under GENCGC, it
+;;; seems to save memory all the way up to the high-water mark, not
+;;; just what's currently used; and then after loading the image to
+;;; make a running Lisp, the memory never gets reclaimed. (But with
+;;; the PURIFY option it seems to work OK.)
(defun save-lisp-and-die (core-file-name &key
(toplevel #'toplevel-init)
(purify nil)
(root-structures ())
(environment-name "auxiliary"))
#!+sb-doc
- "Saves a CMU Common Lisp core image in the file of the specified name,
+ "Save a CMU Common Lisp core image in the file of the specified name,
killing the current Lisp invocation in the process (unless it bails
out early because of some argument error or something).
- The following &KEY args are defined:
+ The following &KEY arguments are defined:
:TOPLEVEL
The function to run when the created core file is resumed.
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
+ If true, 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 PURIFY.
:ROOT-STRUCTURES
(dolist (f *after-save-initializations*)
(funcall f))
(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?
+ ;; 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)))))
(load-native
(load name)))))
-;;; Replace a cold-loaded native object file with a byte-compiled one, if it
-;;; exists.
+;;; Replace a cold-loaded native object file with a byte-compiled one,
+;;; if it exists.
#+nil ; no longer needed in SBCL.. I think.. -- WHN 19990814
(defun byte-load-over (name)
(load (make-pathname
(defun toplevel-init ()
(/show0 "entering TOPLEVEL-INIT")
+ (%primitive print "//entering TOPLEVEL-INIT") ; REMOVEME
+
(let ((sysinit nil) ; value of --sysinit option
(userinit nil) ; value of --userinit option
(ru-nvcsw long) ; voluntary context switches
(ru-nivcsw long))) ; involuntary context switches
\f
-
-;;;; runtime/stat-wrapper.h
-\f
-;;; this looks like "struct stat" according to stat(2). It may not
-;;; correspond to the real in-memory stat structure that the syscall
-;;; uses, and if it doesn't, shouldn't. Linux in particular is packed
-;;; full of stat macros, so we do this stuff in runtime/stat-wrapper.c
-
-;;; Note that st-dev is a long, not a dev-t. This is because dev-t on
-;;; linux 32 bit archs is a 64 bit quantity, but alien doesn's support
-;;; those. We don't actually access that field anywhere, though, so until
-;;; we can get 64 bit alien support it'll do
-
-(def-alien-type nil
- (struct stat
- (st-dev unsigned-long) ;would be dev-t in a real stat
- (st-ino ino-t)
- (st-mode mode-t)
- (st-nlink nlink-t)
- (st-uid uid-t)
- (st-gid gid-t)
- (st-rdev unsigned-long) ;ditto
- (st-size off-t)
- (st-blksize unsigned-long)
- (st-blocks unsigned-long)
- (st-atime time-t)
- (st-mtime time-t)
- (st-ctime time-t)))
-
;;;; unistd.h
;;; Given a file path (a string) and one of four constant modes,
(declare (type unix-pathname path))
(void-syscall ("chdir" c-string) path))
+(defun unix-mkdir (name mode)
+ (declare (type unix-pathname name)
+ (type unix-file-mode mode))
+ (void-syscall ("mkdir" c-string int) name mode))
+
;;; Return the current directory as a SIMPLE-STRING.
(defun unix-current-directory ()
;; FIXME: Gcc justifiably complains that getwd is dangerous and should
\f
;;;; sys/stat.h
-;;; FIXME: This is only used in this file, and needn't be in target Lisp
-;;; runtime. It's also unclear why it needs to be a macro instead of a
-;;; function. Perhaps it should become a FLET.
-(defmacro extract-stat-results (buf)
- `(values T ; result
- (slot ,buf 'st-dev)
- (slot ,buf 'st-ino)
- (slot ,buf 'st-mode)
- (slot ,buf 'st-nlink)
- (slot ,buf 'st-uid)
- (slot ,buf 'st-gid)
- (slot ,buf 'st-rdev)
- (slot ,buf 'st-size)
- (slot ,buf 'st-atime)
- (slot ,buf 'st-mtime)
- (slot ,buf 'st-ctime)
- (slot ,buf 'st-blksize)
- (slot ,buf 'st-blocks)))
-
-;;; Retrieve information about the specified file returning them in
-;;; the form of multiple values. See the UNIX Programmer's Manual for
-;;; a description of the values returned. If the call fails, then NIL
-;;; and an error number is returned instead.
+;;; This is a structure defined in src/runtime/wrap.c, to look
+;;; basically like "struct stat" according to stat(2). It may not
+;;; actually correspond to the real in-memory stat structure that the
+;;; syscall uses, and that's OK. Linux in particular is packed full of
+;;; stat macros, and trying to keep Lisp code in correspondence with
+;;; it is more pain than it's worth, so we just let our C runtime
+;;; synthesize a nice consistent structure for us.
+;;;
+;;; Note that st-dev is a long, not a dev-t. This is because dev-t on
+;;; linux 32 bit archs is a 64 bit quantity, but alien doesn's support
+;;; those. We don't actually access that field anywhere, though, so
+;;; until we can get 64 bit alien support it'll do.
+(def-alien-type nil
+ (struct wrapped_stat
+ (st-dev unsigned-long) ;would be dev-t in a real stat
+ (st-ino ino-t)
+ (st-mode mode-t)
+ (st-nlink nlink-t)
+ (st-uid uid-t)
+ (st-gid gid-t)
+ (st-rdev unsigned-long) ;ditto
+ (st-size off-t)
+ (st-blksize unsigned-long)
+ (st-blocks unsigned-long)
+ (st-atime time-t)
+ (st-mtime time-t)
+ (st-ctime time-t)))
+;;; shared C-struct-to-multiple-VALUES conversion for the stat(2)
+;;; family of Unix system calls
+(defun %extract-stat-results (wrapped-stat)
+ (declare (type (alien (* (struct wrapped_stat)))))
+ (values t
+ (slot wrapped-stat 'st-dev)
+ (slot wrapped-stat 'st-ino)
+ (slot wrapped-stat 'st-mode)
+ (slot wrapped-stat 'st-nlink)
+ (slot wrapped-stat 'st-uid)
+ (slot wrapped-stat 'st-gid)
+ (slot wrapped-stat 'st-rdev)
+ ;; FIXME: OpenBSD has a 64-bit st_size slot, which is
+ ;; basically a good thing, except that it is too
+ ;; 21st-century for sbcl-0.6.12.8's FFI to handle. As a
+ ;; quick kludgy workaround, we return a 0 placeholder from
+ ;; this function, and downstream we stub out the FILE-LENGTH
+ ;; operation (which is the only place that SBCL actually
+ ;; uses the SIZE value returned from any UNIX-STAT-ish call).
+ #!+openbsd 0
+ #!-openbsd (slot wrapped-stat 'st-size)
+ (slot wrapped-stat 'st-atime)
+ (slot wrapped-stat 'st-mtime)
+ (slot wrapped-stat 'st-ctime)
+ (slot wrapped-stat 'st-blksize)
+ (slot wrapped-stat 'st-blocks)))
+
+;;; The stat(2) family of Unix system calls are implemented as calls
+;;; to C-level wrapper functions which copies all the raw "struct
+;;; stat" slots into a system-independent format, so that we don't
+;;; need to mess around with tweaking the Lisp code to correspond to
+;;; different OS/CPU combinations.
+;;; stat(2) <-> stat_wrapper()
+;;; fstat(2) <-> fstat_wrapper()
+;;; lstat(2) <-> lstat_wrapper()
+;;; Then this function is used to convert all the stat slots into
+;;; multiple return values.
(defun unix-stat (name)
(declare (type unix-pathname name))
- (when (string= name "")
- (setf name "."))
- (with-alien ((buf (struct stat)))
- (syscall ("stat_wrapper" c-string (* (struct stat)))
- (extract-stat-results buf)
+ (with-alien ((buf (struct wrapped_stat)))
+ (syscall ("stat_wrapper" c-string (* (struct wrapped_stat)))
+ (%extract-stat-results buf)
name (addr buf))))
-
(defun unix-lstat (name)
- #!+sb-doc
- "Unix-lstat is identical to unix-stat, except if NAME is
- a symlink, in which case it returns information about the
- link itself rather than dereferencing it."
(declare (type unix-pathname name))
- (with-alien ((buf (struct stat)))
- (syscall ("lstat_wrapper" c-string (* (struct stat)))
- (extract-stat-results buf)
+ (with-alien ((buf (struct wrapped_stat)))
+ (syscall ("lstat_wrapper" c-string (* (struct wrapped_stat)))
+ (%extract-stat-results buf)
name (addr buf))))
-
-;;; like UNIX-STAT except the file is specified by the file descriptor FD
(defun unix-fstat (fd)
(declare (type unix-fd fd))
- (with-alien ((buf (struct stat)))
- (syscall ("fstat_wrapper" int (* (struct stat)))
- (extract-stat-results buf)
+ (with-alien ((buf (struct wrapped_stat)))
+ (syscall ("fstat_wrapper" int (* (struct wrapped_stat)))
+ (%extract-stat-results buf)
fd (addr buf))))
-
-
-;;; UNIX-MKDIR accepts a name and a mode and attempts to create the
-;;; corresponding directory with mode mode.
-(defun unix-mkdir (name mode)
- (declare (type unix-pathname name)
- (type unix-file-mode mode))
- (void-syscall ("mkdir" c-string int) name mode))
\f
;;;; time.h
;; timeval' but has nanoseconds instead of microseconds.
(def-alien-type nil
(struct timespec
- (tv-sec long) ;Seconds
- (tv-nsec long))) ;Nanoseconds
+ (tv-sec long) ; seconds
+ (tv-nsec long))) ; nanoseconds
;; used by other time functions
(def-alien-type nil
;;; needing collection and copying; when the application involved is
;;; the SBCL compiler, it doesn't take any longer to collect 20Mb than
;;; 2 -dan, 20000819
-
-#+sbcl
+;;;
+;;; Actually, tweaking *BYTES-CONSED-BETWEEN-GCS* to 20Mb instead of
+;;; the default 2 seemed to make SBCL rebuild O(25%) faster on my 256
+;;; Mb K6/3, so I think it does have some effect on X86/GENCGC. I
+;;; haven't looked into why this would be, though. Also, I'm afraid
+;;; that using 20Mb here might be unfriendly to people using more-reasonable
+;;; machines (like old laptops with 48Mb of memory..) so I've
+;;; suppressed this tweak except for Alpha. -- WHN 2001-05-11
+#+(and sbcl alpha) ; SBCL/Alpha uses stop-and-copy, and Alphas have lotso RAM.
(progn
(sb-ext:gc-off)
- (setf sb-KERNEL::*bytes-consed-between-gcs* (* 20 (expt 10 6)))
+ (setf sb-kernel::*bytes-consed-between-gcs* (* 20 (expt 10 6)))
(sb-ext:gc-on)
(sb-ext:gc))
# provided with absolutely no warranty. See the COPYING and CREDITS
# files for more information.
-CFLAGS += -DGENCGC
ASSEM_SRC = x86-assem.S
ARCH_SRC = x86-arch.c
OS_SRC = bsd-os.c os-common.c undefineds.c
-OS_LIBS=-lm # -ldl
+OS_LIBS = -lm # -ldl
+
+GC_SRC = gencgc.c
+CFLAGS += -DGENCGC
OS_LINK_FLAGS =
OS_LIBS = -ldl
-GC_SRC= gencgc.c
-CFLAGS += -DGENCGC
\ No newline at end of file
+GC_SRC = gencgc.c
+CFLAGS += -DGENCGC
#if defined(WANT_CGC) || defined(GENCGC)
extern lispobj *alloc(int bytes);
#else
-static lispobj *alloc(int bytes)
+static lispobj *
+alloc(int bytes)
{
lispobj *result;
}
#endif
-static lispobj *alloc_unboxed(int type, int words)
+static lispobj *
+alloc_unboxed(int type, int words)
{
lispobj *result;
return result;
}
-static lispobj alloc_vector(int type, int length, int size)
+static lispobj
+alloc_vector(int type, int length, int size)
{
struct vector *result;
return ((lispobj)result)|type_OtherPointer;
}
-lispobj alloc_cons(lispobj car, lispobj cdr)
+lispobj
+alloc_cons(lispobj car, lispobj cdr)
{
struct cons *ptr = (struct cons *)alloc(ALIGNED_SIZE(sizeof(struct cons)));
return (lispobj)ptr | type_ListPointer;
}
-lispobj alloc_number(long n)
+lispobj
+alloc_number(long n)
{
struct bignum *ptr;
}
}
-lispobj alloc_string(char *str)
+lispobj
+alloc_string(char *str)
{
int len = strlen(str);
lispobj result = alloc_vector(type_SimpleString, len+1, 8);
return result;
}
-lispobj alloc_sap(void *ptr)
+lispobj
+alloc_sap(void *ptr)
{
- struct sap *sap = (struct sap *)alloc_unboxed
- ((int)type_Sap,
- ((sizeof (struct sap)) - (sizeof (lispobj))) / (sizeof (u32)));
-
+ int n_words_to_alloc =
+ (sizeof(struct sap) - sizeof(lispobj)) / sizeof(u32);
+ struct sap *sap =
+ (struct sap *)alloc_unboxed ((int)type_Sap, n_words_to_alloc);
sap->pointer = ptr;
return (lispobj) sap | type_OtherPointer;
}
void
os_install_interrupt_handlers(void)
-{}
+{
+ SHOW("os_install_interrupt_handlers()/bsd-os/!defined(GENCGC)");
+}
#else
void
os_install_interrupt_handlers(void)
{
+ SHOW("os_install_interrupt_handlers()/bsd-os/defined(GENCGC)");
+ SHOW("**1"); /* REMOVEME */
#if defined __FreeBSD__
+ SHOW("**2"); /* REMOVEME */
+ SHOW("__FreeBSD__ case");
interrupt_install_low_level_handler(SIGBUS, memory_fault_handler);
#elif defined __OpenBSD__
+ SHOW("**3"); /* REMOVEME */
+ FSHOW((stderr, "/__OpenBSD__ case, SIGSEGV=%d\n", SIGSEGV));
interrupt_install_low_level_handler(SIGSEGV, memory_fault_handler);
#else
#error unsupported BSD variant
#endif
+ SHOW("**4"); /* REMOVEME */
+ SHOW("leaving os_install_interrupt_handlers()");
}
#endif /* !defined GENCGC */
#include "runtime.h"
-#define CORE_PAGESIZE OS_VM_DEFAULT_PAGESIZE
#define CORE_END 3840
#define CORE_NDIRECTORY 3861
#define CORE_VALIDATE 3845
#include "interr.h"
#include "sbcl.h"
-static void process_directory(int fd, long *ptr, int count)
+static void
+process_directory(int fd, long *ptr, int count)
{
struct ndir_entry *entry;
- FSHOW((stderr, "process_directory(..), count=%d\n", count));
+ FSHOW((stderr, "/process_directory(..), count=%d\n", count));
for (entry = (struct ndir_entry *) ptr; --count>= 0; ++entry) {
if (len != 0) {
os_vm_address_t real_addr;
- FSHOW((stderr, "mapping %ld bytes at 0x%lx\n", len, addr));
+ FSHOW((stderr, "/mapping %ld(0x%lx) bytes at 0x%lx\n",
+ (long)len, (long)len, addr));
real_addr = os_map(fd, offset, addr, len);
if (real_addr != addr) {
lose("file mapped in wrong place! "
}
}
- FSHOW((stderr, "space id = %d, free pointer = 0x%08x\n",
- id, free_pointer));
+ FSHOW((stderr, "/space id = %d, free pointer = 0x%08x\n",
+ id, (long)free_pointer));
switch (id) {
case DYNAMIC_SPACE_ID:
fprintf(stderr,"warning: core/runtime address mismatch: DYNAMIC_SPACE_START");
}
#endif
+/* FIXME: Should the conditional here be reg_ALLOC instead of
+ * defined(ibmrt) || defined(__i386__)
+ * ? */
#if defined(ibmrt) || defined(__i386__)
SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer);
#else
dynamic_space_free_pointer = free_pointer;
#endif
- /* on the x86, this will always be space 0 */
+ /* With GENCGC, this will always be space 0. (We checked
+ * above that addr==DYNAMIC_SPACE_START.) */
current_dynamic_space = (lispobj *)addr;
break;
case STATIC_SPACE_ID:
}
}
-lispobj load_core_file(char *file)
+lispobj
+load_core_file(char *file)
{
int fd = open(file, O_RDONLY), count;
#endif
lispobj initial_function = NIL;
+ FSHOW((stderr, "/entering load_core_file(%s)\n", file));
if (fd < 0) {
fprintf(stderr, "could not open file \"%s\"\n", file);
perror("open");
exit(1);
}
- header=calloc(os_vm_page_size / sizeof(u32),sizeof(u32));
+ header = calloc(os_vm_page_size / sizeof(u32),sizeof(u32));
count = read(fd, header, os_vm_page_size);
if (count < os_vm_page_size) {
lose("premature end of core file");
}
+ SHOW("successfully read first page of core");
ptr = header;
val = *ptr++;
val,
CORE_MAGIC);
}
+ SHOW("found CORE_MAGIC");
while (val != CORE_END) {
val = *ptr++;
len = *ptr++;
remaining_len = len - 2; /* (-2 to cancel the two ++ operations) */
+ FSHOW((stderr, "/val=0x%ld, remaining_len=0x%ld\n",
+ (long)val, (long)remaining_len));
switch (val) {
case CORE_END:
+ SHOW("CORE_END case");
break;
case CORE_VERSION:
+ SHOW("CORE_VERSION case");
if (*ptr != SBCL_CORE_VERSION_INTEGER) {
lose("core file version (%d) != runtime library version (%d)",
*ptr,
break;
case CORE_NDIRECTORY:
+ SHOW("CORE_NDIRECTORY case");
process_directory(fd,
ptr,
#ifndef alpha
break;
case CORE_INITIAL_FUNCTION:
+ SHOW("CORE_INITIAL_FUNCTION case");
initial_function = (lispobj)*ptr;
break;
default:
- lose("unknown core file entry: %ld", val);
+ lose("unknown core file entry: %ld", (long)val);
}
ptr += remaining_len;
+ FSHOW((stderr, "/new ptr=%x\n", ptr));
}
+ SHOW("about to free(header)");
free(header);
+ SHOW("returning from load_core_file(..)");
return initial_function;
}
SetSymbolValue(symbol, value);
}
-void unbind(void)
+void
+unbind(void)
{
struct binding *binding;
lispobj symbol;
SetBSP(binding);
}
-void unbind_to_here(lispobj *bsp)
+void
+unbind_to_here(lispobj *bsp)
{
struct binding *target = (struct binding *)bsp;
struct binding *binding = GetBSP();
boolean check_code_fixups = 0;
/* Should we check that newly allocated regions are zero filled? */
-boolean gencgc_zero_check = 0;
+boolean gencgc_zero_check = 1;
/* Should we check that the free space is zero filled? */
-boolean gencgc_enable_verify_zero_fill = 0;
+boolean gencgc_enable_verify_zero_fill = 1;
/* Should we check that free pages are zero filled during gc_free_heap
* called after Lisp PURIFY? */
-boolean gencgc_zero_check_during_free_heap = 0;
+boolean gencgc_zero_check_during_free_heap = 1;
\f
/*
* GC structures and variables
static void *heap_base = NULL;
/* Calculate the start address for the given page number. */
-inline void
-*page_address(int page_num)
+inline void *
+page_address(int page_num)
{
return (heap_base + (page_num * 4096));
}
/* the first page that gc_alloc_unboxed checks on its next call */
int alloc_unboxed_start_page;
- /* the first page that gc_alloc_large (boxed) considers on its next
- * call. (Although it always allocates after the boxed_region.) */
+ /* the first page that we look at for boxed large allocations
+ (Although we always allocate after the boxed_region.) */
int alloc_large_start_page;
- /* the first page that gc_alloc_large (unboxed) considers on its
- * next call. (Although it always allocates after the
- * current_unboxed_region.) */
+ /* the first page that we look at for unboxed large allocations
+ * (Although we always allocate after the current_unboxed_region.) */
int alloc_large_unboxed_start_page;
/* the bytes allocated to this generation */
struct alloc_region boxed_region;
struct alloc_region unboxed_region;
+/* Reset the alloc_region. This indicates that it's safe to call
+ * gc_alloc_new_region() on it, and impossible to allocate space from
+ * until gc_alloc_new_region() is called on it. (The reset values are
+ * chosen so that attempts to allocate space from it will fail
+ * (because free_pointer == end_addr) and cause gc_alloc_new_region()
+ * to be called before retrying.) */
+void
+reset_alloc_region(struct alloc_region *alloc_region)
+{
+ alloc_region->first_page = 0;
+ alloc_region->last_page = -1;
+ alloc_region->start_addr =
+ alloc_region->free_pointer =
+ alloc_region->end_addr =
+ page_address(0);
+ /* REMOVEME: last-ditch sanity check for postcondition */
+ gc_assert(alloc_region_is_completely_reset(alloc_region));
+}
+
+/* Does *alloc_region look exactly like it does after
+ * reset_alloc_region() has munged it? */
+int
+alloc_region_is_completely_reset(struct alloc_region *alloc_region)
+{
+ return
+ alloc_region->first_page == 0
+ && alloc_region->last_page == -1
+ && alloc_region->start_addr == alloc_region->free_pointer
+ && alloc_region->free_pointer == alloc_region->end_addr;
+}
+
+/* Is *alloc_region in a state which it could only have gotten into by
+ * having reset_alloc_region() munge it, as it does in preparation for
+ * having gc_alloc_new_region() operate on it? I.e. are at least some
+ * key fields distinctively munged, even if some others aren't?
+ *
+ * This test is different from alloc_region_is_completely_reset(). In
+ * particular, if you reset the region, and then accidentally scribble
+ * on some of its fields, this test will be true while the other test
+ * is false. Around sbcl-0.6.12.8, merging the Alpha patches, this
+ * difference became important because of some problems with the
+ * global current_region_free_pointer being used to scribble on
+ * alloc_region.free_pointer after the alloc_region had been reset and
+ * before gc_alloc_new_region() was called. */
+int
+alloc_region_looks_reset(struct alloc_region *alloc_region)
+{
+ return
+ alloc_region->first_page == 0
+ && alloc_region->last_page == -1;
+}
+
+/* (should only be needed for debugging or assertion failure reporting) */
+void
+fprint_alloc_region(FILE *file, struct alloc_region *alloc_region)
+{
+ fprintf(file,
+ "alloc_region *0x%0lx:
+ first_page=0x%08lx, last_page=0x%08lx,
+ start_addr=0x%08lx, free_pointer=0x%08lx, end_addr=0x%08lx\n",
+ (unsigned long)alloc_region,
+ (unsigned long)alloc_region->first_page,
+ (unsigned long)alloc_region->last_page,
+ (unsigned long)alloc_region->start_addr,
+ (unsigned long)alloc_region->free_pointer,
+ (unsigned long)alloc_region->end_addr);
+}
+
+
/* XX hack. Current Lisp code uses the following. Need copying in/out. */
void *current_region_free_pointer;
void *current_region_end_addr;
-/* The generation currently being allocated to. */
+/* the generation currently being allocated to */
static int gc_alloc_generation;
-/* Find a new region with room for at least the given number of bytes.
+/* Set *alloc_region to refer to a new region with room for at least
+ * the given number of bytes.
+ *
+ * Before the call to this function, *alloc_region should have been
+ * closed by a call to gc_alloc_update_page_tables(), and will thus be
+ * in an empty "reset" state. Upon return from this function, it should
+ * no longer be in a reset state.
*
- * It starts looking at the current generation's alloc_start_page. So
+ * We start by looking at the current generation's alloc_start_page. So
* may pick up from the previous region if there is enough space. This
* keeps the allocation contiguous when scavenging the newspace.
*
- * The alloc_region should have been closed by a call to
- * gc_alloc_update_page_tables, and will thus be in an empty state.
- *
* To assist the scavenging functions write-protected pages are not
* used. Free pages should not be write-protected.
*
* from space can be recognized. Therefore the generation of pages in
* the region are set to gc_alloc_generation. To prevent another
* allocation call using the same pages, all the pages in the region
- * are allocated, although they will initially be empty.
- */
+ * are allocated, although they will initially be empty. */
static void
gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
{
int num_pages;
int i;
- /*
- FSHOW((stderr,
- "/alloc_new_region for %d bytes from gen %d\n",
- nbytes, gc_alloc_generation));
- */
-
- /* Check that the region is in a reset state. */
- gc_assert((alloc_region->first_page == 0)
- && (alloc_region->last_page == -1)
- && (alloc_region->free_pointer == alloc_region->end_addr));
+ /* Check invariant as per the interface definition comment above. */
+ if (!alloc_region_is_completely_reset(alloc_region)) {
+ fprintf(stderr,
+ "Argh! alloc_region not reset in gc_alloc_new_region()\n");
+ fprint_alloc_region(stderr, alloc_region);
+ lose(0);
+ }
if (unboxed) {
restart_page =
/* Check for a failure. */
if (first_page >= NUM_PAGES) {
fprintf(stderr,
- "Argh! gc_alloc_new_region failed on first_page, nbytes=%d.\n",
+ "Argh! gc_alloc_new_region() failed on first_page, "
+ "nbytes=%d.\n",
nbytes);
print_generation_stats(1);
lose(NULL);
page_table[first_page].first_object_offset = 0;
}
- if (unboxed)
+ if (unboxed) {
gc_assert(page_table[first_page].allocated == UNBOXED_PAGE);
- else
+ } else {
gc_assert(page_table[first_page].allocated == BOXED_PAGE);
+ }
gc_assert(page_table[first_page].gen == gc_alloc_generation);
gc_assert(page_table[first_page].large_object == 0);
if (last_page+1 > last_used_page)
last_used_page = last_page+1;
}
+
+ /* postcondition sanity check*/
+ gc_assert(!alloc_region_is_completely_reset(alloc_region));
}
/* If the record_new_objects flag is 2 then all new regions created
max_new_areas = new_areas_index;
}
-/* Update the tables for the alloc_region. The region maybe added to
+/* Update the tables for the alloc_region. The region may be added to
* the new_areas.
*
- * When done the alloc_region is set up so that the next quick alloc
- * will fail safely and thus a new region will be allocated. Further
- * it is safe to try to re-update the page table of this reset
- * alloc_region. */
+ * When done the alloc_region is "reset", i.e. set up so that the next
+ * quick alloc will fail safely and thus a new region will be
+ * allocated. Further it is safe to try to re-update the page table of
+ * this reset alloc_region. */
void
gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
{
if ((first_page == 0) && (alloc_region->last_page == -1))
return;
- next_page = first_page+1;
+ next_page = first_page + 1;
- /* Skip if no bytes were allocated */
+ /* Skip if no bytes were allocated. */
if (alloc_region->free_pointer != alloc_region->start_addr) {
+
+ /* hunting for invariant violations from the Alpha patches ca.
+ * sbcl-0.6.12.8: It's OK -- I think -- for
+ * gc_alloc_update_page_tables() to be called on a reset
+ * alloc_region, but it's not OK in that case for the
+ * alloc_region.free_pointer to have been modified since the
+ * reset, i.e. the inequality tested just above.
+ * -- WHN 2001-05-14 */
+ gc_assert(!alloc_region_looks_reset(alloc_region));
+
orig_first_page_bytes_used = page_table[first_page].bytes_used;
gc_assert(alloc_region->start_addr == (page_address(first_page) + page_table[first_page].bytes_used));
- /* All the pages used need to be updated */
+ /* All the pages used need to be updated. */
/* Update the first page. */
if (page_table[first_page].bytes_used == 0)
gc_assert(page_table[first_page].first_object_offset == 0);
- if (unboxed)
+ if (unboxed) {
gc_assert(page_table[first_page].allocated == UNBOXED_PAGE);
- else
+ } else {
gc_assert(page_table[first_page].allocated == BOXED_PAGE);
+ }
gc_assert(page_table[first_page].gen == gc_alloc_generation);
gc_assert(page_table[first_page].large_object == 0);
byte_cnt = 0;
- /* Calc. the number of bytes used in this page. This is not always
- the number of new bytes, unless it was free. */
+ /* Calculate the number of bytes used in this page. This is
+ not always the number of new bytes, unless it was free. */
more = 0;
- if ((bytes_used = (alloc_region->free_pointer - page_address(first_page)))>4096) {
+ bytes_used =
+ alloc_region->free_pointer - page_address(first_page);
+ if (bytes_used > 4096) {
bytes_used = 4096;
more = 1;
}
byte_cnt += bytes_used;
- /* All the rest of the pages should be free. Need to set their
+ /* All the rest of the pages should be free. We need to set their
first_object_offset pointer to the start of the region, and set
the bytes_used. */
while (more) {
alloc_region->start_addr - page_address(next_page));
/* Calculate the number of bytes used in this page. */
+ /* FIXME: This code is duplicated about 20 lines above, in
+ * order to be executed on the first pass. Isn't
+ * there some way to move that duplicated block into the
+ * while() loop, converting it into repeat..until? */
more = 0;
- if ((bytes_used = (alloc_region->free_pointer
- - page_address(next_page)))>4096) {
+ bytes_used =
+ alloc_region->free_pointer - page_address(next_page);
+ if (bytes_used > 4096) {
bytes_used = 4096;
more = 1;
}
next_page++;
}
- region_size = alloc_region->free_pointer - alloc_region->start_addr;
+ region_size =
+ alloc_region->free_pointer - alloc_region->start_addr;
bytes_allocated += region_size;
generations[gc_alloc_generation].bytes_allocated += region_size;
gc_assert((byte_cnt- orig_first_page_bytes_used) == region_size);
/* Set the generations alloc restart page to the last page of
- the region. */
- if (unboxed)
+ * the region. */
+ if (unboxed) {
generations[gc_alloc_generation].alloc_unboxed_start_page =
next_page-1;
- else
+ } else {
generations[gc_alloc_generation].alloc_start_page = next_page-1;
+ }
/* Add the region to the new_areas if requested. */
- if (!unboxed)
+ if (!unboxed) {
add_new_area(first_page,orig_first_page_bytes_used, region_size);
+ }
/*
FSHOW((stderr,
region_size,
gc_alloc_generation));
*/
- }
- else
- /* No bytes allocated. Unallocate the first_page if there are 0
- bytes_used. */
+ } else {
+ /* No bytes were allocated. Unallocate the first_page if there
+ * are 0 bytes_used. */
if (page_table[first_page].bytes_used == 0)
page_table[first_page].allocated = FREE_PAGE;
+ }
/* Unallocate any unused pages. */
while (next_page <= alloc_region->last_page) {
next_page++;
}
- /* Reset the alloc_region. */
- alloc_region->first_page = 0;
- alloc_region->last_page = -1;
- alloc_region->start_addr = page_address(0);
- alloc_region->free_pointer = page_address(0);
- alloc_region->end_addr = page_address(0);
+ reset_alloc_region(alloc_region);
}
static inline void *gc_quick_alloc(int nbytes);
/* Allocate a possibly large object. */
-static void
-*gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region)
+static void *
+gc_alloc_possibly_large(int nbytes,
+ int unboxed,
+ struct alloc_region *alloc_region)
{
int first_page;
int last_page;
/*
FSHOW((stderr,
- "/gc_alloc_large for %d bytes from gen %d\n",
- nbytes, gc_alloc_generation));
+ "/gc_alloc_possibly_large for %d bytes (large=%d) from gen %d\n",
+ nbytes, large, gc_alloc_generation));
*/
/* If the object is small, and there is room in the current region
then allocation it in the current region. */
if (!large
- && ((alloc_region->end_addr-alloc_region->free_pointer) >= nbytes))
+ && ((alloc_region->end_addr - alloc_region->free_pointer) >= nbytes))
return gc_quick_alloc(nbytes);
/* Search for a contiguous free region of at least nbytes. If it's a
index ahead of the current region and bumped up here to save a
lot of re-scanning. */
if (unboxed)
- restart_page = generations[gc_alloc_generation].alloc_large_unboxed_start_page;
+ restart_page =
+ generations[gc_alloc_generation].alloc_large_unboxed_start_page;
else
restart_page = generations[gc_alloc_generation].alloc_large_start_page;
if (restart_page <= alloc_region->last_page)
if (first_page >= NUM_PAGES) {
fprintf(stderr,
- "Argh! gc_alloc_large failed (first_page), nbytes=%d.\n",
+ "Argh! gc_alloc_possibly_large failed (first_page), "
+ "nbytes=%d.\n",
nbytes);
print_generation_stats(1);
lose(NULL);
/* Check for a failure */
if ((restart_page >= NUM_PAGES) && (bytes_found < nbytes)) {
fprintf(stderr,
- "Argh! gc_alloc_large failed (restart_page), nbytes=%d.\n",
+ "Argh! gc_alloc_possibly_large failed (restart_page), "
+ "nbytes=%d.\n",
nbytes);
print_generation_stats(1);
lose(NULL);
/*
if (large)
FSHOW((stderr,
- "/gc_alloc_large gen %d: %d of %d bytes: from pages %d to %d: addr=%x\n",
+ "/gc_alloc_possibly_large gen %d: %d of %d bytes: from pages %d to %d: addr=%x\n",
gc_alloc_generation,
nbytes,
bytes_found,
/* Allocate bytes from the boxed_region. It first checks if there is
* room, if not then it calls gc_alloc_new_region to find a new region
* with enough space. A pointer to the start of the region is returned. */
-static void
-*gc_alloc(int nbytes)
+static void *
+gc_alloc(int nbytes)
{
void *new_free_pointer;
* saving, then allocate a large object. */
/* FIXME: "32" should be a named parameter. */
if ((boxed_region.end_addr-boxed_region.free_pointer) > 32)
- return gc_alloc_large(nbytes, 0, &boxed_region);
+ return gc_alloc_possibly_large(nbytes, 0, &boxed_region);
/* Else find a new region. */
/* Allocate space from the boxed_region. If there is not enough free
* space then call gc_alloc to do the job. A pointer to the start of
* the region is returned. */
-static inline void
-*gc_quick_alloc(int nbytes)
+static inline void *
+gc_quick_alloc(int nbytes)
{
void *new_free_pointer;
return((void *)new_obj);
}
- /* Else call gc_alloc */
- return (gc_alloc(nbytes));
+ /* Else call gc_alloc(). */
+ return gc_alloc(nbytes);
}
/* Allocate space for the boxed object. If it is a large object then
* do a large alloc else allocate from the current region. If there is
* not enough free space then call gc_alloc to do the job. A pointer
* to the start of the region is returned. */
-static inline void
-*gc_quick_alloc_large(int nbytes)
+static inline void *
+gc_quick_alloc_large(int nbytes)
{
void *new_free_pointer;
if (nbytes >= large_object_size)
- return gc_alloc_large(nbytes, 0, &boxed_region);
+ return gc_alloc_possibly_large(nbytes, 0, &boxed_region);
/* Check whether there is room in the current region. */
new_free_pointer = boxed_region.free_pointer + nbytes;
return (gc_alloc(nbytes));
}
-static void
-*gc_alloc_unboxed(int nbytes)
+static void *
+gc_alloc_unboxed(int nbytes)
{
void *new_free_pointer;
/* If there is a bit of room left in the current region then
allocate a large object. */
if ((unboxed_region.end_addr-unboxed_region.free_pointer) > 32)
- return gc_alloc_large(nbytes,1,&unboxed_region);
+ return gc_alloc_possibly_large(nbytes,1,&unboxed_region);
/* Else find a new region. */
return((void *) NIL); /* dummy value: return something ... */
}
-static inline void
-*gc_quick_alloc_unboxed(int nbytes)
+static inline void *
+gc_quick_alloc_unboxed(int nbytes)
{
void *new_free_pointer;
* enough free space then call gc_alloc to do the job.
*
* A pointer to the start of the region is returned. */
-static inline void
-*gc_quick_alloc_large_unboxed(int nbytes)
+static inline void *
+gc_quick_alloc_unboxed_possibly_large(int nbytes)
{
void *new_free_pointer;
if (nbytes >= large_object_size)
- return gc_alloc_large(nbytes,1,&unboxed_region);
+ return gc_alloc_possibly_large(nbytes,1,&unboxed_region);
/* Check whether there is room in the current region. */
new_free_pointer = unboxed_region.free_pointer + nbytes;
tag = LowtagOf(object);
/* Allocate space. */
- new = gc_quick_alloc_large_unboxed(nwords*4);
+ new = gc_quick_alloc_unboxed_possibly_large(nwords*4);
dest = new;
source = (lispobj *) PTR(object);
object = *start;
-/* FSHOW((stderr, "Scavenge: %p, %ld\n", start, nwords)); */
+/* FSHOW((stderr, "/Scavenge: %p, %ld\n", start, nwords)); */
gc_assert(object != 0x01); /* not a forwarding pointer */
/* It's ok if it's byte compiled code. The trace table offset will
* be a fixnum if it's x86 compiled code - check. */
if (code->trace_table_offset & 0x3) {
- FSHOW((stderr, "/Sniffing byte compiled code object at %x.\n", code));
+ FSHOW((stderr, "/sniffing byte compiled code object at %x\n", code));
return;
}
(kv_vector[2*i] != empty_symbol))) {
/*FSHOW((stderr,
- "* EQ key %d moved from %x to %x; index %d to %d\n",
+ "/EQ key %d moved from %x to %x; index %d to %d\n",
i, old_key, new_key, old_index, new_index));*/
if (index_vector[old_index] != 0) {
gc_assert(Pointerp(object));
#if defined(DEBUG_WEAK)
- FSHOW((stderr, "Transporting weak pointer from 0x%08x\n", object));
+ FSHOW((stderr, "/transporting weak pointer from 0x%08x\n", object));
#endif
/* Need to remember where all the weak pointers are that have */
case type_BaseChar:
if (gencgc_verbose)
FSHOW((stderr,
- "*Wo3: %x %x %x\n",
+ "/Wo3: %x %x %x\n",
pointer, start_addr, *start_addr));
return 0;
case type_ByteCodeClosure:
if (gencgc_verbose)
FSHOW((stderr,
- "*Wo4: %x %x %x\n",
+ "/Wo4: %x %x %x\n",
pointer, start_addr, *start_addr));
return 0;
case type_InstanceHeader:
if (gencgc_verbose)
FSHOW((stderr,
- "*Wo5: %x %x %x\n",
+ "/Wo5: %x %x %x\n",
pointer, start_addr, *start_addr));
return 0;
default:
if (gencgc_verbose)
FSHOW((stderr,
- "*W?: %x %x %x\n",
+ "/W?: %x %x %x\n",
pointer, start_addr, *start_addr));
return 0;
}
|| (((unsigned)addr & 0xfff)
> page_table[addr_page_index].bytes_used)) {
FSHOW((stderr,
- "weird? ignore ptr 0x%x to freed area of large object\n",
+ "/weird? ignore ptr 0x%x to freed area of large object\n",
addr));
return;
}
}
if (gencgc_verbose > 1) {
FSHOW((stderr,
- "scavenging %d words of control stack %d of length %d words.\n",
+ "/scavenging %d words of control stack %d of length %d words.\n",
length, i, vector_length));
}
for (j = 0; j < length; j++) {
if ((all_wp != 0) && (a1 != bytes_allocated)) {
FSHOW((stderr,
- "alloc'ed over %d to %d\n",
+ "/alloc'ed over %d to %d\n",
i, last_page));
FSHOW((stderr,
"/page: bytes_used=%d first_object_offset=%d dont_move=%d wp=%d wpc=%d\n",
current_new_areas_index = new_areas_index;
/*FSHOW((stderr,
- "The first scan is finished; current_new_areas_index=%d.\n",
+ "/The first scan is finished; current_new_areas_index=%d.\n",
current_new_areas_index));*/
while (current_new_areas_index > 0) {
current_new_areas_index = new_areas_index;
/*FSHOW((stderr,
- "The re-scan has finished; current_new_areas_index=%d.\n",
+ "/The re-scan has finished; current_new_areas_index=%d.\n",
current_new_areas_index));*/
}
return bytes_freed;
}
\f
+#if 0 /* not used as of sbcl-0.6.12.8 */
/* Print some information about a pointer at the given address. */
static void
print_ptr(lispobj *addr)
*(addr+3),
*(addr+4));
}
+#endif
extern int undefined_tramp;
}
}
-/* External entry point for verify_zero_fill */
-void
-gencgc_verify_zero_fill(void)
-{
- /* Flush the alloc regions updating the tables. */
- boxed_region.free_pointer = current_region_free_pointer;
- gc_alloc_update_page_tables(0, &boxed_region);
- gc_alloc_update_page_tables(1, &unboxed_region);
- SHOW("verifying zero fill");
- verify_zero_fill();
- current_region_free_pointer = boxed_region.free_pointer;
- current_region_end_addr = boxed_region.end_addr;
-}
-
static void
verify_dynamic_space(void)
{
generations[generation].alloc_large_unboxed_start_page = 0;
if (generation >= verify_gens) {
- if (gencgc_verbose)
- SHOW("verifying");
+ SHOW("verifying");
verify_gc();
verify_dynamic_space();
}
generations[generation].bytes_allocated
+ generations[generation].bytes_consed_between_gc;
- if (raise)
+ if (raise) {
generations[generation].num_gc = 0;
- else
+ } else {
++generations[generation].num_gc;
+ }
}
/* Update last_free_page then ALLOCATION_POINTER */
int last_page = -1;
int i;
+ FSHOW((stderr,
+ "/entering update_x86_dynamic_space_free_pointer(), "
+ "old value=0x%lx\n",
+ (long)SymbolValue(ALLOCATION_POINTER)));
for (i = 0; i < NUM_PAGES; i++)
if ((page_table[i].allocated != FREE_PAGE)
&& (page_table[i].bytes_used != 0))
last_page = i;
- last_free_page = last_page+1;
+ last_free_page = last_page + 1;
SetSymbolValue(ALLOCATION_POINTER,
(lispobj)(((char *)heap_base) + last_free_page*4096));
+
+ FSHOW((stderr,
+ "/leaving update_x86_dynamic_space_free_pointer(), "
+ "new value=0x%lx\n",
+ (long)SymbolValue(ALLOCATION_POINTER)));
+
return 0; /* dummy value: return something ... */
}
int gen_to_wp;
int i;
+ /* We're about to modify boxed_region in a way which would mess up its
+ * nice tidy reset state if it is currently reset, so make sure it
+ * isn't currently reset: */
+ gc_assert(!alloc_region_looks_reset(&boxed_region));
+
boxed_region.free_pointer = current_region_free_pointer;
FSHOW((stderr, "/entering collect_garbage(%d)\n", last_gen));
/* Verify the new objects created by Lisp code. */
if (pre_verify_gen_0) {
- SHOW((stderr, "pre-checking generation 0\n"));
+ SHOW("pre-checking generation 0\n");
verify_generation(0);
}
if (gencgc_verbose > 1) {
FSHOW((stderr,
- "Starting GC of generation %d with raise=%d alloc=%d trig=%d GCs=%d\n",
+ "/starting GC of generation %d with raise=%d alloc=%d trig=%d GCs=%d\n",
gen,
raise,
generations[gen].bytes_allocated,
generations[gen].cum_sum_bytes_allocated = 0;
if (gencgc_verbose > 1) {
- FSHOW((stderr, "GC of generation %d finished:\n", gen));
+ FSHOW((stderr, "/GC of generation %d finished:\n", gen));
print_generation_stats(0);
}
if (gencgc_verbose > 1)
print_generation_stats(0);
- /* Initialize gc_alloc */
+ /* Initialize gc_alloc(). */
gc_alloc_generation = 0;
- boxed_region.first_page = 0;
- boxed_region.last_page = -1;
- boxed_region.start_addr = page_address(0);
- boxed_region.free_pointer = page_address(0);
- boxed_region.end_addr = page_address(0);
-
- unboxed_region.first_page = 0;
- unboxed_region.last_page = -1;
- unboxed_region.start_addr = page_address(0);
- unboxed_region.free_pointer = page_address(0);
- unboxed_region.end_addr = page_address(0);
+ reset_alloc_region(&boxed_region);
+ reset_alloc_region(&unboxed_region);
#if 0 /* Lisp PURIFY is currently running on the C stack so don't do this. */
zero_stack();
if (verify_after_free_heap) {
/* Check whether purify has left any bad pointers. */
- if (gencgc_verbose)
- SHOW("checking after free_heap\n");
+ SHOW("checking after free_heap\n");
verify_gc();
}
}
int addr = DYNAMIC_SPACE_START;
int alloc_ptr = SymbolValue(ALLOCATION_POINTER);
+ SHOW("entering gencgc_pickup_dynamic()");
+
/* Initialize the first region. */
do {
page_table[page].allocated = BOXED_PAGE;
current_region_free_pointer = boxed_region.free_pointer;
current_region_end_addr = boxed_region.end_addr;
+
+ SHOW("returning from gencgc_pickup_dynamic()");
}
\f
/* a counter for how deep we are in alloc(..) calls */
{
int page_index = find_page_index(fault_addr);
+ /* (When the write barrier is working right, this message is just
+ * a distraction; but when you're trying to get the write barrier
+ * to work, or grok what it's doing, it can be very handy.) */
#if defined QSHOW_SIGNALS
- FSHOW((stderr, "heap WP violation? fault_addr=%x, page_index=%d\n",
- fault_addr, page_index));
+ FSHOW((stderr, "/heap WP violation? fault_addr=0x%0lx, page_index=%d\n",
+ (unsigned long)fault_addr, page_index));
#endif
/* Check whether the fault is within the dynamic space. */
* (If the page is written into, we catch the exception, make
* the page writable, and clear this flag.) */
write_protected :1,
- /* This flag is set when the above write_protected flag is
- * cleared by the sigbus handler. This is useful for
- * re-scavenging pages that are written during a GC. */
+ /* This flag is set when the above write_protected flag is
+ * cleared by the SIGBUS handler (or SIGSEGV handler, for some
+ * OSes). This is useful for * re-scavenging pages that are
+ * written during a GC. */
write_protected_cleared :1,
- /* The region the page is allocated to: 0 for a free page; 1
+ /* the region the page is allocated to: 0 for a free page; 1
* for boxed objects; 2 for unboxed objects. If the page is
* free the following slots are invalid (well the bytes_used
* must be 0). */
int first_object_offset;
};
+/* values for the page.allocated field */
#define FREE_PAGE 0
#define BOXED_PAGE 1
#define UNBOXED_PAGE 2
void *free_pointer;
void *end_addr; /* pointer to the byte after the last usable byte */
- /* needed when closing the region */
+ /* These are needed when closing the region. */
int first_page;
int last_page;
void *start_addr;
lispobj *current_auto_gc_trigger;
#endif
-/* for copying GCs, this points to the start of the dynamic space
+/* For copying GCs, this points to the start of the dynamic space
* currently in use (that will become the from_space when the next GC
- * is done). For the GENCGC, it always points to DYNAMIC_0_SPACE_START */
-lispobj *current_dynamic_space;
+ * is done). For the GENCGC, it always points to DYNAMIC_SPACE_START. */
+lispobj *current_dynamic_space =
+#ifndef GENCGC
+ DYNAMIC_0_SPACE_START;
+#else
+ DYNAMIC_SPACE_START;
+#endif
void globals_init(void)
{
foreign_function_call_active = 1;
/* Initialize the current Lisp state. */
-#ifndef __i386__
+#ifndef __i386__ /* if stack grows upward */
current_control_stack_pointer = (lispobj *)CONTROL_STACK_START;
#else
current_control_stack_pointer = (lispobj *)CONTROL_STACK_END;
extern lispobj *dynamic_space_free_pointer;
extern lispobj *current_auto_gc_trigger;
#endif
-extern lispobj *current_dynamic_space;
+extern lispobj *current_dynamic_space;
extern void globals_init(void);
}
#ifdef QSHOW_SIGNALS
- FSHOW((stderr, "in interrupt_handle_now(%d, info, context)\n", signal));
+ FSHOW((stderr,
+ "/entering interrupt_handle_now(%d, info, context)\n",
+ signal));
#endif
if (ARE_SAME_HANDLER(handler.c, SIG_DFL)) {
{
undo_fake_foreign_function_call(context);
}
+
+#ifdef QSHOW_SIGNALS
+ FSHOW((stderr,
+ "/returning from interrupt_handle_now(%d, info, context)\n",
+ signal));
+#endif
}
static void
sigset_t old, new;
union interrupt_handler oldhandler;
- FSHOW((stderr, "entering POSIX install_handler(%d, ..)\n", signal));
+ FSHOW((stderr, "/entering POSIX install_handler(%d, ..)\n", signal));
sigemptyset(&new);
sigaddset(&new, signal);
sigemptyset(&new);
sigaddset_blockable(&new);
- FSHOW((stderr, "interrupt_low_level_handlers[signal]=%d\n",
+ FSHOW((stderr, "/interrupt_low_level_handlers[signal]=%d\n",
interrupt_low_level_handlers[signal]));
if (interrupt_low_level_handlers[signal]==0) {
if (ARE_SAME_HANDLER(handler, SIG_DFL) ||
sigprocmask(SIG_SETMASK, &old, 0);
- FSHOW((stderr, "leaving POSIX install_handler(%d, ..)\n", signal));
+ FSHOW((stderr, "/leaving POSIX install_handler(%d, ..)\n", signal));
return (unsigned long)oldhandler.lisp;
}
{
int i;
+ SHOW("entering interrupt_init()");
for (i = 0; i < NSIG; i++) {
interrupt_handlers[i].c =
/* (The cast here blasts away the distinction between
* 3-argument form is expected.) */
(void (*)(int, siginfo_t*, void*))SIG_DFL;
}
+ SHOW("returning from interrupt_init()");
}
if (*addr == MAP_FAILED ||
((old_addr != NULL) && (*addr != old_addr))) {
FSHOW((stderr,
- "error in allocating memory from the OS\n"
+ "/error in allocating memory from the OS\n"
"(addr=%lx, len=%lx, flags=%lx)\n",
(long) addr,
(long) len,
static int
maybe_can_move_p(lispobj thing)
{
- lispobj *thingp,header;
- if (dynamic_pointer_p(thing)) { /* in dynamic space */
- thingp = (lispobj*)PTR(thing);
- header = *thingp;
- if(Pointerp(header) && forwarding_pointer_p(header))
- return -1; /* must change it */
- if(LowtagOf(thing) == type_ListPointer)
- return type_ListPointer; /* can we check this somehow */
- else if (thing & 3) { /* not fixnum */
- int kind = TypeOf(header);
- /* printf(" %x %x",header,kind); */
- switch (kind) { /* something with a header */
- case type_Bignum:
- case type_SingleFloat:
- case type_DoubleFloat:
+ lispobj *thingp,header;
+ if (dynamic_pointer_p(thing)) { /* in dynamic space */
+ thingp = (lispobj*)PTR(thing);
+ header = *thingp;
+ if(Pointerp(header) && forwarding_pointer_p(header))
+ return -1; /* must change it */
+ if(LowtagOf(thing) == type_ListPointer)
+ return type_ListPointer; /* can we check this somehow */
+ else if (thing & 3) { /* not fixnum */
+ int kind = TypeOf(header);
+ /* printf(" %x %x",header,kind); */
+ switch (kind) { /* something with a header */
+ case type_Bignum:
+ case type_SingleFloat:
+ case type_DoubleFloat:
#ifdef type_LongFloat
- case type_LongFloat:
-#endif
- case type_Sap:
- case type_SimpleVector:
- case type_SimpleString:
- case type_SimpleBitVector:
- case type_SimpleArrayUnsignedByte2:
- case type_SimpleArrayUnsignedByte4:
- case type_SimpleArrayUnsignedByte8:
- case type_SimpleArrayUnsignedByte16:
- case type_SimpleArrayUnsignedByte32:
+ case type_LongFloat:
+#endif
+ case type_Sap:
+ case type_SimpleVector:
+ case type_SimpleString:
+ case type_SimpleBitVector:
+ case type_SimpleArrayUnsignedByte2:
+ case type_SimpleArrayUnsignedByte4:
+ case type_SimpleArrayUnsignedByte8:
+ case type_SimpleArrayUnsignedByte16:
+ case type_SimpleArrayUnsignedByte32:
#ifdef type_SimpleArraySignedByte8
- case type_SimpleArraySignedByte8:
+ case type_SimpleArraySignedByte8:
#endif
#ifdef type_SimpleArraySignedByte16
- case type_SimpleArraySignedByte16:
+ case type_SimpleArraySignedByte16:
#endif
#ifdef type_SimpleArraySignedByte30
- case type_SimpleArraySignedByte30:
+ case type_SimpleArraySignedByte30:
#endif
#ifdef type_SimpleArraySignedByte32
- case type_SimpleArraySignedByte32:
+ case type_SimpleArraySignedByte32:
#endif
- case type_SimpleArraySingleFloat:
- case type_SimpleArrayDoubleFloat:
+ case type_SimpleArraySingleFloat:
+ case type_SimpleArrayDoubleFloat:
#ifdef type_SimpleArrayLongFloat
- case type_SimpleArrayLongFloat:
+ case type_SimpleArrayLongFloat:
#endif
#ifdef type_SimpleArrayComplexSingleFloat
- case type_SimpleArrayComplexSingleFloat:
+ case type_SimpleArrayComplexSingleFloat:
#endif
#ifdef type_SimpleArrayComplexDoubleFloat
- case type_SimpleArrayComplexDoubleFloat:
+ case type_SimpleArrayComplexDoubleFloat:
#endif
#ifdef type_SimpleArrayComplexLongFloat
- case type_SimpleArrayComplexLongFloat:
-#endif
- case type_CodeHeader:
- case type_FunctionHeader:
- case type_ClosureFunctionHeader:
- case type_ReturnPcHeader:
- case type_ClosureHeader:
- case type_FuncallableInstanceHeader:
- case type_InstanceHeader:
- case type_ValueCellHeader:
- case type_ByteCodeFunction:
- case type_ByteCodeClosure:
- case type_WeakPointer:
- case type_Fdefn:
- return kind;
- break;
- default:
- return 0;
- }}}
- return 0;
+ case type_SimpleArrayComplexLongFloat:
+#endif
+ case type_CodeHeader:
+ case type_FunctionHeader:
+ case type_ClosureFunctionHeader:
+ case type_ReturnPcHeader:
+ case type_ClosureHeader:
+ case type_FuncallableInstanceHeader:
+ case type_InstanceHeader:
+ case type_ValueCellHeader:
+ case type_ByteCodeFunction:
+ case type_ByteCodeClosure:
+ case type_WeakPointer:
+ case type_Fdefn:
+ return kind;
+ break;
+ default:
+ return 0;
+ }}}
+ return 0;
}
static int pverbose=0;
(unsigned int) start_addr, *start_addr);
return 0;
}
- /* Is it plausible cons? */
+ /* Is it a plausible cons? */
if((Pointerp(start_addr[0])
|| ((start_addr[0] & 3) == 0) /* fixnum */
|| (TypeOf(start_addr[0]) == type_BaseChar)
static void
setup_i386_stack_scav(lispobj *lowaddr, lispobj *base)
{
- lispobj *sp = lowaddr;
- num_valid_stack_locations = 0;
- num_valid_stack_ra_locations = 0;
- for (sp = lowaddr; sp < base; sp++) {
- lispobj thing = *sp;
- /* Find the object start address */
- lispobj *start_addr = search_dynamic_space((void *)thing);
- if (start_addr) {
- /* We need to allow raw pointers into Code objects for return
- * addresses. This will also pick up pointers to functions in code
- * objects. */
- if (TypeOf(*start_addr) == type_CodeHeader) {
- gc_assert(num_valid_stack_ra_locations < MAX_STACK_RETURN_ADDRESSES);
- valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
- valid_stack_ra_code_objects[num_valid_stack_ra_locations++] =
- (lispobj *)((int)start_addr + type_OtherPointer);
- } else {
- if (valid_dynamic_space_pointer((void *)thing, start_addr)) {
- gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS);
- valid_stack_locations[num_valid_stack_locations++] = sp;
+ lispobj *sp = lowaddr;
+ num_valid_stack_locations = 0;
+ num_valid_stack_ra_locations = 0;
+ for (sp = lowaddr; sp < base; sp++) {
+ lispobj thing = *sp;
+ /* Find the object start address */
+ lispobj *start_addr = search_dynamic_space((void *)thing);
+ if (start_addr) {
+ /* We need to allow raw pointers into Code objects for
+ * return addresses. This will also pick up pointers to
+ * functions in code objects. */
+ if (TypeOf(*start_addr) == type_CodeHeader) {
+ gc_assert(num_valid_stack_ra_locations <
+ MAX_STACK_RETURN_ADDRESSES);
+ valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
+ valid_stack_ra_code_objects[num_valid_stack_ra_locations++] =
+ (lispobj *)((int)start_addr + type_OtherPointer);
+ } else {
+ if (valid_dynamic_space_pointer((void *)thing, start_addr)) {
+ gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS);
+ valid_stack_locations[num_valid_stack_locations++] = sp;
+ }
+ }
}
- }
}
- }
- if (pointer_filter_verbose) {
- fprintf(stderr, "number of valid stack pointers = %d\n",
- num_valid_stack_locations);
- fprintf(stderr, "number of stack return addresses = %d\n",
- num_valid_stack_ra_locations);
- }
+ if (pointer_filter_verbose) {
+ fprintf(stderr, "number of valid stack pointers = %d\n",
+ num_valid_stack_locations);
+ fprintf(stderr, "number of stack return addresses = %d\n",
+ num_valid_stack_ra_locations);
+ }
}
static void
pscav_i386_stack(void)
{
- int i;
+ int i;
- for (i = 0; i < num_valid_stack_locations; i++)
- pscav(valid_stack_locations[i], 1, 0);
+ for (i = 0; i < num_valid_stack_locations; i++)
+ pscav(valid_stack_locations[i], 1, 0);
- for (i = 0; i < num_valid_stack_ra_locations; i++) {
- lispobj code_obj = (lispobj)valid_stack_ra_code_objects[i];
- pscav(&code_obj, 1, 0);
- if (pointer_filter_verbose) {
- fprintf(stderr,"*C moved RA %x to %x; for code object %x to %x\n",
- *valid_stack_ra_locations[i],
- (int)(*valid_stack_ra_locations[i])
- - ((int)valid_stack_ra_code_objects[i] - (int)code_obj),
- (unsigned int) valid_stack_ra_code_objects[i], code_obj);
+ for (i = 0; i < num_valid_stack_ra_locations; i++) {
+ lispobj code_obj = (lispobj)valid_stack_ra_code_objects[i];
+ pscav(&code_obj, 1, 0);
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*C moved RA %x to %x; for code object %x to %x\n",
+ *valid_stack_ra_locations[i],
+ (int)(*valid_stack_ra_locations[i])
+ - ((int)valid_stack_ra_code_objects[i] - (int)code_obj),
+ (unsigned int) valid_stack_ra_code_objects[i], code_obj);
+ }
+ *valid_stack_ra_locations[i] =
+ ((int)(*valid_stack_ra_locations[i])
+ - ((int)valid_stack_ra_code_objects[i] - (int)code_obj));
}
- *valid_stack_ra_locations[i] =
- ((int)(*valid_stack_ra_locations[i])
- - ((int)valid_stack_ra_code_objects[i] - (int)code_obj));
- }
}
#endif
#endif
}
}
-static lispobj ptrans_boxed(lispobj thing, lispobj header, boolean constant)
+static lispobj
+ptrans_boxed(lispobj thing, lispobj header, boolean constant)
{
int nwords;
lispobj result, *new, *old;
}
/* We need to look at the layout to see whether it is a pure structure
- * class, and only then can we transport as constant. If it is pure, we can
- * ALWAYS transport as a constant. */
-static lispobj ptrans_instance(lispobj thing, lispobj header, boolean constant)
+ * class, and only then can we transport as constant. If it is pure,
+ * we can ALWAYS transport as a constant. */
+static lispobj
+ptrans_instance(lispobj thing, lispobj header, boolean constant)
{
lispobj layout = ((struct instance *)PTR(thing))->slots[0];
lispobj pure = ((struct instance *)PTR(layout))->slots[15];
}
}
-static lispobj ptrans_fdefn(lispobj thing, lispobj header)
+static lispobj
+ptrans_fdefn(lispobj thing, lispobj header)
{
int nwords;
lispobj result, *new, *old, oldfn;
return result;
}
-static lispobj ptrans_unboxed(lispobj thing, lispobj header)
+static lispobj
+ptrans_unboxed(lispobj thing, lispobj header)
{
int nwords;
lispobj result, *new, *old;
return result;
}
-static lispobj ptrans_vector(lispobj thing, int bits, int extra,
- boolean boxed, boolean constant)
+static lispobj
+ptrans_vector(lispobj thing, int bits, int extra,
+ boolean boxed, boolean constant)
{
struct vector *vector;
int nwords;
}
#endif
-static lispobj ptrans_code(lispobj thing)
+static lispobj
+ptrans_code(lispobj thing)
{
struct code *code, *new;
int nwords;
return result;
}
-static lispobj ptrans_func(lispobj thing, lispobj header)
+static lispobj
+ptrans_func(lispobj thing, lispobj header)
{
int nwords;
lispobj code, *new, *old, result;
}
}
-static lispobj ptrans_returnpc(lispobj thing, lispobj header)
+static lispobj
+ptrans_returnpc(lispobj thing, lispobj header)
{
lispobj code, new;
#define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
-static lispobj ptrans_list(lispobj thing, boolean constant)
+static lispobj
+ptrans_list(lispobj thing, boolean constant)
{
struct cons *old, *new, *orig;
int length;
return ((lispobj)orig) | type_ListPointer;
}
-static lispobj ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
+static lispobj
+ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
{
switch (TypeOf(header)) {
case type_Bignum:
}
}
-static int pscav_fdefn(struct fdefn *fdefn)
+static int
+pscav_fdefn(struct fdefn *fdefn)
{
boolean fix_func;
}
#endif
-static lispobj *pscav(lispobj *addr, int nwords, boolean constant)
+static lispobj *
+pscav(lispobj *addr, int nwords, boolean constant)
{
lispobj thing, *thingp, header;
int count = 0; /* (0 = dummy init value to stop GCC warning) */
return addr;
}
-int purify(lispobj static_roots, lispobj read_only_roots)
+int
+purify(lispobj static_roots, lispobj read_only_roots)
{
lispobj *clean;
int count, i;
fflush(stdout);
#endif
#if !defined(ibmrt) && !defined(__i386__)
- pscav( (lispobj *)BINDING_STACK_START,
- (lispobj *)current_binding_stack_pointer - (lispobj *)BINDING_STACK_START,
+ pscav((lispobj *)BINDING_STACK_START,
+ (lispobj *)current_binding_stack_pointer
+ - (lispobj *)BINDING_STACK_START,
0);
#else
pscav( (lispobj *)BINDING_STACK_START,
#ifdef SCAVENGE_READ_ONLY_SPACE
if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != type_UnboundMarker
&& SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
- unsigned read_only_space_size =
- (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
- (lispobj *)READ_ONLY_SPACE_START;
- fprintf(stderr,
- "scavenging read only space: %d bytes\n",
- read_only_space_size * sizeof(lispobj));
- pscav( (lispobj *)READ_ONLY_SPACE_START, read_only_space_size, 0);
+ unsigned read_only_space_size =
+ (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
+ (lispobj *)READ_ONLY_SPACE_START;
+ fprintf(stderr,
+ "scavenging read only space: %d bytes\n",
+ read_only_space_size * sizeof(lispobj));
+ pscav( (lispobj *)READ_ONLY_SPACE_START, read_only_space_size, 0);
}
#endif
#if defined(WANT_CGC) && defined(STATIC_BLUE_BAG)
{
- lispobj bag = SymbolValue(STATIC_BLUE_BAG);
- struct cons*cons = (struct cons*)static_free;
- struct cons*pair = cons + 1;
- static_free += 2*WORDS_PER_CONS;
- if(bag == type_UnboundMarker)
- bag = NIL;
- cons->cdr = bag;
- cons->car = (lispobj)pair | type_ListPointer;
- pair->car = (lispobj)static_end;
- pair->cdr = (lispobj)static_free;
- bag = (lispobj)cons | type_ListPointer;
- SetSymbolValue(STATIC_BLUE_BAG, bag);
+ lispobj bag = SymbolValue(STATIC_BLUE_BAG);
+ struct cons *cons = (struct cons*)static_free;
+ struct cons *pair = cons + 1;
+ static_free += 2 * WORDS_PER_CONS;
+ if(bag == type_UnboundMarker)
+ bag = NIL;
+ cons->cdr = bag;
+ cons->car = (lispobj)pair | type_ListPointer;
+ pair->car = (lispobj)static_end;
+ pair->cdr = (lispobj)static_free;
+ bag = (lispobj)cons | type_ListPointer;
+ SetSymbolValue(STATIC_BLUE_BAG, bag);
}
#endif
- /* It helps to update the heap free pointers so that free_heap can
- * verify after it's done. */
+ /* It helps to update the heap free pointers so that free_heap()
+ * can verify after it's done. */
SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free);
SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free);
else
cgc_free_heap();
#else
-#if defined GENCGC
+#if defined(GENCGC)
gc_free_heap();
#else
/* ibmrt using GC */
\f
/* SIGINT handler that invokes the monitor (for when Lisp isn't up to it) */
-static void sigint_handler(int signal, siginfo_t *info, void *void_context)
+static void
+sigint_handler(int signal, siginfo_t *info, void *void_context)
{
printf("\nSIGINT hit at 0x%08lX\n",
(unsigned long) *os_context_pc_addr(void_context));
/* (This is not static, because we want to be able to call it from
* Lisp land.) */
-void sigint_init(void)
+void
+sigint_init(void)
{
+ SHOW("entering sigint_init()");
install_handler(SIGINT, sigint_handler);
+ SHOW("leaving sigint_init()");
}
\f
/*
if (initial_function == NIL) {
lose("couldn't find initial function");
}
+ SHOW("freeing core");
free(core);
#if defined GENCGC
#ifdef PSEUDO_ATOMIC_ATOMIC
/* Turn on pseudo atomic for when we call into Lisp. */
+ SHOW("turning on pseudo atomic");
SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1));
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0));
#endif
/* Convert remaining argv values to something that Lisp can grok. */
+ SHOW("setting POSIX-ARGV symbol value");
SetSymbolValue(POSIX_ARGV, alloc_string_list(argv));
/* Install a handler to pick off SIGINT until the Lisp system gets
* far enough along to install its own handler. */
sigint_init();
+ FSHOW((stderr, "/funcalling initial_function=0x%lx\n", initial_function));
funcall0(initial_function);
/* initial_function() is not supposed to return. */
bytes = words * sizeof(lispobj);
- printf("writing %d bytes from the %s space at 0x%08lx\n",
- bytes, names[id], (unsigned long)addr);
+ printf("writing %ld(0x%lx) bytes from the %s(%d) space at 0x%08lx\n",
+ (long)bytes, (long)bytes, names[id], id, (unsigned long)addr);
data = write_bytes(file, (char *)addr, bytes);
init_function = *func_ptr;
/* Set dynamic space pointer to base value so we don't write out
* MBs of just cleared heap. */
- if(SymbolValue(X86_CGC_ACTIVE_P) != NIL)
- SetSymbolValue(ALLOCATION_POINTER, DYNAMIC_SPACE_START);
+ if(SymbolValue(X86_CGC_ACTIVE_P) != NIL) {
+ SetSymbolValue(ALLOCATION_POINTER, DYNAMIC_SPACE_START);
+ }
#endif
/* Open the file: */
unlink(filename);
putw(SBCL_CORE_VERSION_INTEGER, file);
putw(CORE_NDIRECTORY, file);
- putw((5*3)+2, file);
+ putw((5*3)+2, file); /* 3 5-word space descriptors, plus code and count */
output_space(file, READ_ONLY_SPACE_ID, (lispobj *)READ_ONLY_SPACE_START,
(lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
(lispobj *)SymbolValue(ALLOCATION_POINTER));
#endif
+ FSHOW((stderr, "/writing init_function=0x%lx\n", (long)init_function));
+ FSHOW((stderr, "/(SymbolValue(ALLOCATION_POINTER)=0x%lx\n",
+ (long)SymbolValue(ALLOCATION_POINTER)));
putw(CORE_INITIAL_FUNCTION, file);
putw(3, file);
putw(init_function, file);
#include "sbcl.h"
#include "validate.h"
-static void ensure_space(lispobj *start, unsigned long size)
+static void
+ensure_space(lispobj *start, unsigned long size)
{
if (os_validate((os_vm_address_t)start,(os_vm_size_t)size)==NULL) {
fprintf(stderr,
static os_vm_address_t holes[] = HOLES;
-static void make_holes(void)
+static void
+make_holes(void)
{
int i;
}
#endif
-void validate(void)
+void
+validate(void)
{
#ifdef PRINTNOISE
printf("validating memory ...");
#ifdef HOLES
make_holes();
#endif
-#ifndef GENCGC
- current_dynamic_space = DYNAMIC_0_SPACE_START;
-#endif
#ifdef PRINTNOISE
printf(" done.\n");
* architecture-dependent header file of memory map data.
*/
-
-
#endif
/* a representation of stat(2) results which doesn't depend on CPU or OS */
struct stat_wrapper {
- my_dev_t st_dev; /* device */
- ino_t st_ino; /* inode */
- mode_t st_mode; /* protection */
- nlink_t st_nlink; /* number of hard links */
- uid_t st_uid; /* user ID of owner */
- gid_t st_gid; /* group ID of owner */
- my_dev_t st_rdev; /* device type (if inode device) */
- off_t st_size; /* total size, in bytes */
- unsigned long st_blksize; /* blocksize for filesystem I/O */
- unsigned long st_blocks; /* number of blocks allocated */
- time_t st_atime; /* time of last access */
- time_t st_mtime; /* time of last modification */
- time_t st_ctime; /* time of last change */
+ /* KLUDGE: The verbose wrapped_st_ prefixes are to protect us from
+ * the C preprocessor as wielded by the fiends of OpenBSD, who do
+ * things like
+ * #define st_atime st_atimespec.tv_sec
+ * I remember when I was young and innocent, I read about how the
+ * C preprocessor isn't to be used to globally munge random
+ * lowercase symbols like this, because things like this could
+ * happen, and I nodded sagely. But now I know better.:-| This is
+ * another entry for Dan Barlow's ongoing episodic rant about C
+ * header files, I guess.. -- WHN 2001-05-10 */
+ my_dev_t wrapped_st_dev; /* device */
+ ino_t wrapped_st_ino; /* inode */
+ mode_t wrapped_st_mode; /* protection */
+ nlink_t wrapped_st_nlink; /* number of hard links */
+ uid_t wrapped_st_uid; /* user ID of owner */
+ gid_t wrapped_st_gid; /* group ID of owner */
+ my_dev_t wrapped_st_rdev; /* device type (if inode device) */
+ off_t wrapped_st_size; /* total size, in bytes */
+ unsigned long wrapped_st_blksize; /* blocksize for filesystem I/O */
+ unsigned long wrapped_st_blocks; /* number of blocks allocated */
+ time_t wrapped_st_atime; /* time_t of last access */
+ time_t wrapped_st_mtime; /* time_t of last modification */
+ time_t wrapped_st_ctime; /* time_t of last change */
};
static void
copy_to_stat_wrapper(struct stat_wrapper *to, struct stat *from)
{
-#define FROB(stem) to->st_##stem = from->st_##stem
+#define FROB(stem) to->wrapped_st_##stem = from->st_##stem
FROB(dev);
FROB(ino);
FROB(mode);
int vlen;
int code;
- FSHOW((stderr, "[arch_skip_inst at %x]\n", *os_context_pc_addr(context)));
+ FSHOW((stderr, "/[arch_skip_inst at %x]\n", *os_context_pc_addr(context)));
/* Get and skip the Lisp interrupt code. */
code = *(char*)(*os_context_pc_addr(context))++;
}
FSHOW((stderr,
- "[arch_skip_inst resuming at %x]\n",
+ "/[arch_skip_inst resuming at %x]\n",
*os_context_pc_addr(context)));
}
switch (trap) {
case trap_PendingInterrupt:
- FSHOW((stderr, "<trap pending interrupt>\n"));
+ FSHOW((stderr, "/<trap pending interrupt>\n"));
arch_skip_instruction(context);
interrupt_handle_pending(context);
break;
break;
default:
- FSHOW((stderr,"[C--trap default %d %d %x]\n",
+ FSHOW((stderr,"/[C--trap default %d %d %x]\n",
signal, code, context));
interrupt_handle_now(signal, info, context);
break;
void
arch_install_interrupt_handlers()
{
+ SHOW("entering arch_install_interrupt_handlers()");
interrupt_install_low_level_handler(SIGILL , sigtrap_handler);
interrupt_install_low_level_handler(SIGTRAP, sigtrap_handler);
+ SHOW("returning from arch_install_interrupt_handlers()");
}
\f
/* This is implemented in assembly language and called from C: */
{
lispobj *args = NULL;
+ FSHOW((stderr, "/entering funcall0(0x%lx)\n", (long)function));
return call_into_lisp(function, args, 0);
}
lispobj
+# 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.
+
all: grovel_headers
+
clean:
- -rm *.o grovel_headers
+ -rm -f *.o grovel_headers
#include <sys/times.h>
#include <sys/stat.h>
#include <fcntl.h>
+#include <unistd.h>
#define DEFTYPE(lispname,cname) { cname foo; \
printf("(def-alien-type "##lispname##" (%s %d))\n", (((foo=-1)<0) ? "sb!alien:signed" : "unsigned"), (8 * (sizeof foo))); }
DEFTYPE("time-t", time_t);
printf("\n");
- printf(";;; fcntl.h\n");
+ printf(";;; fcntl.h (or unistd.h on OpenBSD)\n");
defconstant("r_ok", R_OK);
defconstant("w_ok", W_OK);
defconstant("x_ok", X_OK);
;;; 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.7"
+"0.6.12.7.flaky1"
projects / sbcl.git / commitdiff