suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

expander extract: Improve purity analysis for struct type properties

Browse Source 
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.
This commit is contained in:
Alexis King 2019-05-18 14:23:11 -05:00
parent aab63ad31d
commit 18e897bfb8
6 changed files with 136 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
racket/src/expander/compile/known.rkt
View File

@ -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

23
racket/src/expander/compile/side-effect.rkt
View File

@ -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)

56
racket/src/expander/extract/defn-known.rkt
View File

@ -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]))

7
racket/src/expander/extract/known-primitive.rkt
View File

@ -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)))

86
racket/src/racket/src/startup.inc
View File

@ -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)))"

15
racket/src/thread/Makefile
View File

@ -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 ...`