expander: fix problems with cross-phase persistence

pkgs/racket-doc/scribblings/reference/syntax-model.scrbl

@@ -1170,7 +1170,8 @@ and only if no module-level binding is @racket[set!]ed.
                  boolean
                  identifier
                  string
-                 bytes]
+                 bytes
+                 ()]
 ]
 
 This grammar applies after @tech{expansion}, but because a @tech{cross-phase persistent}

pkgs/racket-test/tests/racket/cross-phase.rkt

@@ -53,6 +53,17 @@
 (check-cross-phase #f '(define-values (x) (#%variable-reference)))
 (check-cross-phase #f '(define-values (x) (lambda () (#%variable-reference))))
 (check-cross-phase #f '(define-values (x) (lambda () (if #f (#%variable-reference) 10))))
+(check-cross-phase #f '(define-values (x) (lambda () (if #f 10 (#%variable-reference)))))
+(check-cross-phase #f '(define-values (x) (lambda () (if (#%variable-reference) #f 10))))
+(check-cross-phase #f '(define-values (x) (lambda () (with-continuation-mark (set! x x) 1 2))))
+(check-cross-phase #f '(define-values (x) (lambda () (with-continuation-mark 1 (set! x x) 2))))
+(check-cross-phase #f '(define-values (x) (lambda () (with-continuation-mark 1 2 (set! x x)))))
+(check-cross-phase #f '(define-values (x) (lambda () (begin 1 2 (set! x x)))))
+(check-cross-phase #f '(define-values (x) (lambda () (begin0 1 2 (set! x x)))))
+(check-cross-phase #f '(define-values (x) (lambda () (let-values ([q (set! x x)]) q))))
+(check-cross-phase #f '(define-values (x) (lambda () (let-values ([q 'ok]) (set! x x)))))
+(check-cross-phase #f '(define-values (x) (lambda () (letrec-values ([q (set! x x)]) q))))
+(check-cross-phase #f '(define-values (x) (lambda () (letrec-values ([q 'ok]) (set! x x)))))
 (check-cross-phase #f '(define-values (x) (#%variable-reference x)))
 (check-cross-phase #f '(#%require racket/base))
 (check-cross-phase #f '(define-values (x) (gensym 1)))

racket/src/expander/expand/cross-phase.rkt

@@ -15,53 +15,103 @@
 
 (provide check-cross-phase-persistent-form)
 
-(define (check-cross-phase-persistent-form bodys)
+(define (check-cross-phase-persistent-form bodys self-mpi)
-  (check-body bodys))
 
-(define (check-body bodys)
+  (define (check-body bodys)
-  (for ([body (in-list bodys)])
+    (for ([body (in-list bodys)])
-    (define p (if (expanded+parsed? body)
+      (define p (if (expanded+parsed? body)
-                  (expanded+parsed-parsed body)
+                    (expanded+parsed-parsed body)
-                  body))
+                    body))
+      (cond
+        [(parsed-define-values? p)
+         (check-expr (parsed-define-values-rhs p) (length (parsed-define-values-syms p)) p)]
+        [(or (parsed-#%declare? p)
+             (parsed-module? p)
+             (syntax? p)) ;; remaining unparsed forms, such as `#%require` and `#%provide`, are ok
+         (void)]
+        [else
+         (disallow p)])))
+
+  (define (check-expr e num-results enclosing)
     (cond
-     [(parsed-define-values? p)
+      [(parsed-lambda? e)
-      (check-expr (parsed-define-values-rhs p) (length (parsed-define-values-syms p)) p)]
+       (check-count 1 num-results enclosing)
-     [(or (parsed-#%declare? p)
+       (check-no-disallowed-expr e)]
-          (parsed-module? p)
+      [(parsed-case-lambda? e)
-          (syntax? p)) ;; remaining unparsed forms, such as `#%require` and `#%provide`, are ok
+       (check-count 1 num-results enclosing)
-      (void)]
+       (check-no-disallowed-expr e)]
-     [else
+      [(parsed-quote? e)
-      (disallow p)])))
+       (check-datum (parsed-quote-datum e) e)
+       (check-count 1 num-results enclosing)]
+      [(parsed-app? e)
+       (define rands (parsed-app-rands e))
+       (for ([rand (in-list rands)])
+         (check-expr rand 1 e))
+       (case (cross-phase-primitive-name (parsed-app-rator e))
+         [(cons list)
+          (check-count 1 num-results enclosing)]
+         [(make-struct-type)
+          (check-count 5 num-results enclosing)]
+         [(make-struct-type-property)
+          (check-count 3 num-results enclosing)]
+         [(gensym)
+          (unless (or (= 0 (length rands))
+                      (and (= 1 (length rands))
+                           (quoted-string? (car rands))))
+            (disallow e))]
+         [(string->uninterned-symbol)
+          (unless (and (= 1 (length rands))
+                       (quoted-string? (car rands)))
+            (disallow e))]
+         [else (disallow e)])]
+      [else (check-no-disallowed-expr e)]))
 
-(define (check-expr e num-results enclosing)
+  (define (check-no-disallowed-expr e)
-  (cond
+    (cond
-    [(or (parsed-lambda? e)
+      [(parsed-lambda? e)
-         (parsed-case-lambda? e))
+       (check-body-no-disallowed-expr (parsed-lambda-body e))]
-     (check-count 1 num-results enclosing)]
+      [(parsed-case-lambda? e)
-    [(parsed-quote? e)
+       (for ([clause (in-list (parsed-case-lambda-clauses e))])
-     (check-datum (parsed-quote-datum e) e)
+         (check-body-no-disallowed-expr (cadr clause)))]
-     (check-count 1 num-results enclosing)]
+      [(parsed-app? e)
-    [(parsed-app? e)
+       (check-no-disallowed-expr (parsed-app-rator e))
-     (define rands (parsed-app-rands e))
+       (for ([e (in-list (parsed-app-rands e))])
-     (for ([rand (in-list rands)])
+         (check-no-disallowed-expr e))]
-       (check-expr rand 1 e))
+      [(parsed-if? e)
-     (case (cross-phase-primitive-name (parsed-app-rator e))
+       (check-no-disallowed-expr (parsed-if-tst e))
-       [(cons list)
+       (check-no-disallowed-expr (parsed-if-thn e))
-        (check-count 1 num-results enclosing)]
+       (check-no-disallowed-expr (parsed-if-els e))]
-       [(make-struct-type)
+      [(parsed-set!? e)
-        (check-count 5 num-results enclosing)]
+       (define id (parsed-set!-id e))
-       [(make-struct-type-property)
+       (define normal-b (parsed-id-binding id))
-        (check-count 3 num-results enclosing)]
+       (when (or (not normal-b)
-       [(gensym)
+                 (parsed-top-id? id)
-        (unless (or (= 0 (length rands))
+                 (eq? (module-binding-module normal-b) self-mpi))
-                    (and (= 1 (length rands))
+         (disallow e))
-                         (quoted-string? (car rands))))
+       (check-no-disallowed-expr (parsed-set!-rhs e))]
-          (disallow e))]
+      [(parsed-with-continuation-mark? e)
-       [(string->uninterned-symbol)
+       (check-no-disallowed-expr (parsed-with-continuation-mark-key e))
-        (unless (and (= 1 (length rands))
+       (check-no-disallowed-expr (parsed-with-continuation-mark-val e))
-                     (quoted-string? (car rands)))
+       (check-no-disallowed-expr (parsed-with-continuation-mark-body e))]
-          (disallow e))]
+      [(parsed-begin? e)
-       [else (disallow e)])]))
+       (check-body-no-disallowed-expr (parsed-begin-body e))]
+      [(parsed-begin0? e)
+       (check-body-no-disallowed-expr (parsed-begin0-body e))]
+      [(parsed-let_-values? e)
+       (for ([clause (in-list (parsed-let_-values-clauses e))])
+         (check-no-disallowed-expr (cadr clause)))
+       (check-body-no-disallowed-expr (parsed-let_-values-body e))]
+      [(or (parsed-quote-syntax? e)
+           (parsed-#%variable-reference? e))
+       (disallow e)]
+      ;; Other forms have no subexpressions
+      [else (void)]))
+
+  (define (check-body-no-disallowed-expr l)
+    (for ([e (in-list l)])
+      (check-no-disallowed-expr e)))
+
+  (check-body bodys))
 
 (define (check-count is-num expected-num enclosing)
   (unless (= is-num expected-num)
@@ -69,9 +119,9 @@
 
 (define (check-datum d e)
   (cond
-   [(or (number? d) (boolean? d) (symbol? d) (string? d) (bytes? d))
+    [(or (number? d) (boolean? d) (symbol? d) (string? d) (bytes? d) (null? d))
-    (void)]
+     (void)]
-   [else (disallow e)]))
+    [else (disallow e)]))
 
 (define (quoted-string? e)
   (and (parsed-quote? e)
@@ -79,12 +129,12 @@
 
 (define (cross-phase-primitive-name id)
   (cond
-   [(parsed-id? id)
+    [(parsed-id? id)
-    (define b (parsed-id-binding id))
+     (define b (parsed-id-binding id))
-    (and (module-binding? b)
+     (and (module-binding? b)
-         (eq? runtime-module-name (module-path-index-resolve (module-binding-module b)))
+          (eq? runtime-module-name (module-path-index-resolve (module-binding-module b)))
-         (module-binding-sym b))]
+          (module-binding-sym b))]
-   [else #f]))
+    [else #f]))
 
 (define (disallow body)
   (raise-syntax-error 'module

racket/src/expander/expand/module.rkt

@@ -389,7 +389,7 @@
          (raise-syntax-error #f "cannot be cross-phase persistent due to required modules"
                              rebuild-s
                              (hash-ref declared-keywords '#:cross-phase-persistent)))
-       (check-cross-phase-persistent-form fully-expanded-bodys-except-post-submodules))
+       (check-cross-phase-persistent-form fully-expanded-bodys-except-post-submodules self))
 
      ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      ;; Pass 4: expand `module*` submodules

racket/src/expander/namespace/attach.rkt

@@ -81,7 +81,8 @@
 
         (define-values (m-ns already?)
           (cond
-           [attach-this-instance?
+           [(or attach-this-instance?
+                (module-cross-phase-persistent? m))
             (define m-ns (namespace->module-namespace src-namespace mod-name phase))
             (unless m-ns
               (raise-arguments-error who