From 6f528c7a1737ba64776b4833bbecc35cde25e3b8 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 13 Jan 2012 09:59:26 -0700
Subject: [PATCH] fix and generalize errortrace detection of always-ok
 functions

---
 collects/errortrace/stacktrace.rkt   | 29 ++++++++---
 collects/tests/errortrace/simple.rkt | 77 ++++++++++++++++++++++++++++
 2 files changed, 99 insertions(+), 7 deletions(-)
 create mode 100644 collects/tests/errortrace/simple.rkt

diff --git a/collects/errortrace/stacktrace.rkt b/collects/errortrace/stacktrace.rkt
index a413d51315..78ed326760 100644
--- a/collects/errortrace/stacktrace.rkt
+++ b/collects/errortrace/stacktrace.rkt
@@ -26,6 +26,9 @@
    st-mark-source
    st-mark-bindings))
 
+(define base-phase
+  (variable-reference->module-base-phase (#%variable-reference)))
+
 (define-unit stacktrace@
   (import stacktrace-imports^)
   (export stacktrace^)
@@ -543,14 +546,26 @@
            [(stx-null? (syntax body))
             ;; It's a null:
             expr]
-           [(syntax-case* expr (#%plain-app void)
-                          (if (positive? phase)
-                              free-transformer-identifier=?
-                              free-identifier=?)
-              [(#%plain-app void) #t]
+           ;; check for functions that are known to always succeed,
+           ;; in which case we can skip the wrapper:
+           [(syntax-case* expr (void cons mcons list list* vector box
+                                     vector-immutable)
+                          (lambda (a b)
+                            (free-identifier=? a b phase base-phase))
+              [(_ void . _) #t]
+              [(_ cons _ _) #t]
+              [(_ mcons _ _) #t]
+              [(_ list . _) #t]
+              [(_ list* _ . _) #t]
+              [(_ vector . _) #t]
+              [(_ vector-immutable . _) #t]
+              [(_ box _) #t]
               [_else #f])
-            ;; It's (void):
-            expr]
+            (rearm
+             expr
+             (annotate-seq disarmed-expr (syntax body)
+                           annotate phase))]
+           ;; general case:
            [else
             (with-mrk* expr (rearm
                              expr
diff --git a/collects/tests/errortrace/simple.rkt b/collects/tests/errortrace/simple.rkt
new file mode 100644
index 0000000000..ef819f62d3
--- /dev/null
+++ b/collects/tests/errortrace/simple.rkt
@@ -0,0 +1,77 @@
+#lang racket/base
+(require syntax/datum
+         compiler/zo-parse
+         compiler/decompile)
+
+;; Check some transformations directly. We check by compiling, which
+;; means that we can check that cerain optimizations still apply, but
+;; beware of the extra layer.
+
+(define et-ns (make-base-namespace))
+(parameterize ([current-namespace et-ns])
+  (dynamic-require 'errortrace #f))
+
+(define plain-ns (make-base-namespace))
+
+(define (do-expand s wrap ns)
+  (parameterize ([current-namespace ns])
+    (define o (open-output-bytes))
+    (write (compile (wrap s)) o)
+    (decompile (zo-parse (open-input-bytes (get-output-bytes o))))))
+
+(define orig (read-syntax 'orig (open-input-string "x")))
+(define (to-original d)
+  (namespace-syntax-introduce (datum->syntax #f d orig orig)))
+
+(define (normalize d)
+  (datum-case d (with-continuation-mark)
+    [(with-continuation-mark _ _ expr) `(with-continuation-mark 
+                                            ?
+                                            ?
+                                          ,(normalize (datum expr)))]
+    [(a ...) (map normalize (datum (a ...)))]
+    [else d]))
+
+;; Check that `et' with annotations is like `plain', modulo
+;; actual `wcm' keys and value expression. If `alt' is supplied,
+;; make sure that it is *different* than `et'.
+(define (check et plain [alt #f])
+  (define et-exp (datum-case (do-expand et to-original et-ns) (begin)
+                   [(begin (begin _ expr)) (normalize (datum expr))]))
+  (define plain-exp (datum-case (do-expand plain values plain-ns) (begin)
+                      [(begin expr) (normalize (datum expr))]))
+  (define alt-exp (datum-case (do-expand alt values plain-ns) (begin)
+                    [(begin expr) (normalize (datum expr))]))
+  (unless (equal? et-exp plain-exp)
+    (error 'errortrace-test "failed: ~s versus ~s" et-exp plain-exp))
+  (when alt
+    (when (equal? et-exp alt-exp)
+      (error 'errortrace-test "failed (shouldn't match): ~s versus ~s" et-exp plain-exp))))
+
+;; Check that known functions like `void' are not wrapped
+;; when applied to the right number of arguments, but other
+;; functions are:
+(check '(void)
+       '(void))
+(check '(void 1 2 3)
+       '(void 1 2 3))
+(check '(void free)
+       '(void (with-continuation-mark ? ? free)))
+(check '(cons)
+       '(with-continuation-mark ? ? (cons))
+       '(cons))
+(check '(cons 1 2)
+       '(cons 1 2))
+(check '(list)
+       '(list))
+(check '(list*)
+       '(with-continuation-mark ? ? (list*)))
+(check '(car (list))
+       '(with-continuation-mark ? ? (car (list)))
+       '(car (list)))
+
+;; Wrappers in these cases shouldn't get in the way of optimizations:
+(check '(+ 1 3)
+       '4)
+(check '(car (list 1))
+       '1)