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

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

;; Representation of a trivial vtable.
(struct ob (vt state) #:transparent)

;; A simple vtable providing a single method named "op".
(define (b%-vt selector)
  (case selector
    ((op) (lambda (self x) (+ x 2)))
    (else (error 'dnu))))

;; A simple class, using b%-vt as its behaviour.
(define (b%)
  (ob b%-vt 'no-state))

;; An uncached send to a struct ob.
(define-syntax unmemo-send
  (syntax-rules ()
    ((_ obj msg arg ...)
     (let ((tmp obj))
       (((ob-vt tmp) 'msg) tmp arg ...)))))

;; A quasi-cached send to a struct ob.
;;
;; A real cache would have per-send-site state rather than a single
;; (!) global variable.
(define *memo-class* #f)
(define *memo-method* #f)
(define-syntax memo-send
  (syntax-rules ()
    ((_ obj msg arg ...)
     (let* ((tmp obj)
            (cls (ob-vt tmp)))
       (if (eq? *memo-class* cls)
           (*memo-method* tmp arg ...)
           (let ((method (cls 'msg)))
             (set! *memo-class* cls)
             (set! *memo-method* method)
             (method tmp arg ...)))))))

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

;; 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 if we expand the send macro in place?
	      ;; This should be almost identical to the time for the
	      ;; previous expression.
	      (expanded-normal-send
	       ,(measure-ns (let-values (((temp1) 'op))
			      (let-values (((temp2 temp3)
					    (find-method/who 'send a0 temp1)))
				(temp2 temp3 '123)))))

	      ;; What about an approximation to a monomorphic inline
	      ;; cache for the Racket object system? This should be
	      ;; much faster than plain old send.
	      (quasi-memoized-normal-send
	       ,(with-method ((a-op (a0 op)))
			     (let ((method (lambda (x) (a-op x))))
			       (measure-ns (if (eq? *memo-class* a0)
					       (*memo-method* 123)
					       (begin
						 (set! *memo-class* a0)
						 (set! *memo-method* method)
						 (method 123)))))))

	      ;; What about an uncached lookup using the trivial
	      ;; vtable format defined above?
	      (unmemoized-simple-lookup
	       ,(measure-ns (unmemo-send b0 op 123)))

	      ;; Finally, the vtable format defined above using an
	      ;; approximation of monomorphic inline caching.
	      (quasi-memoized-simple-lookup
	       ,(measure-ns (memo-send b0 op 123)))

	      )))