From beca0d139b0a92db78974c8172a8af328f24941a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marc=20Nieper-Wi=C3=9Fkirchen?= Date: Wed, 22 Jan 2025 16:45:48 +0100 Subject: [PATCH] Simplify $guard & $reset-protect using call-in-continuation (#904) --- s/7.ss | 59 +++++++++++++++++++++++-------------------------- s/exceptions.ss | 52 ++++++++++++++++++------------------------- 2 files changed, 49 insertions(+), 62 deletions(-) diff --git a/s/7.ss b/s/7.ss index 9b5091b0a..0d535a33d 100644 --- a/s/7.ss +++ b/s/7.ss @@ -1,12 +1,12 @@ ;;; 7.ss ;;; Copyright 1984-2017 Cisco Systems, Inc. -;;; +;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at -;;; +;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; +;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. @@ -466,7 +466,7 @@ (define-record-type (sstats make-sstats sstats?) (nongenerative #{sstats pfwch3jd8ts96giujpitoverj-0}) (sealed #t) - (fields + (fields (mutable cpu sstats-cpu set-sstats-cpu!) (mutable real sstats-real set-sstats-real!) (mutable bytes sstats-bytes set-sstats-bytes!) @@ -479,7 +479,7 @@ (lambda (cpu real bytes gc-count gc-cpu gc-real gc-bytes) (new cpu real bytes gc-count gc-cpu gc-real gc-bytes)))))) (define exact-integer? (lambda (x) (and (integer? x) (exact? x)))) - (set-who! make-sstats + (set-who! make-sstats (lambda (cpu real bytes gc-count gc-cpu gc-real gc-bytes) (define verify-time (lambda (name x) @@ -616,29 +616,26 @@ (unless (and (real? v) (not (negative? v))) ($oops 'collect-maximum-generation-threshold-factor "~s is not a nonnegative real" v)) v))) - + (define $reset-protect (lambda (body out) - ((call/cc - (lambda (k) - (parameterize ([reset-handler + (call/cc + (lambda (k) + (parameterize ([reset-handler (lambda () - (k (lambda () - (out) - ((reset-handler)))))]) - (with-exception-handler - (lambda (c) - ; would prefer not to burn bridges even for serious condition - ; if the exception is continuable, but we have no way to know - ; short of grubbing through the continuation - (if (serious-condition? c) - (k (lambda () (out) (raise c))) - (raise-continuable c))) - (lambda () - (call-with-values body - (case-lambda - [(v) (lambda () v)] - [v* (lambda () (apply values v*))])))))))))) + (call-in-continuation k + (lambda () + (out) + ((reset-handler)))))]) + (with-exception-handler + (lambda (c) + ; would prefer not to burn bridges even for serious condition + ; if the exception is continuable, but we have no way to know + ; short of grubbing through the continuation + (if (serious-condition? c) + (call-in-continuation k (lambda () (out) (raise c))) + (raise-continuable c))) + body)))))) (define exit-handler) (define reset-handler) @@ -890,7 +887,7 @@ (docollect (lambda (gct prev-allocated-after-max) (let ([max-gen? (fx= g (collect-maximum-generation))]) - (values + (values ; make gc-trip to look like we've just collected generation g ; w/o also having collected generation g+1 (if max-gen? @@ -1288,7 +1285,7 @@ (condition-wait $collect-cond $tc-mutex) (f)])))) (critical-section - (dynamic-wind + (dynamic-wind once (collect-request-handler) (lambda () (set! $collect-request-pending #f)))))))) @@ -1467,7 +1464,7 @@ (define-record-type pass-stats (nongenerative) (sealed #t) - (fields + (fields (mutable calls) (mutable cpu) (mutable gc-cpu) @@ -1489,7 +1486,7 @@ (set! stats-ht (make-eq-hashtable)))) (set! $enable-pass-timing (make-parameter #f)) - + (set-who! $pass-time (lambda (name thunk) (unless (symbol? name) ($oops who "~s is not a symbol" name)) @@ -1539,8 +1536,8 @@ (define (build-result namev psv) (vector->list (vector-map - (lambda (name ps) - (list name + (lambda (name ps) + (list name (pass-stats-calls ps) (pass-stats-cpu ps) (pass-stats-gc-cpu ps) diff --git a/s/exceptions.ss b/s/exceptions.ss index 86abba1fb..f15b0f4ae 100644 --- a/s/exceptions.ss +++ b/s/exceptions.ss @@ -1,12 +1,12 @@ ;;; exceptions.ss ;;; Copyright 1984-2017 Cisco Systems, Inc. -;;; +;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at -;;; +;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; +;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. @@ -94,7 +94,7 @@ TODO: [(message-condition? c) (let ([irritants (if (irritants-condition? c) (condition-irritants c) '())]) (case (and (list? irritants) (length irritants)) - [(0) + [(0) ($report-string op (and prefix? (if (warning-only? c) "warning" "exception")) (and (who-condition? c) (condition-who c)) @@ -263,37 +263,27 @@ TODO: (set-who! $guard (lambda (supply-else? guards body) (if supply-else? - ((call/cc - (lambda (kouter) - (let ([original-handler-stack ($current-handler-stack)]) - (with-exception-handler - (lambda (arg) - ((call/cc + (call/cc + (lambda (kouter) + (let ([original-handler-stack ($current-handler-stack)]) + (with-exception-handler + (lambda (arg) + (call/cc (lambda (kinner) - (kouter + (call-in-continuation kouter (lambda () (guards arg (lambda () - (kinner + (call-in-continuation kinner (lambda () (parameterize ([$current-handler-stack original-handler-stack]) - (raise-continuable arg)))))))))))) - (lambda () - (call-with-values - body - (case-lambda - [(x) (lambda () x)] - [vals (lambda () (apply values vals))])))))))) - ((call/cc - (lambda (k) - (with-exception-handler - (lambda (arg) (k (lambda () (guards arg)))) - (lambda () - (call-with-values - body - (case-lambda - [(x) (lambda () x)] - [vals (lambda () (apply values vals))])))))))))) + (raise-continuable arg))))))))))) + body)))) + (call/cc + (lambda (k) + (with-exception-handler + (lambda (arg) (call-in-continuation k (lambda () (guards arg)))) + body)))))) ) (define-syntax guard @@ -471,7 +461,7 @@ TODO: ;;; defining its child types, even though the system is compiled with ;;; (eval-syntax-expanders-when) not including compile. (begin -(let-syntax ([a (syntax-rules () +(let-syntax ([a (syntax-rules () [(_ &condition) ; leave only &condition visible (define-record-type (&condition make-simple-condition simple-condition?) (nongenerative #{&condition oyb459ue1fphfx4-a}))])]) @@ -706,7 +696,7 @@ TODO: (for-each (lambda (m) (unless (string? m) ($oops who "~s is not a string" m))) messages) - (error-help #f who #f + (error-help #f who #f (if (null? messages) "invalid syntax" (apply string-append messages)) #f (make-syntax-violation form #f))))