fix and generalize errortrace detection of always-ok functions
This commit is contained in:
parent
262931bb80
commit
6f528c7a17
|
@ -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
|
||||
|
|
77
collects/tests/errortrace/simple.rkt
Normal file
77
collects/tests/errortrace/simple.rkt
Normal 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)
|
Loading…
Reference in New Issue
Block a user