Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
408 lines (367 sloc) 14.4 KB
;; ***** BEGIN LICENSE BLOCK *****
;; Roadsend PHP Compiler
;; Copyright (C) 2007 Roadsend, Inc.
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License
;; as published by the Free Software Foundation; either version 2
;; of the License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
;; ***** END LICENSE BLOCK *****
(module dotest
(main dotest)
; (library "common")
(include "sys/time.h")
(include "runtime/ext/standard/windows-time.h")
(type timeval
(struct (tv-sec::elong "tv_sec")
(tv-usec::elong "tv_usec"))
"struct timeval")
(type timezone* opaque "struct timezone*")
(macro gettimeofday::int (::timeval* ::timezone*) "gettimeofday") ) )
(define *phpoo* (string-append (or (getenv "PCC_HOME") "@PCC_HOME@")
(string (file-separator))
(string (file-separator))
"pcc " (or (getenv "PCC_OPTS") "")))
(define *php-bin* "php")
(when (getenv "PHP")
(set! *php-bin* (getenv "PHP")))
(when (getenv "PHP5")
(set! *php-bin* (getenv "PHP5")))
(define *php* (string-append *php-bin* " -d display_errors=off")) ;-n? what if my mysql.sock is someplace else?
(define *diff* (cond-expand (PCC_MINGW "diff -u -w ") (else "diff -u ")))
; optimize?
(when (getenv "OPTIMIZE")
(flush-fprint (current-error-port) "compiling all tests with optimization")
(set! *phpoo* (string-append *phpoo* " -O")))
; static?
(when (getenv "STATIC")
(flush-fprint (current-error-port) "using static linking")
(set! *phpoo* (string-append *phpoo* " --static")))
(when (getenv "TEST_CYCLES")
(flush-fprint (current-error-port) (format "operating with ~a test cycles" (getenv "TEST_CYCLES"))))
(define *timing-file* #f)
(when (getenv "STORE_RESULTS")
(if (file-exists? (getenv "STORE_RESULTS"))
(set! *timing-file* (getenv "STORE_RESULTS"))
(set! *timing-file* "timing-data.txt"))
(flush-fprint (current-error-port) (format "saving timing results to: ~a " *timing-file*)))
(flush-fprint (current-error-port) "using roadsend command: " *phpoo*)
(flush-fprint (current-error-port) "using zend command : " *php*)
(define *phpoo-interpreter* (string-append "pcc " (or (getenv "PCC_OPTS") "") " -f "))
(define *run* 0)
(define *build-fail* 0)
(define *run-fail* 0)
(define *interpret-fail* 0)
(define *run-failures* '())
(define *interpret-failures* '())
(define *faster-compiled* 0)
(define *faster-interpreted* 0)
(define *php-run-total* 0.0)
(define *raven-run-total* 0.0)
(define *raven-interp-total* 0.0)
; storing timing information
(define *zend-times* (make-hashtable))
(define *pcc-times* (make-hashtable))
(define *pcci-times* (make-hashtable))
(define-macro (time . prog)
`(let ((t1 (make-timeval*))
(t2 (make-timeval*))
(tz (pragma::timezone* "((struct timezone*)NULL)")))
(gettimeofday t1 tz)
(gettimeofday t2 tz)
(time-difference t1 t2)))
(define (average-time cycles thunk)
(/ (time
(let loop ((i 0))
(when (< i cycles)
(loop (+ i 1)))))
(define (aborting-system . args)
(let ((retval (apply system args)))
(if (= retval 2)
(error 'aborted (format "~A was aborted, exiting." (car args)) retval)
(define (add-run-fail what)
(set! *run-fail* (+ *run-fail* 1))
(set! *run-failures* (cons what *run-failures*)))
(define (add-interpreter-fail what)
(set! *interpret-fail* (+ *interpret-fail* 1))
(set! *interpret-failures* (cons what *interpret-failures*)))
(define (test file home target cycles)
"Copy FILE from HOME to TARGET, run it CYCLES times with Zend and Raven,
and compare the results"
(aborting-system "cp " home "/" file " " target)
(set! *run* (+ 1 *run*))
(let ((zend-time 0)
(raven-time 0)
(raven-interpreter-time 0)
(build-time 0)
(retval 0)
(mydir (pwd))
(pass (color green "[PASS]"))
(fail (color red "[FAIL]"))
;(basename (string-append target "/" (prefix file)));
(basename (prefix file))
(zend (lambda (f)
(aborting-system *php* " -f " f ".php > " f ".ee.out") ))
(raven-build (lambda (f)
(aborting-system *phpoo* " " f ".php > " f ".log 2>&1") ))
(raven-interpret (lambda (f)
(aborting-system *phpoo-interpreter* " " f ".php > "
f ".rebel.interpreter.out 2> " f ".rebel.interpreter.log")))
(raven-run (lambda (f)
;; XXX without this ./, tests like "sort" might run the wrong command
(aborting-system "." (cond-expand (PCC_MINGW "\\") (else "/"))
f " > " f ".rebel.out")))
(diff (lambda (f)
(let* ((dfile (string-append f ".diff"))
(retval (aborting-system *diff* f ".ee.out " f ".rebel.out > " dfile)))
; clean empty diff files
(when (and (file-exists? dfile)
(= 0 (file-size dfile)))
(delete-file dfile))
(flush-print "[" file "]")
(bind-exit (return)
; chdir
(chdir target)
;;Evil Empire
(set! zend-time (time (zend basename)))
;;Rebel Alliance Build
(set! build-time (time (set! retval (raven-build basename))))
(if (= 0 retval)
(display (format "build: ~a ( ~a ) " pass build-time))
(flush-print "build: " fail)
(set! *build-fail* (+ 1 *build-fail*))
(return #f)
;;Rebel Alliance Run
(set! raven-time (time (set! retval (raven-run basename))))
(if (= 0 retval)
(if (= 0 (diff basename))
(flush-print "run: " pass)
(flush-print "run: " fail)
(add-run-fail file)
(return #f)
(add-run-fail file)
(flush-print "run: " fail " (retval " retval ")\n")
(return #f)
(when (getenv "INTERPRETER")
(set! raven-interpreter-time (time (raven-interpret basename)))
(if (= 0 (aborting-system *diff* basename ".ee.out "
basename ".rebel.interpreter.out > " basename ".interpreter.diff"))
(flush-print "interpreter: " pass)
(flush-print "interpreter: " fail)
(add-interpreter-fail file)))
; clean empty diff files
(when (and (file-exists? (string-append basename ".interpreter.diff"))
(= 0 (file-size (string-append basename ".interpreter.diff"))))
(delete-file (string-append basename ".interpreter.diff"))))
(unless (< cycles 2)
(set! zend-time (average-time cycles (lambda () (zend basename))))
(set! raven-time (average-time cycles (lambda () (raven-run basename))))
(when (getenv "INTERPRETER")
(set! raven-interpreter-time (average-time cycles (lambda () (raven-interpret basename))))))
(hashtable-put! *zend-times* file zend-time)
(hashtable-put! *pcc-times* file raven-time)
(when (getenv "INTERPRETER")
(hashtable-put! *pcci-times* file raven-interpreter-time))
(set! *php-run-total* (+ *php-run-total* zend-time))
(set! *raven-run-total* (+ *raven-run-total* raven-time))
(set! *raven-interp-total* (+ *raven-interp-total* raven-interpreter-time))
(flush-print "zend: " zend-time " / raven : " raven-time
(let ((time-diff (/ (round (* (- raven-time zend-time) 1000)) 1000.0))
(xtime (number->string (if (> raven-time zend-time)
(/ raven-time zend-time)
(/ zend-time raven-time))))
(perc (truncate (* 100 (/ raven-time zend-time)))))
(set! xtime (substring xtime 0 (min 5 (string-length xtime))))
(if (< time-diff 0)
(set! *faster-compiled* (+ *faster-compiled* 1))
(color green (format " [~a ~a% | ~aX faster]" time-diff perc xtime)))
(color red (format " [+~a ~a% | ~aX slower]" time-diff perc xtime))))
(if (getenv "INTERPRETER")
(when (getenv "INTERPRETER")
(flush-print " / interpret: " raven-interpreter-time
(let ((time-diff (/ (round (* (- raven-interpreter-time zend-time) 1000)) 1000.0))
(xtime (number->string (if (> raven-interpreter-time zend-time)
(/ raven-interpreter-time zend-time)
(/ zend-time raven-interpreter-time))))
(perc (truncate (* 100 (/ raven-interpreter-time zend-time) ))))
(set! xtime (substring xtime 0 (min 5 (string-length xtime))))
(if (< time-diff 0)
(set! *faster-interpreted* (+ *faster-interpreted* 1))
(color green (format " [~a ~a% | ~aX faster]" time-diff perc xtime)))
(color red (format " [+~a ~a% | ~aX slower]" time-diff perc xtime))))
(chdir mydir)))
(define (time-difference t1::timeval* t2::timeval*)
"time-difference = t2 - t1"
(+ (- (elong->flonum (timeval*-tv-sec t2))
(elong->flonum (timeval*-tv-sec t1)))
(/ (- (elong->flonum (timeval*-tv-usec t2))
(elong->flonum (timeval*-tv-usec t1)))
(define (dotest argv)
(unless (>= (length argv) 3)
(flush-print "Wrong number of arguments: " argv)
(exit 1))
(let ((home (cadr argv))
(target (caddr argv))
(cycles (string->integer
(cond ((> (length argv) 3) (cadddr argv))
((getenv "TEST_CYCLES"))
(else "1")))))
(unless (directory? home)
(flush-print "Test script directory is invalid: " home)
(exit 2))
(unless (directory? target)
(flush-print "Test target directory is invalid: " target)
(exit 3))
;;so that zend can find the include files
(aborting-system "cp " home "/*.inc " target "/")
(let ((single-test (getenv "TEST"))
(test-list '()))
(if single-test
(unless (string=? (suffix single-test) "php")
(set! single-test (string-append single-test ".php")))
(set! test-list (list single-test))
(test single-test home target cycles)
(dump-results single-test target))
(set! test-list (scripts home))
(for-each (lambda (t)
(test t home target cycles))
(when (> (length *run-failures*) 0)
(flush-print "compiler run failures:")
(for-each (lambda (v)
(flush-print v))
(when (> (length *interpret-failures*) 0)
(flush-print "interpreter failures:")
(for-each (lambda (v)
(flush-print v))
(when *timing-file*
; store results
(let ((fp (append-output-file *timing-file*)))
(if fp
(with-output-to-port fp
(lambda ()
(when (getenv "RUN_DESC")
(print "-------------" (getenv "RUN_DESC") "--------------"))
(print (current-date))
(print (string-replace (system->string "uname -a") #\Newline #\space))
(print "Roadsend PHP: " (string-replace (system->string "pcc --version") #\Newline #\space) " | " *phpoo*)
(print "Zend PHP: " (system->string "php -r 'echo phpversion();'") " | " *php*)
(print "test cycles: " cycles)
(format "~a~a~a~a~a"
(for-each (lambda (t)
(print (format "~a~a~a~a~a"
(hashtable-get *zend-times* t)
(hashtable-get *pcc-times* t)
(hashtable-get *pcci-times* t))))
(print (format "AVERAGE ZEND TIME: ~a" (/ *php-run-total* *run*)))
(print (format "AVERAGE PCC TIME: ~a" (/ *raven-run-total* *run*)))
(print *run* " total tests, " *build-fail* " failed to compile and "
*run-fail* " ran wrong.")
(when (getenv "INTERPRETER")
(print (format "AVERAGE INTERPRETER TIME: ~a" (/ *raven-interp-total* *run*)))
(print *interpret-fail* " of " *run* " failed to interpret."))
(flush-print "couldn't write to timing file: " *timing-file*)))))
(flush-print *run* " total tests, " *build-fail* " failed to compile and "
*run-fail* " ran wrong. \n")
(when (> *run* 1)
(flush-print (format "~a tests ran faster than zend php" *faster-compiled*))
(flush-print (format "AVERAGE ZEND TIME: ~a" (/ *php-run-total* *run*)))
(flush-print (format "AVERAGE PCC TIME: ~a" (/ *raven-run-total* *run*)))
(when (getenv "INTERPRETER")
(flush-print *interpret-fail* " of " *run* " failed to interpret.")
(when (> *run* 1)
(flush-print (format "AVERAGE INTERPRETER TIME: ~a" (/ *raven-interp-total* *run*)))
(flush-print (format "~a tests ran faster interpreted than zend php" *faster-interpreted*))))))
(define (usage)
(flush-print "Usage: " (executable-name) " TEST_HOME TEST_TARGET [CYCLES]")
(flush-print " Test scripts from TEST_HOME in scratch directory TEST_TARGET. Scripts")
(flush-print " are run CYCLES times, (for benchmarking).")
(flush-print " The CYCLES option can be passed via environment variable TEST_CYCLES.")
(flush-print " If OPTIMIZE environment variable is set, -O is passed to pcc")
(flush-print " If STATIC environment variable is set, --static is passed to pcc")
(flush-print " If INTERPRETER environment variable is set, the tests will be run through interpreter as well")
(flush-print " If the environment variable TEST is set, it will cause only that test")
(flush-print " to be run."))
(define (scripts dir)
(filter (lambda (a)
(pregexp-match "\\.php$" a))
(sort (directory->list dir) string<?)))
(define yellow 33)
(define red 31)
(define green 32)
(define (color col txt)
"colorize txt"
(if (getenv "NOCOLOR")
(format "\033[~a;1m~a\033[0m" col txt)))
(define (dump-results test target)
(when (> *build-fail* 0)
(flush-print "Log:")
(aborting-system "cat " target "/" (prefix test) ".log"))
(when (> *run-fail* 0)
(flush-print "Differences: (diff <evil empire> <rebel alliance>)")
(aborting-system "cat " target "/" (prefix test) ".diff"))
(when (> *interpret-fail* 0)
(flush-print "Differences (interpreter): (diff <evil empire> <rebel alliance>)")
(aborting-system "cat " target "/" (prefix test) ".interpreter.diff"))
(flush-print "\n"))
(define (flush-fprint port . rest)
(apply fprint port rest)
(flush-output-port port))
(define (flush-print . rest)
(apply print rest)
(flush-output-port (current-output-port)))