#!/bin/sh
#|
exec mzscheme -qu "$0" ${1+"$@"}
|#

;; See "tabulate.ss" for information on the output format

(module auto scheme/base
  (require (for-syntax scheme/base)
           mzlib/process
           "cmdline.ss"
           mzlib/list
           mzlib/compile
           mzlib/inflate
           mzlib/date
           mzlib/port
           mzlib/file
           dynext/file
           syntax/toplevel
           scheme/runtime-path)

  ;; Implementaton-specific control functions ------------------------------

  (define (bytes->number b)
    (string->number (bytes->string/latin-1 b)))

  (define ((run-mk script) bm)
    (when (file-exists? (symbol->string bm))
      (delete-file (symbol->string bm)))
    (parameterize ([current-command-line-arguments (vector (symbol->string bm))])
      (namespace-require 'scheme)
      (load script)))

  (define (clean-up-bin bm)
    (delete-file (symbol->string bm)))

  (define (clean-up-o1 bm)
    (delete-file (format "~a.o1" bm)))

  (define (mk-mzscheme bm)
    (unless (directory-exists? "compiled")
      (make-directory "compiled"))
    (parameterize ([current-namespace (make-base-namespace)]
                   [read-accept-reader #t])
      (let ([name (format "~a.ss" bm)])
        (compile-file name
                      (build-path "compiled" (path-add-suffix name #".zo"))))))

  (define (clean-up-zo bm)
    (delete-directory/files "compiled"))

  (define (clean-up-nothing bm)
    (void))

  (define (mk-plt-r5rs bm)
    (with-output-to-file (format "~a.scm" bm)
      #:exists 'replace
      (lambda ()
        (printf "(load \"r5rs-wrap.ss\")\n(load \"~a.sch\")\n" bm)))
    ;; To get compilation time:
    (parameterize ([current-namespace (make-base-empty-namespace)])
      (namespace-require 'r5rs)
      (with-input-from-file (format "~a.sch" bm)
        (lambda ()
          (let loop ()
            (let ([e (read-syntax)])
              (unless (eof-object? e)
                (eval-compile-time-part-of-top-level/compile 
                 (namespace-syntax-introduce e))
                (loop))))))))

  (define (clean-up-plt-r5rs bm)
    (let ([f (format "~s.scm" bm)])
      (when (file-exists? f)
        (delete-file f))))

  (define (mk-mzscheme-tl bm)
    ;; To get compilation time:
    (parameterize ([current-namespace (make-base-namespace)])
      (namespace-require 'scheme/base)
      (eval '(define null #f)) ; for dynamic.sch
      (compile-file (format "~a.sch" bm))))

  (define (setup-larceny bm)
    (setup-sps bm "(larceny benchmarking)"))

  (define (mk-larceny bm)
    (parameterize ([current-input-port 
		    (open-input-string
		     (format (string-append
			      "(import (larceny compiler))\n"
			      "(compile-library \"~a.sls\")\n")
			     bm))]
		   [current-output-port (open-output-bytes)])
      (system "larceny -err5rs")
      ;; Make sure compiled version is used:
      (delete-file (format "~a.sls" bm))))

  (define (clean-up-fasl bm)
    (clean-up-sps bm)
    (delete-file (format "~a.slfasl" bm)))

  (define (mk-mzc bm)
    (parameterize ([current-output-port (open-output-bytes)])
      (system (format "mzc ~a.ss" bm))))

  (define (clean-up-extension bm)
    (delete-file (append-extension-suffix (symbol->string bm))))

  (define (run-exe bm)
    (system (symbol->string bm)))

  (define (run-exe/time bm)
    (system (format "time ~a" bm)))

  (define (run-gambit-exe bm)
    (system (format "gsi -:d-,m10000 ~a.o1" bm)))

  (define (run-larceny bm)
    (system "larceny -r6rs -program prog.sps -path ."))

  (define (setup-sps bm lib)
    (with-output-to-file "prog.sps"
      #:exists 'truncate
      (lambda ()
        (printf "(import (~a))\n" bm)
        (printf "(bm-!-go)\n")))
    (with-output-to-file (format "~a.sls" bm)
      #:exists 'truncate
      (lambda ()
        (printf "(library (~a)\n" bm)
        (printf " (export bm-!-go)\n")
        (printf " (import (rnrs) (rnrs mutable-pairs) (rnrs mutable-strings) (rnrs r5rs) (rnrs eval) ~a)\n" lib)
        (printf " (define (bm-!-go) 'ok)\n")
        (call-with-input-file (format "~a.sch" bm)
          (lambda (in)
            (copy-port in (current-output-port))))
        (printf ")\n"))))

  (define (clean-up-sps bm)
    (delete-file "prog.sps")
    (let ([f (format "~a.sls" bm)])
      (when (file-exists? f)
        (delete-file f))))

  (define (setup-ikarus bm)
    (setup-sps bm "(ikarus)")
    (system "rm -rf ~/.ikarus"))
  
  (define (mk-ikarus bm)
    (system "ikarus --compile-dependencies prog.sps"))

  (define (run-ikarus bm)
    (system "ikarus --r6rs-script prog.sps"))

  (define (clean-up-ikarus bm)
    (clean-up-sps bm)
    (system "rm -rf ~/.ikarus"))

  (define (extract-times bm str)
    str)

  (define (extract-gambit-times bm str)
    (let ([m (regexp-match (byte-regexp
                            (bytes-append
                             #"([0-9]+) ms real.*[^0-9]"
                             #"([0-9]+) ms cpu.*"
                             #"(?:no collections|collections? accounting for ([0-9]+) ms.*)"))
                           str)])
      (map bytes->number
           (list (caddr m)
                 (cadr m)
                 (or (cadddr m) #"0")))))

  (define (extract-mzscheme-times bm str)
    (let ([m (regexp-match #rx#"cpu time: ([0-9]+) real time: ([0-9]+) gc time: ([0-9]+)" str)])
      (map bytes->number (cdr m))))

  (define (extract-bigloo-times bm str)
    (let ([m (regexp-match #rx#"real: ([0-9]+) sys: ([0-9]+) user: ([0-9]+)" str)]
          ;; `time' result is 10s of milliseconds? OS ticks, maybe?
          [msec/tick 10])
      (list (* msec/tick (+ (bytes->number (caddr m))
                            (bytes->number (cadddr m))))
            (* msec/tick (bytes->number (cadr m)))
            0)))

  (define (extract-larceny-times bm str)
    (let ([m (regexp-match #rx#"Elapsed time...: ([0-9]+) ms.*Elapsed GC time: ([0-9]+) ms" str)])
      (list (bytes->number (cadr m))
	    #f
	    (bytes->number (caddr m)))))

  (define (extract-chicken-times bm str)
    (let ([m (regexp-match #rx#"([0-9.]+) seconds.*[^0-9.]([0-9.]+) seconds" str)])
      (list (* 1000 (string->number (format "#e~a" (cadr m))))
            #f
            (* 1000 (string->number (format "#e~a" (caddr m)))))))

  (define (extract-time-times bm str)
    (let ([m (regexp-match #rx#"real[ \t]+([0-9m.]+)s.*user[ \t]+([0-9m.]+)s.sys[ \t]+([0-9m.]+)s." str)]
          [ms->milliseconds (lambda (s)
                              (let ([m (regexp-match "([0-9]+)m([0-9.]+)" s)])
                                (+ (* 60000 (string->number (format "~a" (cadr m))))
                                   (* 1000 (string->number (format "#e~a" (caddr m)))))))])
      (let ([real (ms->milliseconds (cadr m))]
            [user (ms->milliseconds (caddr m))]
            [sys (ms->milliseconds (cadddr m))])
        (list (+ user sys) real #f))))

  (define (extract-ikarus-times bm str)
    (let ([m (regexp-match (bytes-append
                            #"([0-9]*) ms elapsed cpu time, including ([0-9]*) ms collecting\n"
                            #"[ \t]*([0-9]*) ms elapsed real time")
                           str)])
      (if m
          (list (string->number (bytes->string/utf-8 (cadr m)))
                (string->number (bytes->string/utf-8 (cadddr m)))
                (string->number (bytes->string/utf-8 (caddr m))))
          (list #f #f #f))))


  ;; Table of implementatons and benchmarks ------------------------------

  (define-struct impl (name setup make run extract-result clean-up skips))

  (define mutable-pair-progs '(conform
                               destruct
                               dynamic
                               lattice
                               maze
                               peval
                               scheme
                               sort1))

  (define impls
    (list
     (make-impl 'mzscheme
                void
                mk-mzscheme
                (lambda (bm)
                  (system (format "mzscheme -u ~a.ss" bm)))
                extract-mzscheme-times
                clean-up-zo
                mutable-pair-progs)
     (make-impl 'mz-old
                void
                mk-mzscheme
                (lambda (bm)
                  (system (format "mz-old -u ~a.ss" bm)))
                extract-mzscheme-times
                clean-up-zo
                mutable-pair-progs)
     (make-impl 'mzschemecgc
                void
                mk-mzscheme
                (lambda (bm)
                  (system (format "mzschemecgc -u ~a.ss" bm)))
                extract-mzscheme-times
                clean-up-zo
                mutable-pair-progs)
     (make-impl 'mzscheme3m
                void
                mk-mzscheme
                (lambda (bm)
                  (system (format "mzscheme3m -u ~a.ss" bm)))
                extract-mzscheme-times
                clean-up-zo
                mutable-pair-progs)
     (make-impl 'plt-r5rs
                void
                mk-plt-r5rs
                (lambda (bm)
                  (system (format "plt-r5rs ~a.scm" bm)))
                extract-mzscheme-times
                clean-up-plt-r5rs
                null)
     (make-impl 'mzc
                void
                mk-mzc
                (lambda (bm)
                  (system (format "mzscheme -mvqee '(load-extension \"~a\")' '(require ~a)'" 
                                  (append-extension-suffix (symbol->string bm))
                                  bm)))
                extract-mzscheme-times
                clean-up-extension
                (append '(takr takr2)
                        mutable-pair-progs))
     (make-impl 'mzscheme-j
                void
                mk-mzscheme
                (lambda (bm)
                  (system (format "mzscheme -jqu ~a.ss" bm)))
                extract-mzscheme-times
                clean-up-zo
                mutable-pair-progs)
     (make-impl 'mzschemecgc-j
                void
                mk-mzscheme
                (lambda (bm)
                  (system (format "mzschemecgc -jqu ~a.ss" bm)))
                extract-mzscheme-times
                clean-up-zo
                mutable-pair-progs)
     (make-impl 'mzschemecgc-tl
                void
                mk-mzscheme-tl
                (lambda (bm)
                  (system (format "mzschemecgc -qr compiled/~a.zo" bm)))
                extract-mzscheme-times
                clean-up-zo
                (append '(nucleic2)
                        mutable-pair-progs))
     (make-impl 'chicken
                void
                (run-mk "mk-chicken.ss")
                run-exe
                extract-chicken-times
                clean-up-bin
                '(scheme2 takr2))
     (make-impl 'bigloo
                void
                (run-mk "mk-bigloo.ss")
                run-exe
                extract-bigloo-times
                clean-up-bin
                '(cpstack takr2))
     (make-impl 'gambit
                void
                (run-mk "mk-gambit.ss")
                run-gambit-exe
                extract-gambit-times
                clean-up-o1
                '(nucleic2))
     (make-impl 'larceny
                setup-larceny
                mk-larceny
                run-larceny
                extract-larceny-times
                clean-up-fasl
                '())
     (make-impl 'ikarus
                setup-ikarus
                mk-ikarus
                run-ikarus
                extract-ikarus-times
                clean-up-ikarus
                '(takr))))

  (define obsolte-impls '(mzscheme3m mzschemecgc mzscheme-j mzschemecgc-j mzschemecgc-tl mzc mz-old))

  (define benchmarks
    '(conform
      cpstack
      ctak
      deriv
      dderiv
      destruct
      div
      dynamic
      dynamic2
      earley
      fft
      graphs
      lattice
      lattice2
      maze
      maze2
      mazefun
      nboyer
      nestedloop
      nfa
      nothing
      nqueens
      nucleic2
      paraffins
      peval
      puzzle
      sboyer
      scheme
      scheme2
      sort1
      tak
      takl
      takr
      takr2
      triangle))

  (define extra-benchmarks
    '(kanren
      psyntax))

  (define (run-benchmark impl bm)
    (let ([i (ormap (lambda (i)
                      (and (eq? impl (impl-name i))
                           i))
                    impls)])
      (if (memq bm (impl-skips i))
          (rprintf "[~a ~a ~s #f]\n" impl bm '(#f #f #f))
          (begin
            ((impl-setup i) bm)
            (let ([start (current-inexact-milliseconds)])
              ((impl-make i) bm)
              (let ([end (current-inexact-milliseconds)])
                (let loop ([n num-iterations])
                  (unless (zero? n)
                    (let ([out (open-output-bytes)])
                      (unless (parameterize ([current-output-port out]
                                             [current-error-port out])
                                ((impl-run i) bm))
                        (error 'auto "~a\nrun failed ~a" (get-output-bytes out) bm))
                      (rprintf "[~a ~a ~s ~a]\n"
                               impl
                               bm
                               ((impl-extract-result i) bm (get-output-bytes out))
                               (inexact->exact (round (- end start)))))
                    (loop (sub1 n)))))
              ((impl-clean-up i) bm))))
      (flush-output)))

  ;; Extract command-line arguments --------------------

  (define-values (actual-benchmarks-to-run 
                  actual-implementations-to-run 
                  num-iterations)
    (process-command-line benchmarks
                          extra-benchmarks
                          (map impl-name impls) obsolte-impls
                          3))

  (define-runtime-path bm-directory ".")
  
  ;; Benchmark-specific setup --------------------

  (parameterize ([current-directory bm-directory])
    (when (memq 'dynamic actual-benchmarks-to-run)
      (unless (file-exists? "dynamic-input.txt")
        (gunzip "dynamic-input.txt.gz"))))

  ;; Run benchmarks -------------------------------

  (rprintf "; ~a\n" (date->string (seconds->date (current-seconds)) #t))

  (parameterize ([current-directory bm-directory])
    (for-each (lambda (impl)
                (map (lambda (bm)
                       (run-benchmark impl bm))
                     actual-benchmarks-to-run))
              actual-implementations-to-run)))