time-method-send.scm

#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 ...)))))))

;; A more serious attempt at an inline-caching send for the normal
;; Racket object system.
;;
;; Uses a single box to avoid concurrency issues.
(define-syntax cached-send
  (lambda (stx)
    (syntax-case stx ()
      ((_ obj msg arg ...)
       (with-syntax ([*cached-state*
		      (syntax-local-lift-expression
		       (syntax (cons #f #f)))])
	 (syntax
	  (let* ((tmp obj)
		 (cls tmp) ;; there's no reliable way of getting hold
			   ;; of the raw class object at the moment
		 (state *cached-state*))
	    (if (eq? (car state) cls)
		((cdr state) tmp arg ...)
		(let ((method (find-method/who 'cached-send tmp 'msg)))
		  (set! *cached-state* (cons cls method))
		  (method tmp arg ...))))))))))

;; As for cached-send, but with a weak box to improve space safety.
(define-syntax cached-weak-send
  (lambda (stx)
    (syntax-case stx ()
      ((_ obj msg arg ...)
       (with-syntax ([*cached-state*
		      (syntax-local-lift-expression
		       (syntax (make-weak-box (cons #f #f))))])
	 (syntax
	  (let* ((tmp obj)
		 (cls tmp) ;; there's no reliable way of getting hold
			   ;; of the raw class object at the moment
		 (state (weak-box-value *cached-state*)))
	    (if (and state (eq? (car state) cls))
		((cdr state) tmp arg ...)
		(let ((method (find-method/who 'cached-send tmp 'msg)))
		  (set! *cached-state* (make-weak-box (cons cls 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.

;; Fibonacci experiments

(define fib%
  (class* object% ()
    (super-new)

    (define/public (ifib n)
      (if (< n 2)
	  n
	  (+ (ifib (- n 2))
	     (ifib (- n 1)))))

    (define/public (cfib n)
      (if (< n 2)
	  n
	  (+ (cached-send this cfib (- n 2))
	     (cached-send this cfib (- n 1)))))

    (define/public (fib n)
      (if (< n 2)
	  n
	  (+ (send this fib (- n 2))
	     (send this fib (- n 1)))))))

(time (send (new fib%) ifib 31))
(time (send (new fib%) cfib 31))
(time (send (new fib%) fib 31))

;; 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 ((temp2 (find-method/who 'send a0 temp1)))
				(temp2 a0 '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)))))))

	      ;; A more serious effort.
	      (cached-normal-send
	       ,(measure-ns (cached-send a0 op 123)))

	      ;; A more serious effort, with better space-safety.
	      (cached-weak-normal-send
	       ,(measure-ns (cached-weak-send a0 op 123)))

	      ;; How long does a Racket generic send take?
	      (normal-generic-send
	       ,(let ([op/g (generic a% op)])
		  (measure-ns (send-generic a0 op/g 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)))

	      )))