0.7.13.5
authorDaniel Barlow <dan@telent.net>
Thu, 27 Feb 2003 00:49:57 +0000 (00:49 +0000)
committerDaniel Barlow <dan@telent.net>
Thu, 27 Feb 2003 00:49:57 +0000 (00:49 +0000)
Committed patch for gencgc refactoring based on work done
on threads branch.

... to make header file management a lot simpler, and allow
the use of interesting typedefs in genesis :C-TYPE slot
options, we split runtime.h into lots of smaller files that
can be (semi-)independently included.

... all GC and GCish functions now have the same interface,
so no need for (eq *internal-gc* #'collect-garbage) test in
SUB-GC

... current_region_end_addr and current_region_free_pointer
go away, eliminating potential for weird bugs when they're
not synchronized properly.  Yay OAOO

... disabled (actually, removed) inline allocation, as it
depended on old current_region_* (see above) and appears
to make not a lot of actual difference to run times anyway

pseudo-atomic support is now always compiled in.  I can see
no good reason for not having it

... much code in alloc() collapsed.  Also alloc() no longer
attempts to drop its PA and do a collection in the middle of
allocation - instead it uses the existing maybe_gc flag to
indicate that collection should happen when the allocation is
done.  Possibly this has bad effects when trying to allocate
an object bigger than available dynamic space, but that would
fit if a GC were done first.  Given the (complete lack of)
error handling for out-of-memory conditions in this and all
previous SBCL versions, it would be a foolish programmer who
was depending on this anyway, though.

31 files changed:
make-genesis-2.sh
make-host-1.sh
src/code/gc.lisp
src/code/purify.lisp
src/compiler/generic/genesis.lisp
src/compiler/x86/macros.lisp
src/runtime/GNUmakefile
src/runtime/alloc.c
src/runtime/breakpoint.c
src/runtime/coreparse.c
src/runtime/dynbind.c
src/runtime/gc-common.c
src/runtime/gc-internal.h
src/runtime/gc.h
src/runtime/gencgc-alloc-region.h [new file with mode: 0644]
src/runtime/gencgc-internal.h
src/runtime/gencgc.c
src/runtime/globals.c
src/runtime/interr.c
src/runtime/interrupt.c
src/runtime/monitor.c
src/runtime/parse.c
src/runtime/primitive-objects.h [new file with mode: 0644]
src/runtime/print.c
src/runtime/purify.c
src/runtime/runtime.c
src/runtime/save.c
src/runtime/search.c
src/runtime/x86-arch.c
src/runtime/x86-assem.S
version.lisp-expr

index 551a34f..92016f0 100644 (file)
@@ -44,7 +44,7 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
            (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"
+                      :c-header-dir-name "output/genesis-2"
                       :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
@@ -54,9 +54,9 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
        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.
+if diff -qr src/runtime/genesis output/genesis-2; then
+    echo //header files match between first and second GENESIS -- good
 else
-    echo error: sbcl2.h does not match sbcl.h.
+    echo error: header files do not match between first and second GENESIS
     exit 1
 fi
index 6bbe840..01ba05b 100644 (file)
@@ -43,6 +43,6 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
          (load "tests/type.before-xc.lisp")
          (load "tests/info.before-xc.lisp"))
         (host-cload-stem "src/compiler/generic/genesis")
-       (sb!vm:genesis :c-header-file-name "src/runtime/sbcl.h")
+       (sb!vm:genesis :c-header-dir-name "src/runtime/genesis")
         #+cmu (ext:quit)
        EOF
index 776acdd..6459038 100644 (file)
@@ -349,17 +349,7 @@ function should notify the user that the system has finished GC'ing.")
                   ;; triggered GC could've done a fair amount of
                   ;; consing.)
                   (pre-internal-gc-dynamic-usage (dynamic-usage))
-                  (ignore-me
-                   #!-gencgc (funcall *internal-gc*)
-                   ;; FIXME: This EQ test is pretty gross. Among its other
-                   ;; nastinesses, it looks as though it could break if we
-                   ;; recompile COLLECT-GARBAGE. We should probably just
-                   ;; straighten out the interface so that all *INTERNAL-GC*
-                   ;; functions accept a GEN argument (and then the
-                   ;; non-generational ones just ignore it).
-                   #!+gencgc (if (eq *internal-gc* #'collect-garbage)
-                                 (funcall *internal-gc* gen)
-                                 (funcall *internal-gc*)))
+                  (ignore-me (funcall *internal-gc* gen))
                   (post-gc-dynamic-usage (dynamic-usage))
                   (n-bytes-freed (- pre-internal-gc-dynamic-usage
                                     post-gc-dynamic-usage))
index caf6991..4ff9fc0 100644 (file)
@@ -52,7 +52,7 @@
           (write-string "[doing purification: " notify-stream)
           (force-output notify-stream)))
        (*internal-gc*
-        (lambda ()
+        (lambda (ignored-generation-arg)
           (%purify (get-lisp-obj-address root-structures)
                    (get-lisp-obj-address nil))))
        (*gc-notify-after*
index cdd0941..f32e88d 100644 (file)
   (and (>= (length string) (length tail))
        (string= string tail :start1 (- (length string) (length tail)))))
 
-(defun write-c-header ()
-
-  ;; writing beginning boilerplate
+(defun write-boilerplate ()
   (format t "/*~%")
   (dolist (line
           '("This is a machine-generated file. Please do not edit it by hand."
             "load and run 'core' files, which are basically programs"
             "in SBCL's own format."))
     (format t " * ~A~%" line))
-  (format t " */~%")
-  (terpri)
-  (format t "#ifndef _SBCL_H_~%#define _SBCL_H_~%")
-  (terpri)
+  (format t " */~%"))
 
+(defun write-config-h ()
   ;; propagating *SHEBANG-FEATURES* into C-level #define's
   (dolist (shebang-feature-name (sort (mapcar #'symbol-name
                                              sb-cold:*shebang-features*)
            "#define LISP_FEATURE_~A~%"
            (substitute #\_ #\- shebang-feature-name)))
   (terpri)
-
-  ;; writing miscellaneous constants
+  ;; and miscellaneous constants
   (format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer)
   (format t
          "#define SBCL_VERSION_STRING ~S~%"
          (sb!xc:lisp-implementation-version))
   (format t "#define CORE_MAGIC 0x~X~%" core-magic)
-  (terpri)
-
+  (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
+  (format t "#define LISPOBJ(x) ((lispobj)x)~2%")
+  (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
+  (format t "#define LISPOBJ(thing) thing~2%")
+  (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")
+  (terpri))
+
+(defun write-constants-h ()
   ;; writing entire families of named constants 
   (let ((constants nil))
     (dolist (package-name '(;; Even in CMU CL, constants from VM
            (sb!xc:byte-position (symbol-value symbol)))
     (format t "#define ~A_MASK 0x~X /* ~:*~A */~%"
            (substitute #\_ #\- (symbol-name symbol))
-           (sb!xc:mask-field (symbol-value symbol) -1)))
+           (sb!xc:mask-field (symbol-value symbol) -1))))
 
+
+
+(defun write-primitive-object (obj)  
   ;; writing primitive object layouts
-  (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
-                      :key (lambda (obj)
-                             (symbol-name
-                              (sb!vm:primitive-object-name obj))))))
     (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
-    (format t "#define LISPOBJ(x) ((lispobj)x)~2%")
-    (dolist (obj structs)
       (format t
              "struct ~A {~%"
              (substitute #\_ #\-
        (substitute #\_ #\-
                    (string-downcase (string (sb!vm:slot-name slot))))
        (sb!vm:slot-rest-p slot)))
-      (format t "};~2%"))
+  (format t "};~2%")
     (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
-    (format t "#define LISPOBJ(thing) thing~2%")
-    (dolist (obj structs)
       (let ((name (sb!vm:primitive-object-name obj))
       (lowtag (eval (sb!vm:primitive-object-lowtag obj))))
        (when lowtag
                  (substitute #\_ #\- (string name))
                  (substitute #\_ #\- (string (sb!vm:slot-name slot)))
                  (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag)))
-       (terpri))))
+      (terpri)))
     (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
 
-  ;; writing static symbol offsets
+(defun write-static-symbols ()
   (dolist (symbol (cons nil sb!vm:*static-symbols*))
     ;; FIXME: It would be nice to use longer names than NIL and
     ;; (particularly) T in #define statements.
              (+ sb!vm:static-space-start
                 sb!vm:n-word-bytes
                 sb!vm:other-pointer-lowtag
-                (if symbol (sb!vm:static-symbol-offset symbol) 0)))))
+                  (if symbol (sb!vm:static-symbol-offset symbol) 0))))))
 
-  ;; Voila.
-  (format t "~%#endif~%"))
 \f
 ;;;; writing map file
 
@@ -3111,7 +3105,7 @@ initially undefined function references:~2%")
                      symbol-table-file-name
                      core-file-name
                      map-file-name
-                     c-header-file-name)
+                     c-header-dir-name)
 
   (when (and core-file-name
             (not symbol-table-file-name))
@@ -3125,8 +3119,7 @@ initially undefined function references:~2%")
            ;; we're not e.g. also creating a header file when we
            ;; create a core.
            (format nil "creating core ~S" core-file-name)
-           (format nil "creating header ~S" c-header-file-name)))
-
+           (format nil "creating headers in ~S" c-header-dir-name)))
   (let* ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
 
     ;; Read symbol table, if any.
@@ -3141,8 +3134,7 @@ initially undefined function references:~2%")
             (when filename
               (ensure-directories-exist filename :verbose t))))
       (frob core-file-name)
-      (frob map-file-name)
-      (frob c-header-file-name))
+      (frob map-file-name))
 
     ;; (This shouldn't matter in normal use, since GENESIS normally
     ;; only runs once in any given Lisp image, but it could reduce
@@ -3269,15 +3261,37 @@ initially undefined function references:~2%")
       ;; lexical variable, and it's annoying to have WRITE-MAP (to
       ;; *STANDARD-OUTPUT*) not be parallel to WRITE-INITIAL-CORE-FILE
       ;; (to a stream explicitly passed as an argument).
+      (macrolet ((out-to (name &body body)
+                  `(let ((fn (format nil "~A/~A.h" c-header-dir-name ,name)))
+                    (ensure-directories-exist fn)
+                    (with-open-file (*standard-output* fn  
+                                     :if-exists :supersede :direction :output)
+                      (write-boilerplate)
+                      (let ((n (substitute #\_ #\- (string-upcase ,name))))
+                        (format 
+                         t
+                         "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~A 1~%"
+                         n n))
+                      ,@body
+                      (format t
+                       "#endif /* SBCL_GENESIS_~A */~%"
+                       (string-upcase ,name))))))
       (when map-file-name
        (with-open-file (*standard-output* map-file-name
                                           :direction :output
                                           :if-exists :supersede)
          (write-map)))
-      (when c-header-file-name
-       (with-open-file (*standard-output* c-header-file-name
-                                          :direction :output
-                                          :if-exists :supersede)
-         (write-c-header)))
+       (out-to "config" (write-config-h))
+       (out-to "constants" (write-constants-h))
+       (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
+                            :key (lambda (obj)
+                                   (symbol-name
+                                    (sb!vm:primitive-object-name obj))))))
+         (dolist (obj structs)
+           (out-to
+            (string-downcase (string (sb!vm:primitive-object-name obj)))
+            (write-primitive-object obj))))
+       (out-to "static-symbols" (write-static-symbols))
+       
       (when core-file-name
-       (write-initial-core-file core-file-name)))))
+         (write-initial-core-file core-file-name))))))
index af03663..9db903d 100644 (file)
           (unless (and (tn-p size) (location= alloc-tn size))
             (inst mov dst-tn size))))
     (let ((alloc-tn-offset (tn-offset alloc-tn)))
-      ;; FIXME: All these (MAKE-FIXUP (EXTERN-ALIEN-NAME "foo") :FOREIGN)
-      ;; expressions should be moved into MACROLET ((ALIEN-FIXUP ..)),
-      ;; and INST CALL (MAKE-FIXUP ..) should become CALL-ALIEN-FIXUP.
-      (if (and #!+gencgc t #!-gencgc nil
-              *maybe-use-inline-allocation*
-              (or (null inline) (policy inline (>= speed space))))
-         ;; Inline allocation with GENCGC.
-         (let ((ok (gen-label)))
-           ;; Load the size first so that the size can be in the same
-           ;; register as alloc-tn.
-           (load-size alloc-tn size)
-           (inst add alloc-tn
-                 (make-fixup (extern-alien-name "current_region_free_pointer")
-                             :foreign))
-           (inst cmp alloc-tn
-                 (make-fixup (extern-alien-name "current_region_end_addr")
-                             :foreign))
-           (inst jmp :be OK)
-           ;; Dispatch to the appropriate overflow routine. There is a
-           ;; routine for each destination.
-           ;; FIXME: Could we use an alist here instead of an ECASE with lots
-           ;; of duplicate code? (and similar question for next ECASE, too)
-           (ecase alloc-tn-offset
-             (#.eax-offset ;; FIXME: Why the #\# #\.?
-              (inst call (make-fixup (extern-alien-name "alloc_overflow_eax")
-                                     :foreign)))
-             (#.ecx-offset
-              (inst call (make-fixup (extern-alien-name "alloc_overflow_ecx")
-                                     :foreign)))
-             (#.edx-offset
-              (inst call (make-fixup (extern-alien-name "alloc_overflow_edx")
-                                     :foreign)))
-             (#.ebx-offset
-              (inst call (make-fixup (extern-alien-name "alloc_overflow_ebx")
-                                     :foreign)))
-             (#.esi-offset
-              (inst call (make-fixup (extern-alien-name "alloc_overflow_esi")
-                                     :foreign)))
-             (#.edi-offset
-              (inst call (make-fixup (extern-alien-name "alloc_overflow_edi")
-                                     :foreign))))
-           (emit-label ok)
-           (inst xchg (make-fixup
-                       (extern-alien-name "current_region_free_pointer")
-                       :foreign)
-                 alloc-tn))
          ;; C call to allocate via dispatch routines. Each
          ;; destination has a special entry point. The size may be a
          ;; register or a constant.
               (t
                (load-size edi-tn size)
                (inst call (make-fixup (extern-alien-name "alloc_to_edi")
-                                      :foreign)))))))))
+                                  :foreign))))))))
   (values))
 
 ;;; Allocate an other-pointer object of fixed SIZE with a single word
 \f
 ;;;; PSEUDO-ATOMIC
 
-;;; FIXME: This should be a compile-time option, not a runtime option. Doing it
-;;; at runtime is bizarre. As I understand it, the default should definitely be
-;;; to have pseudo-atomic behavior, but for a performance-critical program
-;;; which is guaranteed not to have asynchronous exceptions, it could be worth
-;;; something to compile with :SB-NO-PSEUDO-ATOMIC.
-(defvar *enable-pseudo-atomic* t)
-
 ;;; FIXME: *PSEUDO-ATOMIC-FOO* could be made into *PSEUDO-ATOMIC-BITS*,
 ;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2;
 ;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check
 (defmacro pseudo-atomic (&rest forms)
   (let ((label (gensym "LABEL-")))
     `(let ((,label (gen-label)))
-       (when *enable-pseudo-atomic*
-        ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
-        ;; something. (perhaps SVLB, for static variable low byte)
-        (inst mov (make-ea :byte :disp (+ nil-value
-                                          (static-symbol-offset
-                                           '*pseudo-atomic-interrupted*)
-                                          (ash symbol-value-slot word-shift)
-                                          ;; FIXME: Use mask, not minus, to
-                                          ;; take out type bits.
-                                          (- other-pointer-lowtag)))
-              0)
-        (inst mov (make-ea :byte :disp (+ nil-value
-                                          (static-symbol-offset
-                                           '*pseudo-atomic-atomic*)
-                                          (ash symbol-value-slot word-shift)
-                                          (- other-pointer-lowtag)))
-              (fixnumize 1)))
-       ,@forms
-       (when *enable-pseudo-atomic*
-        (inst mov (make-ea :byte :disp (+ nil-value
-                                          (static-symbol-offset
-                                           '*pseudo-atomic-atomic*)
-                                          (ash symbol-value-slot word-shift)
-                                          (- other-pointer-lowtag)))
-              0)
-        ;; KLUDGE: Is there any requirement for interrupts to be
-        ;; handled in order? It seems as though an interrupt coming
-        ;; in at this point will be executed before any pending interrupts.
-        ;; Or do incoming interrupts check to see whether any interrupts
-        ;; are pending? I wish I could find the documentation for
-        ;; pseudo-atomics.. -- WHN 19991130
-        (inst cmp (make-ea :byte
-                           :disp (+ nil-value
-                                    (static-symbol-offset
-                                     '*pseudo-atomic-interrupted*)
-                                    (ash symbol-value-slot word-shift)
-                                    (- other-pointer-lowtag)))
-              0)
-        (inst jmp :eq ,label)
-        (inst break pending-interrupt-trap)
-        (emit-label ,label)))))
+      ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
+      ;; something. (perhaps SVLB, for static variable low byte)
+      (inst mov (make-ea :byte :disp (+ nil-value
+                                       (static-symbol-offset
+                                        '*pseudo-atomic-interrupted*)
+                                       (ash symbol-value-slot word-shift)
+                                       ;; FIXME: Use mask, not minus, to
+                                       ;; take out type bits.
+                                       (- other-pointer-lowtag)))
+       0)
+      (inst mov (make-ea :byte :disp (+ nil-value
+                                       (static-symbol-offset
+                                        '*pseudo-atomic-atomic*)
+                                       (ash symbol-value-slot word-shift)
+                                       (- other-pointer-lowtag)))
+       (fixnumize 1))
+      ,@forms
+      (inst mov (make-ea :byte :disp (+ nil-value
+                                       (static-symbol-offset
+                                        '*pseudo-atomic-atomic*)
+                                       (ash symbol-value-slot word-shift)
+                                       (- other-pointer-lowtag)))
+       0)
+      ;; KLUDGE: Is there any requirement for interrupts to be
+      ;; handled in order? It seems as though an interrupt coming
+      ;; in at this point will be executed before any pending interrupts.
+      ;; Or do incoming interrupts check to see whether any interrupts
+      ;; are pending? I wish I could find the documentation for
+      ;; pseudo-atomics.. -- WHN 19991130
+      (inst cmp (make-ea :byte
+                :disp (+ nil-value
+                         (static-symbol-offset
+                          '*pseudo-atomic-interrupted*)
+                         (ash symbol-value-slot word-shift)
+                         (- other-pointer-lowtag)))
+       0)
+      (inst jmp :eq ,label)
+      ;; if PAI was set, interrupts were disabled at the same time
+      ;; using the process signal mask.  
+      (inst break pending-interrupt-trap)
+      (emit-label ,label))))
 \f
 ;;;; indexed references
 
index c081c71..28e6121 100644 (file)
@@ -57,6 +57,12 @@ sbcl: ${OBJS}
 clean:
        -rm -f depend *.o sbcl sbcl.nm core *.tmp
 
+TAGS: $(SRCS)
+       etags $(SRCS)
+
+sbcl.h: genesis/*.h
+       echo '#include "genesis/config.h"' >sbcl.h
+       echo '#include "genesis/constants.h"' >>sbcl.h
 
 depend: ${C_SRCS} sbcl.h
        $(CC) ${DEPEND_FLAGS} ${CFLAGS} ${CPPFLAGS}  ${C_SRCS} > depend.tmp
index 00a24f1..01354b4 100644 (file)
@@ -1,5 +1,6 @@
 /*
- * allocation routines
+ * allocation routines for C code.  For allocation done by Lisp look 
+ * instead at src/compiler/target/alloc.lisp and .../macros.lisp
  */
 
 /*
  * files for more information.
  */
 
+#include <stdio.h>
+#include <string.h>
+
 #include "runtime.h"
+#include "os.h"
 #include "sbcl.h"
 #include "alloc.h"
 #include "globals.h"
 #include "gc.h"
-#include <stdio.h>
-#include <string.h>
+#include "genesis/static-symbols.h"
+#include "genesis/vector.h"
+#include "genesis/cons.h"
+#include "genesis/bignum.h"
+#include "genesis/sap.h"
+#include "genesis/symbol.h"
 
 #define GET_FREE_POINTER() dynamic_space_free_pointer
 #define SET_FREE_POINTER(new_value) \
 
 #if defined LISP_FEATURE_GENCGC
 extern lispobj *alloc(int bytes);
+lispobj *
+pa_alloc(int bytes) 
+{
+    lispobj *result=0;
+    SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0));
+    SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1));
+    result=alloc(bytes);
+    SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0));
+    if (SymbolValue(PSEUDO_ATOMIC_INTERRUPTED)) 
+       /* even if we gc at this point, the new allocation will be
+        * protected from being moved, because result is on the c stack
+        * and points to it */
+       do_pending_interrupt(); 
+    return result; 
+}
+
 #else
 static lispobj *
-alloc(int bytes)
+pa_alloc(int bytes)
 {
     char *result;
 
@@ -53,12 +78,13 @@ alloc(int bytes)
 }
 #endif
 
+
 lispobj *
 alloc_unboxed(int type, int words)
 {
     lispobj *result;
 
-    result = alloc(ALIGNED_SIZE((1 + words) * sizeof(lispobj)));
+    result = pa_alloc(ALIGNED_SIZE((1 + words) * sizeof(lispobj)));
     *result = (lispobj) (words << N_WIDETAG_BITS) | type;
     return result;
 }
@@ -69,7 +95,7 @@ alloc_vector(int type, int length, int size)
     struct vector *result;
 
     result = (struct vector *)
-      alloc(ALIGNED_SIZE((2 + (length*size + 31) / 32) * sizeof(lispobj)));
+      pa_alloc(ALIGNED_SIZE((2 + (length*size + 31) / 32) * sizeof(lispobj)));
 
     result->header = type;
     result->length = make_fixnum(length);
@@ -80,7 +106,7 @@ alloc_vector(int type, int length, int size)
 lispobj
 alloc_cons(lispobj car, lispobj cdr)
 {
-    struct cons *ptr = (struct cons *)alloc(ALIGNED_SIZE(sizeof(struct cons)));
+    struct cons *ptr = (struct cons *)pa_alloc(ALIGNED_SIZE(sizeof(struct cons)));
 
     ptr->car = car;
     ptr->cdr = cdr;
index e45082f..716bc21 100644 (file)
 #include "globals.h"
 #include "alloc.h"
 #include "breakpoint.h"
+#include "genesis/code.h"
+#include "genesis/fdefn.h"
+#include "genesis/symbol.h"
+#include "genesis/static-symbols.h"
 
 #define REAL_LRA_SLOT 0
 #ifndef __i386__
index 007e6c0..2d03737 100644 (file)
@@ -33,6 +33,8 @@
 #include "arch.h"
 #include "interr.h"
 #include "sbcl.h"
+#include "genesis/symbol.h"
+#include "genesis/static-symbols.h"
 
 unsigned char build_id[] =
 #include "../../output/build-id.tmp"
index 2d9f47e..93bdeb7 100644 (file)
@@ -17,6 +17,9 @@
 #include "sbcl.h"
 #include "globals.h"
 #include "dynbind.h"
+#include "genesis/symbol.h"
+#include "genesis/binding.h"
+#include "genesis/static-symbols.h"
 
 #if defined(__i386__)
 #define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER))
index aa15701..0209fc7 100644 (file)
@@ -52,6 +52,7 @@
 #include "lispregs.h"
 #include "arch.h"
 #include "gc.h"
+#include "primitive-objects.h"
 #include "gc-internal.h"
 
 #ifdef LISP_FEATURE_SPARC
index 54cf04c..d0f99bf 100644 (file)
@@ -36,6 +36,7 @@
 #define FREE_PAGE 0
 #define BOXED_PAGE 1
 #define UNBOXED_PAGE 2
+#define OPEN_REGION_PAGE 4
 
 #define ALLOC_BOXED 0
 #define ALLOC_UNBOXED 1
index ff1276e..3dc12ec 100644 (file)
@@ -25,4 +25,5 @@ extern void collect_garbage(unsigned last_gen);
 extern void set_auto_gc_trigger(os_vm_size_t usage);
 extern void clear_auto_gc_trigger(void);
 
+extern boolean maybe_gc_pending;
 #endif /* _GC_H_ */
diff --git a/src/runtime/gencgc-alloc-region.h b/src/runtime/gencgc-alloc-region.h
new file mode 100644 (file)
index 0000000..8e9dbed
--- /dev/null
@@ -0,0 +1,25 @@
+#ifndef _GENCGC_ALLOC_REGION_H_
+#define _GENCGC_ALLOC_REGION_H_
+/* Abstract out the data for an allocation region allowing a single
+ * routine to be used for allocation and closing. */
+struct alloc_region {
+
+    /* These two are needed for quick allocation. */
+    void  *free_pointer;
+    void  *end_addr; /* pointer to the byte after the last usable byte */
+
+    /* These are needed when closing the region. */
+    int  first_page;
+    int  last_page;
+    void  *start_addr;
+};
+
+extern struct alloc_region  boxed_region;
+extern struct alloc_region  unboxed_region;
+extern int from_space, new_space;
+extern struct weak_pointer *weak_pointers;
+
+extern void *current_region_free_pointer;
+extern void *current_region_end_addr;
+
+#endif /*  _GENCGC_ALLOC_REGION_H_ */
index 18dc9fb..f402282 100644 (file)
@@ -19,6 +19,9 @@
 #ifndef _GENCGC_INTERNAL_H_
 #define _GENCGC_INTERNAL_H_
 
+#include "gencgc-alloc-region.h"
+#include "genesis/code.h"
+
 void gc_free_heap(void);
 inline int find_page_index(void *);
 inline void *page_address(int);
@@ -42,7 +45,7 @@ struct page {
          * for boxed objects; 2 for unboxed objects. If the page is
          * free the following slots are invalid (well the bytes_used
          * must be 0). */
-       allocated :2,
+       allocated :3,
        /* If this page should not be moved during a GC then this flag
          * is set. It's only valid during a GC for allocated pages. */
        dont_move :1,
@@ -75,28 +78,6 @@ struct page {
 /* the number of pages needed for the dynamic space - rounding up */
 #define NUM_PAGES ((DYNAMIC_SPACE_SIZE+4095)/4096)
 extern struct page page_table[NUM_PAGES];
-\f
-/* Abstract out the data for an allocation region allowing a single
- * routine to be used for allocation and closing. */
-struct alloc_region {
-
-    /* These two are needed for quick allocation. */
-    void  *free_pointer;
-    void  *end_addr; /* pointer to the byte after the last usable byte */
-
-    /* These are needed when closing the region. */
-    int  first_page;
-    int  last_page;
-    void  *start_addr;
-};
-
-extern struct alloc_region  boxed_region;
-extern struct alloc_region  unboxed_region;
-extern int from_space, new_space;
-extern struct weak_pointer *weak_pointers;
-
-extern void *current_region_free_pointer;
-extern void *current_region_end_addr;
 
 \f
 void  gencgc_pickup_dynamic(void);
index 6e394e6..2af538d 100644 (file)
@@ -26,6 +26,9 @@
 
 #include <stdio.h>
 #include <signal.h>
+#include <sys/ptrace.h>
+#include <linux/user.h>
+#include <errno.h>
 #include "runtime.h"
 #include "sbcl.h"
 #include "os.h"
 #include "arch.h"
 #include "gc.h"
 #include "gc-internal.h"
-
+#include "genesis/vector.h"
+#include "genesis/weak-pointer.h"
+#include "genesis/simple-fun.h"
+#include "genesis/static-symbols.h"
+#include "genesis/symbol.h"
 /* assembly language stub that executes trap_PendingInterrupt */
 void do_pending_interrupt(void);
 
@@ -130,6 +137,7 @@ int new_space;
 /* FIXME: It would be nice to use this symbolic constant instead of
  * bare 4096 almost everywhere. We could also use an assertion that
  * it's equal to getpagesize(). */
+
 #define PAGE_BYTES 4096
 
 /* An array of page structures is statically allocated.
@@ -240,7 +248,6 @@ unsigned int  gencgc_oldest_gen_to_gc = NUM_GENERATIONS-1;
  * search of the heap. XX Gencgc obviously needs to be better
  * integrated with the Lisp code. */
 static int  last_free_page;
-static int  last_used_page = 0;
 \f
 /*
  * miscellaneous heap functions
@@ -350,7 +357,7 @@ print_generation_stats(int verbose) /* FIXME: should take FILE argument */
 
                /* Count the number of boxed pages within the given
                 * generation. */
-               if (page_table[j].allocated == BOXED_PAGE) {
+               if (page_table[j].allocated & BOXED_PAGE) {
                    if (page_table[j].large_object)
                        large_boxed_cnt++;
                    else
@@ -359,7 +366,7 @@ print_generation_stats(int verbose) /* FIXME: should take FILE argument */
 
                /* Count the number of unboxed pages within the given
                 * generation. */
-               if (page_table[j].allocated == UNBOXED_PAGE) {
+               if (page_table[j].allocated & UNBOXED_PAGE) {
                    if (page_table[j].large_object)
                        large_unboxed_cnt++;
                    else
@@ -441,10 +448,6 @@ print_generation_stats(int verbose) /* FIXME: should take FILE argument */
 struct alloc_region boxed_region;
 struct alloc_region unboxed_region;
 
-/* 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. */
 static int gc_alloc_generation;
 
@@ -476,10 +479,7 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
 {
     int first_page;
     int last_page;
-    int region_size;
-    int restart_page;
     int bytes_found;
-    int num_pages;
     int i;
 
     /*
@@ -494,101 +494,16 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
              && (alloc_region->free_pointer == alloc_region->end_addr));
 
     if (unboxed) {
-       restart_page =
+       first_page =
            generations[gc_alloc_generation].alloc_unboxed_start_page;
     } else {
-       restart_page =
+       first_page =
            generations[gc_alloc_generation].alloc_start_page;
     }
-
-    /* Search for a contiguous free region of at least nbytes with the
-     * given properties: boxed/unboxed, generation. */
-    do {
-       first_page = restart_page;
-
-       /* First search for a page with at least 32 bytes free, which is
-        * not write-protected, and which is not marked dont_move.
-        *
-        * FIXME: This looks extremely similar, perhaps identical, to
-        * code in gc_alloc_large(). It should be shared somehow. */
-       while ((first_page < NUM_PAGES)
-              && (page_table[first_page].allocated != FREE_PAGE) /* not free page */
-              && ((unboxed &&
-                   (page_table[first_page].allocated != UNBOXED_PAGE))
-                  || (!unboxed &&
-                      (page_table[first_page].allocated != BOXED_PAGE))
-                  || (page_table[first_page].large_object != 0)
-                  || (page_table[first_page].gen != gc_alloc_generation)
-                  || (page_table[first_page].bytes_used >= (4096-32))
-                  || (page_table[first_page].write_protected != 0)
-                  || (page_table[first_page].dont_move != 0)))
-           first_page++;
-       /* Check for a failure. */
-       if (first_page >= NUM_PAGES) {
-           fprintf(stderr,
-                   "Argh! gc_alloc_new_region failed on first_page, nbytes=%d.\n",
-                   nbytes);
-           print_generation_stats(1);
-           lose(NULL);
-       }
-
-       gc_assert(page_table[first_page].write_protected == 0);
-
-       /*
-       FSHOW((stderr,
-              "/first_page=%d bytes_used=%d\n",
-              first_page, page_table[first_page].bytes_used));
-       */
-
-       /* Now search forward to calculate the available region size. It
-        * tries to keeps going until nbytes are found and the number of
-        * pages is greater than some level. This helps keep down the
-        * number of pages in a region. */
-       last_page = first_page;
-       bytes_found = 4096 - page_table[first_page].bytes_used;
-       num_pages = 1;
-       while (((bytes_found < nbytes) || (num_pages < 2))
-              && (last_page < (NUM_PAGES-1))
-              && (page_table[last_page+1].allocated == FREE_PAGE)) {
-           last_page++;
-           num_pages++;
-           bytes_found += 4096;
-           gc_assert(page_table[last_page].write_protected == 0);
-       }
-
-       region_size = (4096 - page_table[first_page].bytes_used)
+    last_page=gc_find_freeish_pages(&first_page,nbytes,unboxed,alloc_region);
+    bytes_found=(4096 - page_table[first_page].bytes_used)
            + 4096*(last_page-first_page);
 
-       gc_assert(bytes_found == region_size);
-
-       /*
-       FSHOW((stderr,
-              "/last_page=%d bytes_found=%d num_pages=%d\n",
-              last_page, bytes_found, num_pages));
-       */
-
-       restart_page = last_page + 1;
-    } while ((restart_page < NUM_PAGES) && (bytes_found < nbytes));
-
-    /* Check for a failure. */
-    if ((restart_page >= NUM_PAGES) && (bytes_found < nbytes)) {
-       fprintf(stderr,
-               "Argh! gc_alloc_new_region() failed on restart_page, nbytes=%d.\n",
-               nbytes);
-       print_generation_stats(1);
-       lose(NULL);
-    }
-
-    /*
-    FSHOW((stderr,
-          "/gc_alloc_new_region() gen %d: %d bytes: pages %d to %d: addr=%x\n",
-          gc_alloc_generation,
-          bytes_found,
-          first_page,
-          last_page,
-          page_address(first_page)));
-    */
-
     /* Set up the alloc_region. */
     alloc_region->first_page = first_page;
     alloc_region->last_page = last_page;
@@ -628,6 +543,8 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
        gc_assert(page_table[first_page].allocated == UNBOXED_PAGE);
     else
        gc_assert(page_table[first_page].allocated == BOXED_PAGE);
+    page_table[first_page].allocated |= OPEN_REGION_PAGE; 
+
     gc_assert(page_table[first_page].gen == gc_alloc_generation);
     gc_assert(page_table[first_page].large_object == 0);
 
@@ -642,6 +559,7 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
         * broken before!) */
        page_table[i].first_object_offset =
            alloc_region->start_addr - page_address(i);
+       page_table[i].allocated |= OPEN_REGION_PAGE ;
     }
 
     /* Bump up last_free_page. */
@@ -649,8 +567,6 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
        last_free_page = last_page+1;
        SetSymbolValue(ALLOCATION_POINTER,
                       (lispobj)(((char *)heap_base) + last_free_page*4096));
-       if (last_page+1 > last_used_page)
-           last_used_page = last_page+1;
     }
 }
 
@@ -726,12 +642,11 @@ add_new_area(int first_page, int offset, int size)
                   (*new_areas)[i].size,
                   first_page,
                   offset,
-                  size));*/
+                   size);*/
            (*new_areas)[i].size += size;
            return;
        }
     }
-    /*FSHOW((stderr, "/add_new_area S1 %d %d %d\n", i, c, new_area_start));*/
 
     (*new_areas)[new_areas_index].page = first_page;
     (*new_areas)[new_areas_index].offset = offset;
@@ -792,6 +707,7 @@ gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
         * first_object_offset. */
        if (page_table[first_page].bytes_used == 0)
            gc_assert(page_table[first_page].first_object_offset == 0);
+       page_table[first_page].allocated &= ~(OPEN_REGION_PAGE);
 
        if (unboxed)
            gc_assert(page_table[first_page].allocated == UNBOXED_PAGE);
@@ -817,6 +733,7 @@ gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
         * first_object_offset pointer to the start of the region, and set
         * the bytes_used. */
        while (more) {
+           page_table[next_page].allocated &= ~(OPEN_REGION_PAGE);
            if (unboxed)
                gc_assert(page_table[next_page].allocated == UNBOXED_PAGE);
            else
@@ -868,6 +785,7 @@ gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
     } else {
        /* There are no bytes allocated. Unallocate the first_page if
         * there are 0 bytes_used. */
+       page_table[first_page].allocated &= ~(OPEN_REGION_PAGE);
        if (page_table[first_page].bytes_used == 0)
            page_table[first_page].allocated = FREE_PAGE;
     }
@@ -879,12 +797,7 @@ gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
        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);
+    gc_set_region_empty(alloc_region);
 }
 
 static inline void *gc_quick_alloc(int nbytes);
@@ -895,10 +808,6 @@ gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region)
 {
     int first_page;
     int last_page;
-    int region_size;
-    int restart_page;
-    int bytes_found;
-    int num_pages;
     int orig_first_page_bytes_used;
     int byte_cnt;
     int more;
@@ -918,116 +827,28 @@ gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region)
     */
 
     /* If the object is small, and there is room in the current region
-       then allocation it in the current region. */
+       then allocate it in the current region. */
     if (!large
        && ((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
-       large object then align it on a page boundary by searching for a
-       free page. */
-
     /* To allow the allocation of small objects without the danger of
        using a page in the current boxed region, the search starts after
        the current boxed free region. XX could probably keep a page
        index ahead of the current region and bumped up here to save a
        lot of re-scanning. */
+
     if (unboxed) {
-       restart_page =
+       first_page =
            generations[gc_alloc_generation].alloc_large_unboxed_start_page;
     } else {
-       restart_page = generations[gc_alloc_generation].alloc_large_start_page;
+       first_page = generations[gc_alloc_generation].alloc_large_start_page;
     }
-    if (restart_page <= alloc_region->last_page) {
-       restart_page = alloc_region->last_page+1;
-    }
-
-    do {
-       first_page = restart_page;
-
-       if (large)
-           while ((first_page < NUM_PAGES)
-                  && (page_table[first_page].allocated != FREE_PAGE))
-               first_page++;
-       else
-           /* FIXME: This looks extremely similar, perhaps identical,
-            * to code in gc_alloc_new_region(). It should be shared
-            * somehow. */
-           while ((first_page < NUM_PAGES)
-                  && (page_table[first_page].allocated != FREE_PAGE)
-                  && ((unboxed &&
-                       (page_table[first_page].allocated != UNBOXED_PAGE))
-                      || (!unboxed &&
-                          (page_table[first_page].allocated != BOXED_PAGE))
-                      || (page_table[first_page].large_object != 0)
-                      || (page_table[first_page].gen != gc_alloc_generation)
-                      || (page_table[first_page].bytes_used >= (4096-32))
-                      || (page_table[first_page].write_protected != 0)
-                      || (page_table[first_page].dont_move != 0)))
-               first_page++;
-
-       if (first_page >= NUM_PAGES) {
-           fprintf(stderr,
-                   "Argh! gc_alloc_large failed (first_page), nbytes=%d.\n",
-                   nbytes);
-           print_generation_stats(1);
-           lose(NULL);
-       }
-
-       gc_assert(page_table[first_page].write_protected == 0);
-
-       /*
-       FSHOW((stderr,
-              "/first_page=%d bytes_used=%d\n",
-              first_page, page_table[first_page].bytes_used));
-       */
-
-       last_page = first_page;
-       bytes_found = 4096 - page_table[first_page].bytes_used;
-       num_pages = 1;
-       while ((bytes_found < nbytes)
-              && (last_page < (NUM_PAGES-1))
-              && (page_table[last_page+1].allocated == FREE_PAGE)) {
-           last_page++;
-           num_pages++;
-           bytes_found += 4096;
-           gc_assert(page_table[last_page].write_protected == 0);
-       }
-
-       region_size = (4096 - page_table[first_page].bytes_used)
-           + 4096*(last_page-first_page);
-
-       gc_assert(bytes_found == region_size);
-
-       /*
-       FSHOW((stderr,
-              "/last_page=%d bytes_found=%d num_pages=%d\n",
-              last_page, bytes_found, num_pages));
-       */
-
-       restart_page = last_page + 1;
-    } while ((restart_page < NUM_PAGES) && (bytes_found < nbytes));
-
-    /* Check for a failure */
-    if ((restart_page >= NUM_PAGES) && (bytes_found < nbytes)) {
-       fprintf(stderr,
-               "Argh! gc_alloc_large failed (restart_page), nbytes=%d.\n",
-               nbytes);
-       print_generation_stats(1);
-       lose(NULL);
+    if (first_page <= alloc_region->last_page) {
+       first_page = alloc_region->last_page+1;
     }
 
-    /*
-    if (large)
-       FSHOW((stderr,
-              "/gc_alloc_large() gen %d: %d of %d bytes: from pages %d to %d: addr=%x\n",
-              gc_alloc_generation,
-              nbytes,
-              bytes_found,
-              first_page,
-              last_page,
-              page_address(first_page)));
-    */
+    last_page=gc_find_freeish_pages(&first_page,nbytes,unboxed,0);
 
     gc_assert(first_page > alloc_region->last_page);
     if (unboxed)
@@ -1114,23 +935,110 @@ gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region)
        last_free_page = last_page+1;
        SetSymbolValue(ALLOCATION_POINTER,
                       (lispobj)(((char *)heap_base) + last_free_page*4096));
-       if (last_page+1 > last_used_page)
-           last_used_page = last_page+1;
     }
 
     return((void *)(page_address(first_page)+orig_first_page_bytes_used));
 }
 
+int
+gc_find_freeish_pages(int *restart_page_ptr, int nbytes, int unboxed, struct alloc_region *alloc_region)
+{
+    /* if alloc_region is 0, we assume this is for a potentially large
+       object */
+    int first_page;
+    int last_page;
+    int region_size;
+    int restart_page=*restart_page_ptr;
+    int bytes_found;
+    int num_pages;
+    int large = !alloc_region && (nbytes >= large_object_size);
+
+    /* Search for a contiguous free space of at least nbytes. If it's a
+       large object then align it on a page boundary by searching for a
+       free page. */
+
+    /* To allow the allocation of small objects without the danger of
+       using a page in the current boxed region, the search starts after
+       the current boxed free region. XX could probably keep a page
+       index ahead of the current region and bumped up here to save a
+       lot of re-scanning. */
+
+    do {
+       first_page = restart_page;
+       if (large)              
+           while ((first_page < NUM_PAGES)
+                  && (page_table[first_page].allocated != FREE_PAGE))
+               first_page++;
+       else
+           while (first_page < NUM_PAGES) {
+               if(page_table[first_page].allocated == FREE_PAGE)
+                   break;
+               /* I don't know why we need the gen=0 test, but it
+                * breaks randomly if that's omitted -dan 2003.02.26
+                */
+               if((page_table[first_page].allocated ==
+                   (unboxed ? UNBOXED_PAGE : BOXED_PAGE)) &&
+                  (page_table[first_page].large_object == 0) &&
+                  (gc_alloc_genration == 0) &&
+                  (page_table[first_page].gen == gc_alloc_generation) &&
+                  (page_table[first_page].bytes_used < (4096-32)) &&
+                  (page_table[first_page].write_protected == 0) &&
+                  (page_table[first_page].dont_move == 0))
+                   break;
+               first_page++;
+           }
+       
+       if (first_page >= NUM_PAGES) {
+           fprintf(stderr,
+                   "Argh! gc_find_free_space failed (first_page), nbytes=%d.\n",
+                   nbytes);
+           print_generation_stats(1);
+           lose(NULL);
+       }
+
+       gc_assert(page_table[first_page].write_protected == 0);
+
+       last_page = first_page;
+       bytes_found = 4096 - page_table[first_page].bytes_used;
+       num_pages = 1;
+       while (((bytes_found < nbytes) 
+               || (alloc_region && (num_pages < 2)))
+              && (last_page < (NUM_PAGES-1))
+              && (page_table[last_page+1].allocated == FREE_PAGE)) {
+           last_page++;
+           num_pages++;
+           bytes_found += 4096;
+           gc_assert(page_table[last_page].write_protected == 0);
+       }
+
+       region_size = (4096 - page_table[first_page].bytes_used)
+           + 4096*(last_page-first_page);
+
+       gc_assert(bytes_found == region_size);
+       restart_page = last_page + 1;
+    } while ((restart_page < NUM_PAGES) && (bytes_found < nbytes));
+
+    /* Check for a failure */
+    if ((restart_page >= NUM_PAGES) && (bytes_found < nbytes)) {
+       fprintf(stderr,
+               "Argh! gc_find_freeish_pages failed (restart_page), nbytes=%d.\n",
+               nbytes);
+       print_generation_stats(1);
+       lose(NULL);
+    }
+    *restart_page_ptr=first_page;
+    return last_page;
+}
+
 /* Allocate bytes.  All the rest of the special-purpose allocation
  * functions will eventually call this (instead of just duplicating
  * parts of its code) */
 
 void *
-gc_general_alloc(int nbytes,int unboxed_p,int quick_p)
+gc_alloc_with_region(int nbytes,int unboxed_p, struct alloc_region *my_region,
+                    int quick_p)
 {
     void *new_free_pointer;
-    struct alloc_region *my_region = 
-      unboxed_p ? &unboxed_region : &boxed_region;
 
     /* FSHOW((stderr, "/gc_alloc %d\n", nbytes)); */
 
@@ -1151,6 +1059,7 @@ gc_general_alloc(int nbytes,int unboxed_p,int quick_p)
            /* Set up a new region. */
            gc_alloc_new_region(32 /*bytes*/, unboxed_p, my_region);
        }
+
        return((void *)new_obj);
     }
 
@@ -1179,7 +1088,6 @@ gc_general_alloc(int nbytes,int unboxed_p,int quick_p)
        /* If so then allocate from the current region. */
        void *new_obj = my_region->free_pointer;
        my_region->free_pointer = new_free_pointer;
-
        /* Check whether the current region is almost empty. */
        if ((my_region->end_addr - my_region->free_pointer) <= 32) {
            /* If so find, finished with the current region. */
@@ -1197,6 +1105,15 @@ gc_general_alloc(int nbytes,int unboxed_p,int quick_p)
     return((void *) NIL); /* dummy value: return something ... */
 }
 
+void *
+gc_general_alloc(int nbytes,int unboxed_p,int quick_p)
+{
+    struct alloc_region *my_region = 
+      unboxed_p ? &unboxed_region : &boxed_region;
+    return gc_alloc_with_region(nbytes,unboxed_p, my_region,quick_p);
+}
+
+
 
 static void *
 gc_alloc(int nbytes,int unboxed_p)
@@ -1336,7 +1253,7 @@ copy_large_object(lispobj object, int nwords)
        gc_assert(page_table[next_page].bytes_used >= remaining_bytes);
 
        page_table[next_page].gen = new_space;
-       gc_assert(page_table[next_page].allocated = BOXED_PAGE);
+       gc_assert(page_table[next_page].allocated == BOXED_PAGE);
 
        /* Adjust the bytes_used. */
        old_bytes_used = page_table[next_page].bytes_used;
@@ -2626,7 +2543,7 @@ preserve_pointer(void *addr)
        /* Skip if already marked dont_move. */
        || (page_table[addr_page_index].dont_move != 0))
        return;
-
+    gc_assert(!(page_table[addr_page_index].allocated & OPEN_REGION_PAGE));
     /* (Now that we know that addr_page_index is in range, it's
      * safe to index into page_table[] with it.) */
     region_allocation = page_table[addr_page_index].allocated;
@@ -2645,13 +2562,20 @@ preserve_pointer(void *addr)
      * expensive but important, since it vastly reduces the
      * probability that random garbage will be bogusly interpreter as
      * a pointer which prevents a page from moving. */
-    if (!possibly_valid_dynamic_space_pointer(addr))
+    if (!(possibly_valid_dynamic_space_pointer(addr)))
        return;
+    first_page = addr_page_index;
 
     /* Work backwards to find a page with a first_object_offset of 0.
      * The pages should be contiguous with all bytes used in the same
      * gen. Assumes the first_object_offset is negative or zero. */
-    first_page = addr_page_index;
+
+    /* this is probably needlessly conservative.  The first object in
+     * the page may not even be the one we were passed a pointer to:
+     * if this is the case, we will write-protect all the previous
+     * object's pages too.
+     */
+
     while (page_table[first_page].first_object_offset != 0) {
        --first_page;
        /* Do some checks. */
@@ -2746,7 +2670,7 @@ update_page_write_prot(int page)
 
     /* Skip if it's already write-protected or an unboxed page. */
     if (page_table[page].write_protected
-       || (page_table[page].allocated == UNBOXED_PAGE))
+       || (page_table[page].allocated & UNBOXED_PAGE))
        return (0);
 
     /* Scan the page for pointers to younger generations or the
@@ -2834,7 +2758,7 @@ scavenge_generation(int generation)
 #endif
 
     for (i = 0; i < last_free_page; i++) {
-       if ((page_table[i].allocated == BOXED_PAGE)
+       if ((page_table[i].allocated & BOXED_PAGE)
            && (page_table[i].bytes_used != 0)
            && (page_table[i].gen == generation)) {
            int last_page;
@@ -2853,7 +2777,7 @@ scavenge_generation(int generation)
                 * block. */
                if ((page_table[last_page].bytes_used < 4096)
                    /* Or it is 4096 and is the last in the block */
-                   || (page_table[last_page+1].allocated != BOXED_PAGE)
+                   || (!(page_table[last_page+1].allocated & BOXED_PAGE))
                    || (page_table[last_page+1].bytes_used == 0)
                    || (page_table[last_page+1].gen != generation)
                    || (page_table[last_page+1].first_object_offset == 0))
@@ -2951,8 +2875,8 @@ scavenge_newspace_generation_one_scan(int generation)
     FSHOW((stderr,
           "/starting one full scan of newspace generation %d\n",
           generation));
-
     for (i = 0; i < last_free_page; i++) {
+       /* note that this skips over open regions when it encounters them */
        if ((page_table[i].allocated == BOXED_PAGE)
            && (page_table[i].bytes_used != 0)
            && (page_table[i].gen == generation)
@@ -2975,7 +2899,7 @@ scavenge_newspace_generation_one_scan(int generation)
                 * contiguous block */
                if ((page_table[last_page].bytes_used < 4096)
                    /* Or it is 4096 and is the last in the block */
-                   || (page_table[last_page+1].allocated != BOXED_PAGE)
+                   || (!(page_table[last_page+1].allocated & BOXED_PAGE))
                    || (page_table[last_page+1].bytes_used == 0)
                    || (page_table[last_page+1].gen != generation)
                    || (page_table[last_page+1].first_object_offset == 0))
@@ -3040,8 +2964,7 @@ scavenge_newspace_generation(int generation)
     int previous_new_areas_index;
 
     /* Flush the current regions updating the tables. */
-    gc_alloc_update_page_tables(0, &boxed_region);
-    gc_alloc_update_page_tables(1, &unboxed_region);
+    gc_alloc_update_all_page_tables();
 
     /* Turn on the recording of new areas by gc_alloc(). */
     new_areas = current_new_areas;
@@ -3058,8 +2981,7 @@ scavenge_newspace_generation(int generation)
     record_new_objects = 2;
 
     /* Flush the current regions updating the tables. */
-    gc_alloc_update_page_tables(0, &boxed_region);
-    gc_alloc_update_page_tables(1, &unboxed_region);
+    gc_alloc_update_all_page_tables();
 
     /* Grab new_areas_index. */
     current_new_areas_index = new_areas_index;
@@ -3106,8 +3028,7 @@ scavenge_newspace_generation(int generation)
            record_new_objects = 2;
 
            /* Flush the current regions updating the tables. */
-           gc_alloc_update_page_tables(0, &boxed_region);
-           gc_alloc_update_page_tables(1, &unboxed_region);
+           gc_alloc_update_all_page_tables();
 
        } else {
 
@@ -3119,13 +3040,11 @@ scavenge_newspace_generation(int generation)
                int offset = (*previous_new_areas)[i].offset;
                int size = (*previous_new_areas)[i].size / 4;
                gc_assert((*previous_new_areas)[i].size % 4 == 0);
-
                scavenge(page_address(page)+offset, size);
            }
 
            /* Flush the current regions updating the tables. */
-           gc_alloc_update_page_tables(0, &boxed_region);
-           gc_alloc_update_page_tables(1, &unboxed_region);
+           gc_alloc_update_all_page_tables();
        }
 
        current_new_areas_index = new_areas_index;
@@ -3347,9 +3266,17 @@ verify_space(lispobj *start, size_t words)
                /* Does it point to a plausible object? This check slows
                 * it down a lot (so it's commented out).
                 *
-                * FIXME: Add a variable to enable this dynamically. */
-               /* if (!possibly_valid_dynamic_space_pointer((lispobj *)thing)) {
-                *     lose("ptr %x to invalid object %x", thing, start); */
+                * "a lot" is serious: it ate 50 minutes cpu time on
+                * my duron 950 before I came back from lunch and
+                * killed it.
+                *
+                *   FIXME: Add a variable to enable this
+                * dynamically. */
+               /*
+               if (!possibly_valid_dynamic_space_pointer((lispobj *)thing)) {
+                   lose("ptr %x to invalid object %x", thing, start); 
+               }
+               */
            } else {
                /* Verify that it points to another valid space. */
                if (!to_readonly_space && !to_static_space
@@ -3602,13 +3529,9 @@ 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);
+    gc_alloc_update_all_page_tables();
     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
@@ -3806,8 +3729,7 @@ garbage_collect_generation(int generation, int raise)
        scavenge_newspace_generation_one_scan(new_space);
 
        /* Flush the current regions, updating the tables. */
-       gc_alloc_update_page_tables(0, &boxed_region);
-       gc_alloc_update_page_tables(1, &unboxed_region);
+       gc_alloc_update_all_page_tables();
 
        bytes_allocated = bytes_allocated - old_bytes_allocated;
 
@@ -3821,8 +3743,7 @@ garbage_collect_generation(int generation, int raise)
     scan_weak_pointers();
 
     /* Flush the current regions, updating the tables. */
-    gc_alloc_update_page_tables(0, &boxed_region);
-    gc_alloc_update_page_tables(1, &unboxed_region);
+    gc_alloc_update_all_page_tables();
 
     /* Free the pages in oldspace, but not those marked dont_move. */
     bytes_freed = free_oldspace();
@@ -3900,8 +3821,6 @@ collect_garbage(unsigned last_gen)
     int gen_to_wp;
     int i;
 
-    boxed_region.free_pointer = current_region_free_pointer;
-
     FSHOW((stderr, "/entering collect_garbage(%d)\n", last_gen));
 
     if (last_gen > NUM_GENERATIONS) {
@@ -3912,12 +3831,11 @@ collect_garbage(unsigned last_gen)
     }
 
     /* Flush the alloc regions updating the tables. */
-    gc_alloc_update_page_tables(0, &boxed_region);
-    gc_alloc_update_page_tables(1, &unboxed_region);
+    gc_alloc_update_all_page_tables();
 
     /* Verify the new objects created by Lisp code. */
     if (pre_verify_gen_0) {
-       SHOW((stderr, "pre-checking generation 0\n"));
+       FSHOW((stderr, "pre-checking generation 0\n"));
        verify_generation(0);
     }
 
@@ -4005,13 +3923,6 @@ collect_garbage(unsigned last_gen)
 
     update_x86_dynamic_space_free_pointer();
 
-    /* This is now done by Lisp SCRUB-CONTROL-STACK in Lisp SUB-GC, so
-     * we needn't do it here: */
-    /*  zero_stack();*/
-
-    current_region_free_pointer = boxed_region.free_pointer;
-    current_region_end_addr = boxed_region.end_addr;
-
     SHOW("returning from collect_garbage");
 }
 
@@ -4088,27 +3999,13 @@ gc_free_heap(void)
 
     /* 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);
-
-#if 0 /* Lisp PURIFY is currently running on the C stack so don't do this. */
-    zero_stack();
-#endif
+
+    gc_set_region_empty(&boxed_region);
+    gc_set_region_empty(&unboxed_region);
 
     last_free_page = 0;
     SetSymbolValue(ALLOCATION_POINTER, (lispobj)((char *)heap_base));
 
-    current_region_free_pointer = boxed_region.free_pointer;
-    current_region_end_addr = boxed_region.end_addr;
-
     if (verify_after_free_heap) {
        /* Check whether purify has left any bad pointers. */
        if (gencgc_verbose)
@@ -4159,25 +4056,13 @@ gc_init(void)
        generations[i].min_av_mem_age = 0.75;
     }
 
-    /* Initialize gc_alloc.
-     *
-     * FIXME: identical with code in gc_free_heap(), should be shared */
+    /* 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);
+    gc_set_region_empty(&boxed_region);
+    gc_set_region_empty(&unboxed_region);
 
     last_free_page = 0;
 
-    current_region_free_pointer = boxed_region.free_pointer;
-    current_region_end_addr = boxed_region.end_addr;
 }
 
 /*  Pick up the dynamic space from after a core load.
@@ -4207,8 +4092,6 @@ gencgc_pickup_dynamic(void)
     generations[0].bytes_allocated = 4096*page;
     bytes_allocated = 4096*page;
 
-    current_region_free_pointer = boxed_region.free_pointer;
-    current_region_end_addr = boxed_region.end_addr;
 }
 
 void
@@ -4219,9 +4102,8 @@ gc_initialize_pointers(void)
 
 
 \f
-/* a counter for how deep we are in alloc(..) calls */
-int alloc_entered = 0;
 
+extern boolean maybe_gc_pending ;
 /* alloc(..) is the external interface for memory allocation. It
  * allocates to generation 0. It is not called from within the garbage
  * collector as it is only external uses that need the check for heap
@@ -4232,151 +4114,46 @@ int alloc_entered = 0;
  * (E.g. the most significant word of a 2-word bignum in MOVE-FROM-UNSIGNED.)
  *
  * The check for a GC trigger is only performed when the current
- * region is full, so in most cases it's not needed. Further MAYBE-GC
- * is only called once because Lisp will remember "need to collect
- * garbage" and get around to it when it can. */
+ * region is full, so in most cases it's not needed. */
+
 char *
 alloc(int nbytes)
 {
+    struct alloc_region *region=  &boxed_region; 
+    void *new_obj;
+    void *new_free_pointer;
+
     /* Check for alignment allocation problems. */
-    gc_assert((((unsigned)current_region_free_pointer & 0x7) == 0)
+    gc_assert((((unsigned)region->free_pointer & 0x7) == 0)
              && ((nbytes & 0x7) == 0));
-
-    if (SymbolValue(PSEUDO_ATOMIC_ATOMIC)) {/* if already in a pseudo atomic */
-       
-       void *new_free_pointer;
-
-    retry1:
-       if (alloc_entered) {
-           SHOW("alloc re-entered in already-pseudo-atomic case");
-       }
-       ++alloc_entered;
-
-       /* Check whether there is room in the current region. */
-       new_free_pointer = current_region_free_pointer + nbytes;
-
-       /* FIXME: Shouldn't we be doing some sort of lock here, to
-        * keep from getting screwed if an interrupt service routine
-        * allocates memory between the time we calculate new_free_pointer
-        * and the time we write it back to current_region_free_pointer?
-        * Perhaps I just don't understand pseudo-atomics..
-        *
-        * Perhaps I don't. It looks as though what happens is if we
-        * were interrupted any time during the pseudo-atomic
-        * interval (which includes now) we discard the allocated
-        * memory and try again. So, at least we don't return
-        * a memory area that was allocated out from underneath us
-        * by code in an ISR.
-        * Still, that doesn't seem to prevent
-        * current_region_free_pointer from getting corrupted:
-        *   We read current_region_free_pointer.
-        *   They read current_region_free_pointer.
-        *   They write current_region_free_pointer.
-        *   We write current_region_free_pointer, scribbling over
-        *     whatever they wrote. */
-
-       if (new_free_pointer <= boxed_region.end_addr) {
-           /* If so then allocate from the current region. */
-           void  *new_obj = current_region_free_pointer;
-           current_region_free_pointer = new_free_pointer;
-           alloc_entered--;
-           return((void *)new_obj);
-       }
-
-       if (auto_gc_trigger && bytes_allocated > auto_gc_trigger) {
-           /* Double the trigger. */
-           auto_gc_trigger *= 2;
-           alloc_entered--;
-           /* Exit the pseudo-atomic. */
-           SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0));
-           if (SymbolValue(PSEUDO_ATOMIC_INTERRUPTED) != 0) {
-               /* Handle any interrupts that occurred during
-                * gc_alloc(..). */
-               do_pending_interrupt();
-           }
-           funcall0(SymbolFunction(MAYBE_GC));
-           /* Re-enter the pseudo-atomic. */
-           SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0));
-           SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1));
-           goto retry1;
-       }
-       /* Call gc_alloc(). */
-       boxed_region.free_pointer = current_region_free_pointer;
-       {
-           void *new_obj = gc_alloc(nbytes,0);
-           current_region_free_pointer = boxed_region.free_pointer;
-           current_region_end_addr = boxed_region.end_addr;
-           alloc_entered--;
-           return (new_obj);
-       }
-    } else {
-       void *result;
-       void *new_free_pointer;
-
-    retry2:
-       /* At least wrap this allocation in a pseudo atomic to prevent
-        * gc_alloc() from being re-entered. */
-       SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0));
-       SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1));
-
-       if (alloc_entered)
-           SHOW("alloc re-entered in not-already-pseudo-atomic case");
-       ++alloc_entered;
-
-       /* Check whether there is room in the current region. */
-       new_free_pointer = current_region_free_pointer + nbytes;
-
-       if (new_free_pointer <= boxed_region.end_addr) {
-           /* If so then allocate from the current region. */
-           void *new_obj = current_region_free_pointer;
-           current_region_free_pointer = new_free_pointer;
-           alloc_entered--;
-           SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0));
-           if (SymbolValue(PSEUDO_ATOMIC_INTERRUPTED)) {
-               /* Handle any interrupts that occurred during
-                * gc_alloc(..). */
-               do_pending_interrupt();
-               goto retry2;
-           }
-
-           return((void *)new_obj);
-       }
-
-       /* KLUDGE: There's lots of code around here shared with the
-        * the other branch. Is there some way to factor out the
-        * duplicate code? -- WHN 19991129 */
-       if (auto_gc_trigger && bytes_allocated > auto_gc_trigger) {
-           /* Double the trigger. */
-           auto_gc_trigger *= 2;
-           alloc_entered--;
-           /* Exit the pseudo atomic. */
-           SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0));
-           if (SymbolValue(PSEUDO_ATOMIC_INTERRUPTED) != 0) {
-               /* Handle any interrupts that occurred during
-                * gc_alloc(..); */
-               do_pending_interrupt();
-           }
-           funcall0(SymbolFunction(MAYBE_GC));
-           goto retry2;
-       }
-
-       /* Else call gc_alloc(). */
-       boxed_region.free_pointer = current_region_free_pointer;
-       result = gc_alloc(nbytes,0);
-       current_region_free_pointer = boxed_region.free_pointer;
-       current_region_end_addr = boxed_region.end_addr;
-
-       alloc_entered--;
-       SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0));
-       if (SymbolValue(PSEUDO_ATOMIC_INTERRUPTED) != 0) {
-           /* Handle any interrupts that occurred during gc_alloc(..). */
-           do_pending_interrupt();
-           goto retry2;
-       }
-
-       return result;
+    /* At this point we should either be in pseudo-atomic, or early
+     * enough in cold initn that interrupts are not yet enabled anyway.
+     * It would be nice to assert same.
+     */
+    gc_assert(SymbolValue(PSEUDO_ATOMIC_ATOMIC));
+
+    /* maybe we can do this quickly ... */
+    new_free_pointer = region->free_pointer + nbytes;
+    if (new_free_pointer <= region->end_addr) {
+       new_obj = (void*)(region->free_pointer);
+       region->free_pointer = new_free_pointer;
+       return(new_obj);        /* yup */
     }
+    
+    /* we have to go the long way around, it seems.  Check whether 
+     * we should GC in the near future
+     */
+    if (auto_gc_trigger && bytes_allocated > auto_gc_trigger) {
+       auto_gc_trigger *= 2;
+       /* set things up so that GC happens when we finish the PA
+        * section.  */
+       maybe_gc_pending=1;
+       SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1));
+    }
+    new_obj = gc_alloc_with_region(nbytes,0,region,0);
+    return (new_obj);
 }
+
 \f
 /*
  * noise to manipulate the gc trigger stuff
@@ -4478,3 +4255,20 @@ gencgc_handle_wp_violation(void* fault_addr)
 void
 unhandled_sigmemoryfault()
 {}
+
+gc_alloc_update_all_page_tables(void)
+{
+    /* Flush the alloc regions updating the tables. */
+    gc_alloc_update_page_tables(1, &unboxed_region);
+    gc_alloc_update_page_tables(0, &boxed_region);
+}
+void 
+gc_set_region_empty(struct alloc_region *region)
+{
+    region->first_page = 0;
+    region->last_page = -1;
+    region->start_addr = page_address(0);
+    region->free_pointer = page_address(0);
+    region->end_addr = page_address(0);
+}
+
index 96636d1..e266ba4 100644 (file)
@@ -14,6 +14,8 @@
  */
 
 #include <stdio.h>
+#include <sys/types.h>
+#include <unistd.h>
 
 #include "runtime.h"
 #include "sbcl.h"
@@ -28,9 +30,7 @@ lispobj *current_control_frame_pointer;
 lispobj *current_binding_stack_pointer;
 #endif
 
-/* ALLOCATION_POINTER is more or less synonymous with RT, it seems.
- * Anyone want to do an RT port of sbcl?  
- */
+/* ALLOCATION_POINTER is x86 or RT.  Anyone want to do an RT port?   */
 
 #ifndef ALLOCATION_POINTER
 /* The Object Formerly Known As current_dynamic_space_free_pointer */
@@ -46,10 +46,14 @@ lispobj *current_auto_gc_trigger;
  * is done).  For the GENCGC, it always points to DYNAMIC_SPACE_START. */
 lispobj *current_dynamic_space;
 
+boolean stop_the_world=0;
+pid_t parent_pid;
+
 void globals_init(void)
 {
     /* Space, stack, and free pointer vars are initialized by
      * validate() and coreparse(). */
+    current_control_frame_pointer = (lispobj *)0;
 
 #ifndef LISP_FEATURE_GENCGC 
     /* no GC trigger yet */
index 18b3e9e..b86e40f 100644 (file)
@@ -25,6 +25,8 @@
 #include "interr.h"
 #include "print.h"
 #include "lispregs.h"
+#include "genesis/static-symbols.h"
+#include "genesis/vector.h"
 \f
 /* the way that we shut down the system on a fatal error */
 
@@ -44,7 +46,7 @@ never_returns
 lose(char *fmt, ...)
 {
     va_list ap;
-    fprintf(stderr, "fatal error encountered in SBCL runtime system");
+    fprintf(stderr, "fatal error encountered in SBCL pid %d\n",getpid());
     if (fmt) {
        fprintf(stderr, ":\n");
        va_start(ap, fmt);
index f5e5979..4027b3d 100644 (file)
 #include "alloc.h"
 #include "dynbind.h"
 #include "interr.h"
+#include "genesis/simple-fun.h"
+#include "genesis/fdefn.h"
+#include "genesis/symbol.h"
+#include "genesis/static-symbols.h"
 
 void sigaddset_blockable(sigset_t *s)
 {
@@ -99,7 +103,7 @@ static int pending_signal = 0;
 static siginfo_t pending_info;
 static sigset_t pending_mask;
 
-static boolean maybe_gc_pending = 0;
+boolean maybe_gc_pending = 0;
 \f
 /*
  * utility routines used by various signal handlers
index ffefafa..c37c2d5 100644 (file)
 #include "globals.h"
 #include "lispregs.h"
 #include "interrupt.h"
+#include "genesis/static-symbols.h"
+#include "primitive-objects.h"
+
+
 
 /* When we need to do command input, we use this stream, which is not
  * in general stdin, so that things will "work" (as well as being
index 37c4c0a..cb71dc4 100644 (file)
 #include "arch.h"
 #include "search.h"
 
+#include "genesis/simple-fun.h"
+#include "genesis/fdefn.h"
+#include "genesis/symbol.h"
+#include "genesis/static-symbols.h"
+
 static void skip_ws(char **ptr)
 {
     while (**ptr <= ' ' && **ptr != '\0')
diff --git a/src/runtime/primitive-objects.h b/src/runtime/primitive-objects.h
new file mode 100644 (file)
index 0000000..d750b53
--- /dev/null
@@ -0,0 +1,32 @@
+#ifndef SBCL_PRIMITIVE_OBJECTS_H
+#define SBCL_PRIMITIVE_OBJECTS_H 1
+#include "genesis/array.h"
+#include "genesis/bignum.h"
+#include "genesis/binding.h"
+#include "genesis/catch-block.h"
+#include "genesis/closure.h"
+#include "genesis/code.h"
+#include "genesis/complex-double-float.h"
+#include "genesis/complex-single-float.h"
+#include "genesis/complex.h"
+#include "genesis/config.h"
+#include "genesis/cons.h"
+#include "genesis/constants.h"
+#include "genesis/double-float.h"
+#include "genesis/fdefn.h"
+#include "genesis/funcallable-instance.h"
+#include "genesis/instance.h"
+#include "genesis/ratio.h"
+#include "genesis/return-pc.h"
+#include "genesis/sap.h"
+#include "genesis/simple-fun.h"
+#include "genesis/single-float.h"
+#include "genesis/static-symbols.h"
+#include "genesis/symbol.h"
+#include "gencgc-alloc-region.h"
+#include "genesis/thread.h"
+#include "genesis/unwind-block.h"
+#include "genesis/value-cell.h"
+#include "genesis/vector.h"
+#include "genesis/weak-pointer.h"
+#endif /* SBCL_PRIMITIVE_OBJECTS_H */
index cb51452..6875c06 100644 (file)
@@ -30,6 +30,8 @@
 #include "monitor.h"
 #include "vars.h"
 #include "os.h"
+#include "genesis/static-symbols.h"
+#include "primitive-objects.h"
 
 static int max_lines = 20, cur_lines = 0;
 static int max_depth = 5, brief_depth = 2, cur_depth = 0;
index 45a0e6d..a67f338 100644 (file)
@@ -28,6 +28,7 @@
 #include "interr.h"
 #include "gc.h"
 #include "gc-internal.h"
+#include "primitive-objects.h"
 
 #define PRINTNOISE
 
@@ -362,6 +363,11 @@ setup_i386_stack_scav(lispobj *lowaddr, lispobj *base)
             * return addresses. This will also pick up pointers to
             * functions in code objects. */
            if (widetag_of(*start_addr) == CODE_HEADER_WIDETAG) {
+               /* FIXME asserting here is a really dumb thing to do.
+                * If we've overflowed some arbitrary static limit, we
+                * should just refuse to purify, instead of killing
+                * the whole lisp session
+                */
                gc_assert(num_valid_stack_ra_locations <
                          MAX_STACK_RETURN_ADDRESSES);
                valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
@@ -1295,11 +1301,14 @@ purify(lispobj static_roots, lispobj read_only_roots)
     int count, i;
     struct later *laters, *next;
 
+
 #ifdef PRINTNOISE
     printf("[doing purification:");
     fflush(stdout);
 #endif
-
+#ifdef LISP_FEATURE_GENCGC
+    gc_alloc_update_all_page_tables();
+#endif
     if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)) != 0) {
        /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
         * its error simply by a. printing a string b. to stdout instead
@@ -1324,7 +1333,7 @@ purify(lispobj static_roots, lispobj read_only_roots)
     fflush(stdout);
 #endif
 
-#ifdef LISP_FEATURE_GENCGC
+#if (defined(LISP_FEATURE_GENCGC) && defined(LISP_FEATURE_X86))
     gc_assert((lispobj *)CONTROL_STACK_END > ((&read_only_roots)+1));
     setup_i386_stack_scav(((&static_roots)-2), (lispobj *)CONTROL_STACK_END);
 #endif
index b4a8f16..087efc4 100644 (file)
 #include "save.h"
 #include "lispregs.h"
 
+#include "genesis/static-symbols.h"
+#include "genesis/symbol.h"
+
+
 #ifdef irix
 #include <string.h>
 #include "interr.h"
index da73349..716001f 100644 (file)
@@ -25,6 +25,9 @@
 #include "validate.h"
 #include "gc-internal.h"
 
+#include "genesis/static-symbols.h"
+#include "genesis/symbol.h"
+
 static long
 write_bytes(FILE *file, char *addr, long bytes)
 {
@@ -144,17 +147,8 @@ save(char *filename, lispobj init_function)
                 dynamic_space_free_pointer);
 #else
 #ifdef LISP_FEATURE_GENCGC
-    /* I don't know too much about the circumstances in which we could
-     * end up here.  It may be that current_region_free_pointer is
-     * guaranteed to be relevant and we could skip these slightly
-     * paranoid checks.  TRT would be to rid the code of
-     * current_region_foo completely - dan 2002.09.17 */
-    if((boxed_region.free_pointer < current_region_free_pointer) &&
-       (boxed_region.end_addr == current_region_end_addr))
-       boxed_region.free_pointer = current_region_free_pointer;
     /* Flush the current_region, updating the tables. */
-    gc_alloc_update_page_tables(0,&boxed_region);
-    gc_alloc_update_page_tables(1,&unboxed_region);
+    gc_alloc_update_all_page_tables();
     update_x86_dynamic_space_free_pointer();
 #endif
     output_space(file,
index 217a294..48e9faf 100644 (file)
@@ -15,6 +15,7 @@
 #include "sbcl.h"
 #include "os.h"
 #include "search.h"
+#include "primitive-objects.h"
 
 boolean search_for_type(int type, lispobj **start, int *count)
 {
index 5063c98..d2213d5 100644 (file)
@@ -25,6 +25,9 @@
 #include "breakpoint.h"
 #include "monitor.h"
 
+#include "genesis/static-symbols.h"
+#include "genesis/symbol.h"
+
 #define BREAKPOINT_INST 0xcc   /* INT3 */
 
 unsigned long fast_random_state = 1;
index 4fe372a..19584b9 100644 (file)
 #define LANGUAGE_ASSEMBLY
 #include "validate.h"
 #include "sbcl.h"
+#include "genesis/closure.h"
+#include "genesis/fdefn.h"
+#include "genesis/static-symbols.h"
+#include "genesis/symbol.h"    
 
+       
 /* Minimize conditionalization for different OS naming schemes. */
 #if defined __linux__  || defined __FreeBSD__ /* (but *not* OpenBSD) */
 #define GNAME(var) var
@@ -657,7 +662,7 @@ GNAME(alloc_16_to_edi):
                
 
 \f
-#ifdef LISP_FEATURE_GENCGC
+#ifdef LISP_FEATURE_GENCGC_INLINE_ALLOC /* disabled at present */
 
 /* These routines are called from Lisp when an inline allocation 
  * overflows. Every register except the result needs to be preserved.
index 60e97b7..7ef41c9 100644 (file)
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.13.4"
+"0.7.13.5"