diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 05c2cfe2bf..2ae324003b 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -14,7 +14,7 @@ ;; In the Racket source repo, this version should change only when ;; "racket_version.h" changes: -(define version "8.0.0.10") +(define version "8.0.0.11") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/control.scrbl b/pkgs/racket-doc/scribblings/reference/control.scrbl index 476f5668c7..b54905fc49 100644 --- a/pkgs/racket-doc/scribblings/reference/control.scrbl +++ b/pkgs/racket-doc/scribblings/reference/control.scrbl @@ -12,3 +12,4 @@ @include-section["cont-marks.scrbl"] @include-section["breaks.scrbl"] @include-section["exit.scrbl"] +@include-section["unreachable.scrbl"] diff --git a/pkgs/racket-doc/scribblings/reference/unreachable.scrbl b/pkgs/racket-doc/scribblings/reference/unreachable.scrbl new file mode 100644 index 0000000000..b5a28259f4 --- /dev/null +++ b/pkgs/racket-doc/scribblings/reference/unreachable.scrbl @@ -0,0 +1,34 @@ +#lang scribble/doc +@(require "mz.rkt" (for-label racket/unreachable racket/unsafe/ops)) + +@title[#:tag "unreachable"]{Unreachable Expressions} + +@defproc[(assert-unreachable) none/c]{ + +Reports an assertion failure by raising @racket[exn:fail:contract], +which is useful as a safe counterpart to +@racket[unsafe-assert-unreachable]. + +@history[#:added "8.0.0.11"]} + + +@section[#:tag "with-unreachable"]{Customized Unreachable Reporting} + +@note-lib-only[racket/unreachable] + +@history[#:added "8.0.0.11"] + +@defform[(with-assert-unreachable + body ...+)]{ + +Similar to @racket[(assert-unreachable)], asserts that the +@racket[body] forms should not be reached. + +Unless the expression is part of a module that includes +@racket[(#%declare #:unsafe)], then it is equivalent to +@racket[(let-values () body ...+)]. The intent is that the +@racket[body] forms will raise @racket[exn:fail:contract]. + +When a @racket[with-assert-unreachable] expression is part of a module +with @racket[(#%declare #:unsafe)], then it is equivalent to +@racket[(unsafe-assert-unreachable)].} diff --git a/pkgs/racket-doc/scribblings/reference/unsafe.scrbl b/pkgs/racket-doc/scribblings/reference/unsafe.scrbl index 0ee2de2d5c..b2fb6c4026 100644 --- a/pkgs/racket-doc/scribblings/reference/unsafe.scrbl +++ b/pkgs/racket-doc/scribblings/reference/unsafe.scrbl @@ -54,7 +54,7 @@ operations can be prevented by adjusting the code inspector (see For @tech{fixnums}: Unchecked versions of @racket[fx+], @racket[fx-], @racket[fx*], @racket[fxquotient], @racket[fxremainder], @racket[fxmodulo], and -@racket[fxabs]. +@racket[fxabs]. @history[#:changed "7.0.0.13" @elem{Allow zero or more arguments for @racket[unsafe-fx+] and @racket[unsafe-fx*] and allow one or more arguments for @racket[unsafe-fx-].}]} @@ -911,4 +911,39 @@ fixnum).} @; ------------------------------------------------------------------------ +@section[#:tag "unsafeassert"]{Unsafe Assertions} + +@defproc[(unsafe-assert-unreachable) none/c]{ + +Like @racket[assert-unreachable], but the contract of +@racket[unsafe-assert-unreachable] is never satisfied, and the +``unsafe'' implication is that anything at all can happen if a call to +@racket[unsafe-assert-unreachable] is reached. + +The compiler may take advantage of its liberty to pick convenient or +efficient behavior in place of a call to +@racket[unsafe-assert-unreachable]. For example, the expression + +@racketblock[ +(lambda (x) + (if (pair? x) + (car x) + (unsafe-assert-unreachable))) +] + +may be compiled to code equivalent to + +@racketblock[ +(lambda (x) (unsafe-car x)) +] + +because choosing to make @racket[(unsafe-assert-unreachable)] behave +the same as @racket[(unsafe-car x)] makes both branches of the +@racket[if] the same, and then @racket[pair?] test can be eliminated. + +@history[#:added "8.0.0.11"]} + +@; ------------------------------------------------------------------------ + @include-section["unsafe-undefined.scrbl"] + diff --git a/pkgs/racket-test-core/tests/racket/unsafe.rktl b/pkgs/racket-test-core/tests/racket/unsafe.rktl index 4ec1fa20c4..810216d9c0 100644 --- a/pkgs/racket-test-core/tests/racket/unsafe.rktl +++ b/pkgs/racket-test-core/tests/racket/unsafe.rktl @@ -1058,4 +1058,32 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define-syntax-rule (module-claiming-unreachable-part name flag ...) + (module name racket/base + (require racket/unreachable) + (provide f1 f2) + (#%declare flag ...) + (struct s (a) #:authentic) + (define (f1 x) + (if (s? x) + (s-a x) + (assert-unreachable))) + (define (f2 x) + (if (s? x) + (s-a x) + (with-assert-unreachable + (raise-argument-error 'f2 "oops" x)))))) + +(module-claiming-unreachable-part claims-unreachable-parts/safe) +(module-claiming-unreachable-part claims-unreachable-parts/unsafe #:unsafe) + +(err/rt-test ((dynamic-require ''claims-unreachable-parts/safe 'f1) (arity-at-least 7))) +(err/rt-test ((dynamic-require ''claims-unreachable-parts/safe 'f2) (arity-at-least 7))) + +(when (eq? 'chez-scheme (system-type 'vm)) + (test 7 (dynamic-require ''claims-unreachable-parts/unsafe 'f1) (arity-at-least 7)) + (test 7 (dynamic-require ''claims-unreachable-parts/unsafe 'f2) (arity-at-least 7))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (report-errs) diff --git a/racket/collects/racket/unreachable.rkt b/racket/collects/racket/unreachable.rkt new file mode 100644 index 0000000000..7adb1eb2c9 --- /dev/null +++ b/racket/collects/racket/unreachable.rkt @@ -0,0 +1,14 @@ +#lang racket/base +(require (for-syntax racket/base) + (only-in racket/unsafe/ops unsafe-assert-unreachable)) +(provide with-assert-unreachable) + +(define-syntax (with-assert-unreachable stx) + (syntax-case stx () + [(_) (raise-syntax-error + 'with-assert-unreachable + "expected at least one expression on the body")] + [(_ body ...) + #'(if (variable-reference-from-unsafe? (#%variable-reference)) + (unsafe-assert-unreachable) + (let-values () body ...))])) diff --git a/racket/src/ChezScheme/csug/system.stex b/racket/src/ChezScheme/csug/system.stex index f0b7bdcace..dd3852e87f 100644 --- a/racket/src/ChezScheme/csug/system.stex +++ b/racket/src/ChezScheme/csug/system.stex @@ -270,6 +270,40 @@ to the value of the following expression. (lambda (x) ((base-exception-handler) x)) \endschemedisplay +%---------------------------------------------------------------------------- +\entryheader +\formdef{assert-unreachable}{\categoryprocedure}{(assert-unreachable)} +\listlibraries +\endentryheader + +\scheme{assert-unreachable} is used an assertion and optimization hint +in an expression that must not be reached. + +When a safe reference to the procedure is applied, it acts as an +assertion. In that case, an exception is raised if control reaches the +application. + +When an unsafe reference to the procedure is applied, the behavior of +the application is undefined, which gives the compiler liberty to pick +convenient or efficient behavior. For example, the expression + +\schemedisplay +(lambda (x) + (if (pair? x) + (car x) + (#3%assert-unreachable))) +\endschemedisplay + +is compiled to code equivalent to + +\schemedisplay +(lambda (x) (#3%car x)) +\endschemedisplay + +because choosing to make \scheme{(assert-unreachable)} behave the same +as \scheme{(#3%car x)} makes both branches of the \scheme{if} the +same, and then \scheme{pair?} test can be eliminated. + \section{Interrupts\label{SECTSYSTEMINTERRUPTS}} \index{interrupts}{\ChezScheme} allows programs to control diff --git a/racket/src/ChezScheme/mats/cptypes.ms b/racket/src/ChezScheme/mats/cptypes.ms index f8bd28d06c..1ca575abed 100644 --- a/racket/src/ChezScheme/mats/cptypes.ms +++ b/racket/src/ChezScheme/mats/cptypes.ms @@ -1195,3 +1195,13 @@ '(lambda (s) (define x (string->number s)) (when x (number? x))) '(lambda (s) (define x (string->number s)) (when x #t))) ) + +(mat cptypes-unreachable + (cptypes-equivalent-expansion? + '(lambda (x) (if (pair? x) (car x) (#3%assert-unreachable))) + '(lambda (x) (#3%car x))) + (not + (cptypes-equivalent-expansion? + '(lambda (x) (if (pair? x) (car x) (#2%assert-unreachable))) + '(lambda (x) (#3%car x)))) +) diff --git a/racket/src/ChezScheme/s/7.ss b/racket/src/ChezScheme/s/7.ss index fb8c79d9bf..dc36eb20b1 100644 --- a/racket/src/ChezScheme/s/7.ss +++ b/racket/src/ChezScheme/s/7.ss @@ -699,6 +699,10 @@ [() ((abort-handler)) (unexpected-return who)] [(x) ((abort-handler) x) (unexpected-return who)]))) +(define-who assert-unreachable + (lambda () + ($oops who "unreachable code reached"))) + (define $interrupt ($make-thread-parameter void)) (define $format-scheme-version diff --git a/racket/src/ChezScheme/s/cpnanopass.ss b/racket/src/ChezScheme/s/cpnanopass.ss index 27ac09f521..f54ebfd099 100644 --- a/racket/src/ChezScheme/s/cpnanopass.ss +++ b/racket/src/ChezScheme/s/cpnanopass.ss @@ -11430,6 +11430,9 @@ [(arm32 ppc32 pb) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 32)] [(arm64) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 64)])]) + (define-inline 3 assert-unreachable + [() (%constant svoid)]) + )) ; expand-primitives module (define-pass np-place-overflow-and-trap : L9 (ir) -> L9.5 () diff --git a/racket/src/ChezScheme/s/cptypes.ss b/racket/src/ChezScheme/s/cptypes.ss index b68e93adef..5a2c9b89cd 100644 --- a/racket/src/ChezScheme/s/cptypes.ss +++ b/racket/src/ChezScheme/s/cptypes.ss @@ -226,6 +226,14 @@ Notes: ) ) + (define (unsafe-unreachable? ir) + (nanopass-case (Lsrc Expr) ir + [(call ,preinfo ,pr) + (guard (and (eq? (primref-name pr) 'assert-unreachable) + (all-set? (prim-mask unsafe) (primref-flags pr)))) + #t] + [else #f])) + (define make-seq ; ensures that the right subtree of the output seq is not a seq if the ; last argument is similarly constrained, to facilitate result-exp @@ -1430,10 +1438,14 @@ Notes: (predicate-implies? ret3 'bottom)) ;check bottom first (values ir 'bottom pred-env-bottom #f #f)] [(predicate-implies? ret2 'bottom) ;check bottom first - (values (make-seq ctxt `(if ,e1 ,e2 ,void-rec) e3) + (values (if (unsafe-unreachable? e2) + (make-seq ctxt e1 e3) + (make-seq ctxt `(if ,e1 ,e2 ,void-rec) e3)) ret3 types3 t-types3 f-types3)] [(predicate-implies? ret3 'bottom) ;check bottom first - (values (make-seq ctxt `(if ,e1 ,void-rec ,e3) e2) + (values (if (unsafe-unreachable? e3) + (make-seq ctxt e1 e2) + (make-seq ctxt `(if ,e1 ,void-rec ,e3) e2)) ret2 types2 t-types2 f-types2)] [else (let ([new-types (pred-env-union/super-base types2 t-types1 diff --git a/racket/src/ChezScheme/s/primdata.ss b/racket/src/ChezScheme/s/primdata.ss index 5e3254a7af..2a0f7aa315 100644 --- a/racket/src/ChezScheme/s/primdata.ss +++ b/racket/src/ChezScheme/s/primdata.ss @@ -1146,6 +1146,7 @@ (apropos [sig [(sub-ptr) (sub-ptr environment) -> (void)]] [flags true]) (apropos-list [sig [(sub-ptr) (sub-ptr environment) -> (list)]] [flags alloc]) (ash [sig [(sint sint) -> (sint)]] [flags arith-op discard cp02 cp03]) ; can take too long to fold + (assert-unreachable [sig [() -> (bottom)]] [flags abort-op]) (assertion-violationf [sig [(maybe-who string sub-ptr ...) -> (bottom)]] [flags abort-op]) ; 2nd arg is format string (asinh [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) (atanh [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) diff --git a/racket/src/bc/src/env.c b/racket/src/bc/src/env.c index 8e8c101729..cc911e63c9 100644 --- a/racket/src/bc/src/env.c +++ b/racket/src/bc/src/env.c @@ -354,6 +354,7 @@ static void init_unsafe(Scheme_Startup_Env *env) scheme_init_unsafe_fun(env); scheme_init_unsafe_thread(env); scheme_init_unsafe_port(env); + scheme_init_unsafe_error(env); scheme_init_extfl_unsafe_number(env); scheme_init_extfl_unsafe_numarith(env); diff --git a/racket/src/bc/src/error.c b/racket/src/bc/src/error.c index ce0c245a4f..9b551b7669 100644 --- a/racket/src/bc/src/error.c +++ b/racket/src/bc/src/error.c @@ -72,6 +72,7 @@ static void *glib_log_signal_handle; /* locals */ static Scheme_Object *error(int argc, Scheme_Object *argv[]); +static Scheme_Object *assert_unreachable(int argc, Scheme_Object* argv[]); static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_type_error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_argument_error(int argc, Scheme_Object *argv[]); @@ -772,6 +773,12 @@ int scheme_last_error_is_racket(int errid) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_ALWAYS_ESCAPES); \ scheme_addto_prim_instance(name, p, env); +void scheme_init_unsafe_error(Scheme_Startup_Env *env) +{ + Scheme_Object *p; + ESCAPING_NONCM_PRIM("unsafe-assert-unreachable", assert_unreachable, 0, 0, env); +} + void scheme_init_error(Scheme_Startup_Env *env) { Scheme_Object *p; @@ -809,6 +816,8 @@ void scheme_init_error(Scheme_Startup_Env *env) ADD_NONCM_PRIM("exit", scheme_do_exit, 0, 1, env); + ESCAPING_NONCM_PRIM("assert-unreachable", assert_unreachable, 0, 0, env); + /* logging */ ADD_NONCM_PRIM("log-level?", log_level_p, 2, 3, env); ADD_NONCM_PRIM("log-max-level", log_max_level, 1, 2, env); @@ -2709,6 +2718,12 @@ static Scheme_Object *error(int argc, Scheme_Object *argv[]) return do_error("error", MZEXN_FAIL, argc, argv); } +static Scheme_Object *assert_unreachable(int argc, Scheme_Object* argv[]) +{ + scheme_contract_error("assert-unreachable", "unreachable code reached", NULL); + return scheme_void; +} + static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[]) { return do_error("raise-user-error", MZEXN_FAIL_USER, argc, argv); diff --git a/racket/src/bc/src/schminc.h b/racket/src/bc/src/schminc.h index 9bd3b214bf..935f174b70 100644 --- a/racket/src/bc/src/schminc.h +++ b/racket/src/bc/src/schminc.h @@ -15,7 +15,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 1499 +#define EXPECTED_PRIM_COUNT 1501 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/racket/src/bc/src/schpriv.h b/racket/src/bc/src/schpriv.h index 7ef5871511..b8c62d5b0e 100644 --- a/racket/src/bc/src/schpriv.h +++ b/racket/src/bc/src/schpriv.h @@ -377,6 +377,7 @@ void scheme_init_bool(Scheme_Startup_Env *env); void scheme_init_syntax(Scheme_Startup_Env *env); void scheme_init_marshal(Scheme_Startup_Env *env); void scheme_init_error(Scheme_Startup_Env *env); +void scheme_init_unsafe_error(Scheme_Startup_Env *env); void scheme_init_exn(Scheme_Startup_Env *env); void scheme_init_debug(Scheme_Startup_Env *env); void scheme_init_thread(Scheme_Startup_Env *env); diff --git a/racket/src/cs/primitive/kernel.ss b/racket/src/cs/primitive/kernel.ss index f18df40f49..cc4506c721 100644 --- a/racket/src/cs/primitive/kernel.ss +++ b/racket/src/cs/primitive/kernel.ss @@ -29,6 +29,7 @@ [arity-at-least-value (known-procedure 2)] [arity-at-least? (known-procedure/pure/folding 2)] [asin (known-procedure/folding 2)] + [assert-unreachable (known-procedure/no-return 1)] [assoc (known-procedure/single-valued 12)] [assq (known-procedure/no-prompt 4)] [assv (known-procedure/no-prompt 4)] diff --git a/racket/src/cs/primitive/unsafe.ss b/racket/src/cs/primitive/unsafe.ss index a9f45f19c2..ac79a885c7 100644 --- a/racket/src/cs/primitive/unsafe.ss +++ b/racket/src/cs/primitive/unsafe.ss @@ -8,6 +8,7 @@ [unsafe-add-global-finalizer (known-procedure 4)] [unsafe-add-post-custodian-shutdown (known-procedure 2)] [unsafe-add-collect-callbacks (known-procedure 4)] + [unsafe-assert-unreachable (known-procedure/no-return 1)] [unsafe-box*-cas! (known-procedure/succeeds 8)] [unsafe-bytes-length (known-procedure/pure 2)] [unsafe-bytes-ref (known-procedure/succeeds 4)] diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index 1628fe4606..1c0c326c2c 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -720,6 +720,8 @@ unsafe-string->immutable-string! unsafe-vector*->immutable-vector! + unsafe-assert-unreachable + ;; --- not exported to Racket: --- make-pthread-parameter fork-pthread diff --git a/racket/src/cs/rumble/unsafe.ss b/racket/src/cs/rumble/unsafe.ss index abb8950225..3e8386199c 100644 --- a/racket/src/cs/rumble/unsafe.ss +++ b/racket/src/cs/rumble/unsafe.ss @@ -245,3 +245,5 @@ (current-continuation-marks) sym))) v) + +(define unsafe-assert-unreachable (unsafe-primitive assert-unreachable)) diff --git a/racket/src/version/racket_version.h b/racket/src/version/racket_version.h index eb21234a0b..d4dffd93d5 100644 --- a/racket/src/version/racket_version.h +++ b/racket/src/version/racket_version.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 8 #define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 10 +#define MZSCHEME_VERSION_W 11 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x