106 lines
3.5 KiB
Racket
106 lines
3.5 KiB
Racket
#lang racket/base
|
|
|
|
(require
|
|
rackunit
|
|
racket/sandbox
|
|
racket/flonum racket/fixnum racket/unsafe/ops
|
|
racket/math
|
|
syntax/srcloc
|
|
(for-syntax
|
|
racket/base
|
|
syntax/parse))
|
|
|
|
(provide tests)
|
|
|
|
;; Test suite that makes sure that TR+opt returns the same results as Racket.
|
|
;; Historically contained bugs that we knew about, but had not fixed.
|
|
;; Now those are all fixed.
|
|
|
|
(define (mk-eval lang)
|
|
(call-with-trusted-sandbox-configuration
|
|
(λ ()
|
|
(parameterize ([sandbox-memory-limit 300])
|
|
(make-evaluator lang)))))
|
|
(define racket-eval (mk-eval 'racket))
|
|
(define tr-eval (mk-eval 'typed/racket))
|
|
|
|
(define-syntax bad-opt
|
|
(syntax-parser
|
|
[(_ exp:expr)
|
|
#`(test-case #,(format "~a" (syntax->datum #'exp))
|
|
(define r-value (racket-eval #'exp))
|
|
(define tr-value (tr-eval #'exp))
|
|
(with-check-info (['r-value r-value]
|
|
['tr-value tr-value]
|
|
['location (build-source-location-list (quote-syntax exp))])
|
|
(when (equal? r-value tr-value)
|
|
(fail-check "Known bug no longer exists."))))]))
|
|
|
|
(define-syntax good-opt
|
|
(syntax-parser
|
|
[(_ exp:expr)
|
|
#`(test-case #,(format "~a" (syntax->datum #'exp))
|
|
(define r-value (racket-eval #'exp))
|
|
(define tr-value (tr-eval #'exp))
|
|
(with-check-info (['r-value r-value]
|
|
['tr-value tr-value]
|
|
['location (build-source-location-list (quote-syntax exp))])
|
|
(when (not (equal? r-value tr-value))
|
|
(fail-check "Optimizer regression"))))]))
|
|
|
|
|
|
(define tests
|
|
(test-suite "Known bugs"
|
|
|
|
;; Arguments are converted to inexact too early
|
|
(good-opt (* (make-rectangular -inf.0 1) (* 1 1)))
|
|
(good-opt (/ -inf.0-inf.0i 8))
|
|
(good-opt (- (* -1 1 +nan.0) 1.0+1.0i))
|
|
(good-opt (- (* (/ 6 11) (/ 1.2345678f0 123456.7f0)) (make-rectangular 0.0 0.3)))
|
|
(good-opt (/ 1.0 0.0+0.0i))
|
|
(good-opt (+ 0.0+0.0i (* 1 1 +inf.0)))
|
|
(good-opt (* 1.0f-30 1.0f-30 1.0e60+1.0e60i))
|
|
|
|
;; Unary division has bad underflow
|
|
(good-opt (/ (make-rectangular 1e+100 1e-300)))
|
|
(good-opt (/ 0.5+1.7e+308i))
|
|
(good-opt (/ 1 (make-rectangular 1e+100 1e-300)))
|
|
(good-opt (/ 1 0.5+1.7e+308i))
|
|
|
|
;; Division of complex 0 should only make part of the result nan
|
|
(good-opt (/ 0.0+0.0i))
|
|
(good-opt (/ 1 0.0+0.0i))
|
|
(good-opt (/ 1.5 -3.0+9.8e-324i))
|
|
|
|
;; Division of complex infinity should only make part of the result nan
|
|
(good-opt (/ (make-rectangular 1.0 +inf.0)))
|
|
(good-opt (/ (make-rectangular +inf.0 1.0)))
|
|
(good-opt (/ 1 (make-rectangular 1.0 +inf.0)))
|
|
(good-opt (/ 1 (make-rectangular +inf.0 1.0)))
|
|
|
|
;; Exp of large real should have 0 imaginary component
|
|
(good-opt (+ (exp 1.7976931348623151e+308) 0.0+0.0i))
|
|
|
|
;; Multiplication of multiple args should keep exact semantics for exact args
|
|
(good-opt (* (expt 10 500) (expt 10 -500) 1.0+1.0i))
|
|
|
|
;; Addition of multiple args should keep exact semantics for exact args
|
|
(good-opt (+ (expt 10 501) (expt -10 501) 1.0+1.0i))
|
|
|
|
;; Magnitude should not overflow unless necessary
|
|
(good-opt (magnitude 3.0e300+4.0e300i))
|
|
|
|
;; Negation should correctly compute sign of 0.0
|
|
(good-opt (- 0.0+0.0i))
|
|
(good-opt (- 0+0i 0.0+0.0i))
|
|
|
|
;; Conjugate should correctly compute sign of 0.0
|
|
(good-opt (conjugate 0.0+0.0i))
|
|
|
|
;; Magnitude should always return positive results
|
|
(good-opt (magnitude -1.0-2i))))
|
|
|
|
(module+ main
|
|
(require rackunit/text-ui)
|
|
(void (run-tests tests)))
|