ヤドカリ自習室(第二倉庫)

2009-12-16

[]問題5.15&問題5.16 08:03

;; レジスタ
(define (make-register name)
  (let ((contents '*unassigned*))
    (define (dispatch message)
      (cond ((eq? message 'get) contents)
            ((eq? message 'set) (lambda (value) (set! contents value)))
            (else (error "Unknown request -- REGISTER" message))))
    dispatch))

(define (get-contents register)
  (register 'get))

(define (set-contents! register value)
  ((register 'set) value))

;; スタック
(define (make-stack)
  (let ((s '())
        (number-pushes 0)
        (max-depth 0)
        (current-depth 0))
    (define (push x)
      (set! s (cons x s))
      (set! number-pushes (+ 1 number-pushes))
      (set! current-depth (+ 1 current-depth))
      (set! max-depth (max current-depth max-depth)))

    (define (pop)
      (if (null? s)
          (error "Empty stack -- POP")
          (let ((top (car s)))
            (set! s (cdr s))
            (set! current-depth (- current-depth 1))
            top)))

    (define (initialize)
      (set! s '())
      (set! number-pushes 0)
      (set! max-depth 0)
      (set! current-depth 0)
      'done)
 
    (define (print-statistics)
      (newline)
      (display (list 'total-pushes  '= number-pushes
                     'maximum-depth '= max-depth)))

    (define (dispatch message)
      (cond ((eq? message 'push)       push)
            ((eq? message 'pop)        (pop))
            ((eq? message 'initialize) (initialize))
            ((eq? message 'print-statistics)
             (print-statistics))
            (else
             (error "Unknown request -- STACK" message))))
    dispatch))

(define (pop stack)
  (stack 'pop))

(define (push stack value)
  ((stack 'push) value))

;; 基本計算機
(define (start machine)
  (machine 'start))

(define (get-register-contents machine register-name)
  (get-contents (get-register machine register-name)))

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

(define (get-register machine register-name)
  ((machine 'get-register) register-name))


;; 5.2.2 アセンブラ
(define (make-new-machine)
  (let ((pc (make-register 'pc))
	(flag (make-register 'flag))
	(stack (make-stack))
	(the-instruction-sequence '())
	(information '())
        (insts-count 0)
        (trace-on? #f))
    (let ((the-ops
	   (list (list 'initialize-stack
		       (lambda () (stack 'initialize)))
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))))
	  (register-table
	   (list (list 'pc pc) (list 'flag flag))))
 
      (define (allocate-register name)
	(if (assoc name register-table)
	    (error "Multiply 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
              (let ((inst (car insts)))
                ((instruction-execution-proc inst))
                (set! insts-count (+ insts-count 1))
                (if trace-on?
                    (begin (display (instruction-text inst))
                           (newline)))
                (execute)))))
      (define (get-goto-reg information)
        (define (iter info result)
          (if (null? info) result
              (if (and (eq? (caar info) 'goto)
                       (eq? (car (cadr (car info))) 'reg))
                  (iter (cdr info) (cons (cadr (cadr (car info))) result))
                  (iter (cdr info) result))))
        (iter information '()))
      (define (get-save-restore-reg information)
        (define (iter info result)
          (if (null? info) result
              (if (or (eq? (caar info) 'save)
                      (eq? (caar info) 'restore))
                  (iter (cdr info) (cons (cadr (car info)) result))
                  (iter (cdr info) result))))
        (remove-duplicates (iter information '())))
      (define (get-assign-source information)
        (define (iter info result)
          (if (null? info) result
              (if (eq? (caar info) 'assign)
                  (iter (cdr info)
                        (cons
                         (if (null? (cdddr (car info)))
                             (cdr (car info))
                             (list (cadr (car info)) (cddr (car info))))
                         result))
                  (iter (cdr info) result))))
        (iter information '()))
      (define (aggregate source)
        (map (lambda (r)
               (cons r
                     (map cadr
                          (filter (lambda (p) (eq? (car p) r)) source))))
             (remove-duplicates (map car source))))
      (define (dispatch message)
	(cond ((eq? message 'start)
	       (set-contents! pc the-instruction-sequence)
	       (execute))
	      ((eq? message 'install-instruction-sequence)
	       (lambda (seq) (set! the-instruction-sequence seq)))
	      ((eq? message 'allocate-register) allocate-register)
	      ((eq? message 'get-register) lookup-register)
	      ((eq? message 'install-operations)
	       (lambda (ops) (set! the-ops (append the-ops ops))))
	      ((eq? message 'stack) stack)
	      ((eq? message 'operations) the-ops)
	      ((eq? message 'install-information)
	       (lambda (info) (set! information (append information info))))
	      ((eq? message 'get-insts-info)
	       information)
              ((eq? message 'get-goto-reg-info)
               (get-goto-reg information))
              ((eq? message 'get-save-restore-reg-info)
               (get-save-restore-reg information))
              ((eq? message 'get-assign-source-info)
               (aggregate (get-assign-source information)))
              ((eq? message 'print-insts-count)
               (begin (display "instruction counting: ")
                      (display insts-count)
                      (set! insts-count 0)
                      (newline)
                      'cleared))
              ((eq? message 'trace-on)
               (set! trace-on? #t))
              ((eq? message 'trace-off)
               (set! trace-on? #f))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

(define (assemble controller-text machine)
  (extract-labels controller-text
    (lambda (insts labels)
      (update-insts! insts labels machine)
      (cons insts (make-information insts)))))

(define (make-machine register-names ops controller-text)
  (let ((machine (make-new-machine)))
    (for-each (lambda (register-name)
		((machine 'allocate-register) register-name))
	      register-names)
    ((machine 'install-operations) ops)
    (let ((assembled (assemble controller-text machine)))
      ((machine 'install-instruction-sequence)
       (car assembled))
      ((machine 'install-information)
       (cdr assembled)))
    machine))

(define (extract-labels text receive)
  (if (null? text)
      (receive '() '())
      (extract-labels
       (cdr text)
       (lambda (insts labels)
         (let ((next-inst (car text)))
           (if (symbol? next-inst)
               (receive insts
                        (cons (make-label-entry next-inst insts)
                              labels))
               (receive (cons (make-instruction next-inst)
                              insts)
                        labels)))))))

(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-instruction-execution-proc!
        inst
        (make-execution-procedure
         (instruction-text inst) labels machine
         pc flag stack ops)))
     insts)))

;; constructor for an instruction
(define (make-instruction text)
  (cons text '()))

;; selector(getter) for an instruction
(define (instruction-text inst)
  (car inst))

;; selector(getter) for an instruction
(define (instruction-execution-proc inst)
  (cdr inst))

;; setter for an instruction
(define (set-instruction-execution-proc! inst proc)
  (set-cdr! inst proc))

(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 -- ASSEMBLE" label-name))))

;; 5.2.3 命令の実行手続きの生成

(define (make-execution-procedure inst labels machine pc flag stack ops)
  (cond ((eq? (car inst) 'assign)
         (make-assign inst machine labels ops pc))

        ((eq? (car inst) 'test)
         (make-test inst machine labels ops flag pc))

        ((eq? (car inst) 'branch)
         (make-branch inst machine labels flag pc))

        ((eq? (car inst) 'goto)
         (make-goto inst machine labels pc))

        ((eq? (car inst) 'save)
         (make-save inst machine stack pc))

        ((eq? (car inst) 'restore)
         (make-restore inst machine stack pc))

        ((eq? (car inst) 'perform)
         (make-perform inst machine labels ops pc))

        (else
         (error "Unknown instruction type -- ASSEMBLE" inst))))


;; assign命令
(define (make-assign inst machine labels operations pc)
  (let ((target (get-register machine (assign-reg-name inst)))
        (value-exp (assign-value-exp inst)))
    (let ((value-proc
           (if (operation-exp? value-exp)
               (make-operation-exp value-exp machine labels operations)
               (make-primitive-exp (car value-exp) machine labels))))
      (lambda ()
        (set-contents! target (value-proc))
        (advance-pc pc)))))

(define (assign-reg-name assign-instruction)
  (cadr assign-instruction))

(define (assign-value-exp assign-instruction)
  (cddr assign-instruction))

(define (advance-pc pc)
  (set-contents! pc (cdr (get-contents pc)))) ; pc には命令列
                                              ; (the-instruction-sequence)
                                              ; が入ってる

;; test, branch および goto命令

(define (make-test inst machine labels operations flag pc)
  (let ((condition (test-condition inst)))
    (if (operation-exp? condition)
        (let ((condition-proc
               (make-operation-exp condition machine labels operations)))
          (lambda ()
            (set-contents! flag (condition-proc))
            (advance-pc pc)))
        (error "Bad TEST instruction -- ASSEMBLE" inst))))

(define (test-condition test-instruction)
  (cdr test-instruction))


(define (make-branch inst machine labels flag pc)
  (let ((dest (branch-dest inst)))
    (if (label-exp? dest)
        (let ((insts
               (lookup-label labels (label-exp-label dest))))
          (lambda ()
            (if (get-contents flag)
                (set-contents! pc insts)
                (advance-pc pc))))
        (error "Bad BRANCH instruction -- ASSEMBLE" inst))))

(define (branch-dest branch-instruction)
  (cadr branch-instruction))


(define (make-goto inst machine labels pc)
  (let ((dest (goto-dest inst)))
    (cond ((label-exp? dest)
           (let ((insts
                  (lookup-label labels (label-exp-label dest))))
             (lambda ()
               (set-contents! pc insts))))
          ((register-exp? dest)
           (let ((reg
                  (get-register machine (register-exp-reg dest))))
             (lambda ()
               (set-contents! pc (get-contents reg)))))
          (else
           (error "Bad GOTO instruction -- ASSEMBLE" inst)))))

(define (goto-dest goto-instruction)
  (cadr goto-instruction))


;; その他の命令
(define (make-save inst machine stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (push stack (get-contents reg))
      (advance-pc pc))))

(define (make-restore inst machine stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (set-contents! reg (pop stack))
      (advance-pc pc))))

(define (stack-inst-reg-name stack-instruction)
  (cadr stack-instruction))


(define (make-perform inst machine labels operations pc)
  (let ((action (perform-action inst)))
    (if (operation-exp? action)
        (let ((action-proc
               (make-operation-exp action machine labels operations)))
          (lambda ()
            (action-proc)
            (advance-pc pc)))
        (error "Bad PERFORM instruction -- ASSEMBLE" inst))))

(define (perform-action inst)
  (cdr inst))


;; 部分式の実行手続き
(define (make-primitive-exp exp machine labels)
  (cond ((constant-exp? exp)
         (let ((c (constant-exp-value exp)))
           (lambda () c)))

        ((label-exp? exp)
         (let ((insts
                (lookup-label labels
                              (label-exp-label exp))))
           (lambda () insts)))
        
        ((register-exp? exp)
         (let ((r
                (get-register machine
                              (register-exp-reg exp))))
           (lambda () (get-contents r))))

        (else (error "Unknown expression type -- ASSEMBLE" exp))))

(define (tagged-list? exp tag)
  (and (pair? exp)
       (eq? (car exp) tag)))

(define (register-exp? exp) (tagged-list? exp 'reg))
(define (register-exp-reg exp) (cadr exp))

(define (constant-exp? exp) (tagged-list? exp 'const))
(define (constant-exp-value exp) (cadr exp))

(define (label-exp? exp) (tagged-list? exp 'label))
(define (label-exp-label exp) (cadr exp))

(define (make-operation-exp exp machine labels operations)
  (let ((op (lookup-prim (operation-exp-op exp) operations))
        (aprocs
         (map (lambda (e)
                (make-primitive-exp e machine labels))
              (operation-exp-operands exp))))
    (lambda ()
      (apply op (map (lambda (p) (p)) aprocs)))))

(define (operation-exp? exp)
  (and (pair? exp) (tagged-list? (car exp) 'op)))
(define (operation-exp-op exp)
  (cadr (car exp)))
(define (operation-exp-operands exp)
  (cdr exp))

(define (lookup-prim symbol operations)
  (let ((val (assoc symbol operations)))
    (if val
        (cadr val)
        (error "Unknown operation -- ASSEMBLE" symbol))))

(define (filter pred lst)
  (cond ((null? lst) '())
        ((pred (car lst))
         (cons (car lst)
               (filter pred (cdr lst))))
        (else (filter pred (cdr lst)))))

(define (remove-duplicates lst)
  (define (iter lst result)
    (if (null? lst) result
        (if (member (car lst) (cdr lst))
            (iter (cdr lst) result)
            (iter (cdr lst) (cons (car lst) result)))))
  (iter lst '()))

(define (make-information insts)
  (let ((insts-text (map instruction-text insts)))
    (apply append
           (map
            (lambda (name)
              (remove-duplicates
               (filter
                (lambda (i) (eq? (car i) name))
                insts-text)))
            '(assign test branch goto save restore perform)))))

(define (get-insts-info machine)
  (machine 'get-insts-info))
(define (get-goto-reg-info machine)
  (machine 'get-goto-reg-info))
(define (get-save-restore-reg-info machine)
  (machine 'get-save-restore-reg-info))
(define (get-assign-source-info machine)
  (machine 'get-assign-source-info))
(define (print-insts-count machine)
  (machine 'print-insts-count))
(define (trace-on machine)
  (machine 'trace-on))
(define (trace-off machine)
  (machine 'trace-off))

(define fib-machine
  (make-machine
   '(n val continue)
   (list (list '< <) (list '- -) (list '+ +))
   '(
       (assign continue (label fib-done))
     fib-loop
       (test (op <) (reg n) (const 2))
       (branch (label immediate-answer))
       ;; set up to compute Fib(n - 1)
       (save continue)
       (assign continue (label afterfib-n-1))
       (save n)                           ; save old value of n
       (assign n (op -) (reg n) (const 1)); clobber n to n - 1
       (goto (label fib-loop))            ; perform recursive call
     afterfib-n-1                         ; upon return, val contains Fib(n - 1)
       (restore n)
       (restore continue)
       ;; set up to compute Fib(n - 2)
       (assign n (op -) (reg n) (const 2))
       (save continue)
       (assign continue (label afterfib-n-2))
       (save val)                         ; save Fib(n - 1)
       (goto (label fib-loop))
     afterfib-n-2                         ; upon return, val contains Fib(n - 2)
       (assign n (reg val))               ; n now contains Fib(n - 2)
       (restore val)                      ; val now contains Fib(n - 1)
       (restore continue)
       (assign val                        ;  Fib(n - 1) +  Fib(n - 2)
               (op +) (reg val) (reg n)) 
     (goto (reg continue))              ; return to caller, answer is in val
     immediate-answer
       (assign val (reg n))               ; base case:  Fib(n) = n
       (goto (reg continue))
     fib-done)))

(define (test-fib-machine)
  (set-register-contents! fib-machine 'n 5)
  (start fib-machine)
  (display (get-register-contents fib-machine 'val))
  (newline)
  (print-insts-count fib-machine))

(define (info-fib-machine)
  (display "instructions: ")
  (display (get-insts-info fib-machine))
  (newline) (newline)
  (display "label registers: ")
  (display (get-goto-reg-info fib-machine))
  (newline)  (newline)
  (display "stacked registers: ")
  (display (get-save-restore-reg-info fib-machine))
  (newline)  (newline)
  (display "assign sources: ")
  (display (get-assign-source-info fib-machine))
  (newline)
  'done)

;;(trace-on fib-machine)
;;(test-fib-machine)

bucbaiswlnbucbaiswln 2014/06/02 20:03 ibiwutjdq, <a href="http://www.jjmhoxwkbl.com/">yxkvgqsxix</a> , [url=http://www.uabyktuvph.com/]hvxifqveek[/url], http://www.kedrioqvum.com/ yxkvgqsxix

ChasPriodsChasPriods 2017/05/10 05:49 Levitra Costo In Farmacia Cialis 20 <a href=http://byuvaigranonile.com>viagra</a> Overdose Amoxicillin 3000 Mg Day Cialis 5 Mg Filmtabl 28 St

ゲスト



トラックバック - http://sicp.g.hatena.ne.jp/yad-EL/20091216