[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: Bug fix
Thank you to Alexandro and John for pointing out the bugs in the
implementation. I have fixed them and included the suggested extra
tests in the update below.
Best regards
Andre
;=====================================================================
; Boxes
(define (box x) (list x))
(define unbox car)
(define set-box! set-car!)
;==========================================================
; Primitives for lazy evaluation:
(define-syntax lazy
(syntax-rules ()
((lazy exp)
(box (box (cons 'lazy (lambda () exp)))))))
(define (eager x)
(box (box (cons 'eager x))))
(define-syntax delay
(syntax-rules ()
((delay exp) (lazy (eager exp)))))
(define (force promise)
(let ((content (unbox (unbox promise))))
(case (car content)
((eager) (cdr content))
((lazy) (let* ((promise* ((cdr content)))
(content (unbox (unbox promise))))
(when (not (eqv? (car content) 'eager)) ; for reentrancy test 3
(set-box! (unbox promise) (unbox (unbox promise*)))
(set-box! promise* (unbox promise)))
(force promise))))))
;============================================================
; BENCHMARKS:
;============================================================
;============================================================
; Memoization test 1:
(define s (delay (begin (display 'hello) 1)))
(force s)
(force s)
;===> Should display 'hello once
;============================================================
; Memoization test 2:
(let ((s (delay (begin (display 'bonjour) 2))))
(+ (force s) (force s)))
;===> Should display 'bonjour once
;============================================================
; Memoization test 3: (pointed out by Alejandro Forero Cuervo)
(define s (delay (begin (display 'hi) 1)))
(define t (lazy s))
(force t)
(force s)
;===> Should display 'hi once
;============================================================
; Memoization test 4: Stream memoization
(define (stream-drop s index)
(lazy
(if (zero? index)
s
(stream-drop (cdr (force s)) (- index 1)))))
(define (from n)
(delay (begin
(display 'ho)
(cons n (from (+ n 1))))))
(define s (from 0))
(car (force (stream-drop s 4)))
(car (force (stream-drop s 4)))
;===> Should display 'ho five times
;=============================================================
; Reentrancy test 1: from R5RS
(define count 0)
(define p
(delay (begin (set! count (+ count 1))
(if (> count x)
count
(force p)))))
(define x 5)
(force p) ;===> 6
(set! x 10)
(force p) ;===> 6
;===========================================================
; Reentrancy test 2: from SRFI 40
(define f
(let ((first? #t))
(delay
(if first?
(begin
(set! first? #f)
(force f))
'second))))
(force f) ;===> 'second
;===========================================================
; Reentrancy test 3: due to John Shutt
(define q
(let ((count 5))
(define (get-count) count)
(define p (delay (if (<= count 0)
count
(begin (set! count (- count 1))
(force p)
(set! count (+ count 2))
count))))
(list get-count p)))
(define get-count (car q))
(define p (cadr q))
(get-count) ; => 5
(force p) ; => 0
(get-count) ; => 10
;=============================================================
; Test leaks: All the leak tests should run in bounded space.
;============================================================
; Leak test 1: Infinite loop in bounded space.
(define (loop) (lazy (loop)))
;(force (loop))
;============================================================
; Leak test 2: Pending memos should not accumulate
; in shared structures.
(define s (loop))
;(force s)
;============================================================
; Leak test 3: Safely traversing infinite stream.
(define (from n)
(delay (cons n (from (+ n 1)))))
(define (traverse s)
(lazy (traverse (cdr (force s)))))
;(force (traverse (from 0)))
;============================================================
; Leak test 4: Safely traversing infinite stream
; while pointer to head of result exists.
(define s (traverse (from 0)))
;(force s)
;=========================================================================
; Convenient list deconstructor.
(define-syntax match
(syntax-rules ()
((match exp
(() exp1)
((h . t) exp2))
(let ((lst exp))
(cond ((null? lst) exp1)
((pair? lst) (let ((h (car lst))
(t (cdr lst)))
exp2))
(else 'match-error))))))
;==============================================================
(define (stream-filter p? s)
(lazy (match (force s)
(() (delay '()))
((h . t) (if (p? h)
(delay (cons h (stream-filter p? t)))
(stream-filter p? t))))))
;============================================================
; Leak test 5: Naive stream-filter should run in bounded space.
; Simplest case.
;(force (stream-filter (lambda (n) (= n 10000000000))
; (from 0)))
; The stream-ref procedure below does not strictly need to be lazy.
; It is defined lazy for the purpose of testing safe compostion of lazy procedures in
; the times3 benchmark below (previous candidate solutions had failed this).
(define (stream-ref s index)
(lazy
(match (force s)
(() 'error)
((h . t) (if (zero? index)
(delay h)
(stream-ref t (- index 1)))))))
; Check that evenness is correctly implemented - should terminate:
(force (stream-ref (stream-filter zero? (from 0))
0))
;============================================================
; Leak test 6: Another long traversal should run in bounded space.
(define s (stream-ref (from 0) 100000000))
;(force s)
(define (times3 n)
(stream-ref (stream-filter
(lambda (x) (zero? (modulo x n)))
(from 0))
3))
;============================================================
; Leak test 7: Infamous example from SRFI 40.
(force (times3 7))
;(force (times3 100000000))