;; implementation of the Lisp type system (e.g. TYPE-INTERSECTION and
;; SPECIFIER-TYPE) could move to a separate package SB!TYPE. (There's
;; lots of stuff which currently uses the SB!KERNEL package which
- ;; doesn't actually use the type system stuff.)
+ ;; doesn't actually use the type system stuff.) And maybe other
+ ;; possible splits too:
+ ;; * Pull GC stuff (*GC-INHIBIT*, *NEED-TO-COLLECT-GARBAGE*, etc.)
+ ;; out into SB-GC.
+ ;; * Pull special case implementations of sequence functions (e.g.
+ ;; %MAP-TO-LIST-ARITY-1 and %FIND-POSITION-IF-NOT) and
+ ;; other sequence function implementation grot into SB-SEQ.
+ ;; * Pull all the math stuff (%ACOS, %COSH, 32BIT-LOGICAL-AND...)
+ ;; into SB-MATH.
+ ;; * Pull all the array stuff (%ARRAY-DATA-VECTOR, %RAW-REF-LONG,
+ ;; WITH-ARRAY-DATA, ALLOCATE-VECTOR, HAIRY-DATA-VECTOR-REF...)
+ ;; into SB-ARRAY.
+ ;; * Pull all the streams stuff out into SB-STREAM.
+ ;; * Pull all the OBJECT-NOT-FOO symbols out. Maybe we could even
+ ;; figure out a way to stop exporting them? Failing that,
+ ;; they could be in SB-INTERR.
#s(sb-cold:package-data
:name "SB!KERNEL"
:doc
"%SET-SIGNED-SAP-REF-16" "%SET-SIGNED-SAP-REF-32"
"%SET-SIGNED-SAP-REF-64" "%SET-SIGNED-SAP-REF-8"
"%SET-STACK-REF" "%SIN" "%SIN-QUICK"
- "%SINGLE-FLOAT" "%SINH" "%SP-SET-DEFINITION"
- "%SP-SET-PLIST"
+ "%SINGLE-FLOAT" "%SINH"
"%SQRT" "%SXHASH-SIMPLE-STRING"
"%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK"
"%TANH" "%UNARY-ROUND" "%UNARY-TRUNCATE"
"%WITH-ARRAY-DATA" "%WITH-ARRAY-DATA-MACRO"
"*ALREADY-MAYBE-GCING*"
"*CURRENT-LEVEL*" "*EMPTY-TYPE*"
- "*EVAL-STACK*" "*EVAL-STACK-TOP*" "*GC-INHIBIT*"
+ "*GC-INHIBIT*"
"*NEED-TO-COLLECT-GARBAGE*"
"*PRETTY-PRINTER*" "*UNIVERSAL-TYPE*"
"*UNIVERSAL-FUN-TYPE*"
;;; 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+ 22)
+;;; This value should be incremented when the system changes in such a
+;;; way that it will no longer work reliably with old fasl files. In
+;;; practice, I (WHN) fairly often neglect to increment it for CVS
+;;; versions which break binary compatibility. But it certainly should
+;;; be incremented for release versions which break binary
+;;; compatibility.
+(defconstant +fasl-file-version+ 23)
;;; 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
;;; 22 = about a zillion changes between sbcl-0.pre7.62 and
;;; sbcl-0.pre7.133, during which time it seemed too much
;;; trouble to increment the counter
+;;; 23 = sbcl-0.7.0.1 deleted no-longer-used EVAL-STACK stuff,
+;;; causing changes in *STATIC-SYMBOLS*.
;;; the conventional file extension for our fasl files
(declaim (type simple-string *fasl-file-type*))
;;; 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
+;;; 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
+;;; as opposed to C's "extern"). The table contains symbols known at
;;; the time that the program was built, but not symbols defined
;;; in object files which have been loaded dynamically since then.
(declaim (type hash-table *assembler-routines* *static-foreign-symbols*))
(define-mutator-accessors binding-stack-end :sap nil)
(define-mutator-accessors number-stack-base :sap nil)
(define-mutator-accessors number-stack-end :sap nil)
- (define-mutator-accessors eval-stack :des t)
- (define-mutator-accessors eval-stack-top :ub32 t)
(define-mutator-accessors nursery-start :sap nil)
(define-mutator-accessors nursery-end :sap nil)
(define-mutator-accessors storebuf-start :sap nil)
;;;;
;;;; These VOPs are used in the reentered function to restore the
;;;; appropriate dynamic environment. Currently we only save the
-;;;; Current-Catch and binding stack pointer. We don't need to
-;;;; save/restore the current unwind-protect, since unwind-protects
+;;;; CURRENT-CATCH and binding stack pointer. We don't need to
+;;;; save/restore the current UNWIND-PROTECT, since UNWIND-PROTECTS
;;;; are implicitly processed during unwinding. If there were any
-;;;; additional stacks, then this would be the place to restore the
+;;;; additional stacks (as e.g. there was an interpreter "eval stack"
+;;;; before sbcl-0.7.0), then this would be the place to restore the
;;;; top pointers.
-
-;;; Return a list of TNs that can be used to snapshot the dynamic state for
-;;; use with the Save/Restore-Dynamic-Environment VOPs.
+;;; Return a list of TNs that can be used to snapshot the dynamic
+;;; state for use with the SAVE- and RESTORE-DYNAMIC-ENVIRONMENT VOPs.
(!def-vm-support-routine make-dynamic-state-tns ()
(list (make-normal-tn *backend-t-primitive-type*)
(make-normal-tn *backend-t-primitive-type*)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(inst mskll cur-nfp 4 nfp)))
- (inst mskll nsp-tn 4 nsp)
- (load-symbol-value eval *eval-stack-top*)))
+ (inst mskll nsp-tn 4 nsp)))
(define-vop (restore-dynamic-state)
(:args (catch :scs (descriptor-reg))
(:temporary (:sc any-reg) temp)
(:generator 10
(store-symbol-value catch *current-catch-block*)
- (store-symbol-value eval *eval-stack-top*)
(inst mskll nsp-tn 0 temp)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
;; things needed for non-local exit
*current-catch-block*
*current-unwind-protect-block*
- *eval-stack-top*
;; interrupt handling
*free-interrupt-context-index*
(cold-set '*current-catch-block* (make-fixnum-descriptor 0))
(cold-set '*current-unwind-protect-block* (make-fixnum-descriptor 0))
- (cold-set '*eval-stack-top* (make-fixnum-descriptor 0))
(cold-set '*free-interrupt-context-index* (make-fixnum-descriptor 0))
;;;;
;;;; These VOPs are used in the reentered function to restore the
;;;; appropriate dynamic environment. Currently we only save the
-;;;; Current-Catch, the eval stack pointer, and the alien stack
-;;;; pointer.
+;;;; Current-Catch and the alien stack pointer. (Before sbcl-0.7.0,
+;;;; when there were IR1 and byte interpreters, we had to save
+;;;; the interpreter "eval stack" too.)
;;;;
-;;;; We don't need to save/restore the current unwind-protect, since
-;;;; unwind-protects are implicitly processed during unwinding.
+;;;; We don't need to save/restore the current UNWIND-PROTECT, since
+;;;; UNWIND-PROTECTs are implicitly processed during unwinding.
;;;;
;;;; We don't need to save the BSP, because that is handled automatically.
-;;; Return a list of TNs that can be used to snapshot the dynamic state for
-;;; use with the Save/Restore-Dynamic-Environment VOPs.
+;;; Return a list of TNs that can be used to snapshot the dynamic
+;;; state for use with the SAVE- and RESTORE-DYNAMIC-ENVIRONMENT VOPs.
(!def-vm-support-routine make-dynamic-state-tns ()
(make-n-tns 3 *backend-t-primitive-type*))
(alien-stack :scs (descriptor-reg)))
(:generator 13
(load-symbol-value catch *current-catch-block*)
- (load-symbol-value eval *eval-stack-top*)
(load-symbol-value alien-stack *alien-stack*)))
(define-vop (restore-dynamic-state)
(alien-stack :scs (descriptor-reg)))
(:generator 10
(store-symbol-value catch *current-catch-block*)
- (store-symbol-value eval *eval-stack-top*)
(store-symbol-value alien-stack *alien-stack*)))
(define-vop (current-stack-pointer)
;; things needed for non-local exit
*current-catch-block*
*current-unwind-protect-block*
- *eval-stack-top*
*alien-stack*
;; interrupt handling
save(char *filename, lispobj init_function)
{
FILE *file;
- /* Open the file: */
+
+ /* Open the output file. We don't actually need the file yet, but
+ * the fopen() might fail for some reason, and we want to detect
+ * that and back out before we do anything irreversible. */
unlink(filename);
file = fopen(filename, "w");
- if (file == NULL) {
+ if (!file) {
perror(filename);
return 1;
}
- printf("[undoing binding stack... ");
+
+ /* Smash the enclosing state. (Once we do this, there's no good
+ * way to go back, which is a sufficient reason that this ends up
+ * being SAVE-LISP-AND-DIE instead of SAVE-LISP-AND-GO-ON). */
+ printf("[undoing binding stack and other enclosing state... ");
fflush(stdout);
unbind_to_here((lispobj *)BINDING_STACK_START);
SetSymbolValue(CURRENT_CATCH_BLOCK, 0);
SetSymbolValue(CURRENT_UNWIND_PROTECT_BLOCK, 0);
- SetSymbolValue(EVAL_STACK_TOP, 0);
printf("done]\n");
+ fflush(stdout);
+
+ /* (Now we can actually start copying ourselves into the
+ * output file.) */
+
printf("[saving current Lisp image into %s:\n", filename);
+ fflush(stdout);
putw(CORE_MAGIC, file);
putw(CORE_NDIRECTORY, file);
putw((5*3)+2, file);
- output_space(file, READ_ONLY_SPACE_ID, (lispobj *)READ_ONLY_SPACE_START,
+ output_space(file,
+ READ_ONLY_SPACE_ID,
+ (lispobj *)READ_ONLY_SPACE_START,
(lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
- output_space(file, STATIC_SPACE_ID, (lispobj *)STATIC_SPACE_START,
+ output_space(file,
+ STATIC_SPACE_ID,
+ (lispobj *)STATIC_SPACE_START,
(lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER));
#ifdef reg_ALLOC
- output_space(file, DYNAMIC_SPACE_ID, (lispobj *)current_dynamic_space,
+ output_space(file,
+ DYNAMIC_SPACE_ID,
+ (lispobj *)current_dynamic_space,
dynamic_space_free_pointer);
#else
#ifdef GENCGC
- /* Flush the current_region updating the tables. */
+ /* Flush the current_region, updating the tables. */
gc_alloc_update_page_tables(0,&boxed_region);
gc_alloc_update_page_tables(1,&unboxed_region);
update_x86_dynamic_space_free_pointer();
#endif
- output_space(file, DYNAMIC_SPACE_ID, (lispobj *)DYNAMIC_SPACE_START,
+ output_space(file,
+ DYNAMIC_SPACE_ID,
+ (lispobj *)DYNAMIC_SPACE_START,
(lispobj *)SymbolValue(ALLOCATION_POINTER));
#endif
putw(init_function, file);
putw(CORE_END, file);
- fclose(file);
+ fclose(file);
printf("done]\n");
exit(0);
projects / sbcl.git / commitdiff