Implement 5.49

ex-5_45-49.scm

@@ -0,0 +1,178 @@
+(load "shared/util")
+(load "shared/sicp-load-eceval-compiler")
+(load "shared/sicp-compiler")
+
+(display "\nex-5.45 - factorial-stack-usage-comparison\n")
+
+;(compile-and-go
+; '(begin
+;    (define (factorial n)
+;      (if (= n 1)
+;        1
+;        (* (factorial (- n 1)) n)))
+;    (factorial 10)))
+
+; a.
+
+; | (factorial 10) | pushes | depth  |
+; | -------------- | ------ | ------ |
+; | machine        |     18 |     18 |
+; | compiled       |     56 |     29 |
+; | evaluator      |    310 |     35 |
+
+; | (factorial 20) | pushes | depth  |
+; | -------------- | ------ | ------ |
+; | machine        |     38 |     38 |
+; | compiled       |    116 |     59 |
+; | evaluator      |    630 |     65 |
+
+; pushes(compiled/machine) = 3
+; depth(compiled/machine) = 1.5
+
+; pushes(evaluator/compiled) = 5.5
+; depth(evaluator/compiled) = 1.2
+
+; b. Use special handling for primitive procedures from exercise 5.38.
+
+(display "[done]\n")
+
+(display "\nex-5.46 - fibo-stack-usage-comparison\n")
+
+;(compile-and-go
+; '(begin
+;    (define (fib n)
+;      (if (< n 2)
+;          n
+;          (+ (fib (- n 1)) (fib (- n 2)))))
+;    (fib 10)))
+
+; | (fib 10)       | pushes | depth  |
+; | -------------- | ------ | ------ |
+; | machine        |    264 |     18 |
+; | compiled       |    882 |     29 |
+; | evaluator      |   4950 |     53 |
+
+; | (fib 20)       | pushes | depth  |
+; | -------------- | ------ | ------ |
+; | machine        |  32835 |     38 |
+; | compiled       | 109452 |     59 |
+; | evaluator      | 612942 |    103 |
+
+(display "[done]\n")
+
+(display "\nex-5.47 - call-interpreted-from-compiled\n")
+
+(define (compile-procedure-call target linkage)
+  (let* ((primitive-branch (make-label 'primitive-branch))
+         (compiled-branch (make-label 'compiled-branch))
+         (interpreted-branch (make-label 'interpreted-branch))
+         (after-call (make-label 'after-call))
+         (compiled-linkage (if (eq? linkage 'next) after-call linkage))
+         (compiled-test-primitive
+           (make-instruction-sequence
+             '(proc) '()
+             `((test (op primitive-procedure?) (reg proc))
+               (branch (label ,primitive-branch)))))
+         (compiled-test-procedure
+           (make-instruction-sequence
+             '(proc) '()
+             `((test (op compiled-procedure?) (reg proc))
+               (branch (label ,compiled-branch)))))
+         (compiled-interpreted-branch
+           (append-instruction-sequences
+             interpreted-branch
+             (compile-intp-appl target compiled-linkage)))
+         (compiled-compiled-branch
+           (append-instruction-sequences
+             compiled-branch
+             (compile-proc-appl target compiled-linkage)))
+         (compiled-primitive-branch
+           (append-instruction-sequences
+             primitive-branch
+             (end-with-linkage
+               linkage
+               (make-instruction-sequence
+                 '(proc argl) (list target)
+                 `((assign ,target (op apply-primitive-procedure) (reg proc) (reg argl))))))))
+      (append-instruction-sequences
+        compiled-test-primitive
+       (append-instruction-sequences
+         compiled-test-procedure
+         (parallel-instruction-sequences
+           compiled-interpreted-branch
+           (parallel-instruction-sequences
+             compiled-compiled-branch
+             compiled-primitive-branch)))
+       after-call)))
+
+(define (compile-intp-appl target linkage)
+  (cond ((and (eq? target 'val) (not (eq? linkage 'return)))
+         (make-instruction-sequence
+           '(proc) all-regs
+           `((save continue)
+             (assign continue (label ,linkage))
+             (save continue)
+             (goto (reg compapp)))))
+        ((and (not (eq? target 'val)) (not (eq? linkage 'return)))
+         (let ((proc-return (make-label 'proc-return)))
+           (make-instruction-sequence '(proc) all-regs
+            `((save continue)
+              (assign continue (label ,proc-return))
+              (save continue)
+              (goto (reg compapp))
+              ,proc-return
+              (assign ,target (reg val))
+              (goto (label ,linkage))))))
+        ((and (eq? target 'val) (eq? linkage 'return))
+         (make-instruction-sequence
+           '(proc) all-regs
+           `((save continue)
+             (goto (reg compapp)))))
+        (else (error "unsupported target linkage -- COMPILE-INTP-APPL"
+                     (list target linkage)))))
+
+(define expression
+  '(begin
+     (define (f n)
+       (g n))
+     (define (factorial n)
+       (if (= n 1)
+         1
+         (* (factorial (- n 1)) n)))))
+
+; (compile-to-file expression 'val 'return "f-call-interpreted.scm")
+;; Requires compile-to-file from ex-5_3_31-38.scm
+
+; (compile-and-go expression)
+;; To test this exercise uncomment the previous line, then:
+;; $ mit-scheme
+;; 1 ]=> (load "ex-5_45-49")
+;; 2 ]=> (define (g n) (* n n n))
+;; 3 ]=> (f 3) ; calls interpreted 'g'
+
+(display "[done]\n")
+
+(display "\nex-5.48 - compile-and-run\n")
+
+;; compile-and-go is implemented in sicp-eceval-compiler.scm
+; (start-eceval)
+;; To test this exercise uncomment the previous line, then:
+;; $ mit-scheme
+;; 1 ]=> (load "ex-5_45-49")
+;; 2 ]=> (compile-and-run (define (f n) (if (= n 1) 1 (* n (f (- n 1))))))
+;; 3 ]=> (f 5)
+
+(display "[done]\n")
+
+(display "\nex-5.49 - read-compile-execute-print\n")
+
+; Changing the loop to read-compile-execute requies a single additional line
+; within the read-eval-print-loop. If we add a compile-and-run tag to the
+; expression eval-dispatch automatically dispatches to the compiler.
+
+; (assign exp (op list) (const compile-and-run) (reg exp))
+;; read-compile-execute - ex-5.49
+;; Implemented in sicp-eceval-compiler.scm
+
+(display "[done]\n")
+