non-original code inspector => mark loaded bytecode as non-runnable

This change adjusts the way that trust is threaded through bytecode
and the code inspector. In Racket v6.x, reading bytecode would fail if
the code inspector is non-original and if the bytecode contains a
reference to an unsafe operation. Now, reading bytecode doesn't fail
for that reason, but all bytecode is marked as non-runnable (even
without references to unsafe operations) when loaded under a
non-original code inspector. A `read` operation by itself remains as
safe as ever.

This commit also disables the bytecode validator. For now, the
validate can be re-enabled with `PLT_VALIDATE_LOAD`.

pkgs/racket-doc/scribblings/reference/code-inspectors.scrbl

@@ -57,5 +57,9 @@ requires control over the old one).
 
 @defparam[current-code-inspector insp inspector?]{
 
-A @tech{parameter} that determines an inspector to control access to module
+A @tech{parameter} that determines an inspector to control access to
-bindings and redefinitions.}
+module bindings and redefinitions.
+
+If the code inspector is changed from its original value, then
+bytecode loaded by the default @tech{compiled-load handler} is marked
+as non-runnable.}

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

@@ -560,12 +560,16 @@ be @tech{tainted} or @tech{armed}; the @litchar{#~}-marshaled form
 drops source-location information and properties (see
 @secref["stxprops"]) for the @tech{syntax objects}.
 
-Compiled code parsed from @litchar{#~} may contain references to
+Compiled code parsed from @litchar{#~} is marked as non-runnable if
-unexported or protected bindings from a module. At read time, such
+the current code inspector (see @racket[current-code-inspector]) is
-references are associated with the current code inspector (see
+not the original code inspector; on attempting to evaluate or reoptimize
-@racket[current-code-inspector]), and the code will only execute if
+non-runnable bytecode, @exnraise[exn:fail]. Otherwise, compiled
-that inspector controls the relevant module invocation (see
+code parsed from @litchar{#~} may contain references to unexported or
-@secref["modprotect"]).
+protected bindings from a module. Conceptually, the references in
+bytecode are associated with the current code inspector, where the
+code will only execute if that inspector controls the relevant module
+invocation (see @secref["modprotect"])---but the original code
+inspector controls all other inspectors, anyway.
 
 A compiled-form object may contain @tech{uninterned} symbols (see
 @secref["symbols"]) that were created by @racket[gensym] or
@@ -587,17 +591,7 @@ identifiers either with @racket[generate-temporaries] or by applying
 the result of @racket[make-syntax-introducer] to an existing
 identifier; those functions lead to top-level and module variables
 with @tech{unreadable symbol}ic names, and the names are deterministic
-as long as expansion is otherwise deterministic. 
+as long as expansion is otherwise deterministic.
-
-Despite the problems inherent with @tech{uninterned} symbols as
-variable names, they are partially supported even across multiple
-@litchar{#~}s: When compiled code contains a reference to a module-defined
-variable whose name is an @tech{uninterned} symbol, the relative
-position of the variable among the module's definitions is recorded,
-and the reference can be linked back to the definition based on its
-position and the characters in its name. This accommodation works only
-for variable references in compiled code; it does not work for
-@racket[syntax]-quoted identifiers, for example.
 
 Finally, a compiled form may contain path literals. Although paths are
 not normally printed in a way that can be read back in, path literals
@@ -615,3 +609,18 @@ path is not relative to the value of the
 coerced to a string that preserves only part of the path (an in effort
 to make it less tied to the build-time filesystem, which can be
 different than the run-time filesystem).
+
+For internal testing purposes, when the
+@as-index{@envvar{PLT_VALIDATE_LOAD}} environment variable is set, the
+reader runs a validator on bytecode parsed from @litchar{#~}. The
+validator may catch miscompilations or bytecode-file corruption. The
+validtor may run lazily, such as checking a procedure only when the
+procedure is called.
+
+@history[#:changed "6.90.0.21" @elem{Adjusted the effect of changing
+                                    the code inspector on parsed
+                                    bytecode, causing the reader to
+                                    mark the loaded code as generally
+                                    unrunnable instead of rejecting at
+                                    read time references to unsafe
+                                    operations.}]

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

@@ -222,11 +222,7 @@
 (define (xeval e)
   (eval
    (if (bytes? e)
-       (parameterize ([read-accept-compiled #t]
+       (parameterize ([read-accept-compiled #t])
-                      ;; The read-time inspector is supposed to
-                      ;; be irrelevant; only the declaration-time
-                      ;; inspector should matter
-                      [current-code-inspector (make-inspector)])
          (read (open-input-bytes e)))
        e)))
 
@@ -366,30 +362,7 @@
             three/nabbed-c three/pnabbed-c three/snabbed-c three/nfnabbed-c three/nfpnabbed-c three/nfsnabbed-c 
             three/normal-c
             current-code-inspector make-inspector #f #f #f #f #f)
-(unsafe-try unsafe-c make-inspector #f #f #t)
+(unsafe-try unsafe-c make-inspector #f #f #f)
-
-;; zo and source; changing inspector affects access in various ways-----------------
-
-(displayln "zo and source:")
-(mp-try-all zero-zo one-zo two/no-protect-zo two/protect-zo 
-            three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/nfnabbed-zo three/nfpnabbed-zo three/nfsnabbed-zo 
-            three/normal-zo
-            make-inspector current-code-inspector #t #f #f #f #t)
-(unsafe-try unsafe-zo make-inspector #f #f #t)
-
-(displayln "source and zo, change inspector:")
-(mp-try-all zero one two/no-protect two/protect 
-            three/nabbed three/pnabbed three/snabbed-zo three/nfnabbed three/nfpnabbed three/nfsnabbed-zo 
-            three/normal
-            current-code-inspector make-inspector #t #t #t #t #t
-            #:early-ok? #t)
-(unsafe-try unsafe make-inspector #t #t #f)
-
-(displayln "zo, change inspector:")
-(mp-try-all zero-zo one-zo two/no-protect-zo two/protect-zo 
-            three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/nfnabbed-zo three/nfpnabbed-zo three/nfsnabbed-zo 
-            three/normal-zo
-            make-inspector make-inspector #t #t #f #f #f #:via-2-ok? #t)
 
 (displayln "just source, weaken inspector:")
 (mp-try-all zero one two/no-protect two/protect 

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

@@ -4975,8 +4975,8 @@
 (err/rt-test (do-test-of-lift-fixpoint) exn:fail?)
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; generate byecode with a lifted function that has
+;; generate bytecode with a lifted function that has
-;; a boxed argument and rest args, to test that case
+;; a boxed argument and rest args, originally to test that case
 ;; of the validator
 
 (parameterize ([current-namespace (make-base-namespace)])
@@ -5023,65 +5023,6 @@
 
 (test #t (dynamic-require ''check-tail-call-by-jit-for-struct-predicate 'go))
 
-;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Test bytecode validator's checking of constantness
-
-(let ()
-  (define c1
-    '(module c1 racket/kernel
-       ((if (zero? (random 1))
-            (lambda (f) (display (f)))
-            #f)
-        (lambda ()
-          ;; This access of i should raise an exception:
-          i))
-       (define-values (i) (random 1))))
-
-  (define o (open-output-bytes))
-
-  (parameterize ([current-namespace (make-base-namespace)])
-    (write (compile c1) o))
-
-  (define m (zo-parse (open-input-bytes (get-output-bytes o))))
-
-  (define o2 (open-output-bytes))
-
-  ;; construct bytecode that is broken by claiming that `i' is constant
-  ;; in the too-early reference:
-  (void
-   (write-bytes
-    (zo-marshal
-     (match m
-       [(linkl-bundle t)
-        (linkl-bundle
-         (hash-set t
-                   0
-                   (let* ([l (hash-ref t 0)]
-                          [body (linkl-body l)])
-                     (struct-copy linkl l [body
-                                           (match body 
-                                             [(list a b c)
-                                              (list (match a
-                                                      [(application rator (list rand))
-                                                       (application
-                                                        rator
-                                                        (list
-                                                         (struct-copy 
-                                                          lam rand
-                                                          [body
-                                                           (match (lam-body rand)
-                                                             [(toplevel depth pos const? ready?)
-                                                              (toplevel depth pos #t #t)])])))])
-                                                    b
-                                                    c)])]))))]))
-    o2))
-
-  ;; validator should reject this at read or eval time (depending on how lazy validation is):
-  (err/rt-test (parameterize ([current-namespace (make-base-namespace)]
-                              [read-accept-compiled #t])
-                 (eval (read (open-input-bytes (get-output-bytes o2)))))
-               exn:fail:read?))
-
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; make sure sfs pass doesn't add a nested begin0
 ;; to clear the variables used in the first expression
@@ -5123,8 +5064,8 @@
                    list)))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Make sure compiler isn't too agressive for the validator
+;; Originally: make sure compiler isn't too agressive for the
-;;  in terms of typed arguments:
+;; validator in terms of typed arguments:
 
 (let ([m '(module m racket/base
             (require racket/flonum)
@@ -5140,7 +5081,7 @@
   (define o (open-output-bytes))
   (write (compile m) o)
   (parameterize ([read-accept-compiled #t])
-    ;; too-aggressive compilation produces a validator failure here
+    ;; too-aggressive compilation produced a validator failure here
     (read (open-input-bytes (get-output-bytes o)))))
 
 (when (extflonum-available?)
@@ -5158,7 +5099,7 @@
     (define o (open-output-bytes))
     (write (compile m) o)
     (parameterize ([read-accept-compiled #t])
-      ;; too-aggressive compilation produces a validator failure here
+      ;; too-aggressive compilation produced a validator failure here
       (read (open-input-bytes (get-output-bytes o))))))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -5368,7 +5309,7 @@
     (test #t toplevel-const? v)))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; The validator should understand that a structure
+;; Originally: The validator should understand that a structure
 ;; constructor always succeeds:
 
 (let ()
@@ -5473,7 +5414,7 @@
                          (define n (fxmax (length l) 1))
                          (lambda _ n))))
            o)
-    ;; Should succeed, as opposed to a validation error:
+    ;; Should succeed; once produced a validation error:
     (eval (read (open-input-bytes (get-output-bytes o))))))
 
 (parameterize ([current-namespace (make-base-namespace)]
@@ -5489,7 +5430,7 @@
                        (let ([n (fxmax (length '()) 1)])
                          (app (lambda _ (ident n))))))
            o)
-    ;; Should succeed, as opposed to a validation error:
+    ;; Should succeed; once produced a validation error:
     (eval (read (open-input-bytes (get-output-bytes o))))))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -5608,8 +5549,8 @@
                    (void)))))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Check that bytecode validator is consistent with respect to the
+;; Originally: Check that bytecode validator is consistent with
-;; optimizer and special-casing of bitwise operators:
+;; respect to the optimizer and special-casing of bitwise operators:
 
 (let ([o (open-output-bytes)])
   (write (compile
@@ -5877,8 +5818,8 @@
     (void proc proc)))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Make sure validation doesn't fail for importing a setter of a
+;; Originally: Make sure validation doesn't fail for importing a
-;; structure type that has auto fields:
+;; setter of a structure type that has auto fields:
 
 (module provides-a-mutator-for-a-struct-with-an-auto-field racket/base
   (provide foo set-foo-y!)
@@ -5955,9 +5896,8 @@
   bar)
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Check that `string-append` on a known-string argument
+;; Originally: Check that `string-append` on a known-string argument
-;; is not treated consistently by the optimzier and
+;; is not treated consistently by the optimzier and validator
-;; validator
 
 (let ([c (compile
           '(module m racket/base

pkgs/racket-test/tests/racket/stress/fuzz.rkt

@@ -15,8 +15,9 @@
         (custodian-limit-memory (current-custodian)
                                 (* 512 (expt 2 20)))
         (with-handlers ([void void])
-          (parameterize ([read-accept-compiled #t])
+          (eval (parameterize ([read-accept-compiled #t]
-            (with-input-from-bytes bs read))))))))
+                               [current-code-inspector (make-inspector)])
+                  (with-input-from-bytes bs read)))))))))
 
 (define (run-file fname seed0 #:write? [out-fname? #f])
   (define seed (or seed0 (+ 1 (random (expt 2 30)))))

racket/src/racket/src/linklet.c

@@ -323,6 +323,15 @@ static Scheme_Object *linklet_p(int argc, Scheme_Object **argv)
           : scheme_false);
 }
 
+static void check_linklet_allowed(const char *who, Scheme_Linklet *linklet)
+{
+  if (linklet->reject_eval) {
+    scheme_raise_exn(MZEXN_FAIL,
+                     "%s: cannot use linklet loaded with non-original code inspector",
+                     who);
+  }
+}
+
 void extract_import_info(const char *who, int argc, Scheme_Object **argv,
                          Scheme_Object **_import_keys, Scheme_Object **_get_import)
 {
@@ -395,6 +404,8 @@ static Scheme_Object *recompile_linklet(int argc, Scheme_Object **argv)
 
   linklet = (Scheme_Linklet *)argv[0];
 
+  check_linklet_allowed("recompile-linklet", linklet);
+
   extract_import_info("recompile-linklet", argc, argv, &import_keys, &get_import);
 
   if ((argc > 1) && SCHEME_TRUEP(argv[1]))
@@ -434,6 +445,9 @@ static Scheme_Object *eval_linklet(int argc, Scheme_Object **argv)
     scheme_wrong_contract("eval-linklet", "linklet?", 0, argc, argv);
 
   linklet = (Scheme_Linklet *)argv[0];
+
+  check_linklet_allowed("eval-linklet", linklet);
+  
   if (!linklet->jit_ready) {
     Scheme_Object *b;
     b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT);
@@ -476,6 +490,7 @@ static Scheme_Object *instantiate_linklet(int argc, Scheme_Object **argv)
     scheme_wrong_contract("instantiate-linklet", "(listof instance?)", 1, argc, argv);
 
   linklet = (Scheme_Linklet *)argv[0];
+  check_linklet_allowed("instantiate-linklet", linklet);
   num_importss = SCHEME_VEC_SIZE(linklet->importss);
   if (len != num_importss)
     scheme_contract_error("instantiate-linklet",

racket/src/racket/src/marshal.c

@@ -422,7 +422,7 @@ static Scheme_Object *vector_to_hash_tree(Scheme_Object *vec)
   return (Scheme_Object *)ht;
 }
 
-Scheme_Object *scheme_read_linklet(Scheme_Object *obj)
+Scheme_Object *scheme_read_linklet(Scheme_Object *obj, int unsafe_ok)
 {
   Scheme_Linklet *linklet = (Scheme_Linklet *)obj;
   Scheme_Object *e, *a;
@@ -503,5 +503,8 @@ Scheme_Object *scheme_read_linklet(Scheme_Object *obj)
       return_NULL();
   }
 
+  if (!unsafe_ok)
+    linklet->reject_eval = 1;
+
   return (Scheme_Object *)linklet;
 }

racket/src/racket/src/read.c

@@ -1,4 +1,4 @@
- /*
+/*
   Racket
   Copyright (c) 2004-2018 PLT Design Inc.
   Copyright (c) 1995-2001 Matthew Flatt
@@ -61,6 +61,7 @@ SHARED_OK int scheme_square_brackets_are_parens = 1;
 SHARED_OK int scheme_curly_braces_are_parens = 1;
 /* global flag set from environment variable */
 SHARED_OK static int use_perma_cache = 1;
+SHARED_OK static int validate_loaded_linklet = 0;
 
 THREAD_LOCAL_DECL(int scheme_num_read_syntax_objects = 0);
 
@@ -296,9 +297,10 @@ void scheme_init_read(Scheme_Startup_Env *env)
 
   ADD_NONCM_PRIM("datum-intern-literal", read_intern, 1, 1, env);
 
-  if (getenv("PLT_DELAY_FROM_ZO")) {
+  if (getenv("PLT_DELAY_FROM_ZO"))
     use_perma_cache = 0;
-  }
+  if (getenv("PLT_VALIDATE_LOAD"))
+    validate_loaded_linklet = 0;
 }
 
 void scheme_init_variable_references_constants()
@@ -2783,7 +2785,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
     case CPT_LINKLET:
       {
         v = read_compact(port, 1);
-        v = scheme_read_linklet(v);
+        v = scheme_read_linklet(v, port->unsafe_ok);
         if (!v) scheme_ill_formed_code(port);
         return v;
       }
@@ -2794,9 +2796,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
     case CPT_REFERENCE:
       l = read_compact_number(port);
       RANGE_CHECK(l, < EXPECTED_PRIM_COUNT);
-      if ((l >= unsafe_variable_references_start)
-          && !port->unsafe_ok)
-        unsafe_disallowed(port);
       return variable_references[l];
       break;
     case CPT_TOPLEVEL:
@@ -3979,7 +3978,9 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
           i = scheme_hash_tree_next(t, -1);
           while (i != -1) {
             scheme_hash_tree_index(t, i, &key, &val);
-            if (SAME_TYPE(SCHEME_TYPE(val), scheme_linklet_type))
+            if (validate_loaded_linklet
+                && SAME_TYPE(SCHEME_TYPE(val), scheme_linklet_type)
+                && !((Scheme_Linklet *)val)->reject_eval)
               scheme_validate_linklet(rp, (Scheme_Linklet *)val);
             i = scheme_hash_tree_next(t, i);
           }

racket/src/racket/src/schpriv.h

@@ -463,7 +463,7 @@ Scheme_Object *scheme_read_lambda(int flags, int closure_size, int num_params, i
                                   Scheme_Object *closure_map,
                                   Scheme_Object *tl_map);
 Scheme_Object *scheme_write_linklet(Scheme_Object *obj);
-Scheme_Object *scheme_read_linklet(Scheme_Object *obj);
+Scheme_Object *scheme_read_linklet(Scheme_Object *obj, int unsafe_ok);
 
 extern Scheme_Equal_Proc *scheme_type_equals;
 extern Scheme_Primary_Hash_Proc *scheme_type_hash1s;
@@ -3271,7 +3271,8 @@ struct Scheme_Linklet
   int max_let_depth;
   int need_instance_access; /* whether the instance-access toplevel is needed */
 
-  int jit_ready; /* true if the linklet is in has been prepared for the JIT */
+  char jit_ready; /* true if the linklet is in has been prepared for the JIT */
+  char reject_eval; /* true when loaded without the root inspector, for example */
 
   Scheme_Hash_Table *constants; /* holds info about the linklet's body for inlining */
 };