add unsafe-set-immutable-{car,cdr}!

Reluctantly, with intentionally oxymoronic names, and with the key
caveat: using these requires making correct assumptions about Racket's
implementation.

With BC, a related assumption was that `unsafe-set-mcar!` and
`unsafe-set-mcdr!` mutate pairs, but that's not the case with CS. So,
adding these functions supports a kind of portability between BC and
CS.

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 "7.9.0.17")
+(define version "7.9.0.18")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

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

@@ -235,7 +235,7 @@ Unchecked versions of @racket[char=?], @racket[char<?], @racket[char>?],
 
 
 
-@section{Unsafe Data Extraction}
+@section[#:tag "Unsafe Data Extraction"]{Unsafe Compound-Data Operations}
 
 @deftogether[(
 @defproc[(unsafe-car [p pair?]) any/c]
@@ -267,6 +267,44 @@ at least @racket[(add1 pos)] (for @racket[unsafe-list-ref]) or
 @racket[pos] (for @racket[unsafe-list-tail]) pairs.}
 
 
+@deftogether[(
+@defproc[(unsafe-set-immutable-car! [p pair?] [v any/c]) void?]
+@defproc[(unsafe-set-immutable-cdr! [p pair?] [v any/c]) void?]
+)]{
+
+As their oxymoronic names should suggest, there is @emph{no generally
+correct way} to use these functions. They may be useful nevertheless,
+as a last resort, in settings where pairs are used in a constrained
+way and when making correct assumptions about Racket's implementation
+(including limits on the compiler's optimizations).
+
+Some pitfalls of using @racket[unsafe-set-immutable-car!] and
+@racket[unsafe-set-immutable-cdr!]:
+
+@itemlist[
+
+ @item{Functions that consume a pair may take advantage of
+       immutability, such as computing a list's length once and
+       expecting the list to retain that length, or checking a list
+       against a contract and expecting the contract to hold
+       thereafter.}
+
+ @item{The result of @racket[list?] for a pair may be cached
+       internally, so that changing the @racket[cdr] of a pair from a
+       list to a non-list or vice versa may cause @racket[list?] to
+       produce the wrong value---for the mutated pair or for another
+       pair that reaches the mutated pair.}
+
+ @item{The compiler may reorder or even optimize away a call to
+       @racket[car] or @racket[cdr] on the grounds that pairs are
+       immutable, in which case a @racket[unsafe-set-immutable-car!]
+       or @racket[unsafe-set-immutable-cdr!] may not have an effect on
+       the use of @racket[car] or @racket[cdr].}
+
+]
+
+@history[#:added "7.9.0.18"]}
+
 @deftogether[(
 @defproc[(unsafe-unbox [b box?]) fixnum?]
 @defproc[(unsafe-set-box! [b box?] [k fixnum?]) void?]

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

@@ -526,6 +526,15 @@
 
   (test-un 5 'unsafe-car (cons 5 9))
   (test-un 9 'unsafe-cdr (cons 5 9))
+  (let ([v (cons 3 7)])
+    (test-bin 8 'unsafe-set-immutable-car! v 8
+              #:pre (lambda () (unsafe-set-immutable-car! v 0))
+              #:post (lambda (x) (car v))
+              #:literal-ok? #f)
+    (test-bin 9 'unsafe-set-immutable-cdr! v 9
+              #:pre (lambda () (unsafe-set-immutable-cdr! v 0))
+              #:post (lambda (x) (cdr v))
+              #:literal-ok? #f))
   (test-un 15 'unsafe-mcar (mcons 15 19))
   (test-un 19 'unsafe-mcdr (mcons 15 19))
   (let ([v (mcons 3 7)])

racket/src/bc/src/jitinline.c

@@ -4242,10 +4242,13 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
 
       return 1;
     } else if (IS_NAMED_PRIM(rator, "unsafe-set-mcar!")
-               || IS_NAMED_PRIM(rator, "unsafe-set-mcdr!")) {
+               || IS_NAMED_PRIM(rator, "unsafe-set-mcdr!")
+               || IS_NAMED_PRIM(rator, "unsafe-set-immutable-car!")
+               || IS_NAMED_PRIM(rator, "unsafe-set-immutable-cdr!")) {
       int set_mcar;
 
-      set_mcar = IS_NAMED_PRIM(rator, "unsafe-set-mcar!");
+      set_mcar = (IS_NAMED_PRIM(rator, "unsafe-set-mcar!")
+                  || IS_NAMED_PRIM(rator, "unsafe-set-immutable-car!"));
 
       LOG_IT(("inlined unsafe-set-mcar!\n"));
 

racket/src/bc/src/list.c

@@ -875,6 +875,14 @@ scheme_init_unsafe_list (Scheme_Startup_Env *env)
   scheme_addto_prim_instance ("unsafe-cdr", p, env);
   scheme_unsafe_cdr_proc = p;
 
+  p = scheme_make_immed_prim(unsafe_set_mcar, "unsafe-set-immutable-car!", 2, 2);
+  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);
+  scheme_addto_prim_instance ("unsafe-set-immutable-car!", p, env);
+
+  p = scheme_make_immed_prim(unsafe_set_mcdr, "unsafe-set-immutable-cdr!", 2, 2);
+  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);
+  scheme_addto_prim_instance ("unsafe-set-immutable-cdr!", p, env);
+
   p = scheme_make_folding_prim(unsafe_list_ref, "unsafe-list-ref", 2, 2, 1);
   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
                                                             | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL

racket/src/bc/src/schminc.h

@@ -15,7 +15,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1482
+#define EXPECTED_PRIM_COUNT 1484
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP

racket/src/cs/primitive/unsafe.ss

@@ -122,8 +122,8 @@
   [unsafe-make-os-semaphore (known-procedure 1)]
   [unsafe-make-security-guard-at-root (known-procedure 15)]
   [unsafe-make-srcloc (known-procedure/pure 32)]
-  [unsafe-mcar (known-procedure 2)]
+  [unsafe-mcar (known-procedure/succeeds 2)]
-  [unsafe-mcdr (known-procedure 2)]
+  [unsafe-mcdr (known-procedure/succeeds 2)]
   [unsafe-mutable-hash-iterate-first (known-procedure 2)]
   [unsafe-mutable-hash-iterate-key (known-procedure 12)]
   [unsafe-mutable-hash-iterate-key+value (known-procedure 12)]
@@ -145,12 +145,14 @@
   [unsafe-register-process-global (known-procedure 4)]
   [unsafe-remove-collect-callbacks (known-procedure 2)]
   [unsafe-root-continuation-prompt-tag (known-procedure/pure 1)]
-  [unsafe-s16vector-ref (known-procedure 4)]
+  [unsafe-s16vector-ref (known-procedure/succeeds 4)]
-  [unsafe-s16vector-set! (known-procedure 8)]
+  [unsafe-s16vector-set! (known-procedure/succeeds 8)]
   [unsafe-set-box! (known-procedure 4)]
-  [unsafe-set-box*! (known-procedure 4)]
+  [unsafe-set-box*! (known-procedure/succeeds 4)]
-  [unsafe-set-mcar! (known-procedure 4)]
+  [unsafe-set-immutable-car! (known-procedure/succeeds 4)]
-  [unsafe-set-mcdr! (known-procedure 4)]
+  [unsafe-set-immutable-cdr! (known-procedure/succeeds 4)]
+  [unsafe-set-mcar! (known-procedure/succeeds 4)]
+  [unsafe-set-mcdr! (known-procedure/succeeds 4)]
   [unsafe-set-on-atomic-timeout! (known-procedure 2)]
   [unsafe-set-sleep-in-thread! (known-procedure 4)]
   [unsafe-signal-received (known-procedure 1)]

racket/src/cs/rumble.sls

@@ -511,6 +511,8 @@
           unsafe-list-tail
           unsafe-list-ref
           unsafe-cons-list
+          unsafe-set-immutable-car!
+          unsafe-set-immutable-cdr!
 
           unsafe-char=?
           unsafe-char<?

racket/src/cs/rumble/unsafe.ss

@@ -8,6 +8,8 @@
 (define unsafe-cdr (unsafe-primitive cdr))
 (define unsafe-list-tail (unsafe-primitive list-tail))
 (define unsafe-list-ref (unsafe-primitive list-ref))
+(define (unsafe-set-immutable-car! p a) ((unsafe-primitive set-car!) p a))
+(define (unsafe-set-immutable-cdr! p d) ((unsafe-primitive set-cdr!) p d))
 
 (define unsafe-char=? (unsafe-primitive char=?))
 (define unsafe-char<? (unsafe-primitive char<?))

racket/src/version/racket_version.h

@@ -16,7 +16,7 @@
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 9
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 17
+#define MZSCHEME_VERSION_W 18
 
 /* A level of indirection makes `#` work as needed: */
 #define AS_a_STR_HELPER(x) #x