Change lazy evaluator to use data-directed dispatch

This will enable on the fly overriding of sequence processing for
exercise 4.30.

mceval/4-29.rkt

@@ -0,0 +1,60 @@
+#lang sicp
+
+(#%require "leval.rkt")
+(#%require "test-eval.rkt")
+
+(define (program delay)
+  `((define count 0)
+    (define (id ,(qualify-arg 'x delay))
+      (set! count (+ count 1)) x)
+    (define (square ,(qualify-arg 'x delay))
+      (* x x))
+    (square (id 10))
+    count))
+
+(define (input-sequence val count)
+  (cons 'list
+        (let loop ((n count))
+          (if (= n 0) '()
+              (cons val (loop (- n 1)))))))
+
+(define (map-program length delay)
+  `((define (f ,(qualify-arg 'x delay))
+      (+ x (sqrt x)))
+    (define input
+      ,(input-sequence 5 length))
+    (define (map ,(qualify-arg 'f delay)
+                 ,(qualify-arg 'x delay))
+      (if (null? x) '()
+          (cons (f (car x))
+                (map f (cdr x)))))
+    (map f input)))
+
+
+(#%require (only racket/base module+))
+(#%require rackunit)  
+
+(module+ test
+  ;; With the normal lazy evaluator, square evaluates id twice
+  (check-equal? (lazy-eval-program (program 'lazy)) 2)
+  ;; With the memoizing evaluator, the first call to id is memoized,
+  ;; so another call is not needed.
+  (check-equal? (lazy-eval-program (program 'lazy-memo)) 1))
+
+(module+ timing
+
+  ;; Map needs to re-evaluate the procedure f for each element of the
+  ;; input for lazy evaluation.  If memoized, this is only evaluated once.
+  (define lazy-map (time-proc 100 (lambda () (lazy-eval-program
+                                              (map-program 100 'lazy)))))
+  (define lazy-memo-map (time-proc 100 (lambda () (lazy-eval-program
+                                                   (map-program 100 'lazy-memo)))))
+  (display `("Map: lazy " ,lazy-map " lazy-memo " ,lazy-memo-map " speed-up "
+                          ,(/ lazy-map lazy-memo-map)))
+
+  ;; Gives ~16x speedup.
+)
+
+;; In general, performance for the memoizing evaluator should be
+;; much better when multiple references are made to the result of
+;; evaluating a procedure.

mceval/environment.rkt

@@ -166,6 +166,7 @@
         (list '/ /)
         (list '< <)
         (list '> >)
+        (list 'sqrt sqrt)
         (list 'newline newline)
         (list 'display display)
         ))

mceval/leval.rkt

@@ -5,33 +5,78 @@
 
 ;;;; OMP: modified to work with racket and to fit with existing code
 
+;;;; This evaluator uses the modifications of exercise 4.31: arguments
+;;;; can be strict, lazy or lazy with memoization.  To specify a
+;;;; procedure, strict in x, lazy in y and lazy with memoization in z:
+;;;; (define (f x (y 'lazy) (z 'lazy-memo))).  Also modified from the
+;;;; book's version is the use of data-directed dispatch for eval.
+
 (#%require racket/trace)
 (#%require "syntax.rkt")
 (#%require "environment.rkt")
 (#%require "common.rkt")
 (#%require "special-forms.rkt")
+(#%require "dispatch-table.rkt")
 
 (#%provide lazy-driver-loop
-           lazy-eval-program)
+           lazy-eval-program
+           lazy-put-dispatch!
+           actual-value)
 
-;;;SECTION 4.2.2
+(define type-tag car)
+(define dispatch-table (make-dispatch-table))
 
-;;; Modifying the evaluator
+(define lazy-dispatch-alist
+  `((if . ,(lambda (exp env)
+             (lazy-eval-if exp env)))
+    (begin .
+           ,(lambda (exp env)
+              (eval-sequence (begin-actions exp) env lazy-eval)))
+    (set! . ,(lambda (exp env)
+               (eval-assignment exp env lazy-eval)))
+    (define .
+      ,(lambda (exp env)
+         (eval-definition exp env lazy-eval)))
+    (make-unbound! . ,(lambda (exp env)
+                        (eval-unbind exp env lazy-eval)))
+    (quote .
+           ,(lambda (exp env)
+              (text-of-quotation exp)))
+    (lambda .
+      ,(lambda (exp env)
+         (make-procedure (lambda-parameters exp)
+                         (scan-out-defines (lambda-body exp))
+                         env)))
+    (cond .
+          ,(lambda (exp env)
+             (lazy-eval (cond->if exp) env)))
+    (and . ,(lambda (exp env)
+              (eval-and exp env lazy-eval)))
+    (or . ,(lambda (exp env)
+             (eval-or exp env lazy-eval)))
+    (let . ,(lambda (exp env)
+              (lazy-eval (let->combination exp) env)))
+    (let* . ,(lambda (exp env)
+               (lazy-eval (let*->nested-let exp) env)))
+    (letrec . ,(lambda (exp env)
+                 (lazy-eval (letrec->let exp) env)))
+    (for . ,(lambda (exp env)
+              (lazy-eval (for->named-let exp) env)))
+    (unless . ,(lambda (exp env)
+                 (lazy-eval (unless->if exp) env)))))
+
+;; Set up dispatch table from the alist
+(put-alist! dispatch-table lazy-dispatch-alist)
+
+;; Allow setting of dispatched procedures externally
+(define (lazy-put-dispatch! tag proc)
+  (put! dispatch-table tag proc))
 
 (define (lazy-eval exp env)
   (cond ((self-evaluating? exp) exp)
         ((variable? exp) (lookup-variable-value exp env))
-        ((quoted? exp) (text-of-quotation exp))
-        ((assignment? exp) (eval-assignment exp env lazy-eval))
-        ((definition? exp) (eval-definition exp env lazy-eval))
-        ((if? exp) (lazy-eval-if exp env))
-        ((lambda? exp)
-         (make-procedure (lambda-parameters exp)
-                         (lambda-body exp)
-                         env))
-        ((begin? exp) 
-         (eval-sequence (begin-actions exp) env lazy-eval))
-        ((cond? exp) (lazy-eval (cond->if exp) env))
+        ((get dispatch-table (type-tag exp))
+         => (lambda (proc) (proc exp env)))
         ((application? exp)             ; clause from book
          (lazy-apply (actual-value (operator exp) env)
                      (operands exp)
@@ -52,7 +97,10 @@
           (procedure-body procedure)
           (extend-environment
            (procedure-parameters procedure)
-           (list-of-delayed-args arguments env) ; changed
+           (list-of-qualified-args
+            arguments
+            (procedure-delays procedure)
+            env) ; changed
            (procedure-environment procedure))
           lazy-eval))
         (else
@@ -66,12 +114,18 @@
             (list-of-arg-values (rest-operands exps)
                                 env))))
 
-(define (list-of-delayed-args exps env)
+(define (list-of-qualified-args exps delays env)
   (if (no-operands? exps)
       '()
-      (cons (delay-it (first-operand exps) env)
-            (list-of-delayed-args (rest-operands exps)
-                                  env))))
+      (cons
+       (let ((delay (first-delay delays)))
+         (if (eq? delay 'strict)
+           (lazy-eval (first-operand exps) env)
+           (delay-it (first-operand exps) env delay)))
+       (list-of-qualified-args
+        (rest-operands exps)
+        (rest-delays delays)
+        env))))
 
 (define (lazy-eval-if exp env)
   (if (true? (actual-value (if-predicate exp) env))
@@ -98,20 +152,17 @@
 
 ;;; Representing thunks
 
-;; non-memoizing version of force-it
-
-;; (define (force-it obj)
-;;   (if (thunk? obj)
-;;       (actual-value (thunk-exp obj) (thunk-env obj))
-;;       obj))
-
-(define (delay-it exp env)
-  (make-thunk exp env))
-
-;; memoizing version of force-it
+(define (delay-it exp env method)
+  (cond ((eq? method 'lazy-memo)
+         (make-memo-thunk exp env))
+        ((eq? method 'lazy)
+         (make-thunk exp env))
+        (else
+         (error ("Unknown delay type -- DELAY-IT" method)))))
 
+;; memo-thunks created by are memoized on forcing. thunks are not.
 (define (force-it obj)
-  (cond ((thunk? obj)
+  (cond ((memo-thunk? obj)
          (let ((result (actual-value
                         (thunk-exp obj)
                         (thunk-env obj))))
@@ -121,7 +172,17 @@
            result))
         ((evaluated-thunk? obj)
          (thunk-value obj))
+        ((thunk? obj)
+         (actual-value
+          (thunk-exp obj)
+          (thunk-env obj)))
         (else obj)))
 
+(#%require (only racket/base module+))
+(module+ test
+  (#%require rackunit)
+  (define env (setup-environment))
+  (check-equal? (force-it (delay-it '(+ 1 1) env 'lazy)) 2)
+  (check-equal? (force-it (delay-it '(+ 1 1) env 'lazy-memo)) 2))
 
 'LAZY-EVALUATOR-LOADED

mceval/syntax.rkt

@@ -1,5 +1,7 @@
 #lang sicp
 
+(#%require racket/trace)
+
 (#%provide (all-defined))
 
 (define (self-evaluating? exp)
@@ -90,6 +92,11 @@
 (define (rest-operands ops) (cdr ops))
 (define (last-operand? ops) (null? (rest-operands ops)))
 
+(define (no-delays? ops) (null? ops))
+(define (first-delay ops) (car ops))
+(define (rest-delays ops) (cdr ops))
+(define (last-delay? ops) (null? (rest-delays ops)))
+
 ;; cond (including recipient clause for exercise 4.5)
 (define (cond? exp) (tagged-list? exp 'cond))
 (define (cond-clauses exp) (cdr exp))
@@ -318,16 +325,31 @@
            (unless-consequent exp)
            (unless-alternative exp)))
 
-(define (make-procedure parameters body env)
-  (list 'procedure parameters body env))
+;; Exercise 4.31: procedure parameters can be qualified by 'lazy or
+;; 'lazy-memo.  In either case, the parameter will be a 2-element list
+;; with the parameter name first and the delay second. Normal
+;; single-element parameters are taken to be strictly evaluated.
+(define (make-procedure qualified-parameters body env)
+  (define (parameter qualified-parameter)
+    (if (pair? qualified-parameter)
+        (car qualified-parameter)
+        qualified-parameter))
+  (define (delay qualified-parameter)
+    (if (pair? qualified-parameter)
+        (cadr qualified-parameter)
+        'strict))
+  (list 'procedure
+        (map parameter qualified-parameters)
+        (map delay qualified-parameters)
+        body env))
 
 (define (compound-procedure? p)
   (tagged-list? p 'procedure))
 
-
 (define (procedure-parameters p) (cadr p))
-(define (procedure-body p) (caddr p))
-(define (procedure-environment p) (cadddr p))
+(define (procedure-delays p) (caddr p))
+(define (procedure-body p) (cadddr p))
+(define (procedure-environment p) (car (cddddr p)))
 
 ;; Exercise 4.16: transform the body to scan out internal
 ;; definitions.  Variables will be created unassigned by a let and
@@ -382,13 +404,19 @@
 
 (define (make-thunk exp env)
   (list 'thunk exp env))
-
 (define (thunk? obj)
   (tagged-list? obj 'thunk))
-
 (define (thunk-exp thunk) (cadr thunk))
 (define (thunk-env thunk) (caddr thunk))
 
+;; thunk that should be memoized when forced
+(define (make-memo-thunk exp env)
+  (list 'memo-thunk exp env))
+(define (memo-thunk? obj)
+  (tagged-list? obj 'memo-thunk))
+(define memo-thunk-exp thunk-exp)
+(define memo-thunk-env thunk-env)
+
 ;; "thunk" that has been forced and is storing its (memoized) value
 (define (evaluated-thunk? obj)
   (tagged-list? obj 'evaluated-thunk))

mceval/test-eval.rkt

@@ -7,6 +7,9 @@
            "analyzing-mceval.rkt"
            "leval.rkt")
 
+(#%provide qualify-arg
+           time-proc)
+
 (#%require (only racket current-process-milliseconds))
 (#%require (only racket/base module+))
 
@@ -31,8 +34,16 @@
           (* n (fact (- n 1)))))
     (fact ,x)))
 
-(define (fib-program x)
-  `((define (fib n)
+
+(define (qualify-arg arg delay)
+  (cond ((eq? delay 'strict) arg)
+        ((eq? delay 'lazy) `(,arg lazy))
+        ((eq? delay 'lazy-memo) `(,arg lazy-memo))
+        (else (error "Unknown delay" delay))))
+
+(define (fib-program x delay)
+  `((define (fib
+             ,(qualify-arg 'n delay))
       (cond ((= n 0) 0)
             ((= n 1) 1)
             (else
@@ -40,8 +51,9 @@
                 (fib (- n 1))))))
     (fib ,x)))
 
-(define lazy-test-program
-  '((define (try a b)
+(define (lazy-test-program delay)
+  `((define (try a
+                 ,(qualify-arg 'b delay))
       (if (= a 0) 1 b))
     (try 0 (/ 1 0))))
 
@@ -56,21 +68,41 @@
   (check-equal? (lazy-eval-program (fact-program 5)) 120)
   (check-equal? (dd-eval-program (fact-program 10))
                 (analyzing-eval-program (fact-program 10)))
-  (check-equal? (dd-eval-program (fib-program 5))
-                (analyzing-eval-program (fib-program 5)))
-  (check-equal? (dd-eval-program (fib-program 5))
-                (lazy-eval-program (fib-program 5)))
-  (check-equal? (lazy-eval-program lazy-test-program) 1))
+  (check-equal? (dd-eval-program (fib-program 5 'strict))
+                (analyzing-eval-program (fib-program 5 'strict)))
+  (check-equal? (dd-eval-program (fib-program 5 'strict))
+                (lazy-eval-program (fib-program 5 'strict)))
+  (check-equal? (lazy-eval-program (fib-program 5 'strict))
+                (lazy-eval-program (fib-program 5 'lazy)))
+  (check-equal? (lazy-eval-program (fib-program 5 'strict))
+                (lazy-eval-program (fib-program 5 'lazy-memo)))
+  (check-equal? (lazy-eval-program (lazy-test-program 'lazy)) 1)
+  (check-equal? (lazy-eval-program (lazy-test-program 'lazy-memo)) 1))
 
 (module+ timing
-  (define dd-fib (time-proc 100 (lambda () (dd-eval-program (fib-program 10)))))
-  (define analyzing-fib (time-proc 100 (lambda () (analyzing-eval-program (fib-program 10)))))
-  (define dd-fact (time-proc 100 (lambda () (dd-eval-program (fact-program 50)))))
-  (define analyzing-fact (time-proc 100 (lambda () (analyzing-eval-program (fact-program 50)))))
+  (define dd-fib (time-proc 100 (lambda () (dd-eval-program
+                                            (fib-program 10 'strict)))))
+  (define analyzing-fib (time-proc 100 (lambda () (analyzing-eval-program
+                                                   (fib-program 10 'strict)))))
+  (define dd-fact (time-proc 100 (lambda () (dd-eval-program
+                                             (fact-program 50)))))
+  (define analyzing-fact (time-proc 100 (lambda () (analyzing-eval-program
+                                                    (fact-program 50)))))
 
-  (display `("Fib: dd " ,dd-fib " analyzing " ,analyzing-fib " speed-up " ,(/ dd-fib analyzing-fib)))
+  (define lazy-fib (time-proc 100 (lambda () (lazy-eval-program
+                                              (fib-program 10 'lazy)))))
+  (define lazy-memo-fib (time-proc 100 (lambda () (lazy-eval-program
+                                                   (fib-program 10 'lazy-memo)))))
+
+  (display `("Fib: dd " ,dd-fib " analyzing " ,analyzing-fib " speed-up "
+                        ,(/ dd-fib analyzing-fib)))
   (newline)
-  (display `("Fact: dd " ,dd-fact " analyzing " ,analyzing-fact " speed-up " ,(/ dd-fib analyzing-fact))))
+  (display `("Fact: dd " ,dd-fact " analyzing " ,analyzing-fact " speed-up "
+                         ,(/ dd-fib analyzing-fact)))
+  (newline)
+  (display `("Fib: lazy " ,lazy-fib " memoizing " ,lazy-memo-fib " speed-up "
+                          ,(/ lazy-fib lazy-memo-fib))))
+
 
 ;; Test results
 ;; test-eval.rkt> (time-proc 100 eval-program fib-program mce-eval mce-user-print)