add [unsafe-]assert-unreachable

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]))

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"]

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)].}

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"]
+

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)

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 ...))]))

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

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))))
+)

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

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 ()

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

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])

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);

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);

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

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);

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)]

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)]

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

racket/src/cs/rumble/unsafe.ss

@@ -245,3 +245,5 @@
             (current-continuation-marks)
             sym)))
   v)
+
+(define unsafe-assert-unreachable (unsafe-primitive assert-unreachable))

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