echain.ss

(define ephemeron-key car)
(define ephemeron-value cdr)

(define (show v) (write v) (newline))
(define (check-same a b)
  (unless (eq? a b)
    (error 'check-same "failed")))

(define gdn (make-guardian))

;; Check that the ephemeron value doesn't retain
;; itself as an epehemeron key
(define-values (es wps saved)
  (let loop ([n 1000] [es '()] [wps '()] [saved '()])
    (cond
     [(zero? n)
       (values es wps saved)]
     [else
      (let ([k1 (gensym)]
            [k2 (gensym)])
        (gdn k2)
        (loop (sub1 n)
              (cons (ephemeron-cons k1 (box k1))
                    (cons (ephemeron-cons k2 (box k2))
                          es))
              (weak-cons k1 (weak-cons k2 wps))
              (cons k1 saved)))])))

(collect (collect-maximum-generation))

(let loop ([es es] [wps wps] [saved saved])
  (unless (null? saved)
    (check-same (car saved) (car wps))
    (check-same (car saved) (ephemeron-key (car es)))
    (check-same (car saved) (unbox (ephemeron-value (car es))))
    (check-same (cadr wps) (ephemeron-key (cadr es)))
    (check-same (cadr wps) (unbox (ephemeron-value (cadr es))))
    (loop (cddr es) (cddr wps) (cdr saved))))

(let loop ([saved saved])
  (unless (null? saved)
    (gdn)
    (loop (cdr saved))))

(collect (collect-maximum-generation))

(let loop ([es es] [wps wps] [saved saved])
  (unless (null? saved)
    (check-same (car saved) (car wps))
    (check-same (car saved) (ephemeron-key (car es)))
    (check-same (car saved) (unbox (ephemeron-value (car es))))
    (check-same #!bwp (cadr wps))
    (check-same #!bwp (ephemeron-key (cadr es)))
    (check-same #!bwp (ephemeron-value (cadr es)))
    (loop (cddr es) (cddr wps) (cdr saved))))

;; ----------------------------------------
;; Stress test to check that the GC doesn't suffer from quadratic
;; behavior

(define (wrapper v) (list 1 2 3 4 5 v))

;; Create a chain of ephemerons where we have all
;; the the ephemerons immediately in a list,
;; but we discover the keys one at a time
(define (mk n prev-key es)
  (cond
   [(zero? n)
    (values prev-key es)]
   [else
    (let ([key (gensym)])
      (mk (sub1 n)
          key
          (cons (ephemeron-cons key (wrapper prev-key))
                es)))]))

;; Create a chain of ephemerons where we have all
;; of the keys immediately in a list,
;; but we discover the ephemerons one at a time
(define (mk* n prev-e keys)
  (cond
   [(zero? n)
    (values prev-e keys)]
   [else
    (let ([key (gensym)])
      (mk* (sub1 n)
           (ephemeron-cons key (wrapper prev-e))
           (cons key
                 keys)))]))

(define (measure-time n)
  ;; Hang the discover-keys-one-at-a-time chain
  ;; off the end of the discover-ephemerons-one-at-a-time
  ;; chain, which is the most complex case for avoiding
  ;; quadratic GC times
  (define-values (key es) (mk n (gensym) '()))
  (define-values (root holds) (mk* n key es))

  (define start (current-time))
  (collect (collect-maximum-generation))
  (let ([delta (time-difference (current-time) start)])
    ;; Sanity check on ephemerons
    (for-each (lambda (e)
                (when (eq? #!bwp (ephemeron-key e))
                  (error 'check "oops")))
              es)
    ;; Keep `root` and `holds` live:
    (show (length (cons root holds)))
    ;; Return duration:
    delta))

(define N 10000)

;; The first time should be roughy x10 the second (not x100)
(show (measure-time (* 10 N)))
(show (measure-time N))

;; ----------------------------------------
;; Check interaction of mutation and generations

;; This check makes assuptions about `collect` and
;; generations that are fragile and not guaranteed
(let ([e (ephemeron-cons (gensym) 'ok)])
  (collect)
  (check-same #!bwp (ephemeron-key e))
  (check-same #!bwp (ephemeron-value e))
  (let ([s (gensym)])
    (set-car! e s)
    (set-cdr! e 'ok-again)
    (collect)
    (check-same s (ephemeron-key e))
    (check-same 'ok-again (ephemeron-value e))
    (set! s #f)
    (collect 1)
    (check-same #!bwp (ephemeron-key e))
    (check-same #!bwp (ephemeron-value e))))

;; ----------------------------------------
;; Check fasl:

(let ([s (gensym)])
  (define-values (o get) (open-bytevector-output-port))
  (fasl-write (list s
                    (ephemeron-cons s 'ok))
              o)
  (let* ([l (fasl-read (open-bytevector-input-port (get)))]
         [e (cadr l)])
    (check-same (car l) (ephemeron-key e))
    (check-same 'ok (ephemeron-value e))
    (set! s #f)
    (set! l #f)
    (collect (collect-maximum-generation))
    (check-same #!bwp (ephemeron-key e))
    (check-same #!bwp (ephemeron-value e))))