fix and generalize errortrace detection of always-ok functions

This commit is contained in:
Matthew Flatt 2012-01-13 09:59:26 -07:00
parent 262931bb80
commit 6f528c7a17
2 changed files with 99 additions and 7 deletions

View File

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

View File

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