#lang racket
(require racket/private/class-internal)

(define-syntax (let-static stx)
  (syntax-case stx ()
    [(let-static ([var rhs] ...) . body)
     (with-syntax ([(gvar ...)
                    (syntax-local-lift-values-expression
                     (length (syntax->list #'(var ...)))
                     #'(values rhs ...))])
       #'(let-syntax ([var (make-rename-transformer #'gvar)] ...)
           . body))]))

;; An ordinary Racket class.
(define a%
  (class* object% ()
    (super-new)
    (define/public (op x) (+ x 1))))
;; ==== Cached versions of send ====

;; (Real version should base cache on class, not object.)

;; send/cache0
;; Uses 2 vars.
;; Problem: not safe for space!
;; Problem: race condition in 2 set!s.
(define-syntax send/cache0
  (syntax-rules ()
    [(_ obj-expr msg arg ...)
     (let-static ([*memo-class* #f]
                  [*memo-method* #f])
       (let ([obj obj-expr])
         (let ([f (if (eq? obj *memo-class*)
                      *memo-method*
                      (let-values ([(method _obj)
                                    (find-method/who 'send obj 'msg)])
                        (set! *memo-class* obj)
                        (set! *memo-method* method)
                        method))])
           (f obj arg ...))))]))

;; send/cache1
;; Uses 2 weak-boxes to be safe for space.
;; Problem: race condition in 2 set!s.
(define-syntax send/cache1
  (syntax-rules ()
    ((_ obj-expr msg arg ...)
     (let-static ([*memo-class* (make-weak-box #f)]
                  [*memo-method* (make-weak-box #f)])
       (let* ([obj obj-expr]
              [memo-class (weak-box-value *memo-class*)]
              [memo-method (weak-box-value *memo-method*)])
         (let ([f (if (eq? obj memo-class)
                      memo-method
                      (let-values ([(method _obj)
                                    (find-method/who 'send obj 'msg)])
                        (set! *memo-class* (make-weak-box obj))
                        (set! *memo-method* (make-weak-box method))
                        method))])
           (f obj arg ...)))))))

;; send/cache2
;; Uses one weak-box instead of two, so safe for space and eliminates
;; race condition.
;; Problem (minor): the weak-box's pair is held nowhere else, so the
;; cache is potentially emptied on every (major?) GC. (But that's ok.)
(define-syntax send/cache2
  (syntax-rules ()
    ((_ obj-expr msg arg ...)
     (let-static ([*memo* (make-weak-box #f)])
       (let* ([obj obj-expr]
              [memo (weak-box-value *memo*)]
              [memo-class (and (pair? memo) (car memo))]
              [memo-method (and (pair? memo) (cdr memo))])
         (let ([f (if (eq? obj memo-class)
                      memo-method
                      (let-values ([(method _obj)
                                    (find-method/who 'send obj 'msg)])
                        (set! *memo*
                              (make-weak-box (cons obj method)))
                        method))])
           (f obj arg ...)))))))

;; Test objects.
(define a0 (new a%))

;; Syntax: (measure-ns exp)
;;
;; Expands to an expression that repeats "exp" NREPEATS times,
;; measuring the elapsed time, and returns the number of nanoseconds
;; of CPU time used *per iteration*, excluding any GC time.
(define NREPEATS 5000000)
(define-syntax measure-ns
  (syntax-rules ()
    ((_ exp)
     (call-with-values (lambda ()
			 (pretty-print `(measuring exp))
                         (time-apply (lambda ()
                                       (do ((i 0 (+ i 1)))
                                         ((= i NREPEATS))
                                         exp))
                                     '()))
                       (lambda (results cpu real gc)
                         (/ (* 1000000000.0 (/ (- cpu gc) 1000.0))
                            NREPEATS))))))

;; Main program.

;; Measure the time for a null measure-ns loop first, then measure the
;; operations of interest, subtracting the null-time overhead
;; measurement from each to get an estimate of the time taken for the
;; interesting operation.

(let ((null-time (measure-ns 123)))
  (define (report-on t)
    (let ((name (first t))
	  (ns/op (second t)))
      (write (list name (- ns/op null-time)))
      (newline)))
  (for-each report-on
	    `(
	      ;; Report on the loop overhead for sanity checking.
	      (constant ,null-time)

	      ;; How long does a plain Scheme addition operation take?
	      (simple-add
	       ,(measure-ns (+ 123 12)))

	      ;; How long does a regular Racket object send take?
	      (normal-send
	       ,(measure-ns (send a0 op 123)))

	      ;; What about an approximation to a monomorphic inline
	      ;; cache for the Racket object system? This should be
	      ;; much faster than plain old send.

              ;; 2 vars (not SFS, race condition)
	      (memoized-send/0
               ,(measure-ns (send/cache0 a0 op 123)))

              ;; 2 weak-boxes (SFS, race condition)
	      (memoized-send/1
               ,(measure-ns (send/cache1 a0 op 123)))

              ;; 1 weak-box (SFS, no race condition)
              (memoized-send/2
               ,(measure-ns (send/cache2 a0 op 123)))
	      )))