expander extract: Improve purity analysis for struct type properties

The changes in aab63ad3 introduced a dependency on
racket/private/promise, which the analysis was not capable of dropping
due to the use of the `prop:force` property. This caused trouble for the
thread layer, since it introduced a reference to `error`, which is
defined in the io layer. This change adds some additional detection for
struct type properties with guards that accept procedures of particular
arities, which allows `prop:force` to be marked as pure.

Also, a typo in the thread layer’s Makefile meant globals weren’t
actually getting tracked, so this fixes that, too.

racket/src/expander/compile/known.rkt

@@ -3,6 +3,7 @@
 (provide (struct-out known-defined)
          (struct-out known-defined/delay)
          (struct-out known-property)
+         (struct-out known-property-of-function)
          (struct-out known-function)
          (struct-out known-function-of-satisfying)
          (struct-out known-predicate)
@@ -21,6 +22,10 @@
 (struct known-property () #:prefab)
 ;; defined as a struct property with no guard
 
+(struct known-property-of-function (arity) #:prefab)
+;; a struct type property with a guard that is pure as long as
+;; it is given a function with a known arity
+
 (struct known-function (arity pure?) #:prefab)
 ;; function of known arity and maybe known pure (at least, no side effect), where
 ;; pure must return 1 value

racket/src/expander/compile/side-effect.rkt

@@ -196,7 +196,7 @@
                          (lambda (v) (quoted? symbol? v))
                          (lambda (v) (is-lambda? v 2 defns))
                          (lambda (v) (ok-make-struct-type-property-super? v defns))
-                         (lambda (v) (any-side-effects? v 1 #:known-defns defns))))])
+                         (lambda (v) (not (any-side-effects? v 1 #:known-defns defns)))))])
          (pred arg))))
 
 (define (ok-make-struct-type-property-super? v defns)
@@ -209,8 +209,10 @@
                   (let ([prop+val (correlated->list prop+val)])
                     (and (eq? 'cons (correlated-e (car prop+val)))
                          (or (memq (correlated-e (list-ref prop+val 1))
-                                   '(prop:procedure prop:equal+hash prop:custom-write))
+                                   '(prop:procedure prop:equal+hash))
-                             (known-property? (lookup-defn defns (correlated-e (list-ref prop+val 1)))))
+                             (let ([o (lookup-defn defns (correlated-e (list-ref prop+val 1)))])
+                               (or (known-property? o)
+                                   (known-property-of-function? o))))
                          (not (any-side-effects? (list-ref prop+val 2) 1 #:known-defns defns))))))
            ;; All properties must be distinct
            (= (sub1 (correlated-length v))
@@ -313,27 +315,24 @@
                     (immutable-field? val-expr immutables-expr))]
     [(prop:procedure) (or (is-lambda? val-expr 1 defns)
                           (immutable-field? val-expr immutables-expr))]
-    [(prop:custom-write) (is-lambda? val-expr 3 defns)]
     [(prop:equal+hash)
      (define l (correlated->list val-expr))
      (and (eq? 'list (car l))
           (is-lambda? (list-ref l 1) 3 defns)
           (is-lambda? (list-ref l 2) 2 defns)
           (is-lambda? (list-ref l 3) 2 defns))]
-    [(prop:method-arity-error prop:incomplete-arity)
-     (not (any-side-effects? val-expr 1 #:known-defns defns))]
-    [(prop:impersonator-of)
-     (is-lambda? val-expr 1 defns)]
-    [(prop:arity-string) (is-lambda? val-expr 1 defns)]
     [(prop:checked-procedure)
      (and (quoted? false? super-expr)
           ;; checking that we have at least 2 fields
           (immutable-field? 1 immutables-expr))]
     [else
      (define o (lookup-defn defns prop-name))
-     (and o
+     (cond
-          (known-property? o)
+       [(known-property? o)
-          (not (any-side-effects? val-expr 1 #:known-defns defns)))]))
+        (not (any-side-effects? val-expr 1 #:known-defns defns))]
+       [(known-property-of-function? o)
+        (is-lambda? val-expr (known-property-of-function-arity o) defns)]
+       [else #f])]))
 
 ;; is expr a procedure of specified arity? (arity irrelevant if #f)
 (define (is-lambda? expr arity defns)

racket/src/expander/extract/defn-known.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require racket/match
+(require racket/list
+         racket/match
          "../run/status.rkt"
          "../compile/side-effect.rkt"
          "../compile/known.rkt")
@@ -37,10 +38,12 @@
                                             (struct-shape-num-parent-fields shape))]
                                         [else (struct-shape-num-fields shape)]))))))]
    ;; Recognize structure-property declaration
-   [(and (= 3 (length syms)) (simple-property? rhs))
+   [(expr-known-property rhs)
-    (hash-set! seen-defns (list-ref syms 0) (known-property))
+    => (lambda (vals)
-    (hash-set! seen-defns (list-ref syms 1) (known-function 1 #t))
+         (when (= (length syms) (length vals))
-    (hash-set! seen-defns (list-ref syms 2) (known-function 1 #t))]))
+           (for ([sym (in-list syms)]
+                 [val (in-list vals)])
+             (hash-set! seen-defns sym val))))]))
 
 (define (lambda-arity e)
   (match e
@@ -139,8 +142,45 @@
                                         'mutator)))))]
       [_ #f])))
 
-;; checks for properties without guards
+;; checks for properties without guards or with guards for procedures of a known arity
-(define (simple-property? e)
+(define (expr-known-property e)
   (match e
-    [`(make-struct-type-property ,_) #t]
+    [`(make-struct-type-property ,name)
+     (expr-known-property `(make-struct-type-property ,name #f))]
+    [`(make-struct-type-property ,name ,guard)
+     (expr-known-property `(make-struct-type-property ,name ,guard '()))]
+    [`(make-struct-type-property ,name ,guard ,supers)
+     (expr-known-property `(make-struct-type-property ,name ,guard ,supers #f))]
+    [`(make-struct-type-property ,_ ,guard ,(or ''() 'null) ,_)
+     (define prop (cond
+                    [(not guard)
+                     (known-property)]
+                    [(property-function-guard-arity guard)
+                     => known-property-of-function]
+                    [else #f]))
+     (and prop (list prop
+                     (known-function 1 #t)
+                     (known-function 1 #f)))]
+    [`(let-values ([(,xs ...) ,mstp])
+        (values ,vs ...))
+     (define vals (expr-known-property mstp))
+     (and vals
+          (= (length xs) (length vals))
+          (for/and ([v (in-list vs)])
+            (memq v xs))
+          (for/list ([v (in-list vs)])
+            (list-ref vals (index-of xs v eq?))))]
+    [_ #f]))
+
+(define (property-function-guard-arity e)
+  (match e
+    [`(lambda (,v ,_)
+        (begin
+          (if (if (procedure? ,v)
+                  (procedure-arity-includes? ,v ,(? exact-nonnegative-integer? arity))
+                  #f)
+              (void)
+              ,_)
+          ,v))
+     arity]
     [_ #f]))

racket/src/expander/extract/known-primitive.rkt

@@ -25,4 +25,9 @@
   (hash-set! seen-defns 'procedure-arity (known-function-of-satisfying '(procedure)))
   (hash-set! seen-defns 'procedure-arity-mask (known-function-of-satisfying '(procedure)))
   (hash-set! seen-defns 'object-name (known-function 1 #t)) ; assuming no `prop:object-name`
-  (hash-set! seen-defns 'procedure-rename (known-function-of-satisfying '(procedure symbol))))
+  (hash-set! seen-defns 'procedure-rename (known-function-of-satisfying '(procedure symbol)))
+  (hash-set! seen-defns 'prop:custom-write (known-property-of-function 3))
+  (hash-set! seen-defns 'prop:method-arity-error (known-property))
+  (hash-set! seen-defns 'prop:incomplete-arity (known-property))
+  (hash-set! seen-defns 'prop:impersonator-of (known-property-of-function 1))
+  (hash-set! seen-defns 'prop:arity-string (known-property-of-function 1)))

racket/src/racket/src/startup.inc

@@ -33751,7 +33751,28 @@ static const char *startup_source =
 "(let-values()(make-struct-type 'known-property #f 0 0 #f null 'prefab #f '() #f 'known-property)))))"
 "(values struct:_0 make-_0 ?_0)))"
 "(define-values"
-"(struct:known-function known-function4.1 known-function? known-function-arity known-function-pure?)"
+"(struct:known-property-of-function"
+" known-property-of-function4.1"
+" known-property-of-function?"
+" known-property-of-function-arity)"
+"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)"
+"(let-values()"
+"(let-values()"
+"(make-struct-type"
+" 'known-property-of-function"
+" #f"
+" 1"
+" 0"
+" #f"
+" null"
+" 'prefab"
+" #f"
+" '(0)"
+" #f"
+" 'known-property-of-function)))))"
+"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'arity))))"
+"(define-values"
+"(struct:known-function known-function5.1 known-function? known-function-arity known-function-pure?)"
 "(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)"
 "(let-values()"
 "(let-values()"
@@ -33764,7 +33785,7 @@ static const char *startup_source =
 "(make-struct-field-accessor -ref_0 1 'pure?))))"
 "(define-values"
 "(struct:known-function-of-satisfying"
-" known-function-of-satisfying5.1"
+" known-function-of-satisfying6.1"
 " known-function-of-satisfying?"
 " known-function-of-satisfying-arg-predicate-keys)"
 "(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)"
@@ -33784,21 +33805,21 @@ static const char *startup_source =
 " 'known-function-of-satisfying)))))"
 "(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'arg-predicate-keys))))"
 "(define-values"
-"(struct:known-predicate known-predicate6.1 known-predicate? known-predicate-key)"
+"(struct:known-predicate known-predicate7.1 known-predicate? known-predicate-key)"
 "(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)"
 "(let-values()"
 "(let-values()"
 "(make-struct-type 'known-predicate #f 1 0 #f null 'prefab #f '(0) #f 'known-predicate)))))"
 "(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'key))))"
 "(define-values"
-"(struct:known-satisfies known-satisfies7.1 known-satisfies? known-satisfies-predicate-key)"
+"(struct:known-satisfies known-satisfies8.1 known-satisfies? known-satisfies-predicate-key)"
 "(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)"
 "(let-values()"
 "(let-values()"
 "(make-struct-type 'known-satisfies #f 1 0 #f null 'prefab #f '(0) #f 'known-satisfies)))))"
 "(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'predicate-key))))"
 "(define-values"
-"(struct:known-struct-op known-struct-op8.1 known-struct-op? known-struct-op-type known-struct-op-field-count)"
+"(struct:known-struct-op known-struct-op9.1 known-struct-op? known-struct-op-type known-struct-op-field-count)"
 "(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)"
 "(let-values()"
 "(let-values()"
@@ -35494,7 +35515,7 @@ static const char *startup_source =
 "(hash-set"
 " locals_1"
 " id:arg71_0"
-"(known-satisfies7.1"
+"(known-satisfies8.1"
 "(known-predicate-key"
 " d_0)))))"
 "(loop_0 els73_0 locals_1)"
@@ -35808,7 +35829,7 @@ static const char *startup_source =
 " locals_4"
 "(correlated-e"
 " id_0)"
-"(known-struct-op8.1"
+"(known-struct-op9.1"
 " type_0"
 " field-count_0)))))"
 "(values"
@@ -35914,7 +35935,7 @@ static const char *startup_source =
 "(begin"
 "(let-values(((tmp_0)(if(pair?(correlated-e e_0))(correlated-e(car(correlated-e e_0))) #f)))"
 "(if(if(equal? tmp_0 'lambda) #t(equal? tmp_0 'case-lambda))"
-"(let-values()(known-satisfies7.1 'procedure))"
+"(let-values()(known-satisfies8.1 'procedure))"
 "(let-values() #t))))))"
 "(define-values"
 "(ok-make-struct-type-property?)"
@@ -35929,8 +35950,9 @@ static const char *startup_source =
 "(lambda(v_0)(is-lambda? v_0 2 defns_0))"
 "(lambda(v_0)(ok-make-struct-type-property-super? v_0 defns_0))"
 "(lambda(v_0)"
+"(not"
 "(let-values(((v103_0) v_0)((temp104_0) 1)((defns105_0) defns_0))"
-"(any-side-effects?9.1 defns105_0 unsafe-undefined unsafe-undefined v103_0 temp104_0))))))"
+"(any-side-effects?9.1 defns105_0 unsafe-undefined unsafe-undefined v103_0 temp104_0)))))))"
 "(begin"
 "(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_0)))"
 "(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_1)))"
@@ -36006,17 +36028,23 @@ static const char *startup_source =
 " prop+val_1"
 " 1))"
 " '(prop:procedure"
-" prop:equal+hash"
+" prop:equal+hash))))"
-" prop:custom-write))))"
 "(if or-part_2"
 " or-part_2"
-"(known-property?"
+"(let-values(((o_0)"
 "(lookup-defn"
 " defns_0"
 "(correlated-e"
 "(list-ref"
 " prop+val_1"
-" 1))))))"
+" 1)))))"
+"(let-values(((or-part_3)"
+"(known-property?"
+" o_0)))"
+"(if or-part_3"
+" or-part_3"
+"(known-property-of-function?"
+" o_0))))))"
 "(not"
 "(let-values(((temp106_0)"
 "(list-ref"
@@ -36316,8 +36344,6 @@ static const char *startup_source =
 "(let-values()"
 "(let-values(((or-part_0)(is-lambda? val-expr_0 1 defns_0)))"
 "(if or-part_0 or-part_0(immutable-field? val-expr_0 immutables-expr_0))))"
-"(if(equal? tmp_0 'prop:custom-write)"
-"(let-values()(is-lambda? val-expr_0 3 defns_0))"
 "(if(equal? tmp_0 'prop:equal+hash)"
 "(let-values()"
 "(let-values(((l_0)(correlated->list val-expr_0)))"
@@ -36326,31 +36352,23 @@ static const char *startup_source =
 "(if(is-lambda?(list-ref l_0 2) 2 defns_0)(is-lambda?(list-ref l_0 3) 2 defns_0) #f)"
 " #f)"
 " #f)))"
-"(if(if(equal? tmp_0 'prop:method-arity-error) #t(equal? tmp_0 'prop:incomplete-arity))"
-"(let-values()"
-"(not"
-"(let-values(((val-expr113_0) val-expr_0)((temp114_0) 1)((defns115_0) defns_0))"
-"(any-side-effects?9.1 defns115_0 unsafe-undefined unsafe-undefined val-expr113_0 temp114_0))))"
-"(if(equal? tmp_0 'prop:impersonator-of)"
-"(let-values()(is-lambda? val-expr_0 1 defns_0))"
-"(if(equal? tmp_0 'prop:arity-string)"
-"(let-values()(is-lambda? val-expr_0 1 defns_0))"
 "(if(equal? tmp_0 'prop:checked-procedure)"
 "(let-values()(if(quoted? false? super-expr_0)(immutable-field? 1 immutables-expr_0) #f))"
 "(let-values()"
 "(let-values(((o_0)(lookup-defn defns_0 prop-name_0)))"
-"(if o_0"
 "(if(known-property? o_0)"
+"(let-values()"
 "(not"
-"(let-values(((val-expr116_0) val-expr_0)((temp117_0) 1)((defns118_0) defns_0))"
+"(let-values(((val-expr113_0) val-expr_0)((temp114_0) 1)((defns115_0) defns_0))"
 "(any-side-effects?9.1"
-" defns118_0"
+" defns115_0"
 " unsafe-undefined"
 " unsafe-undefined"
-" val-expr116_0"
+" val-expr113_0"
-" temp117_0)))"
+" temp114_0))))"
-" #f)"
+"(if(known-property-of-function? o_0)"
-" #f))))))))))))))))"
+"(let-values()(is-lambda? val-expr_0(known-property-of-function-arity o_0) defns_0))"
+"(let-values() #f))))))))))))))"
 "(define-values"
 "(is-lambda?)"
 "(lambda(expr_0 arity_0 defns_0)"
@@ -42392,7 +42410,9 @@ static const char *startup_source =
 " 'for-loop"
 "(if(pair? lst_1)"
 "(let-values(((rr_0)(unsafe-car lst_1))((rest_0)(unsafe-cdr lst_1)))"
-"(let-values(((post-guard-var_0)(lambda()(begin 'post-guard-var #t))))"
+"(let-values()"
+"(let-values(((next-k-proc_0)"
+"(lambda()(begin 'next-k-proc(for-loop_0 rest_0)))))"
 "(let-values()"
 "(if(reference-record-all-referenced? rr_0)"
 "(values)"
@@ -42403,7 +42423,7 @@ static const char *startup_source =
 "(let-values()"
 "(set-reference-record-all-referenced?! rr_0 #t))"
 "(values)))))"
-"(if(post-guard-var_0)(for-loop_0 rest_0)(values))))))))"
+"(next-k-proc_0))))))))"
 "(values))))))"
 " for-loop_0)"
 " lst_0)))"

racket/src/thread/Makefile

@@ -12,6 +12,9 @@ thread-src:
 # a direct use of the primitive name:
 DIRECT = ++direct pthread
 
+# Make sure that the flattened form doesn't use `error`:
+DISALLOW = ++disallow error
+
 # Enable the sanity check for global state (to be avoided in
 # favor of place-local state), but declare some initialized-once
 # global state to be ok:
@@ -20,7 +23,15 @@ GLOBALS = --no-global \
           ++global-ok sync-on-channel \
           ++global-ok post-shutdown-action \
           ++global-ok get-subprocesses-time \
-          ++global-ok force-atomic-timeout-callback
+          ++global-ok force-atomic-timeout-callback \
+          ++global-ok pre-poll-callbacks \
+          ++global-ok queued-shutdowns \
+          ++global-ok place-ensure-wakeup! \
+          ++global-ok place-wakeup-initial \
+          ++global-ok place-wakeup \
+          ++global-ok compute-memory-sizes \
+          ++global-ok check-place-activity \
+          ++global-ok make-place-ports+fds
 
 GENERATE_ARGS = -t main.rkt --submod main \
                 --check-depends $(BUILDDIR)compiled/thread-dep.rktd \
@@ -28,7 +39,7 @@ GENERATE_ARGS = -t main.rkt --submod main \
                 --depends $(BUILDDIR)compiled/thread-dep.rktd \
                 --makefile-depends $(DEPENDSDIR)compiled/thread.rktl $(BUILDDIR)compiled/thread.d \
                 -c $(BUILDDIR)compiled/cache-src \
-                -k ../.. -s -x $(DIRECT) $(GLOBAL) \
+                -k ../.. -s -x $(DIRECT) $(DISALLOW) $(GLOBALS) \
                 -o $(BUILDDIR)compiled/thread.rktl
 
 # This target can be used with a `RACKET` that builds via `-l- setup --chain ...`