Eliminate runtime support for pure space, which no longer exists.

diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm
index be447badff45a199a5a34d9a995fa8fda306d35f..a39fa741410dca559f30d912e3b137c6374bf7d9 100644 (file)
--- a/v7/src/runtime/boot.scm
+++ b/v7/src/runtime/boot.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: boot.scm,v 14.27 2007/04/29 18:26:20 cph Exp $
+$Id: boot.scm,v 14.28 2007/04/29 19:25:11 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -127,16 +127,13 @@ USA.
     procedure))
 
 (define-primitives
+  (object-constant? constant?)
   gc-space-status)
 
 (define (object-pure? object)
   object
   #f)
 
-(define (object-constant? object)
-  object
-  #t)
-
 (define-integrable (default-object? object)
   (eq? object (default-object)))
 

diff --git a/v7/src/runtime/gc.scm b/v7/src/runtime/gc.scm
index 8a029694a56f1d11b9e15beeb0d65e50f7ffb28a..22e0de5de9ec2fbcff0f82f9cf4da86f13e40e49 100644 (file)
--- a/v7/src/runtime/gc.scm
+++ b/v7/src/runtime/gc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: gc.scm,v 14.25 2007/01/05 21:19:28 cph Exp $
+$Id: gc.scm,v 14.26 2007/04/29 19:25:16 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -37,7 +37,6 @@ USA.
   (set! hook/stack-overflow default/stack-overflow)
   (set! hook/hardware-trap default/hardware-trap)
   (set! default-safety-margin 4500)
-  (set! pure-space-queue (list 'PURE-SPACE-QUEUE))
   (set! constant-space-queue (list 'CONSTANT-SPACE-QUEUE))
   (set! hook/gc-start default/gc-start)
   (set! hook/gc-finish default/gc-finish)
@@ -87,26 +86,24 @@ USA.
                                 (set-cdr! queue (cdr items))
                                 (queued-purification-failure)))
                           (cdr result)))))))))
-    (or (try-queue pure-space-queue #t)
-       (try-queue constant-space-queue #f)
+    (or (try-queue constant-space-queue #f)
        (gc-flip-internal safety-margin))))
 
 (define (queued-purification-failure)
   (warn "Unable to purify all queued items; dequeuing one."))
 
 (define (default/purify item pure-space? queue?)
-  (if (not (if pure-space? (object-pure? item) (object-constant? item)))
+  pure-space?
+  (if (not (object-constant? item))
       (if queue?
-         (let ((queue (if pure-space? pure-space-queue constant-space-queue)))
-           (with-absolutely-no-interrupts
-             (lambda ()
-               (set-cdr! queue (cons item (cdr queue)))
-               unspecific)))
+         (with-absolutely-no-interrupts
+           (lambda ()
+             (set-cdr! constant-space-queue
+                       (cons item (cdr constant-space-queue)))
+             unspecific))
          (let loop ()
            (let ((result
-                  (purify-internal item
-                                   pure-space?
-                                   default-safety-margin)))
+                  (purify-internal item #f default-safety-margin)))
              (cond ((not (pair? result))
                     ;; Wrong phase -- try again.
                     (gc-flip)
@@ -122,7 +119,6 @@ USA.
   escape-code
   (abort->nearest "Aborting!: the hardware trapped"))
 \f
-(define pure-space-queue)
 (define constant-space-queue)
 (define hook/gc-start)
 (define hook/gc-finish)
@@ -134,11 +130,10 @@ USA.
       space-remaining)))
 
 (define (purify-internal item pure-space? safety-margin)
+  pure-space?
   (let ((start-value (hook/gc-start)))
     (let ((result
-          ((ucode-primitive primitive-purify) item
-                                              pure-space?
-                                              safety-margin)))
+          ((ucode-primitive primitive-purify) item #f safety-margin)))
       (if result
          (gc-finish start-value (cdr result)))
       result)))
@@ -194,8 +189,7 @@ USA.
                       safety-margin)))))
 
 (define (flush-purification-queue!)
-  (if (or (pair? (cdr pure-space-queue))
-         (pair? (cdr constant-space-queue)))
+  (if (pair? (cdr constant-space-queue))
       (begin
        (gc-flip)
        (flush-purification-queue!))))
@@ -203,9 +197,8 @@ USA.
 (define (purify item #!optional pure-space? queue?)
   ;; Purify an item -- move it into pure space and clean everything by
   ;; doing a gc-flip.
-  (hook/purify item
-              (if (default-object? pure-space?) #t pure-space?)
-              (if (default-object? queue?) #t queue?))
+  pure-space?
+  (hook/purify item #f (if (default-object? queue?) #t queue?))
   item)
 
 (define (constant-space/in-use)

diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm
index 3db9244b5d7a16749294652c006d4de8e4b7b982..948255f6c23d11e69b49ec58155c3576150272ff 100644 (file)
--- a/v7/src/runtime/global.scm
+++ b/v7/src/runtime/global.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: global.scm,v 14.78 2007/01/09 06:36:21 cph Exp $
+$Id: global.scm,v 14.79 2007/04/29 19:25:21 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -335,8 +335,6 @@ USA.
                (per-bucket (fix:- index 1) accumulator)))))))
 
 (define (impurify object)
-  (if (and (object-pointer? object) (object-pure? object))
-      ((ucode-primitive primitive-impurify) object))
   object)
 
 (define (fasdump object filename #!optional quiet? dump-option)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 824b69f1eec7dcf5704ee5929827cdd692e7ecbf..03bcb90555d349be5f4f944fc7d058c1e1f172aa 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.615 2007/04/14 03:52:59 cph Exp $
+$Id: runtime.pkg,v 14.616 2007/04/29 19:25:27 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -2450,7 +2450,6 @@ USA.
          condition-type:fasload-band
          condition-type:fasload-error
          condition-type:hardware-trap
-         condition-type:impurify-object-too-large
          condition-type:inapplicable-object
          condition-type:out-of-file-handles
          condition-type:primitive-io-error

diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm
index 259bdaa5d008c93f4e79ec609a1d31bb77069bd4..c2a436ca470d3e7f105e09eca3294f514e5c038f 100644 (file)
--- a/v7/src/runtime/uerror.scm
+++ b/v7/src/runtime/uerror.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uerror.scm,v 14.56 2007/04/03 04:11:33 cph Exp $
+$Id: uerror.scm,v 14.57 2007/04/29 19:25:32 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -39,7 +39,6 @@ USA.
 (define condition-type:fasload-band)
 (define condition-type:fasload-error)
 (define condition-type:hardware-trap)
-(define condition-type:impurify-object-too-large)
 (define condition-type:inapplicable-object)
 (define condition-type:out-of-file-handles)
 (define condition-type:primitive-io-error)
@@ -930,39 +929,6 @@ USA.
            (signal continuation
                    (apply-frame/operator frame)
                    (apply-frame/operands frame)))))))
-\f
-(define-error-handler 'WRITE-INTO-PURE-SPACE
-  (lambda (continuation)
-    (let ((frame (continuation/first-subproblem continuation)))
-      (if (apply-frame? frame)
-         (let ((object (apply-frame/operand frame 0)))
-           (let ((port (notification-output-port)))
-             (fresh-line port)
-             (write-string ";Automagically impurifying an object..." port))
-           (impurify object)
-           (continuation object))))))
-
-(set! condition-type:impurify-object-too-large
-  (make-condition-type 'IMPURIFY-OBJECT-TOO-LARGE
-      condition-type:bad-range-argument
-      '()
-    (lambda (condition port)
-      (write-string "Object is too large to be impurified: " port)
-      (write (access-condition condition 'DATUM) port))))
-
-(define-error-handler 'IMPURIFY-OBJECT-TOO-LARGE
-  (let ((signal
-        (condition-signaller condition-type:impurify-object-too-large
-                             '(DATUM OPERATOR OPERAND))))
-    (lambda (continuation)
-      (let ((frame (continuation/first-subproblem continuation)))
-       (if (apply-frame? frame)
-           (let ((operator (apply-frame/operator frame)))
-             (if (eq? (ucode-primitive primitive-impurify) operator)
-                 (signal continuation
-                         (apply-frame/operand frame 0)
-                         operator
-                         0))))))))
 
 (set! condition-type:fasdump-environment
   (make-condition-type 'FASDUMP-ENVIRONMENT condition-type:bad-range-argument

diff --git a/v7/src/sf/gconst.scm b/v7/src/sf/gconst.scm
index a393423249121550d4407413d392c6b0fffeefac..32677fbf8975b5f57bc911608a37765fa69cc7de 100644 (file)
--- a/v7/src/sf/gconst.scm
+++ b/v7/src/sf/gconst.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: gconst.scm,v 4.35 2007/01/05 21:19:29 cph Exp $
+$Id: gconst.scm,v 4.36 2007/04/29 19:26:51 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -185,7 +185,6 @@ USA.
     OBJECT-CONSTANT?
     OBJECT-DATUM
     OBJECT-NEW-TYPE
-    OBJECT-PURE?
     OBJECT-TYPE
     OBJECT-TYPE?
     PAIR?