I think the best solution is adding the label information for each instruction
at the time when the function "extract-labels" is called.
But too lazy to modify many basic functions and decide to add label information
when the machine is created and update/refer to the information in the function
"execute".
The approach to hand "GOTO (REG XXX)" is too dirty and hope to modify it
when have time.
比较好的解决方案应该是在EXTRACT-LABELS函数中给每个指令另外加上LABEL的信息。
但是对于懒得修改很多基本的函数。于是决定在make-machine中加上LABEL的信息，
之后在EXECUTE函数中参照并随时加以修改。
但是之前没有很好考虑处理GOTO (REG xxx)语句的情况，导致不得不根据指令反过来
判断LABEL。希望有时间再修改吧。
一番良い方法は多分、Extract-labels関数に各命令のラベル情報
も追加してあげて、Execute関数それらを出力する。
いくつかの基本関数を修正しなければならないので、気が遠くなったので、
代わりに、make-machineにラベル情報を追加し、Execute関数にそれらを
参照/更新するアプローチを取った。
但し、GOTO （REG xxx）のケースは考慮不足で、汚い処理になってしまった。
時間があるときに修正しようかな。
Execution image（実行イーメージ）
(set-register-contents! fm 'n 3)
;Value: done
(fm 'trace-on)
;Value: #f
(fm 'prepare-label-trace)
;Value: ()
(start fm)
(label: controller text: (assign continue (label fact-done)))
(label: controller text: (test (op =) (reg n) (const 1)))
(label: controller text: (branch (label base-case)))
(label: controller text: (save continue))
(label: controller text: (save n))
(label: controller text: (assign n (op -) (reg n) (const 1)))
(label: controller text: (assign continue (label after-fact)))
(label: controller text: (goto (label fact-loop)))
(label: fact-loop text: (test (op =) (reg n) (const 1)))
(label: fact-loop text: (branch (label base-case)))
(label: fact-loop text: (save continue))
(label: fact-loop text: (save n))
(label: fact-loop text: (assign n (op -) (reg n) (const 1)))
(label: fact-loop text: (assign continue (label after-fact)))
(label: fact-loop text: (goto (label fact-loop)))
(label: fact-loop text: (test (op =) (reg n) (const 1)))
(label: fact-loop text: (branch (label base-case)))
(label: base-case text: (assign val (const 1)))
(label: base-case text: (goto (reg continue)))
(label: after-fact text: (restore n))
(label: after-fact text: (restore continue))
(label: after-fact text: (assign val (op *) (reg n) (reg val)))
(label: after-fact text: (goto (reg continue)))
(label: after-fact text: (restore n))
(label: after-fact text: (restore continue))
(label: after-fact text: (assign val (op *) (reg n) (reg val)))
(label: after-fact text: (goto (reg continue)))
;Value: done
Simulator instructions used above（上記レジスタマシーンfmのコード）：
(define fm
(make-machine
'(n val continue)
(list (list '= =) (list '- -) (list '* *))
'(controller
(assign continue (label fact-done))
fact-loop
(test (op =) (reg n) (const 1))
(branch (label base-case))
(save continue)
(save n)
(assign n (op -) (reg n) (const 1))
(assign continue (label after-fact))
(goto (label fact-loop))
after-fact
(restore n)
(restore continue)
(assign val (op *) (reg n) (reg val))
(goto (reg continue))
base-case
(assign val (const 1))
(goto (reg continue))
fact-done)))
Functions modified and added in the implementation of the simulator machine
(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)
((machine 'install-labels) controller-text)
((machine 'install-instruction-sequence)
(assemble controller-text machine))
machine))
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(counter 0)
(trace-flg #f)
(the-labels '())
(current-label 'initial-label)
(current-label-counter 1)
(current-label-info '())) (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 (initialize-program-counter)
(set! counter 0))
(define (print-program-counter)
(newline)
(display (list 'program-counter= counter)))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(let ((text (instruction-text (car insts))))
(if (not (false? trace-flg))
(begin
(newline)
(display
(list 'label: (caar current-label-info) 'text: text))))
((instruction-execution-proc (car insts)))
(set! counter (+ counter 1))
(cond ((eq? (car text) 'goto)
(let ((goto-dest (cadr text)))
(if (eq? (car goto-dest) 'reg)
(set-label-info-cmds!
(map
(lambda (x) (car x))
(get-contents pc)))
(set-label-info! (cadr goto-dest)))))
((eq? (car text) 'branch)
(if (get-contents flag)
(set-label-info! (cadadr text))))
(else
(update-label-info! (+ current-label-counter 1))))
(execute)))))
(define (install-labels controller-text)
(define (iter seq symb counter seq-follow-symb)
(if (null? seq)
'()
(if (symbol? (car seq))
(cons (cons symb (cons counter seq-follow-symb))
(iter (cdr seq) (car seq) 0 (cdr seq)))
(iter (cdr seq) symb (+ counter 1) seq-follow-symb))))
(let ((insts (cdr controller-text)))
(iter insts (car controller-text) 0 insts)))
(define (prepare-label-trace!)
(set! current-label-info the-labels))
; (set! current-label (caar current-label-info)))
(define (update-label-info! counter)
(let ((label-counter (car current-label-info)))
(let ((counter-threshold (cadr label-counter)))
(if (= counter counter-threshold)
(begin
(set! current-label-info (cdr current-label-info))
(set! current-label-counter 1))
(set! current-label-counter counter)))))
(define (set-label-info! label)
(define (iter labels-info label-text)
(if (null? labels-info)
(set! current-label-info '())
(if (eq? (caar labels-info) label-text)
(set! current-label-info labels-info)
(iter (cdr labels-info) label-text))))
(iter the-labels label))
(define (set-label-info-cmds! seq)
(define (iter labels-info cmds)
(if (null? labels-info)
(set! current-label-info '())
(if (equal?
(filter
(lambda (x)
(not (symbol? x)))
(cddar labels-info))
cmds)
(set! current-label-info labels-info)
(iter (cdr labels-info) cmds))))
(iter the-labels seq))
(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 'print-program-counter)
(print-program-counter))
((eq? message 'initialize-program-counter)
(initialize-program-counter))
((eq? message 'trace-on)
(set! trace-flg #t))
((eq? message 'trace-off)
(set! trace-flg #f))
((eq? message 'install-labels)
(lambda (controller-text)
(set! the-labels
(install-labels controller-text))))
((eq? message 'prepare-label-trace)
(prepare-label-trace!))
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
No comments:
Post a Comment