465 lines
15 KiB
Scheme
465 lines
15 KiB
Scheme
;;;;REGISTER-MACHINE SIMULATOR FROM SECTION 5.2 OF
|
|
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
|
|
|
|
;;;;Matches code in ch5.scm
|
|
|
|
;;;;This file can be loaded into Scheme as a whole.
|
|
;;;;Then you can define and simulate machines as shown in section 5.2
|
|
|
|
;;;**NB** there are two versions of make-stack below.
|
|
;;; Choose the monitored or unmonitored one by reordering them to put the
|
|
;;; one you want last, or by commenting one of them out.
|
|
;;; Also, comment in/out the print-stack-statistics op in make-new-machine
|
|
;;; To find this stack code below, look for comments with **
|
|
|
|
|
|
(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-instruction-sequence)
|
|
(assemble controller-text machine))
|
|
machine))
|
|
|
|
(define (make-register name)
|
|
(let ((contents '*unassigned*)
|
|
(trace #f))
|
|
(define (set value)
|
|
(if trace
|
|
(begin
|
|
(display "set! ") (display name)
|
|
(display " from ") (display contents)
|
|
(display " to ") (display value) (newline)))
|
|
(set! contents value))
|
|
(define (dispatch message)
|
|
(cond ((eq? message 'get) contents)
|
|
((eq? message 'set) set)
|
|
((eq? message 'name?) name)
|
|
((eq? message 'trace-on) (set! trace #t))
|
|
((eq? message 'trace-off) (set! trace #f))
|
|
(else
|
|
(error "Unknown request -- REGISTER" message))))
|
|
dispatch))
|
|
|
|
(define (get-contents register)
|
|
(register 'get))
|
|
|
|
(define (set-contents! register value)
|
|
((register 'set) value))
|
|
|
|
;;**original (unmonitored) version from section 5.2.1
|
|
(define (make-stack)
|
|
(let ((s '()))
|
|
(define (push x)
|
|
(set! s (cons x s)))
|
|
(define (pop)
|
|
(if (null? s)
|
|
(error "Empty stack -- POP")
|
|
(let ((top (car s)))
|
|
(set! s (cdr s))
|
|
top)))
|
|
(define (initialize)
|
|
(set! s '())
|
|
'done)
|
|
(define (dispatch message)
|
|
(cond ((eq? message 'push) push)
|
|
((eq? message 'pop) (pop))
|
|
((eq? message 'initialize) (initialize))
|
|
(else (error "Unknown request -- STACK"
|
|
message))))
|
|
dispatch))
|
|
|
|
(define (pop stack)
|
|
(stack 'pop))
|
|
|
|
(define (push stack value)
|
|
((stack 'push) value))
|
|
|
|
;;**monitored version from section 5.2.4
|
|
(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 (make-new-machine)
|
|
(let ((pc (make-register 'pc))
|
|
(flag (make-register 'flag))
|
|
(stack (make-stack))
|
|
(instruction-count 0)
|
|
(instruction-trace #f)
|
|
(breakpoints '())
|
|
(location (list 'none 0))
|
|
(proceed #f)
|
|
(the-instruction-sequence '()))
|
|
(let ((the-ops
|
|
(list (list 'initialize-stack
|
|
(lambda () (stack 'initialize)))
|
|
;;**next for monitored stack (as in section 5.2.4)
|
|
;; -- comment out if not wanted
|
|
(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 (update-location inst-text)
|
|
(if (eq? (car inst-text) 'label)
|
|
(set! location (list (cadr inst-text) 0))
|
|
(set-cdr! location (list (+ (cadr location) 1)))))
|
|
(define (execute)
|
|
(let ((insts (get-contents pc)))
|
|
(if (null? insts)
|
|
'done
|
|
(begin
|
|
(update-location (instruction-text (car insts)))
|
|
(if (and (member location breakpoints)
|
|
(not proceed))
|
|
(begin
|
|
(display "stopped @ ")
|
|
(display (instruction-text (car insts)))
|
|
(newline))
|
|
(begin
|
|
(set! proceed #f)
|
|
((instruction-execution-proc (car insts)))
|
|
(if instruction-trace
|
|
(begin
|
|
(display (instruction-text (car insts)))
|
|
(newline)))
|
|
(if (not (eq? 'label (car (instruction-text (car insts)))))
|
|
(set! instruction-count (+ instruction-count 1)))
|
|
(execute)))))))
|
|
(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 'instruction-count) instruction-count)
|
|
((eq? message 'reset-instruction-acount)
|
|
(set! instruction-count 0) 'ok)
|
|
((eq? message 'trace-on) (set! instruction-trace #t) 'ok)
|
|
((eq? message 'trace-off) (set! instruction-trace #f) 'ok)
|
|
((eq? message 'trace-on-reg)
|
|
(lambda (reg-name) ((lookup-register reg-name) 'trace-on)))
|
|
((eq? message 'trace-off-reg)
|
|
(lambda (reg-name) ((lookup-register reg-name) 'trace-off)))
|
|
((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 'set-breakpoint)
|
|
(lambda (label count) (set! breakpoints (cons (list label count) breakpoints))))
|
|
((eq? message 'cancel-breakpoint)
|
|
(lambda (label count) (set! breakpoints (delete (list label count) breakpoints))))
|
|
((eq? message 'proceed)
|
|
(set! proceed #t) (execute))
|
|
((eq? message 'cancel-all-breakpoints) (set! breakpoints '()))
|
|
((eq? message 'stack) stack)
|
|
((eq? message 'operations) the-ops)
|
|
(else (error "Unknown request -- MACHINE" message))))
|
|
dispatch)))
|
|
|
|
|
|
(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 reg-name)
|
|
((machine 'get-register) reg-name))
|
|
|
|
(define (assemble controller-text machine)
|
|
(extract-labels controller-text
|
|
(lambda (insts labels)
|
|
(update-insts! insts labels machine)
|
|
insts)))
|
|
|
|
(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)
|
|
(begin
|
|
(set! insts (cons (make-instruction (list 'label next-inst)) insts))
|
|
(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)))
|
|
|
|
(define (make-instruction text)
|
|
(cons text '()))
|
|
|
|
(define (instruction-text inst)
|
|
(car inst))
|
|
|
|
(define (instruction-execution-proc inst)
|
|
(cdr inst))
|
|
|
|
(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))))
|
|
|
|
|
|
(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) 'label)
|
|
(make-label pc))
|
|
((eq? (car inst) 'perform)
|
|
(make-perform inst machine labels ops pc))
|
|
((eq? (car inst) 'inc)
|
|
(make-inc inst machine labels ops pc))
|
|
(else (error "Unknown instruction type -- ASSEMBLE"
|
|
inst))))
|
|
|
|
(define (make-label pc)
|
|
(lambda () (advance-pc pc)))
|
|
|
|
(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 () ; execution procedure for assign
|
|
(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))))
|
|
|
|
(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 (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 operation-exp)
|
|
(cadr (car operation-exp)))
|
|
(define (operation-exp-operands operation-exp)
|
|
(cdr operation-exp))
|
|
|
|
|
|
(define (lookup-prim symbol operations)
|
|
(let ((val (assoc symbol operations)))
|
|
(if val
|
|
(cadr val)
|
|
(error "Unknown operation -- ASSEMBLE" symbol))))
|
|
|
|
;; from 4.1
|
|
(define (tagged-list? exp tag)
|
|
(if (pair? exp)
|
|
(eq? (car exp) tag)
|
|
false))
|
|
|
|
'(REGISTER SIMULATOR LOADED)
|