Test to help pin down slowness of execution due to TR-inserted contracts (?)

bitsyntax-slow-contracts.rkt

#lang racket
;; Example to pin down influence of contract checks at a typed/untyped
;; boundary on execution speed in the `bitsyntax` package.
;;
;; TO RUN:
;;   - install the `bitsyntax` package.
;;   - run this program.
;;   - modify the file `bitstring.rkt` in the `bitsyntax` package to have
;;     ".../no-check" at the end of its `#lang`.
;;   - rerun the program.
;;
;; Example output, with "#lang typed/racket/base" (the current default) in bitstring.rkt:
;;
;;     1000 checksums over a 1024-byte packet in 3344 ms gives 299.04306220095697 checksums/sec
;;
;; Example output, with "#lang typed/racket/base/no-check" in bitstring.rkt:
;;
;;     1000 checksums over a 1024-byte packet in 169 ms gives 5917.159763313609 checksums/sec
;;
;; The untyped variant is ~20x faster than the typed variant.

;;---------------------------------------------------------------------------
;; Contents of "checksum.rkt" from the netstack example in Syndicate

(provide ones-complement-sum16 ip-checksum)

(require bitsyntax)

(define (ones-complement-+16 a b)
  (define c (+ a b))
  (bitwise-and #xffff (+ (arithmetic-shift c -16) c)))

(define (ones-complement-sum16 bs)
  (bit-string-case bs
    ([ (n :: integer bytes 2) (rest :: binary) ]
     (ones-complement-+16 n (ones-complement-sum16 rest)))
    ([ odd-byte ]
     (arithmetic-shift odd-byte 8))
    ([ ]
     0)))

(define (ones-complement-negate16-safely x)
  (define r (bitwise-and #xffff (bitwise-not x)))
  (if (= r 0) #xffff r))

(define (ip-checksum offset blob #:pseudo-header [pseudo-header #""])
  (bit-string-case blob
    ([ (prefix :: binary bytes offset)
       (:: binary bytes 2)
       (suffix :: binary) ]
     (define result (ones-complement-+16
		     (ones-complement-sum16 pseudo-header)
		     (ones-complement-+16 (ones-complement-sum16 prefix)
					  (ones-complement-sum16 suffix))))
     (define checksum (ones-complement-negate16-safely result))
     (define final-packet (bit-string (prefix :: binary)
				      (checksum :: integer bytes 2)
				      (suffix :: binary)))
     final-packet)))

;;---------------------------------------------------------------------------

(define dummy-packet (make-bytes 1024 #x5a))

(define N 1000)

(define-values (_results cpu-ms _wall-ms gc-ms)
  (time-apply (lambda () (for [(i N)]
                           (ip-checksum 10 dummy-packet)))
              '()))

(let ((delta (- cpu-ms gc-ms)))
  (printf "~a checksums over a ~a-byte packet in ~a ms gives ~a checksums/sec\n"
          N
          (bytes-length dummy-packet)
          delta
          (/ N (/ delta 1000.0))))