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

schemify: adjust simple? for multiple returns

Browse Source 
The check for whether an expression is "simple" at the schemify layer
didn't take into account the expected arity.
This commit is contained in:
Matthew Flatt 2019-11-29 14:20:45 -07:00
parent 430760ddb4
commit fa2ef64adb
4 changed files with 73 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
racket/src/cs/primitive/kernel.ss
View File

@ -685,7 +685,7 @@
[pseudo-random-generator-vector? (known-procedure/no-prompt 2)]
[pseudo-random-generator? (known-procedure/pure/folding 2)]
[quotient (known-procedure/folding 4)]
[quotient/remainder (known-procedure/no-prompt 4)]
[quotient/remainder (known-procedure 4)] ; no `no-prompt` due to multiple return values
[raise (known-procedure 6)]
[raise-argument-error (known-procedure -8)]
[raise-arguments-error (known-procedure -4)]

3
racket/src/schemify/mutated.rkt
View File

@ -143,7 +143,8 @@
(find-mutated! rhs (unwrap-list ids))
(define new-maybe-cc? (or maybe-cc?
(not (simple? rhs prim-knowns knowns imports mutated simples
#:pure? #f))))
#:pure? #f
#:result-arity (length ids)))))
;; Each `id` in `ids` is now ready (but might also hold a delay):
(for ([id (in-wrap-list ids)])
(let ([u-id (unwrap id)])

8
racket/src/schemify/schemify.rkt
View File

@ -343,7 +343,8 @@
(finish-wrapped-definition (list id) rhs)])]
[`(define-values ,ids ,rhs)
(cond
[(simple? #:pure? #f rhs prim-knowns knowns imports mutated simples)
[(simple? #:pure? #f rhs prim-knowns knowns imports mutated simples
#:result-arity (length ids))
(match rhs
[`(values ,rhss ...)
;; Flatten `(define-values (id ...) (values rhs ...))` to
@ -378,7 +379,8 @@
(finish-definition ids (append set-vars accum-exprs) null)]
[`,_
(cond
[(simple? #:pure? #f schemified prim-knowns knowns imports mutated simples)
[(simple? #:pure? #f schemified prim-knowns knowns imports mutated simples
#:result-arity #f)
(loop (cdr l) mut-l (cons schemified accum-exprs) accum-ids knowns)]
[else
;; In case `schemified` triggers an error, sync exported variables
@ -581,7 +583,7 @@
(authentic-valued? key knowns prim-knowns imports mutated))
(cond
[(and authentic-key?
(simple? s-body prim-knowns knowns imports mutated simples))
(simple? s-body prim-knowns knowns imports mutated simples #:result-arity #f))
`(begin ,(ensure-single-valued s-key knowns prim-knowns imports mutated)
,(ensure-single-valued s-val knowns prim-knowns imports mutated)
,s-body)]

102
racket/src/schemify/simple.rkt
View File

@ -12,54 +12,79 @@
;; of evaluation isn't detectable. This function receives both
;; schemified and non-schemified expressions.
(define (simple? e prim-knowns knowns imports mutated simples
#:pure? [pure? #t])
(let simple? ([e e])
#:pure? [pure? #t]
#:result-arity [result-arity 1])
(let simple? ([e e] [result-arity result-arity])
(define-syntax-rule (cached expr)
(let* ([c (hash-ref simples e '(unknown . unknown))]
[r (if pure? (car c) (cdr c))])
(if (eq? 'unknown r)
(let* ([c (hash-ref simples e #(unknown unknown 1))]
[r (vector-ref c (if pure? 0 1))]
[arity-match? (eqv? result-arity (vector-ref c 2))])
(if (or (eq? 'unknown r)
(not arity-match?))
(let ([r expr])
(hash-set! simples e (if pure? (cons r (cdr c)) (cons (car c) r)))
(hash-set! simples e (if pure?
(vector r
(if arity-match? (vector-ref c 1) 'unknown)
result-arity)
(vector (if arity-match? (vector-ref c 0) 'unknown)
r
result-arity)))
r)
r)))
(define (returns n)
(or (not result-arity)
(eqv? n result-arity)))
(match e
[`(lambda . ,_) #t]
[`(case-lambda . ,_) #t]
[`(quote . ,_) #t]
[`(#%variable-reference . ,_) #t]
[`(let-values ([,_ ,rhss] ...) ,body)
[`(lambda . ,_) (returns 1)]
[`(case-lambda . ,_) (returns 1)]
[`(quote . ,_) (returns 1)]
[`(#%variable-reference . ,_) (returns 1)]
[`(let-values ([,idss ,rhss] ...) ,body)
(cached
(and (for/and ([rhs (in-list rhss)])
(simple? rhs))
(simple? body)))]
(and (for/and ([ids (in-list idss)]
[rhs (in-list rhss)])
(simple? rhs (length ids)))
(simple? body result-arity)))]
[`(let ([,_ ,rhss] ...) ,body)
(cached
(and (for/and ([rhs (in-list rhss)])
(simple? rhs))
(simple? body)))]
(simple? rhs 1))
(simple? body result-arity)))]
[`(letrec-values ([(,idss ...) ,rhss] ...) ,body)
(cached
(and (for/and ([rhs (in-list rhss)])
(simple? rhs))
(simple? body)))]
(and (for/and ([ids (in-list idss)]
[rhs (in-list rhss)])
(simple? rhs (length ids)))
(simple? body result-arity)))]
[`(letrec* ([,ids ,rhss] ...) ,body)
(cached
(and (for/and ([rhs (in-list rhss)])
(simple? rhs))
(simple? body)))]
(simple? rhs 1))
(simple? body result-arity)))]
[`(begin ,es ...)
#:guard (not pure?)
(cached
(for/and ([e (in-list es)])
(simple? e)))]
(let loop ([es es])
(cond
[(null? (cdr es))
(simple? (car es) result-arity)]
[else
(and (simple? (car es) #f)
(loop (cdr es)))])))]
[`(begin0 ,e0 ,es ...)
(cached
(and (simple? e0 result-arity)
(for/and ([e (in-list es)])
(simple? e #f))))]
[`(set! ,_ ,e)
#:guard (not pure?)
(simple? e)]
(simple? e 1)
(returns 1)]
[`(values ,es ...)
#:guard (not pure?)
(cached
(for/and ([e (in-list es)])
(simple? e)))]
(and (returns (length es))
(for/and ([e (in-list es)])
(simple? e 1))))]
[`(,proc . ,args)
(cached
(let ([proc (unwrap proc)])
@ -67,21 +92,24 @@
(let ([v (or (hash-ref-either knowns imports proc)
(hash-ref prim-knowns proc #f))])
(and (if pure?
(known-procedure/pure? v)
(known-procedure/no-prompt? v))
(and (known-procedure/pure? v)
(returns 1))
(and (known-procedure/no-prompt? v)
(eqv? result-arity #f)))
(bitwise-bit-set? (known-procedure-arity-mask v) (length args))))
(simple-mutated-state? (hash-ref mutated proc #f))
(for/and ([arg (in-list args)])
(simple? arg)))))]
(simple? arg 1)))))]
[`,_
(let ([e (unwrap e)])
(or (and (symbol? e)
(simple-mutated-state? (hash-ref mutated e #f)))
(integer? e)
(boolean? e)
(string? e)
(bytes? e)
(regexp? e)))])))
(and (returns 1)
(or (and (symbol? e)
(simple-mutated-state? (hash-ref mutated e #f)))
(integer? e)
(boolean? e)
(string? e)
(bytes? e)
(regexp? e))))])))
(define (simple/can-copy? e prim-knowns knowns imports mutated)
(match e