add support for an unsafe compilation mode

For now, unsafe mode is only accessible via `compile-linklet`, where
it can be used to compile the expander in unsafe mode.

Also add `vector*-length`, `vector*-ref`, `vector*-set!`, `unbox*`,
and `set-box*!`, which can be converted in unsafe mode to the unsafe
variants.

Author: mflatt

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "6.90.0.14")
+(define version "6.90.0.15")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/compiler-lib/compiler/decompile.rkt

@@ -169,7 +169,7 @@
   (match expr
     [(struct toplevel (depth pos const? ready?))
      (decompile-tl expr globs stack closed #f)]
-    [(struct varref (constant? tl dummy))
+    [(struct varref (tl dummy constant? from-unsafe?))
      `(#%variable-reference . ,(cond
                                  [(not tl) '()]
                                  [(eq? tl #t) '(<constant-local>)]

pkgs/compiler-lib/compiler/demodularizer/gc.rkt

@@ -61,7 +61,7 @@
        (for-each used! forms)]
       [(seq forms)
        (for-each used! forms)]
-      [(varref constant? toplevel dummy)
+      [(varref toplevel dummy constant? unsafe?)
        (used! toplevel)
        (used! dummy)]
       [(assign id rhs undef-ok?)

pkgs/compiler-lib/compiler/demodularizer/remap.rkt

@@ -55,8 +55,8 @@
           (beg0 (map remap forms))]
          [(seq forms)
           (seq (map remap forms))]
-         [(varref constant? toplevel dummy)
-          (varref constant? (remap toplevel) (remap dummy))]
+         [(varref toplevel dummy constant? unsafe?)
+          (varref (remap toplevel) (remap dummy) constant? unsafe?)]
          [(assign id rhs undef-ok?)
           (assign (remap id) (remap rhs) undef-ok?)]
          [(apply-values proc args-expr)

pkgs/racket-doc/scribblings/raco/zo-struct.scrbl

@@ -419,15 +419,21 @@ binding, constructor, etc.}
   @racket[seq] is never in tail position, even if it is the only
   expression in the list.}
 
-@defstruct+[(varref expr) ([constant? boolean?]
-                           [toplevel (or/c toplevel? #t)] 
-                           [dummy (or/c toplevel? #f)])]{
+@defstruct+[(varref expr) ([toplevel (or/c toplevel? #t)] 
+                           [dummy (or/c toplevel? #f)]
+                           [constant? boolean?]
+                           [from-unsafe? boolean?])]{
   Represents a @racket[#%variable-reference] form. The @racket[toplevel]
   field is @racket[#t] if the original reference was to a constant local
   binding. The @racket[dummy] field
   accesses a variable bucket that strongly references its namespace (as
   opposed to a normal variable bucket, which only weakly references its
-  namespace); it can be @racket[#f].}
+  namespace); it can be @racket[#f].
+
+  The value of @racket[constant?] is true when the @racket[toplevel]
+  field is not @racket[#t] but the referenced variable is known to be
+  constant. The value of @racket[from-unsafe?] is true when the module
+  that created the reference was compiled in unsafe mode.}
 
 @defstruct+[(assign expr)
             ([id toplevel?]

pkgs/racket-doc/scribblings/reference/data.scrbl

@@ -119,6 +119,18 @@ For any @racket[v], @racket[(unbox (box v))] returns @racket[v].
 Sets the content of @racket[box] to @racket[v].}
 
 
+@deftogether[(
+@defproc[(unbox* [box (and box? (not/c impersonator?))]) any/c]
+@defproc[(set-box*! [box (and/c box? (not/c immutable?) (not/c impersonator?))]
+                    [v any/c]) void?]
+)]{
+
+Like @racket[unbox] and @racket[set-box!], but constrained to work on
+boxes that are not @tech{impersonators}.
+
+@history[#:added "6.90.0.15"]}
+
+
 @defproc[(box-cas! [box (and/c box? (not/c immutable?) (not/c impersonator?))]
                    [old any/c] 
                    [new any/c]) 

pkgs/racket-doc/scribblings/reference/linklet.scrbl

@@ -1,6 +1,7 @@
 #lang scribble/doc
 @(require "mz.rkt"
-          (for-label racket/linklet))
+          (for-label racket/linklet
+                     racket/unsafe/ops))
 
 @title[#:tag "linklets"]{Linklets and the Core Compiler}
 
@@ -119,15 +120,17 @@ otherwise.}
                              [name any/c #f]
                              [import-keys #f #f]
                              [get-import #f #f]
-                             [serializable? any/c #t])
+                             [serializable? any/c #t]
+                             [unsafe-mode? any/c #f])
             linklet?]
            [(compile-linklet [form (or/c correlated? any/c)]
                              [name any/c]
                              [import-keys vector?]
                              [get-import (or/c #f (any/c . -> . (values (or/c linklet? instance? #f)
                                                                         (or/c vector? #f))))
                                          #f]
-                             [serializable? any/c #t])
+                             [serializable? any/c #t]
+                             [unsafe-mode? any/c #f])
             (values linklet? vector?)])]{
 
 Takes an S-expression or @tech{correlated object} for a
@@ -166,7 +169,21 @@ When @racket[import-keys] is not @racket[#f], then the compiler is
 allowed to grow or shrink the set of imported instances for the
 linklet. The result vector specifies the keys of the imports for the
 returned linklet. Any key that is @racket[#f] or a @tech{linklet instance}
-must be preserved intact, however.}
+must be preserved intact, however.
+
+If @racket[unsafe-mode?] is true, then the linklet is compiled in
+@deftech{unsafe mode}: uses of safe operations within the linklet can
+be converted to unsafe operations on the assumption that the relevant
+contracts are satisfied. For example, @racket[car] is converted to
+@racket[unsafe-car]. Some substituted unsafe operations may not have
+directly accessible names, such as the unsafe variant of
+@racket[in-list] that can be substituted in @tech{unsafe mode}. An
+unsafe operation is substituted only if its (unchecked) contract is
+subsumed by the safe operation's contract. The fact that the linklet
+is compiled in @tech{unsafe mode} can be exposed through
+@racket[variable-reference-from-unsafe?] using a variable reference
+produced by a @racket[#%variable-reference] form within the module
+body.}
 
 
 @defproc*[([(recompile-linklet [linklet linklet?]

pkgs/racket-doc/scribblings/reference/namespaces.scrbl

@@ -503,3 +503,27 @@ Returns the declaration @tech{inspector} (see @secref["modprotect"])
 for the module of @racket[varref], where @racket[varref] must refer to
 an anonymous module variable as produced by
 @racket[(#%variable-reference)].}
+
+
+@defproc[(variable-reference-from-unsafe? [varref variable-reference?]) boolean?]{
+
+Returns @racket[#t] if the module of the variable reference itself
+(not necessarily a referenced variable) is compiled in unsafe mode,
+@racket[#f] otherwise.
+
+The @racket[variable-reference-from-unsafe?] procedure is intended for
+use as
+
+@racketblock[
+(variable-reference-from-unsafe? (#%variable-reference))
+]
+
+which the compiler can optimize to a literal @racket[#t] or
+@racket[#f] (since the enclosing module is being compiled in
+@tech{unsafe mode} or not).
+
+Currently @tech{unsafe mode} can be controlled only through the
+@tech{linklet} interface, but future changes may make @tech{unsafe
+mode} more accessible at the module level.
+
+@history[#:added "6.12.0.4"]}

pkgs/racket-doc/scribblings/reference/unsafe.scrbl

@@ -655,6 +655,7 @@ fixnum).}
 
  @history[#:added "6.9.0.2"]
 }
+
 @; ------------------------------------------------------------------------
 
 @include-section["unsafe-undefined.scrbl"]

pkgs/racket-doc/scribblings/reference/vectors.scrbl

@@ -72,6 +72,23 @@ slot is position @racket[0], and the last slot is one less than
 
 Updates the slot @racket[pos] of @racket[vec] to contain @racket[v].}
 
+
+@deftogether[(
+@defproc[(vector*-length [vec (and/c vector? (not/c impersonator?))]) exact-nonnegative-integer?]
+@defproc[(vector*-ref [vec (and/c vector? (not/c impersonator?))] [pos exact-nonnegative-integer?]) any/c]
+@defproc[(vector*-set! [vec (and/c vector? (not/c immutable?)  (not/c impersonator?))]
+                       [pos exact-nonnegative-integer?]
+                       [v any/c])
+         void?]
+)]{
+
+Like @racket[vector-length], @racket[vector-ref], and
+@racket[vector-set!], but constrained to work on vectors that are not
+@tech{impersonators}.
+
+@history[#:added "6.90.0.15"]}
+
+
 @defproc[(vector-cas! [vec (and/c vector? (not/c immutable?) (not/c impersonator?))]
                       [pos exact-nonnegative-integer?]
                       [old-v any/c]

pkgs/racket-test-core/tests/racket/jitinline.rktl

@@ -702,8 +702,14 @@
     (bin-exact 'b 'vector-ref #(a b c) 1)
     (bin-exact 'c 'vector-ref #(a b c) 2)
 
+    (bin-exact 'a 'vector*-ref #(a b c) 0 #t)
+    (bin-exact 'b 'vector*-ref #(a b c) 1)
+    (bin-exact 'c 'vector*-ref #(a b c) 2)
+
     (un-exact 'a 'unbox (box 'a) #t)
+    (un-exact 'a 'unbox* (box 'a) #t)
     (un-exact 3 'vector-length (vector 'a 'b 'c) #t)
+    (un-exact 3 'vector*-length (vector 'a 'b 'c) #t)
 
     (bin-exact 1.1 'flvector-ref (flvector 1.1 2.2 3.3) 0 #t)
     (bin-exact 3.3 'flvector-ref (flvector 1.1 2.2 3.3) 2)
@@ -857,6 +863,7 @@
 				      3rd-all-ok?))
 			 '(0 1 2))))])
       (test-setter make-vector #f 7 'vector-set! vector-set! vector-ref #t)
+      (test-setter make-vector #f 7 'vector*-set! vector*-set! vector*-ref #t)
       (test-setter make-bytes 0 7 'bytes-set! bytes-set! bytes-ref #f)
       (test-setter make-string #\a #\7 'string-set! string-set! string-ref #f)
       (test-setter make-flvector 1.0 7.0 'flvector-set! flvector-set! flvector-ref #f)
@@ -869,14 +876,29 @@
         (test-setter (lambda (n v) (chap-vec (chap-vec (make-vector n v))))
                      #f 7 'vector-set! vector-set! vector-ref #t)))
 
+    (err/rt-test (apply (list-ref (list (lambda (v) (vector*-length v))) (random 1)) 
+                        (list (chaperone-vector (vector 1 2 3) (lambda (vec i val) val) (lambda (vec i val) val)))))
+    (err/rt-test (apply (list-ref (list (lambda (v) (vector*-ref v 0))) (random 1)) 
+                        (list (chaperone-vector (vector 1 2 3) (lambda (vec i val) val) (lambda (vec i val) val)))))
+    (err/rt-test (apply (list-ref (list (lambda (v) (unbox* v))) (random 1)) 
+                        (list (chaperone-box (box 1) (lambda (b v) v) (lambda (b v) v)))))
+
     (err/rt-test (apply (list-ref (list (lambda (v) (vector-set! v 0 #t))) (random 1)) 
                         (list (vector-immutable 1 2 3))))
+    (err/rt-test (apply (list-ref (list (lambda (v) (vector*-set! v 0 #t))) (random 1)) 
+                        (list (vector-immutable 1 2 3))))
+    (err/rt-test (apply (list-ref (list (lambda (v) (vector*-set! v 0 #t))) (random 1)) 
+                        (list (chaperone-vector (vector 1 2 3) (lambda (vec i val) val) (lambda (vec i val) val)))))
     (err/rt-test (apply (list-ref (list (lambda (s) (string-set! s 0 #\a))) (random 1)) 
                         (list "123")))
     (err/rt-test (apply (list-ref (list (lambda (s) (bytes-set! s 0 0))) (random 1)) 
                         (list #"123")))
     (err/rt-test (apply (list-ref (list (lambda (b) (set-box! b #t))) (random 1)) 
                         (list (box-immutable 1))))
+    (err/rt-test (apply (list-ref (list (lambda (b) (set-box*! b #t))) (random 1)) 
+                        (list (box-immutable 1))))
+    (err/rt-test (apply (list-ref (list (lambda (v) (set-box*! v 'no))) (random 1)) 
+                        (list (chaperone-box (box 1) (lambda (b v) v) (lambda (b v) v)))))
 
     (let ([v (box 1)])
       (check-error-message 'set-box! (eval `(lambda (x) (set-box! x 10))))

pkgs/zo-lib/compiler/zo-marshal.rkt

@@ -615,9 +615,11 @@
         (out-anything (protect-quote key) out)
         (out-anything (protect-quote val) out)
         (out-anything (protect-quote body) out)]
-       [(struct varref (constant? expr dummy))
+       [(struct varref (expr dummy constant? from-unsafe?))
         (out-byte CPT_VARREF out)
-        (out-number (if constant? 1 0) out)
+        (out-number (bitwise-ior (if constant? 1 0)
+                                 (if from-unsafe? 2 0))
+                    out)
         (out-anything expr out)
         (out-anything dummy out)]
        [(struct inline-variant (direct inline))

pkgs/zo-lib/compiler/zo-parse.rkt

@@ -633,7 +633,10 @@
          (define undef-ok? (not (zero? (read-compact-number cp))))
          (make-assign (read-compact cp) (read-compact cp) undef-ok?)]
         [(varref)
-         (make-varref (not (zero? (read-compact-number cp))) (read-compact cp) (read-compact cp))]
+         (define flags (read-compact-number cp))
+         (make-varref (read-compact cp) (read-compact cp)
+                      (bitwise-bit-set? flags 1)
+                      (bitwise-bit-set? flags 2))]
         [(apply-values)
          (make-apply-values (read-compact cp) (read-compact cp))]
         [(other-form)

pkgs/zo-lib/compiler/zo-structs.rkt

@@ -115,7 +115,10 @@
                                            [val (or/c expr? seq? any/c)] 
                                            [body (or/c expr? seq? any/c)])) ; `with-continuation-mark'
 (define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? any/c))])) ; `begin0'
-(define-form-struct (varref expr) ([constant? boolean?] [toplevel (or/c toplevel? #f #t symbol?)] [dummy (or/c toplevel? #f)])) ; `#%variable-reference'
+(define-form-struct (varref expr) ([toplevel (or/c toplevel? #f #t symbol?)]
+                                   [dummy (or/c toplevel? #f)]
+                                   [constant? boolean?]
+                                   [from-unsafe? boolean?]))
 (define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set!
 (define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc)
 (define-form-struct (with-immed-mark expr) ([key (or/c expr? seq? any/c)] 

racket/collects/racket/private/for.rkt

@@ -388,6 +388,9 @@
     (raise-syntax-error #f
       "illegal outside of a loop or comprehension binding" stx))
 
+  (define-syntax-rule (unless-unsafe e)
+    (unless (variable-reference-from-unsafe? (#%variable-reference)) e))
+
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;  streams & sequences
 
@@ -807,7 +810,7 @@
                             ;;outer bindings
                             ([(ht) ht-expr])
                             ;; outer check
-                            (CHECK-SEQ ht)
+                            (unless-unsafe (CHECK-SEQ ht))
                             ;; loop bindings
                             ([i (-first ht)])
                             ;; pos check
@@ -1901,7 +1904,7 @@
                   ([(start) a] [(end) b] [(inc) step])
                   ;; outer check:
                   ;; let `check-range' report the error:
-                  (check-range start end inc)
+                  (unless-unsafe (check-range start end inc))
                   ;; loop bindings:
                   ([pos start])
                   ;; pos check
@@ -1942,7 +1945,7 @@
                 ([(start) start-expr])
                 ;; outer check:
                 ;; let `check-naturals' report the error:
-                (check-naturals start)
+                (unless-unsafe (check-naturals start))
                 ;; loop bindings:
                 ([pos start])
                 ;; pos check
@@ -1971,7 +1974,7 @@
               ;;outer bindings
               ([(lst) lst-expr])
               ;; outer check
-              (check-list lst)
+              (unless-unsafe (check-list lst))
               ;; loop bindings
               ([lst lst])
               ;; pos check
@@ -2025,7 +2028,7 @@
               ;;outer bindings
               ([(lst) lst-expr])
               ;; outer check
-              (unless (stream? lst) (in-stream lst))
+              (unless (unless-unsafe (stream? lst)) (in-stream lst))
               ;; loop bindings
               ([lst lst])
               ;; pos check

racket/src/cify/inline.rkt

@@ -18,13 +18,13 @@
     [(cons) (and (= n 2) can-gc? 'scheme_make_pair)]
     [(list*) (and (= n 2) can-gc? 'scheme_make_pair)]
     [(list) (and (or (= n 1) (= n 2)) can-gc? (if (= n 1) 'c_make_list1 'c_make_list2))]
-    [(unbox unsafe-unbox unsafe-unbox*) (and (= n 1) 'c_box_ref)]
+    [(unbox unsafe-unbox unbox* unsafe-unbox*) (and (= n 1) 'c_box_ref)]
     [(weak-box-value) (and (or (= n 1) (= n 2)) 'c_weak_box_value)]
-    [(set-box! unsafe-set-box! unsafe-set-box*!) (and (= n 2) 'c_box_set)]
+    [(set-box! set-box*! unsafe-set-box! unsafe-set-box*!) (and (= n 2) 'c_box_set)]
     [(vector-ref unsafe-vector-ref) (and (= n 2) 'c_vector_ref)]
-    [(vector*-set! unsafe-vector*-set! unsafe-vector*-set!) (and (= n 3) 'c_vector_set)]
-    [(unsafe-vector*-ref) (and (= n 2) 'c_authentic_vector_ref)]
-    [(vector-length unsafe-vector-length unsafe-vector*-length) (and (= n 1) 'c_vector_length)]
+    [(vector*-ref unsafe-vector*-ref) (and (= n 2) 'c_authentic_vector_ref)]
+    [(vector-set! unsafe-vector-set! vector*-set! unsafe-vector*-set!) (and (= n 3) 'c_vector_set)]
+    [(vector-length unsafe-vector-length vector*-length unsafe-vector*-length) (and (= n 1) 'c_vector_length)]
     [(string-ref unsafe-string-ref) (and (= n 2) can-gc? 'c_string_ref)]
     [(bytes-ref unsafe-bytes-ref) (and (= n 2) 'c_bytes_ref)]
     [(fx+ unsafe-fx+) (and (= n 2) 'c_int_add)]

racket/src/cs/Makefile

@@ -22,7 +22,7 @@ PRIMITIVES_TABLES = primitive/kernel.ss primitive/unsafe.ss primitive/flfxnum.ss
 
 CONVERT_DEPS = convert.rkt $(PRIMITIVES_TABLES)
 
-CONVERT = $(RACKET) -l- raco make convert.rkt && $(RACKET) convert.rkt
+CONVERT = $(RACKET) -l- raco make convert.rkt && $(RACKET) convert.rkt $(UNSAFE_COMP)
 
 THREAD_DEPS = chezpart.so rumble.so
 IO_DEPS = $(THREAD_DEPS) thread.so

racket/src/cs/convert.rkt

@@ -12,6 +12,7 @@
 
 (define skip-export? #f)
 (define for-cify? #f)
+(define unsafe-mode? #f)
 
 (define-values (in-file out-file)
   (command-line
@@ -20,6 +21,8 @@
     (set! skip-export? #t)]
    [("--for-cify") "Keep `make-struct-type` as-is, etc."
     (set! for-cify? #t)]
+   [("--unsafe") "Compile for unsafe mode"
+    (set! unsafe-mode? #t)]
    #:args
    (in-file out-file)
    (values in-file out-file)))
@@ -121,7 +124,7 @@
     (printf "Schemify...\n")
     (define body
       (time
-       (schemify-body bodys/constants-lifted (lambda (old-v new-v) new-v) prim-knowns #hasheq() #hasheq() for-cify?)))
+       (schemify-body bodys/constants-lifted (lambda (old-v new-v) new-v) prim-knowns #hasheq() #hasheq() for-cify? unsafe-mode?)))
     (printf "Lift...\n")
     ;; Lift functions to aviod closure creation:
     (define lifted-body