Permalink
Browse files

Add solutions to 5.2.2-5.2.3

  • Loading branch information...
1 parent c693764 commit 72ee96daceee7e6ed02c223621f9cab730fa4ffe @fastred committed Jan 3, 2013
Showing with 612 additions and 0 deletions.
  1. +40 −0 5_08.scm
  2. +28 −0 5_09.scm
  3. +42 −0 5_10.scm
  4. +37 −0 5_11.scm
  5. +58 −0 5_13.scm
  6. +407 −0 ch5-regsim.scm
View
@@ -0,0 +1,40 @@
+(load "ch5-regsim.scm")
+
+; In current implementation register 'a' would contain value 3.
+
+(define (label-exists? labels label)
+ (memq label (map car labels)))
+(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)
+ (if (not (label-exists? labels next-inst))
+ (receive insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels))
+ (error "Label already exists -- EXTRACT-LABELS" next-inst))
+ (receive (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+
+(define machine
+ (make-machine
+ '(a)
+ (list (list '= =) (list '* *) (list '+ +) (list '- -))
+ '(
+ start
+ (goto (label here))
+ here
+ (assign a (const 3))
+ (goto (label there))
+ here
+ (assign a (const 4))
+ (goto (label there))
+ there)))
+
+(start machine)
+(get-register-contents machine 'a)
View
@@ -0,0 +1,28 @@
+(load "ch5-regsim.scm")
+(define (allowed-for-operation? exp)
+ (or (register-exp? exp) (constant-exp? exp)))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ (if (allowed-for-operation? e)
+ (make-primitive-exp e machine labels)
+ (error "Labels are not allowed in operations -- MAKE-OPERATION-EXP")))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+
+(define machine
+ (make-machine
+ '(a b)
+ (list (list '= =) (list '* *) (list '+ +) (list '- -))
+ '(
+ start
+ (assign b (const 2))
+ (assign a (op *) (const 2) (reg b))
+ (assign a (op *) (const 2) (label there))
+ there)))
+
+(start machine)
+(get-register-contents machine 'a)
+
View
@@ -0,0 +1,42 @@
+(load "ch5-regsim.scm")
+(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) 'jump)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'push)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'pop)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ ((eq? (car inst) 'nop)
+ (make-nop inst machine pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (label-exp? exp) (tagged-list? exp 'lab))
+
+(define (make-nop inst machine pc)
+ (lambda ()
+ (advance-pc pc)))
+
+(define machine
+ (make-machine
+ '(a b)
+ (list (list '= =) (list '* *) (list '+ +) (list '- -))
+ '(
+ start
+ (assign b (const 2))
+ (nop) ; new operation that doesn't do anything
+ (assign a (op *) (const 2) (reg b))
+ (jump (lab there)) ; changes in namings
+ (assign a (const 3))
+ there)))
+
+(start machine)
+(get-register-contents machine 'a)
View
@@ -0,0 +1,37 @@
+(load "ch5-regsim.scm")
+
+;a)
+;
+;We can replace:
+ ;(assign n (reg val)) ; n now contains Fib(n - 2)
+ ;(restore val) ; val now contains Fib(n - 1)
+;with:
+ ;(restore n)
+;Values stored in n and val are now switched, but it doesn't change value of val
+;computed at the end of this label.
+
+
+;b)
+
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst)))
+ (register-name (stack-inst-reg-name inst)))
+ (lambda ()
+ (push stack (cons register-name (get-contents reg)))
+ (advance-pc pc))))
+
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst)))
+ (register-name (stack-inst-reg-name inst)))
+ (lambda ()
+ (let ((saved-register (pop stack)))
+ (if (eq? (car saved-register) register-name)
+ (begin (set-contents! reg (cdr saved-register))
+ (advance-pc pc))
+ (error "Popped from stack into different register -- MAKE-RESTORE"))))))
+
+;c) It would be best to change 'make-stack' to return object acting as
+;a stacks' container. API of simulator wouldn't have to be much changed.
+;TODO
View
@@ -0,0 +1,58 @@
+(load "ch5-regsim.scm")
+
+(define (extract-register-name inst)
+ (cond ((symbol? inst) '())
+ ((eq? (car inst) 'assign)
+ (assign-reg-name inst))
+ ((or (eq? (car inst) 'save) (eq? (car inst) 'restore))
+ (stack-inst-reg-name inst))
+ ((eq? (car inst) 'goto)
+ (let ((dest (goto-dest inst)))
+ (if (register-exp? dest)
+ (register-exp-reg dest)
+ '())))
+ (else '())))
+(define (not-null? x)
+ (not (null? x)))
+(define (remove-duplicates l)
+ (do ((a '() (if (member (car l) a) a (cons (car l) a)))
+ (l l (cdr l)))
+ ((null? l) (reverse a))))
+(define (make-machine ops controller-text)
+ (let* ((machine (make-new-machine))
+ (registers-with-dups (filter not-null?
+ (map extract-register-name controller-text)))
+ (register-names (remove-duplicates registers-with-dups)))
+ (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 expt-machine-rec
+ (make-machine
+ (list (list '= =) (list '* *) (list '- -))
+ '((assign continue (label expt-done))
+ (assign n (const 2))
+ (assign b (const 4))
+ expt-loop
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (save continue)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-expt))
+ (goto (label expt-loop))
+ after-expt
+ (restore continue)
+ (assign val (op *) (reg b) (reg val))
+ (goto (reg continue))
+ base-case
+ (assign val (const 1))
+ (goto (reg continue))
+ expt-done)))
+(start expt-machine-rec)
+(get-register-contents expt-machine-rec 'val)
+
+
Oops, something went wrong.

0 comments on commit 72ee96d

Please sign in to comment.