Structure and Interpretation of Computer Programs

(define loop
  (lambda () (loop)))
(define test
  (lambda (x y)
    (cond ((zero? x) 0)
          (else y))))
(test 0 (loop))

(define foo
  (lambda (x . ls)
    (+ x (apply max ls))))
(display (foo 1 2 3 4)) ; 1 + (max 2 3 4) = 5

(define-syntax delay
  (syntax-rules ()
    ((delay exp)
      (lambda () exp))))
(define force
  (lambda (delayed) (delayed)))

;; an example
(define x (delay (begin
                   (display "hello")
                   (newline))))
(force x)

(define-syntax s-cons
  (syntax-rules ()
    ((s-cons x y) (cons x (delay y)))))
(define s-car
  (lambda (s) (car s)))
(define s-cdr
  (lambda (s) (force (cdr s))))
(define s-map
  (lambda (f . ss)
    (s-cons (apply f (map s-car ss))
            (apply s-map (cons f (map s-cdr ss))))))
(define s-nth
  (lambda (n s)
    (let recur ((n n) (s s))
      (cond
        ((zero? n) (s-car s))
        (else (recur (- n 1) (s-cdr s)))))))

(define fibs
  (s-cons 1 (s-cons 1 (s-map + fibs (s-cdr fibs)))))
(display (s-nth 30 fibs))

(define memorize
  (lambda (f)
    (let ((already? #f) (cache #f))
      (lambda ()
        (cond
         (already? cache)
         (else (begin
                 (set! already? #t)
                 (set! cache (f))
                 cache)))))))
(define-syntax delay
  (syntax-rules ()
    ((delay exp)
     (memorize
      (lambda () exp)))))

;; ----- registers -----
(define (make-register name)
  (let ((content 'nil))
    (define (dispatch message)
      (cond
       ((eq? message 'get) content)
       ((eq? message 'set) (lambda (value) (set! content value)))
       (else (error "unknown request on register:" message))))
    dispatch))
(define (get-contents register) (register 'get))
(define (set-contents! register value) ((register 'set) value) 'done)

;; ----- stack -----
(define (make-stack)
  (let ((s '()))
    (define (push x) (set! s (cons x s)) 'done)
    (define (pop) (if (null? s)
                      (error "pop stack: empty!")
                      (let ((top (car s)))
                        (set! s (cdr s))
                        top)))
    (define (init) (set! s '()) 'done)
    (define (dispatch message)
      (cond
       ((eq? message 'push) push)
       ((eq? message 'pop) pop)
       ((eq? message 'init) init)
       (else (error "unknonw request on stack:" message))))
    dispatch))
(define (pop stack) (stack 'pop))
(define (push stack value) ((stack 'push) value))

;;; ----- machine -----
(define (make-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (inst-sequences '()))
    (let ((ops `((init-stack ,(lambda () (stack 'init)))))
          (register-table `((pc ,pc) (flag ,flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "multiple defined register:" name)
            (set! register-table
                  (cons (list name (make-register name)) register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "unknown register:" name))))
      (define (execute) ;; 开始运行
        (let ((insts (get-contents pc)))
          (if (null? insts) 'done
              (begin
                ((inst-execute-proc (car insts))) ; update pc internally
                (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc inst-sequences)
               (execute))
              ((eq? message 'install-inst-sequences)
               (lambda (aseqs) (set! inst-sequences aseqs)))
              ((eq? message 'install-operations)
               (lambda (aops) (set! ops (append aops ops))))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'stack) stack)
              ((eq? message 'operations) ops)
              (else (error "unknown request on machine:" message))))
      dispatch)))

(define (start machine) (machine 'start))
(define (get-register machine reg-name) ((machine 'get-register) reg-name))
(define (get-register-contents machine reg-name) (get-contents (get-register machine reg-name)))
(define (set-register-contents! machine reg-name value) (set-contents! (get-register machine reg-name) value))

(define (new-machine register-names ops controller-text)
  (let ((machine (make-machine)))
    (for-each (lambda (register-name)
                ((machine 'allocate-register) register-name))
              register-names)
    ((machine 'install-operations) ops)
    ((machine 'install-inst-sequences)
     ;; 安装汇编程序处理之后的指令
     (assemble controller-text machine))
    machine))

(define (assemble controller-text machine)
  (extract-labels controller-text
                  ;; 这里用到了continuation.
                  ;; 抽取指令和标签
                  (lambda (insts labels)
                    (update-insts! insts labels machine)
                    insts)))

;; 指令格式(text, proc).
(define (update-insts! insts labels machine)
  (let ((pc (get-register machine 'pc))
        (flag (get-register machine 'flag))
        (stack (machine 'stack))
        (ops (machine 'operations)))
    (for-each (lambda (inst)
                (set-inst-execute-proc!
                 inst
                 ;; inst->proc
                 (make-inst-execute-proc
                  (inst-text inst) labels machine
                  pc flag stack ops)))
              insts)
    'done))
(define (make-inst text) (cons text '()))
(define (inst-text inst) (car inst))
(define (inst-execute-proc inst) (cdr inst))
(define (set-inst-execute-proc! inst proc) (set-cdr! inst proc) 'done)
(define (advance-pc pc)
  ;; 这里(get-contents pc) = inst-sequences.
  (set-contents! pc (cdr (get-contents pc))))

;; 标签和指令对应关系
(define (make-label-entry label-name insts) (cons label-name insts))
(define (lookup-label labels label-name)
  (let ((val (assoc label-name labels)))
    (if val (cdr val) (error "undefined label:" label-name))))

(define (extract-labels text cont)
  (if ((null? text) (cont '() '()))
      (extract-labels
       (cdr text)
       (lambda (insts labels)
         (let ((next-inst (car text)))
           (if (symbol? next-inst)
               ;; 如果是branch的话，那么将branch和下面一条指令关联起来
               (cont insts (cons (make-label-entry next-inst insts) labels))
               (cont (cons (make-inst next-inst) insts) labels)))))))

typedef struct memory_cell {
    char mark; // if it's already moved.
    struct memory_cell* back; // if moved, what's the new cell.
    T value;
    struct memory_cell* refs[10]; // references.
} memory_cell_t;

typedef struct memory {
    int free;
    int scan;
    memory_cell_t array[10000];
} memory_t;

memory_cell_t* do_copy(memory_t* mem, memory_cell_t* mc) {
    memory_cell_t* av = mem->array + mem->free;
    mempcy(av, mc, sizeof(*mc));
    mc->mark = 1; // mark moved already.
    mc->back = av; // store new memory cell.
    mem->free += 1; // increase free pointer.
    return av;
}

void stop_and_copy(memory_t* new_mem, memory_cell_t* root) {
    new_mem->free = new_mem->scan = 0;
    do_copy(new_mem, root);

    while (new_mem->scan < new_mem->free) {
        memory_cell_t* mc = new_mem->array + mew_mem->scan;
        // mc is in new arena, but we are not sure if its references are.
        for(int i = 0; i < 10; i++) {
            memory_cell_t* ref = mc->refs[i];
            if (!ref) break;
            memory_cell_t* nref = 0;
            if (ref->mark == 1) { // already copied.
                nref = ref->back;
            } else {
                nref = do_copy(new_mem, ref);
            }
            mc->refs[i] = nref;
        }
        scan += 1;
    }
}

scheme@(guile-user)> `(a b ,(+ 1 2) d)
$1 = (a b 3 d)
scheme@(guile-user)> `(a b (+ 1 2) d)
$2 = (a b (+ 1 2) d)

(define make-inst-sequence
  (lambda (needs modifies statements)
    (list needs modifies statements)))
(define (empty-inst-sequence)
  (make-inst-sequence '() '() '()))
;; symbol? 来处理<branch>这样的指令序列
(define (registers-needed s) (if (symbol? s) '() (car s)))
(define (registers-modified s) (if (symbol? s) '() (cadr s)))
(define (statements s) (if (symbol? s) (list s) (caddr s)))
(define (needs-register? s reg) (memq reg (registers-needed s)))
(define (modifies-register? s reg) (memq reg (registers-modified s)))

(define (list-union s1 s2)
  (cond
   ((null? s1) s2)
   ((memq (car s1) s2) (list-union (cdr s1) s2))
   (else (cons (car s1) (list-union (cdr s1) s2)))))
(define (list-diff s1 s2)
  (cond
   ((null? s1) '())
   ((memq (car s1) s2) (list-diff (cdr s1) s2))
   (else (cons (car s1) (list-diff (cdr s1) s2)))))

(define (append-inst-sequences . seqs)
  (define (append-2-sequences seq1 seq2)
    (make-inst-sequence
     ;; seq1 needed + (seq2 needed - seq1 modified)
     (list-union (registers-needed seq1)
                 (list-diff (registers-needed seq2)
                            (registers-modified seq1)))
     ;; seq1 modified + seq2 modified
     (list-union (registers-modified seq1)
                 (registers-modified seq2))
     (append (statements seq1) (statements seq2))))
  (define (append-seq-list seqs)
    (if (null? seqs) (empty-inst-sequence)
        (append-2-sequences (car seqs) (append-seq-list (cdr seqs)))))
  (append-seq-list seqs))

(define (preserving regs seq1 seq2)
  (if (null? regs)
      (append-inst-sequences seq1 seq2)
      (let ((first-reg (car regs)))
        (if (and (needs-register? seq2 first-reg)
                 (modifies-register? seq1 first-reg))
            (preserving
             (cdr regs)
             (make-inst-sequence
              ;; 为什么生成这个指令序列？可以看看这个指令序列的statements部分
              (list-union (list first-reg)
                          (registers-needed seq1))
              (list-diff (registers-modified seq1)
                         (list first-reg))
              (append `((save ,first-reg))
                      (statements seq1)
                      `((restore ,first-reg))))
             seq2)
            (preserving (cdr regs) seq1 seq2)))))

(define (compile-linkage linkage)
  (cond ((eq? linkage 'return)
         (make-inst-sequence
          '(continue) '() '((goto (reg continue)))))
        ((eq? linkage 'next) (empty-inst-sequence))
        (else (make-inst-sequence '() '() `((goto (label ,linkage)))))))
(define (end-with-linkage linkage inst-sequences)
  (preserving '(continue)
              inst-sequences
              (compile-linkage linkage)))