From ab9edd7430c0e177d46aeb291bf998179b156685 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 29 Apr 2007 19:26:51 +0000 Subject: [PATCH] Eliminate runtime support for pure space, which no longer exists. --- v7/src/runtime/boot.scm | 7 ++----- v7/src/runtime/gc.scm | 37 +++++++++++++++---------------------- v7/src/runtime/global.scm | 4 +--- v7/src/runtime/runtime.pkg | 3 +-- v7/src/runtime/uerror.scm | 36 +----------------------------------- v7/src/sf/gconst.scm | 3 +-- 6 files changed, 21 insertions(+), 69 deletions(-) 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? -- 2.25.1