diff --git a/racket/src/cs/primitive/kernel.ss b/racket/src/cs/primitive/kernel.ss index 094f780d3b..ddbf10df7e 100644 --- a/racket/src/cs/primitive/kernel.ss +++ b/racket/src/cs/primitive/kernel.ss @@ -559,7 +559,7 @@ [number->string (known-procedure 6)] [number? (known-procedure/pure 2)] [numerator (known-procedure 2)] - [object-name (known-procedure 2)] + [object-name (known-procedure/succeeds 2)] [odd? (known-procedure 2)] [open-input-bytes (known-procedure 6)] [open-input-file (known-procedure 14)] diff --git a/racket/src/expander/compile/known.rkt b/racket/src/expander/compile/known.rkt index cadbf85364..a1938e46a1 100644 --- a/racket/src/expander/compile/known.rkt +++ b/racket/src/expander/compile/known.rkt @@ -22,7 +22,7 @@ ;; defined as a struct property with no guard (struct known-function (arity pure?) #:prefab) -;; function of known arity and maybe known pure, where +;; function of known arity and maybe known pure (at least, no side effect), where ;; pure must return 1 value (struct known-function-of-satisfying (arg-predicate-keys) #:prefab) diff --git a/racket/src/expander/compile/side-effect.rkt b/racket/src/expander/compile/side-effect.rkt index 20592623b6..6998ff167e 100644 --- a/racket/src/expander/compile/side-effect.rkt +++ b/racket/src/expander/compile/side-effect.rkt @@ -170,8 +170,20 @@ (loop (caddr (correlated->list rhs))) (loop #f))] [else - (for/fold ([locals locals]) ([id (in-list (correlated->list ids))]) - (hash-set locals (correlated-e id) #t))])))) + (define ids* (correlated->list ids)) + (cond + [(and (pair? ids*) (null? (cdr ids*))) + (hash-set locals (correlated-e (car ids*)) (infer-known rhs))] + [else + (for/fold ([locals locals]) ([id (in-list ids*)]) + (hash-set locals (correlated-e id) #t))])])))) + +(define (infer-known e) + (case (and (pair? (correlated-e e)) + (correlated-e (car (correlated-e e)))) + [(lambda case-lambda) + (known-satisfies 'procedure)] + [else #t])) ;; ---------------------------------------- diff --git a/racket/src/expander/extract/defn-known.rkt b/racket/src/expander/extract/defn-known.rkt index 7fa4ad7d97..6a9c530639 100644 --- a/racket/src/expander/extract/defn-known.rkt +++ b/racket/src/expander/extract/defn-known.rkt @@ -69,9 +69,10 @@ [`(begin (quote ,_) ,e) e] [else orig-body])) (cond - [(and (pair? body) - (eq? (car body) self-id) - ((sub1 (length body)) . > . (length args))) + [(let ([result (extract-result body)]) + (and (pair? result) + (eq? (car result) self-id) + ((sub1 (length result)) . > . (length args)))) ;; Allow a self-call as pure, as long as the number of arguments ;; grows. We'll only conclude that the function is pure overall if ;; that assumption now as justified, but we require the number of @@ -91,6 +92,11 @@ #:known-defns seen-defns #:known-locals locals))])) +(define (extract-result body) + (match body + [`(let-values ,_ ,e) (extract-result e)] + [_ body])) + (define struct-general-op-types '(struct-type constructor predicate general-accessor general-mutator)) diff --git a/racket/src/expander/extract/known-primitive.rkt b/racket/src/expander/extract/known-primitive.rkt index 1f366e0684..18f4d8cf94 100644 --- a/racket/src/expander/extract/known-primitive.rkt +++ b/racket/src/expander/extract/known-primitive.rkt @@ -16,10 +16,13 @@ (hash-set! seen-defns 'not (known-predicate 'anything)) (hash-set! seen-defns 'null? (known-predicate 'null)) (hash-set! seen-defns 'integer? (known-predicate 'integer)) + (hash-set! seen-defns 'symbol? (known-predicate 'symbol)) (hash-set! seen-defns 'list? (known-predicate 'list)) (hash-set! seen-defns 'length (known-function-of-satisfying '(list))) (hash-set! seen-defns 'arity-at-least? (known-predicate 'arity-at-least)) (hash-set! seen-defns 'arity-at-least-value (known-function-of-satisfying '(arity-at-least))) (hash-set! seen-defns 'procedure? (known-predicate 'procedure)) (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 'procedure-arity-mask (known-function-of-satisfying '(procedure))) + (hash-set! seen-defns 'object-name (known-function 1 #t)) + (hash-set! seen-defns 'procedure-rename (known-function-of-satisfying '(procedure symbol))))