diff options
Diffstat (limited to 'chap5/part3.rkt')
| -rw-r--r-- | chap5/part3.rkt | 219 |
1 files changed, 219 insertions, 0 deletions
diff --git a/chap5/part3.rkt b/chap5/part3.rkt new file mode 100644 index 0000000..2fad35d --- /dev/null +++ b/chap5/part3.rkt @@ -0,0 +1,219 @@ +#lang sicp +(#%require (only racket/base print-as-expression print-mpair-curly-braces)) +(print-as-expression #f) +(print-mpair-curly-braces #f) + +;; Chapter 5 +;; Computing with Register Machines + +;; 5.3 +;; Storage Allocation and Garbage Collection + +;; Memory as Vectors + +#| 5.20 |# + +#| (define x (cons 1 2)) |# +#| (define y (list x x)) |# + +#| | 0 | 1 | 2 | 3 | 4 | |# +#| ---------|----|----|----|----|----| |# +#| the-cars | n1 | p0 | p0 | |# +#| the-cdrs | n2 | e0 | p1 | |# + +#| x = p0 |# +#| y = p2 |# +#| free = 3 |# + +#| 5.21 |# + +(define (count-leaves tree) + (cond + ((null? tree) 0) + ((not (pair? tree)) 1) + (else + (+ + (count-leaves (car tree)) + (count-leaves (cdr tree)))))) + +(define count-leaves-controller + '(controller + (assign continue (label count-leaves-done)) + (assign tree (op read)) + count-leaves + (test (op null?) (reg tree)) + (branch (label if-null)) + (assign t (op pair?) (reg tree)) + (test (op not) (reg t)) + (branch (label if-leaf)) + (save continue) + (save tree) + (assign continue (label after-car-tree)) + (assign tree (op car) (reg tree)) + (goto (label count-leaves)) + after-car-tree + (restore tree) + (save tree) + (save val) + (assign tree (op cdr) (reg tree)) + (assign continue (label after-cdr-tree)) + (goto (label count-leaves)) + after-cdr-tree + (assign t (reg val)) + (restore val) + (restore tree) + (restore continue) + (assign val (op +) (reg t) (reg val)) + (goto (reg continue)) + if-null + (assign val (const 0)) + (goto (reg continue)) + if-leaf + (assign val (const 1)) + (goto (reg continue)) + count-leaves-done)) + +(define (count-leaves- tree) + (define (count-iter tree n) + (cond + ((null? tree) n) + ((not (pair? tree)) (+ n 1)) + (else + (count-iter + (cdr tree) + (count-iter (car tree) n))))) + (count-iter tree 0)) + +(define count-leaves-iter-controller + '(controller + (assign continue (label count-leaves-done)) + (assign tree (op read)) + (assign n (const 0)) + count-iter + (test (op null?) (reg tree)) + (branch (label if-null)) + (assign t (op pair?) (reg tree)) + (test (op not) (reg t)) + (branch (label if-leaf)) + (save tree) + (save continue) + (assign tree (car tree)) + (assign continue (label after-car-tree)) + (goto (label count-iter)) + after-car-tree + (restore continue) + (restore tree) + (assign tree (cdr tree)) + (goto (label count-iter)) + if-null + (goto (reg continue)) + if-leaf + (assign n (op +) (reg n) (const 1)) + (goto (reg continue)) + count-leaves-done)) + +#| 5.22 |# + +(define (append x y) + (if (null? x) + y + (cons (car x) (append (cdr x) y)))) + +(define append-controller + '(controller + (assign x (op read)) + (assign y (op read)) + (assign continue (label append-done)) + append + (test (op null?) (reg x)) + (branch (label if-null)) + (save x) + (save continue) + (assign x (op cdr) (reg x)) + (assign continue (label after-append)) + (goto (label append)) + after-append + (restore continue) + (restore x) + (assign x (op car) (reg x)) + (assign val (op cons) (reg x) (reg val)) + (goto (reg continue)) + if-null + (assign val (reg y)) + (goto (reg continue)) + append-done)) + +(#%provide append!) +(define (append! x y) + (set-cdr! (last-pair x) y) + x) + +(define append!-controller + '(controller + (assign x (op read)) + (assign y (op read)) + (assign head (reg x)) + (assign rest (op cdr) (reg x)) + last-pair + (test (op null?) (reg rest)) + (branch (label found-last-pair)) + (assign head (reg rest)) + (assign rest (op cdr) (reg rest)) + (goto (label last-pair)) + found-last-pair + (perform (op set-cdr!) (reg head) (reg y)))) + +;; Maintaining the Illusion of Infinite Memory + +(define gc-controller + '(begin-garbage-collection + (assign free (const 0)) + (assign scan (const 0)) + (assign old (reg root)) + (assign relocate-continue (label reassign-root)) + (goto (label relocate-old-result-in-new)) + reassign-root + (assign root (reg new)) + (goto (label gc-loop)) + gc-loop + (test (op =) (reg scan) (reg free)) + (branch (label gc-flip)) + (assign old (op vector-ref) (reg new-cars) (reg scan)) + (assign relocate-continue (label update-car)) + (goto (label relocate-old-result-in-new)) + update-car + (perform (op vector-set!) (reg new-cars) (reg scan) (reg new)) + (assign old (op vector-ref) (reg new-cdrs) (reg scan)) + (assign relocate-continue (label update-cdr)) + (goto (label relocate-old-result-in-new)) + update-cdr + (perform (op vector-set!) (reg new-cdrs) (reg scan) (reg new)) + (assign scan (op +) (reg scan) (const 1)) + (goto (label gc-loop)) + relocate-old-result-in-new + (test (op pointer-to-pair?) (reg old)) + (branch (label pair)) + (assign new (reg old)) + (goto (reg relocate-continue)) + pair + (assign oldcr (op vector-ref) (reg the-cars) (reg old)) + (test (op broken-heart?) (reg oldcr)) + (branch (label already-moved)) + (assign new (reg free)) + (assign free (op +) (reg free) (const 1)) + (perform (op vector-set!) (reg new-cars) (reg new) (reg olcr)) + (assign oldcr (op vector-ref) (reg the-cdrs) (reg old)) + (perform (op vector-set!) (reg new-cdrs) (reg new) (reg olcr)) + (perform (op vector-set!) (reg the-cars) (reg old) (const broken-heart)) + (perform (op vector-set!) (reg the-cdrs) (reg old) (reg new)) + (goto (reg relocate-continue)) + already-moved + (assign new (op vector-ref) (reg the-cdrs) (reg old)) + (goto (reg relocate-continue)) + gc-flip + (assign temp (reg the-cdrs)) + (assign the-cdrs (reg new-cdrs)) + (assign new-cdrs (reg temp)) + (assign temp (reg the-cars)) + (assign the-cars (reg new-cars)) + (assign new-cars (reg temp)))) |