From a930426963304be512bb35338bc0f045fae29c09 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 16 Jul 2005 03:44:22 +0000 Subject: [PATCH] Eliminate non-reentrant continuations. Microcode 14.17 will drop support for them. --- v7/src/runtime/conpar.scm | 5 +- v7/src/runtime/contin.scm | 146 +++++++------------------------------ v7/src/runtime/runtime.pkg | 4 +- 3 files changed, 31 insertions(+), 124 deletions(-) diff --git a/v7/src/runtime/conpar.scm b/v7/src/runtime/conpar.scm index c27c4cb86..c0940f090 100644 --- a/v7/src/runtime/conpar.scm +++ b/v7/src/runtime/conpar.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: conpar.scm,v 14.47 2005/03/13 05:02:12 cph Exp $ +$Id: conpar.scm,v 14.48 2005/07/16 03:44:04 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1999,2001,2003,2004,2005 Massachusetts Institute of Technology @@ -465,8 +465,7 @@ USA. ;;;; Unparser (define (stack-frame->continuation stack-frame) - (make-continuation 'REENTRANT - (stack-frame->control-point stack-frame) + (make-continuation (stack-frame->control-point stack-frame) (stack-frame/dynamic-state stack-frame) #f)) diff --git a/v7/src/runtime/contin.scm b/v7/src/runtime/contin.scm index cd60a6d6d..95a4e1c75 100644 --- a/v7/src/runtime/contin.scm +++ b/v7/src/runtime/contin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: contin.scm,v 14.13 2005/03/29 05:00:26 cph Exp $ +$Id: contin.scm,v 14.14 2005/07/16 03:44:12 cph Exp $ Copyright 1988,1989,1991,1992,1999,2005 Massachusetts Institute of Technology @@ -27,117 +27,33 @@ USA. ;;; package: (runtime continuation) (declare (usual-integrations)) - + (define (call-with-current-continuation receiver) - (call/cc (ucode-primitive call-with-current-continuation 1) - 'REENTRANT - receiver)) - -;;; The following is not properly tail recursive because it builds the -;;; extra frame that invokes cont on the result. This is done to -;;; guarantee that the continuation is still valid, since the -;;; continuation invocation code is the code that maintains this -;;; state. Note that any other way of verifying this information -;;; would also add a continuation frame to the stack! - -(define (non-reentrant-call-with-current-continuation receiver) - (call/cc (ucode-primitive non-reentrant-call-with-current-continuation 1) - 'UNUSED - (lambda (cont) (cont (receiver cont))))) - -(define (call/cc primitive type receiver) - (primitive + ((ucode-primitive call-with-current-continuation 1) (lambda (control-point) - (let ((continuation - (make-continuation type - control-point + (let ((k + (make-continuation control-point (get-dynamic-state) (get-thread-event-block)))) - (%%within-continuation - continuation - (lambda () (receiver continuation))))))) + (%within-continuation k (lambda () (receiver k))))))) + +(define (within-continuation k thunk) + (guarantee-continuation k 'WITHIN-CONTINUATION) + (%within-continuation k thunk)) + +(define (make-continuation control-point dynamic-state block-thread-events?) + (make-entity (lambda (k value) (%within-continuation k (lambda () value))) + (make-%continuation control-point + dynamic-state + block-thread-events?))) -(define-integrable (%%within-continuation continuation thunk) +(define-integrable (%within-continuation k thunk) ((ucode-primitive within-control-point 2) - (continuation/control-point continuation) - thunk)) - -(define (%within-continuation continuation thread-switch? thunk) - (%%within-continuation - continuation - (let ((restore-state (state-restoration-procedure continuation))) - (lambda () - (restore-state thread-switch?) - (thunk))))) - -(define (invocation-method/reentrant continuation value) - (%%within-continuation - continuation - (let ((restore-state (state-restoration-procedure continuation))) - (lambda () - (restore-state #f) - value)))) - -(define (state-restoration-procedure continuation) - (let ((dynamic-state (continuation/dynamic-state continuation)) - (block-thread-events? - (continuation/block-thread-events? continuation))) - (lambda (thread-switch?) - (set-dynamic-state! dynamic-state thread-switch?) - (set-thread-event-block! block-thread-events?)))) - -;;; These two are correctly locked for multiprocessing, but not for -;;; multiprocessors. - -(define (within-continuation continuation thunk) - (if (not (continuation? continuation)) - (error:wrong-type-argument continuation "continuation" - 'WITHIN-CONTINUATION)) - (if (without-interrupts - (lambda () - (let ((method (continuation/invocation-method continuation))) - (if (eq? method invocation-method/reentrant) - #t - (and (eq? method invocation-method/unused) - (begin - (set-continuation/invocation-method! - continuation - invocation-method/used) - #t)))))) - (%within-continuation continuation #f thunk) - (error "Reentering used continuation" continuation))) - -(define (invocation-method/unused continuation value) - (if (eq? (without-interrupts - (lambda () - (let ((method (continuation/invocation-method continuation))) - (set-continuation/invocation-method! continuation - invocation-method/used) - method))) - invocation-method/unused) - (invocation-method/reentrant continuation value) - (invocation-method/used continuation value))) - -(define (invocation-method/used continuation value) - value - (error "Reentering used continuation" continuation)) - -(define (make-continuation type control-point dynamic-state - block-thread-events?) - (make-entity - (case type - ((REENTRANT) invocation-method/reentrant) - ((UNUSED) invocation-method/unused) - ((USED) invocation-method/used) - (else (error "Illegal continuation type" type))) - (make-%continuation control-point dynamic-state block-thread-events?))) - -(define (continuation/type continuation) - (let ((invocation-method (continuation/invocation-method continuation))) - (cond ((eq? invocation-method invocation-method/reentrant) 'REENTRANT) - ((eq? invocation-method invocation-method/unused) 'UNUSED) - ((eq? invocation-method invocation-method/used) 'USED) - (else (error "Illegal invocation-method" invocation-method))))) + (continuation/control-point k) + (lambda () + (set-dynamic-state! (continuation/dynamic-state k) #f) + (set-thread-event-block! (continuation/block-thread-events? k)) + (thunk)))) (define (continuation? object) (and (entity? object) @@ -147,20 +63,14 @@ USA. (define-guarantee continuation "continuation") -(define-integrable (continuation/invocation-method continuation) - (entity-procedure continuation)) - -(define-integrable (set-continuation/invocation-method! continuation method) - (set-entity-procedure! continuation method)) - -(define-integrable (continuation/control-point continuation) - (%continuation/control-point (entity-extra continuation))) +(define-integrable (continuation/control-point k) + (%continuation/control-point (entity-extra k))) -(define-integrable (continuation/dynamic-state continuation) - (%continuation/dynamic-state (entity-extra continuation))) +(define-integrable (continuation/dynamic-state k) + (%continuation/dynamic-state (entity-extra k))) -(define-integrable (continuation/block-thread-events? continuation) - (%continuation/block-thread-events? (entity-extra continuation))) +(define-integrable (continuation/block-thread-events? k) + (%continuation/block-thread-events? (entity-extra k))) (define-structure (%continuation (constructor make-%continuation) (conc-name %continuation/)) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index e593c04a8..ad8520dae 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.558 2005/06/16 17:15:15 cph Exp $ +$Id: runtime.pkg,v 14.559 2005/07/16 03:44:22 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology @@ -1138,12 +1138,10 @@ USA. continuation/block-thread-events? continuation/control-point continuation/dynamic-state - continuation/type continuation? error:not-continuation guarantee-continuation make-continuation - non-reentrant-call-with-current-continuation within-continuation) (export (runtime thread) %within-continuation)) -- 2.25.1