From 535fa168131a764649bd4043105f5d793dafb5e1 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 8 Dec 2020 10:28:19 -0700
Subject: [PATCH] Chez Scheme: make inlining see through
 `make-wrapper-procedure`

For example,

 (let ([f (make-wrapper-procedure (lambda (x) x) 2 'metadata)])
   (f 5))

optimizes to just 5.
---
 racket/src/ChezScheme/mats/cp0.ms | 62 +++++++++++++++++++++++++++++++
 racket/src/ChezScheme/s/cp0.ss    | 36 ++++++++++++++++++
 2 files changed, 98 insertions(+)

diff --git a/racket/src/ChezScheme/mats/cp0.ms b/racket/src/ChezScheme/mats/cp0.ms
index 3da3b9642c..d15989cbc4 100644
--- a/racket/src/ChezScheme/mats/cp0.ms
+++ b/racket/src/ChezScheme/mats/cp0.ms
@@ -3141,3 +3141,65 @@
                '(#t #f)))
 
 )
+
+(mat make-wrapper-procedure
+  (equivalent-expansion?
+   (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+     (expand/optimize '((make-wrapper-procedure (lambda (x) x) 2 'ok) 5)))
+   5)
+  (equivalent-expansion?
+   (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+     (expand/optimize '((make-arity-wrapper-procedure (lambda (x) x) 2 'ok) 5)))
+   5)
+
+  (equivalent-expansion?
+   (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+     (expand/optimize '((make-wrapper-procedure (lambda (x) x) 2 (g)) 5)))
+   (if (= 3 (optimize-level))
+       '(begin (g) 5)
+       '(begin (#3%$value (g)) 5)))
+  (equivalent-expansion?
+   (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+     (expand/optimize '((make-arity-wrapper-procedure (lambda (x) x) 2 (g)) 5)))
+   (if (= 3 (optimize-level))
+       '(begin (g) 5)
+       '(begin (#3%$value (g)) 5)))
+
+  (equivalent-expansion?
+   (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+     (expand/optimize '(let ([f (make-wrapper-procedure (lambda (x) x) 2 (g))]) (f 5))))
+   (if (= 3 (optimize-level))
+       '(begin (g) 5)
+       '(begin (#3%$value (g)) 5)))
+  (equivalent-expansion?
+   (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+     (expand/optimize '(let ([f (make-arity-wrapper-procedure (lambda (x) x) 2 (g))]) (f 5))))
+   (if (= 3 (optimize-level))
+       '(begin (g) 5)
+       '(begin (#3%$value (g)) 5)))
+
+  (equivalent-expansion?
+   (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+     (expand/optimize '(let ([g (let ([f (make-wrapper-procedure (lambda (x) x) 2 (g))]) f)]) (g 5))))
+   (if (= 3 (optimize-level))
+       '(begin (g) 5)
+       '(begin (#3%$value (g)) 5)))
+
+  (not
+   (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(let ([f (#2%make-wrapper-procedure (lambda (x) x) 2 (g))]) (#2%list (g f) (f 5)))))
+    '(#2%list (g (#2%make-wrapper-procedure (lambda (x) x) 2 (g))) 5)))
+  (not
+   (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(let ([f (#2%make-arity-wrapper-procedure (lambda (x) x) 2 (g))]) (#2%list (g f) (f 5)))))
+    '(#2%list (g (#2%make-arity-wrapper-procedure (lambda (x) x) 2 (g))) 5)))
+
+  (not
+   (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      ;; arity mismatch:
+      (expand/optimize '((make-arity-wrapper-procedure (lambda (x) x) 1 'ok) 5)))
+    5))
+  )
diff --git a/racket/src/ChezScheme/s/cp0.ss b/racket/src/ChezScheme/s/cp0.ss
index a75532f0be..d1c03e17c9 100644
--- a/racket/src/ChezScheme/s/cp0.ss
+++ b/racket/src/ChezScheme/s/cp0.ss
@@ -5117,6 +5117,42 @@
                                                         (preinfo-call-mask))
                                                     (preinfo-call-mask no-inline)))])
          (cp0 `(call ,preinfo ,e ,e* ...) ctxt env sc wd name moi))]
+      [(call ,preinfo ,pr ,e1 ,e2 ,e3)
+       ;; remove wrapper for immediately applied
+       (guard (app? ctxt)
+              (or (eq? (primref-name pr) 'make-wrapper-procedure)
+                  (eq? (primref-name pr) 'make-arity-wrapper-procedure))
+              (nanopass-case (Lsrc Expr) e2
+                [(quote ,d)
+                 (and (exact? d) (integer? d)
+                      (bitwise-bit-set? d (length (app-opnds ctxt))))]
+                [else #f]))
+       (let ([e1 (cp0 e1 ctxt env sc wd name moi)])
+         (if (app-used ctxt)
+             (make-1seq ctxt (make-seq* 'ignored (list e2 e3)) e1)
+             (let ([e2 (cp0 e2 'value env sc wd #f moi)]
+                   [e3 (cp0 e2 'value env sc wd #f moi)])
+               `(call ,preinfo ,pr ,e1 ,e2 ,e3))))]
+      [(call ,preinfo ,pr ,e1 ,e2 ,e3)
+       ;; discard unused, non-error wrapper construction
+       (guard (or (eq? (primref-name pr) 'make-wrapper-procedure)
+                  (eq? (primref-name pr) 'make-arity-wrapper-procedure))
+              (unused-value-context? ctxt))
+       (let ([e1 (cp0 e1 'value env sc wd name moi)]
+             [e2 (cp0 e2 'value env sc wd #f moi)]
+             [e3 (cp0 e3 'value env sc wd #f moi)])
+         (cond
+           [(nanopass-case (Lsrc Expr) e2
+              [(quote ,d)
+               (and (exact? d) (integer? d)
+                    (nanopass-case (Lsrc Expr) e1
+                      [(case-lambda ,preinfo (clause (,x* ...) ,interface ,body) ...) #t]
+                      [else #f]))]
+              [else #f])
+            ;; can drop call
+            (make-1seq* 'ignored (list e1 e3))]
+           [else
+            `(call ,preinfo ,pr ,e1 ,e2 ,e3)]))]
       [(call ,preinfo ,e ,e* ...)
        (let ()
          (define lift-let