From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 29 Apr 2007 19:26:51 +0000 (+0000)
Subject: Eliminate runtime support for pure space, which no longer exists.
X-Git-Tag: 20090517-FFI~621
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ab9edd7430c0e177d46aeb291bf998179b156685;p=mit-scheme.git

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 be447badf..a39fa7414 100644
--- 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 8a029694a..22e0de5de 100644
--- 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"))
 
-(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 3db9244b5..948255f6c 100644
--- 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 824b69f1e..03bcb9055 100644
--- 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 259bdaa5d..c2a436ca4 100644
--- 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)))))))
-
-(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 a39342324..32677fbf8 100644
--- 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?