--- /dev/null
+;;;; needed-early, or at least meaningful-early, stuff for FASL files
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!FASL")
+\f
+;;;; various constants and essentially-constants
+
+;;; a string which appears at the start of a fasl file header
+;;;
+;;; This value is used to identify fasl files. Even though this is not
+;;; declared as a constant (because ANSI Common Lisp has no facility
+;;; for declaring values which are constant under EQUAL but not EQL),
+;;; obviously you shouldn't mess with it lightly. If you do set a new
+;;; value for some reason, keep these things in mind:
+;;; * To avoid confusion with the similar but incompatible CMU CL
+;;; fasl file format, the value should not be "FASL FILE", which
+;;; is what CMU CL used for the same purpose.
+;;; * Since its presence at the head of a file is used by LOAD to
+;;; decide whether a file is to be fasloaded or just loaded
+;;; ordinarily (as source), the value should be something which
+;;; can't legally appear at the head of a Lisp source file.
+;;; * The value should not contain any line-terminating characters,
+;;; because they're hard to express portably and because the LOAD
+;;; code might reasonably use READ-LINE to get the value to compare
+;;; against.
+(defparameter *fasl-header-string-start-string* "# FASL")
+
+;;; the code for a character which terminates a fasl file header
+(defconstant +fasl-header-string-stop-char-code+ 255)
+
+;;; This value should be incremented when the system changes in such
+;;; a way that it will no longer work reliably with old fasl files.
- (defconstant +fasl-file-version+ 12)
++(defconstant +fasl-file-version+ 13)
+;;; 2 = sbcl-0.6.4 uses COMPILE-OR-LOAD-DEFGENERIC.
+;;; 3 = sbcl-0.6.6 uses private symbol, not :EMPTY, for empty HASH-TABLE slot.
+;;; 4 = sbcl-0.6.7 uses HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
+;;; when array headers or data element type uncertainty exist, and
+;;; uses DATA-VECTOR-REF and DATA-VECTOR-SET only for VOPs. (Thus,
+;;; full calls to DATA-VECTOR-REF and DATA-VECTOR-SET from older
+;;; fasl files would fail, because there are no DEFUNs for these
+;;; operations any more.)
+;;; 5 = sbcl-0.6.8 has rearranged static symbols.
+;;; 6 = sbcl-0.6.9, got rid of non-ANSI %DEFCONSTANT/%%DEFCONSTANT stuff
+;;; and deleted a slot from DEBUG-SOURCE structure.
+;;; 7 = around sbcl-0.6.9.8, merged SB-CONDITIONS package into SB-KERNEL
+;;; 8 = sbcl-0.6.10.4 revived Gray stream support, changing stream layouts.
+;;; 9 = deleted obsolete CONS-UNIQUE-TAG bytecode in sbcl-0.6.11.8
+;;; (somewhere in here also changes to AND and OR CTYPE layouts)
+;;; 10 = new layout for CONDITION in sbcl-0.6.11.38
+;;; 11 = (a) new helper functions for MAKE-LOAD-FORM (HASH-TABLE) in
- ;;; sbcl-0.6.12.11
- ;;; (b) new address space constants for OpenBSD in 0.6.12.17,
- ;;; doesn't need separate version from (a) because the OpenBSD
- ;;; port was broken from sometime before 0.6.12.11 until
- ;;; the address space was changed
++;;; sbcl-0.6.12.11
++;;; (b) new address space constants for OpenBSD in 0.6.12.17
++;;; (doesn't need separate version from (a) because the
++;;; OpenBSD port was broken from sometime before 0.6.12.11
++;;; until the address space was changed)
+;;; 12 = sbcl-0.6.12.22 added new SB-FASL package
++;;; 13 = sbcl-0.6.12.x removed some elements from *STATIC-SYMBOLS*
+
+;;; the conventional file extension for fasl files on this
+;;; architecture, e.g. "x86f"
+(declaim (type (or simple-string null) *backend-fasl-file-type*))
+(defvar *backend-fasl-file-type* nil)
+
+;;; This is a sort of pun that we inherited from CMU CL. For ordinary,
+;;; non-byte-coded fasl files, the "implementation" is basically the
+;;; CPU. For byte-coded fasl files, the "implementation" is whether
+;;; the data are stored big-endianly or little-endianly.
+(defun backend-byte-fasl-file-implementation ()
+ *backend-byte-order*)
+\f
+;;; information about below-Lisp-level linkage
+;;;
+;;; Note:
+;;; Assembler routines are named by full Lisp symbols: they
+;;; have packages and that sort of native Lisp stuff associated
+;;; with them. We can compare them with EQ.
+;;; Foreign symbols are named by Lisp strings: the Lisp package
+;;; system doesn't extend out to symbols in languages like C.
+;;; We want to use EQUAL to compare them.
+;;; *STATIC-FOREIGN-SYMBOLS* are static as opposed to "dynamic" (not
+;;; as opposed to "extern"). The table contains symbols known at
+;;; the time that the program was built, but not symbols defined
+;;; in object files which have been loaded dynamically since then.
+(declaim (type hash-table *assembler-routines* *static-foreign-symbols*))
+(defvar *assembler-routines* (make-hash-table :test 'eq))
+(defvar *static-foreign-symbols* (make-hash-table :test 'equal))
+\f
+;;;; the FOP database
+
+(declaim (simple-vector *fop-names* *fop-functions*))
+
+;;; a vector indexed by a FaslOP that yields the FOP's name
+(defvar *fop-names* (make-array 256 :initial-element nil))
+
+;;; a vector indexed by a FaslOP that yields a function of 0 arguments
+;;; which will perform the operation
+(defvar *fop-functions*
+ (make-array 256
+ :initial-element (lambda ()
+ (error "corrupt fasl file: losing FOP"))))
+\f
+;;;; other miscellaneous loading-related stuff
+
+\f
+;;;; variables
+
+(defvar *load-depth* 0
+ #!+sb-doc
+ "the current number of recursive LOADs")
+(declaim (type index *load-depth*))
+
+;;; the FASL file we're reading from
+(defvar *fasl-input-stream*)
+(declaim (type lisp-stream *fasl-input-stream*))
+
+(defvar *load-print* nil
+ #!+sb-doc
+ "the default for the :PRINT argument to LOAD")
+(defvar *load-verbose* nil
+ ;; Note that CMU CL's default for this was T, and ANSI says it's
+ ;; implementation-dependent. We choose NIL on the theory that it's
+ ;; a nicer default behavior for Unix programs.
+ #!+sb-doc
+ "the default for the :VERBOSE argument to LOAD")
+
+(defvar *load-code-verbose* nil)
+
sb!vm::*fp-constant-l2e*
sb!vm::*fp-constant-lg2*
sb!vm::*fp-constant-ln2*
-- sb!vm::*scavenge-read-only-space*
-- sb!pcl::..slot-unbound..
-- sb!vm::*x86-cgc-active-p*
-- sb!vm::*static-blue-bag*))
++ sb!pcl::..slot-unbound..))
(declaim (type (or index null) *gc-trigger*))
--;;; On the RT, we store the GC trigger in a ``static'' symbol instead of
--;;; letting magic C code handle it. It gets initialized by the startup
--;;; code. The X86 port defines this here because it uses the `ibmrt'
--;;; feature in the C code for allocation and binding stack access and
--;;; a lot of stuff wants this INTERNAL_GC_TRIGGER available as well.
--#!+(or ibmrt x86)
++;;; On the X86, we store the GC trigger in a ``static'' symbol instead
++;;; of letting magic C code handle it. It gets initialized by the
++;;; startup code.
++#!+x86
(defvar sb!vm::*internal-gc-trigger*)
;;;; The following specials are used to control when garbage collection
(defvar *fp-constant-lg2*)
(defvar *fp-constant-ln2*)
--;;; Enable/disable scavenging of the read-only space.
--(defvar *scavenge-read-only-space* nil)
--;;; FIXME: should be *SCAVENGE-READ-ONLY-SPACE-P*
--
;;; The current alien stack pointer; saved/restored for non-local exits.
(defvar *alien-stack*)
(gspace-name gspace)
"unknown"))))))))
--(defun allocate-descriptor (gspace length lowtag)
-- #!+sb-doc
-- "Return a descriptor for a block of LENGTH bytes out of GSPACE. The free
-- word index is boosted as necessary, and if additional memory is needed, we
-- grow the GSPACE. The descriptor returned is a pointer of type LOWTAG."
++;;; Return a descriptor for a block of LENGTH bytes out of GSPACE. The
++;;; free word index is boosted as necessary, and if additional memory
++;;; is needed, we grow the GSPACE. The descriptor returned is a
++;;; pointer of type LOWTAG.
++(defun allocate-cold-descriptor (gspace length lowtag)
(let* ((bytes (round-up length (ash 1 sb!vm:lowtag-bits)))
(old-free-word-index (gspace-free-word-index gspace))
(new-free-word-index (+ old-free-word-index
#!+sb-doc
"Allocate LENGTH words in GSPACE and return a new descriptor of type LOWTAG
pointing to them."
-- (allocate-descriptor gspace (ash length sb!vm:word-shift) lowtag))
++ (allocate-cold-descriptor gspace (ash length sb!vm:word-shift) lowtag))
(defun allocate-unboxed-object (gspace element-bits length type)
#!+sb-doc
"Allocate LENGTH units of ELEMENT-BITS bits plus a header word in GSPACE and
return an ``other-pointer'' descriptor to them. Initialize the header word
with the resultant length and TYPE."
(let* ((bytes (/ (* element-bits length) sb!vm:byte-bits))
-- (des (allocate-descriptor gspace
-- (+ bytes sb!vm:word-bytes)
-- sb!vm:other-pointer-type)))
++ (des (allocate-cold-descriptor gspace
++ (+ bytes sb!vm:word-bytes)
++ sb!vm:other-pointer-type)))
(write-memory des
(make-other-immediate-descriptor (ash bytes
(- sb!vm:word-shift))
;; FIXME: Here and in ALLOCATE-UNBOXED-OBJECT, BYTES is calculated using
;; #'/ instead of #'CEILING, which seems wrong.
(let* ((bytes (/ (* element-bits length) sb!vm:byte-bits))
-- (des (allocate-descriptor gspace (+ bytes (* 2 sb!vm:word-bytes))
-- sb!vm:other-pointer-type)))
++ (des (allocate-cold-descriptor gspace
++ (+ bytes (* 2 sb!vm:word-bytes))
++ sb!vm:other-pointer-type)))
(write-memory des (make-other-immediate-descriptor 0 type))
(write-wordindexed des
sb!vm:vector-length-slot
(cold-set 'sb!vm::*fp-constant-lg2* (number-to-core (log 2L0 10L0)))
(cold-set 'sb!vm::*fp-constant-ln2*
(number-to-core
-- (log 2L0 2.718281828459045235360287471352662L0))))
-- #!+gencgc
-- (cold-set 'sb!vm::*SCAVENGE-READ-ONLY-GSPACE* *nil-descriptor*)))
++ (log 2L0 2.718281828459045235360287471352662L0))))))
;;; Make a cold list that can be used as the arg list to MAKE-PACKAGE in order
;;; to make a package that is similar to PKG.
;; Note: we round the number of constants up to ensure
;; that the code vector will be properly aligned.
(round-up raw-header-n-words 2))
-- (des (allocate-descriptor
-- ;; In the X86 with CGC, code can't be relocated, so
-- ;; we have to put it into static space. In all other
-- ;; configurations, code can go into dynamic space.
-- #!+(and x86 cgc) *static* ; KLUDGE: Why? -- WHN 19990907
-- #!-(and x86 cgc) *dynamic*
-- (+ (ash header-n-words sb!vm:word-shift) code-size)
-- sb!vm:other-pointer-type)))
++ (des (allocate-cold-descriptor *dynamic*
++ (+ (ash header-n-words
++ sb!vm:word-shift)
++ code-size)
++ sb!vm:other-pointer-type)))
(write-memory des
(make-other-immediate-descriptor header-n-words
sb!vm:code-header-type))
;; Note: we round the number of constants up to ensure that
;; the code vector will be properly aligned.
(round-up sb!vm:code-constants-offset 2))
-- (des (allocate-descriptor *read-only*
-- (+ (ash header-n-words sb!vm:word-shift)
-- length)
-- sb!vm:other-pointer-type)))
++ (des (allocate-cold-descriptor *read-only*
++ (+ (ash header-n-words
++ sb!vm:word-shift)
++ length)
++ sb!vm:other-pointer-type)))
(write-memory des
(make-other-immediate-descriptor header-n-words
sb!vm:code-header-type))
;; Tell the target Lisp how much stuff we've allocated.
(cold-set 'sb!vm:*read-only-space-free-pointer*
-- (allocate-descriptor *read-only* 0 sb!vm:even-fixnum-type))
++ (allocate-cold-descriptor *read-only*
++ 0
++ sb!vm:even-fixnum-type))
(cold-set 'sb!vm:*static-space-free-pointer*
-- (allocate-descriptor *static* 0 sb!vm:even-fixnum-type))
++ (allocate-cold-descriptor *static*
++ 0
++ sb!vm:even-fixnum-type))
(cold-set 'sb!vm:*initial-dynamic-space-free-pointer*
-- (allocate-descriptor *dynamic* 0 sb!vm:even-fixnum-type))
++ (allocate-cold-descriptor *dynamic*
++ 0
++ sb!vm:even-fixnum-type))
(/show "done setting free pointers")
;; Write results to files.
;;; Note these spaces grow from low to high addresses.
(defvar *allocation-pointer*)
(defvar *binding-stack-pointer*)
--(defvar *x86-cgc-active-p*) ; FIXME: Document this.
--(defvar *static-blue-bag* nil)
;;; FIXME: *!INITIAL-FDEFN-OBJECTS* and !COLD-INIT probably don't need
;;; to be in the static symbols table any more. Also, if
sb!vm::*fp-constant-lg2*
sb!vm::*fp-constant-ln2*
-- ;; used by gencgc
-- sb!vm::*scavenge-read-only-space*
--
;; The ..SLOT-UNBOUND.. symbol is static in order to optimise the
;; common slot unbound check.
-- sb!pcl::..slot-unbound..
--
-- ;; spare symbols
-- sb!vm::spare-10
-- sb!vm::spare-9
-- sb!vm::spare-8
-- sb!vm::spare-7
-- sb!vm::spare-6
-- sb!vm::spare-5
-- sb!vm::spare-4
-- sb!vm::spare-3
-- sb!vm::spare-2
-- sb!vm::spare-1
--
-- ;; used by cgc
-- sb!vm::*x86-cgc-active-p*
-- sb!vm::*static-blue-bag* ; must be last or change C code
-- ))
++ ;;
++ ;; FIXME: In SBCL, the CLOS code has become sufficiently tightly
++ ;; integrated into the system that it'd probably make sense to use
++ ;; the ordinary unbound marker for this.
++ sb!pcl::..slot-unbound..))
(defparameter *static-functions*
'(length
#include "gc.h"
#include <stdio.h>
--#ifdef ibmrt
--#define GET_FREE_POINTER() ((lispobj *)SymbolValue(ALLOCATION_POINTER))
--#define SET_FREE_POINTER(new_value) \
-- (SetSymbolValue(ALLOCATION_POINTER,(lispobj)(new_value)))
--#define GET_GC_TRIGGER() ((lispobj *)SymbolValue(INTERNAL_GC_TRIGGER))
--#define SET_GC_TRIGGER(new_value) \
-- (SetSymbolValue(INTERNAL_GC_TRIGGER,(lispobj)(new_value)))
--#else
#define GET_FREE_POINTER() dynamic_space_free_pointer
#define SET_FREE_POINTER(new_value) \
(dynamic_space_free_pointer = (new_value))
#define GET_GC_TRIGGER() current_auto_gc_trigger
#define SET_GC_TRIGGER(new_value) \
clear_auto_gc_trigger(); set_auto_gc_trigger(new_value);
#define ALIGNED_SIZE(n) (n+lowtag_Mask) & ~lowtag_Mask
--#if defined(WANT_CGC) || defined(GENCGC)
++#if defined GENCGC
extern lispobj *alloc(int bytes);
#else
static lispobj *
}
#endif
/* FIXME: Should the conditional here be reg_ALLOC instead of
-- * defined(ibmrt) || defined(__i386__)
++ * defined(__i386__)
* ? */
--#if defined(ibmrt) || defined(__i386__)
++#if defined(__i386__)
SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer);
#else
dynamic_space_free_pointer = free_pointer;
#include "globals.h"
#include "dynbind.h"
--#if defined(ibmrt) || defined(__i386__)
++#if defined(__i386__)
#define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER))
#define SetBSP(value) SetSymbolValue(BINDING_STACK_POINTER, (lispobj)(value))
#else
/* Set up from space and new space pointers. */
from_space = current_dynamic_space;
--#ifndef ibmrt
from_space_free_pointer = dynamic_space_free_pointer;
--#else
-- from_space_free_pointer = (lispobj *)SymbolValue(ALLOCATION_POINTER);
--#endif
#ifdef PRINTNOISE
fprintf(stderr,"from_space = %lx\n",
scavenge(((lispobj *)CONTROL_STACK_START), control_stack_size);
binding_stack_size =
current_binding_stack_pointer -
(lispobj *)BINDING_STACK_START;
--#endif
#ifdef PRINTNOISE
printf("Scavenging the binding stack %x - %x (%d words) ...\n",
BINDING_STACK_START,current_binding_stack_pointer,
(os_vm_size_t) DYNAMIC_SPACE_SIZE);
current_dynamic_space = new_space;
--#ifndef ibmrt
dynamic_space_free_pointer = new_space_free_pointer;
--#else
-- SetSymbolValue(ALLOCATION_POINTER, (lispobj)new_space_free_pointer);
--#endif
#ifdef PRINTNOISE
size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj);
\f
/* noise to manipulate the gc trigger stuff */
--#ifndef ibmrt
--
void set_auto_gc_trigger(os_vm_size_t dynamic_usage)
{
os_vm_address_t addr=(os_vm_address_t)current_dynamic_space +
current_auto_gc_trigger = NULL;
}
}
--
--#endif
* adds another GC, or ports one of the other CMU CL GCs like gengc. */
extern void collect_garbage(unsigned last_gen);
--#ifndef ibmrt
--
#include "os.h"
extern void set_auto_gc_trigger(os_vm_size_t usage);
extern void clear_auto_gc_trigger(void);
--#endif ibmrt
--
#endif _GC_H_
(lispobj *)SymbolValue(BINDING_STACK_POINTER) -
(lispobj *)BINDING_STACK_START);
++ /* The original CMU CL code had scavenge-read-only-space code
++ * controlled by the Lisp-level variable
++ * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
++ * wasn't documented under what circumstances it was useful or
++ * safe to turn it on, so it's been turned off in SBCL. If you
++ * want/need this functionality, and can test and document it,
++ * please submit a patch. */
++#if 0
if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
read_only_space_size =
(lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
read_only_space_size * sizeof(lispobj)));
scavenge( (lispobj *) READ_ONLY_SPACE_START, read_only_space_size);
}
++#endif
static_space_size =
(lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER) -
extern lispobj *current_control_stack_pointer;
extern lispobj *current_control_frame_pointer;
--#if !defined(ibmrt) && !defined(__i386__)
++#if !defined(__i386__)
extern lispobj *current_binding_stack_pointer;
#endif
--#if !defined(ibmrt) && !defined(__i386__)
++#if !defined(__i386__)
/* FIXME: Why doesn't the x86 need this? */
extern lispobj *dynamic_space_free_pointer;
extern lispobj *current_auto_gc_trigger;
#endif
#endif
/**/
--#ifdef ibmrt
--#define EXTERN(name,bytes) .globl _/**/name
--#endif
--/**/
#ifdef alpha
-#ifdef linux
+#ifdef __linux__
#define EXTERN(name,bytes) .globl name
#endif
#endif
#include "sparc-lispregs.h"
#endif
--#ifdef ibmrt
--#include "rt-lispregs.h"
--#endif
--
#ifdef __i386__
#include "x86-lispregs.h"
#endif
{
printf("CSP\t=\t0x%08lX\n", (unsigned long)current_control_stack_pointer);
printf("FP\t=\t0x%08lX\n", (unsigned long)current_control_frame_pointer);
--#if !defined(ibmrt) && !defined(__i386__)
++#if !defined(__i386__)
printf("BSP\t=\t0x%08X\n", (unsigned long)current_binding_stack_pointer);
#endif
#ifdef __i386__
#endif
printf("DYNAMIC\t=\t0x%08lx\n", (unsigned long)DYNAMIC_SPACE_START);
--#if defined(ibmrt) || defined(__i386__)
++#if defined(__i386__)
printf("ALLOC\t=\t0x%08lx\n",
(unsigned long)SymbolValue(ALLOCATION_POINTER));
printf("TRIGGER\t=\t0x%08lx\n",
/* Search dynamic space. */
headerptr = (lispobj *)DYNAMIC_SPACE_START;
--#if !defined(ibmrt) && !defined(__i386__)
++#if !defined(__i386__)
count =
dynamic_space_free_pointer -
(lispobj *)DYNAMIC_SPACE_START;
#define PRINTNOISE
--#if defined(ibmrt) || defined(__i386__)
++#if defined(__i386__)
/* again, what's so special about the x86 that this is differently
* visible there than on other platforms? -dan 20010125
*/
\f
#ifdef __i386__
--#ifdef WANT_CGC
--/* original x86/CGC stack scavenging code by Paul Werkowski */
--
--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 */
-- } else 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:
--#ifdef type_SimpleArraySignedByte8
-- case type_SimpleArraySignedByte8:
--#endif
--#ifdef type_SimpleArraySignedByte16
-- case type_SimpleArraySignedByte16:
--#endif
--#ifdef type_SimpleArraySignedByte30
-- case type_SimpleArraySignedByte30:
--#endif
--#ifdef type_SimpleArraySignedByte32
-- case type_SimpleArraySignedByte32:
--#endif
-- case type_SimpleArraySingleFloat:
-- case type_SimpleArrayDoubleFloat:
--#ifdef type_SimpleArrayLongFloat
-- case type_SimpleArrayLongFloat:
--#endif
--#ifdef type_SimpleArrayComplexSingleFloat
-- case type_SimpleArrayComplexSingleFloat:
--#endif
--#ifdef 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;
--}
--
--static int pverbose=0;
--#define PVERBOSE pverbose
--static void
--carefully_pscav_stack(lispobj*lowaddr, lispobj*base)
--{
-- lispobj *sp = lowaddr;
-- while (sp < base) {
-- int k;
-- lispobj thing = *sp;
-- if ((unsigned)thing & 0x3) { /* may be pointer */
-- /* need to check for valid float/double? */
-- k = maybe_can_move_p(thing);
-- if(PVERBOSE)printf("%8x %8x %d\n",sp, thing, k);
-- if(k)
-- pscav(sp, 1, 0);
-- }
-- sp++;
-- }
--}
--#endif
--
#ifdef GENCGC
/*
* enhanced x86/GENCGC stack scavenging by Douglas Crosher
return 0;
}
--#if defined(ibmrt) || defined(__i386__)
++#if defined(__i386__)
dynamic_space_free_pointer =
(lispobj*)SymbolValue(ALLOCATION_POINTER);
#endif
#ifdef GENCGC
pscav_i386_stack();
#endif
--#ifdef WANT_CGC
-- gc_assert((lispobj *)control_stack_end > ((&read_only_roots)+1));
-- carefully_pscav_stack(((&read_only_roots)+1),
-- (lispobj *)CONTROL_STACK_END);
--#endif
#endif
#ifdef PRINTNOISE
printf(" bindings");
fflush(stdout);
#endif
--#if !defined(ibmrt) && !defined(__i386__)
++#if !defined(__i386__)
pscav( (lispobj *)BINDING_STACK_START,
(lispobj *)current_binding_stack_pointer - (lispobj *)BINDING_STACK_START,
0);
0);
#endif
--#ifdef SCAVENGE_READ_ONLY_SPACE
++ /* The original CMU CL code had scavenge-read-only-space code
++ * controlled by the Lisp-level variable
++ * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
++ * wasn't documented under what circumstances it was useful or
++ * safe to turn it on, so it's been turned off in SBCL. If you
++ * want/need this functionality, and can test and document it,
++ * please submit a patch. */
++#if 0
if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != type_UnboundMarker
&& SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
unsigned read_only_space_size =
fflush(stdout);
#endif
--#if defined(WANT_CGC) && defined(X86_CGC_ACTIVE_P)
-- if(SymbolValue(X86_CGC_ACTIVE_P) != T) {
-- os_zero((os_vm_address_t) DYNAMIC_SPACE_START,
-- (os_vm_size_t) DYNAMIC_SPACE_SIZE);
-- }
--#else
os_zero((os_vm_address_t) current_dynamic_space,
(os_vm_size_t) DYNAMIC_SPACE_SIZE);
--#endif
/* Zero the stack. Note that the stack is also zeroed by SUB-GC
* calling SCRUB-CONTROL-STACK - this zeros the stack on the x86. */
sizeof(lispobj))));
#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);
-- }
--#endif
--
/* 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);
--#if !defined(ibmrt) && !defined(__i386__)
++#if !defined(__i386__)
dynamic_space_free_pointer = current_dynamic_space;
#else
#if defined GENCGC
gc_free_heap();
#else
-- /* ibmrt using GC */
-- SetSymbolValue(ALLOCATION_POINTER, (lispobj)DYNAMIC_SPACE_START);
--#endif
++#error unsupported case /* in CMU CL, was "ibmrt using GC" */
#endif
#endif
#if defined GENCGC
gencgc_pickup_dynamic();
#else
--#if defined WANT_CGC && defined X86_CGC_ACTIVE_P
-- {
-- extern int use_cgc_p;
-- lispobj x = SymbolValue(X86_CGC_ACTIVE_P);
-- if (x != type_UnboundMarker && x != NIL) {
-- /* Enable allocator. */
-- use_cgc_p = 1;
-- }
-- }
--#endif
#endif
#ifdef BINDING_STACK_POINTER
save(char *filename, lispobj init_function)
{
FILE *file;
--#if defined WANT_CGC
-- volatile lispobj*func_ptr = &init_function;
-- char sbuf[128];
-- strcpy(sbuf,filename);
-- filename=sbuf;
-- /* Get rid of remnant stuff. This is a MUST so that the memory
-- * manager can get started correctly when we restart after this
-- * save. Purify is going to maybe move the args so we need to
-- * consider them volatile, especially if the gcc optimizer is
-- * working!! */
-- purify(NIL,NIL);
--
-- 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);
--#endif
/* Open the file: */
unlink(filename);
file = fopen(filename, "w");
SetSymbolValue(CURRENT_UNWIND_PROTECT_BLOCK, 0);
SetSymbolValue(EVAL_STACK_TOP, 0);
printf("done]\n");
--#if defined WANT_CGC && defined X86_CGC_ACTIVE_P
-- SetSymbolValue(X86_CGC_ACTIVE_P, T);
--#endif
printf("[saving current Lisp image into %s:\n", filename);
putw(CORE_MAGIC, file);
F(sigblock)
#endif
F(sigpause)
--#if !defined(ibmrt) && !defined(hpux) && !defined(SVR4) && !defined(__i386__)
++#if !defined(hpux) && !defined(SVR4) && !defined(__i386__)
F(sigreturn)
#endif
#if !defined(SVR4) && !defined(__FreeBSD__) && !defined(__OpenBSD__)
ret
.size GNAME(do_pending_interrupt),.-GNAME(do_pending_interrupt)
\f
--#ifdef WANT_CGC
--/* This is a copy function which is optimized for the Pentium and
-- * works OK on 486 as well. This assumes (does not check) that the
-- * input byte count is a multiple of 8 bytes (one Lisp object).
-- * This code takes advantage of pairing in the Pentium as well
-- * as the 128-bit cache line.
-- */
-- .global GNAME(fastcopy16)
-- .type GNAME(fastcopy16),@function
-- .align align_4byte,0x90
--GNAME(fastcopy16):
-- pushl %ebp
-- movl %esp,%ebp
-- movl 8(%ebp), %edx # dst
-- movl 12(%ebp),%eax # src
-- movl 16(%ebp),%ecx # bytes
-- pushl %ebx
-- pushl %esi
-- pushl %edi
-- movl %edx,%edi
-- movl %eax,%esi
-- sarl $3,%ecx # number 8-byte units
-- testl $1,%ecx # odd?
-- jz Lquad
-- movl (%esi),%eax
-- movl 4(%esi),%ebx
-- movl %eax,(%edi)
-- movl %ebx,4(%edi)
-- leal 8(%esi),%esi
-- leal 8(%edi),%edi
--Lquad: sarl $1,%ecx # count 16-byte units
-- jz Lend
-- movl %ecx,%ebp # use ebp for loop counter
-- .align align_16byte,0x90
--Ltop:
-- movl (%edi),%eax # prefetch! MAJOR Pentium win..
-- movl (%esi),%eax
-- movl 4(%esi),%ebx
-- movl 8(%esi),%ecx
-- movl 12(%esi),%edx
-- movl %eax, (%edi)
-- movl %ebx, 4(%edi)
-- movl %ecx, 8(%edi)
-- movl %edx,12(%edi)
-- leal 16(%esi),%esi
-- leal 16(%edi),%edi
-- decl %ebp
-- jnz Ltop # non-prefixed jump saves cycles
--Lend:
-- popl %edi
-- popl %esi
-- popl %ebx
-- popl %ebp
-- ret
-- .size GNAME(fastcopy16),.-GNAME(fastcopy16)
--#endif
--\f
#ifdef GENCGC
/* This is a fast bzero using the FPU. The first argument is the start
* address which needs to be aligned on an 8 byte boundary, the second
;;; 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.27"
-"0.6.12.21.flaky2.2"
++"0.6.12.28"
projects / sbcl.git / commitdiff