expander extract: improve pure-function analysis

Improve the analysis enough to handle changes to
`make-keyword-procedure` (in 47467a1dba) and restore the Racket CS
build.

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

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)

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

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

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