diff --git a/racket/src/expander/compile/known.rkt b/racket/src/expander/compile/known.rkt index a1938e46a1..60281cdbd9 100644 --- a/racket/src/expander/compile/known.rkt +++ b/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 diff --git a/racket/src/expander/compile/side-effect.rkt b/racket/src/expander/compile/side-effect.rkt index 6998ff167e..4f8824c938 100644 --- a/racket/src/expander/compile/side-effect.rkt +++ b/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)) - (known-property? (lookup-defn defns (correlated-e (list-ref prop+val 1))))) + '(prop:procedure prop:equal+hash)) + (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 - (known-property? o) - (not (any-side-effects? val-expr 1 #:known-defns defns)))])) + (cond + [(known-property? o) + (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) diff --git a/racket/src/expander/extract/defn-known.rkt b/racket/src/expander/extract/defn-known.rkt index 6a9c530639..1be845dec3 100644 --- a/racket/src/expander/extract/defn-known.rkt +++ b/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)) - (hash-set! seen-defns (list-ref syms 0) (known-property)) - (hash-set! seen-defns (list-ref syms 1) (known-function 1 #t)) - (hash-set! seen-defns (list-ref syms 2) (known-function 1 #t))])) + [(expr-known-property rhs) + => (lambda (vals) + (when (= (length syms) (length vals)) + (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 -(define (simple-property? e) +;; checks for properties without guards or with guards for procedures of a known arity +(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])) diff --git a/racket/src/expander/extract/known-primitive.rkt b/racket/src/expander/extract/known-primitive.rkt index 8404a20ab0..66d2ab0419 100644 --- a/racket/src/expander/extract/known-primitive.rkt +++ b/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))) diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 62d9c77e97..67e845db24 100644 --- a/racket/src/racket/src/startup.inc +++ b/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:custom-write))))" +" prop:equal+hash))))" "(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" -" temp117_0)))" -" #f)" -" #f))))))))))))))))" +" val-expr113_0" +" temp114_0))))" +"(if(known-property-of-function? o_0)" +"(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)))" diff --git a/racket/src/thread/Makefile b/racket/src/thread/Makefile index b0297cb714..561391e94c 100644 --- a/racket/src/thread/Makefile +++ b/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 ...`