Chapter 5, Computing with Register Machines
Exercise 5.42
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
(define (compile-variable exp target linkage cenv)
(let ((lex-addr (find-variable exp cenv)))
(end-with-linkage linkage
(make-instruction-sequence
'(env) (list target)
(if (eq? lex-addr 'not-found)
`((assign ,target
(op lookup-variable-value)
(const ,exp)
(reg env)))
`((assign ,target
(op lexical-address-lookup)
(const ,lex-addr)
(reg env))))))))
(define (compile-assignment exp target linkage cenv)
(let ((var (assignment-variable exp))
(get-value-code
(compile (assignment-value exp) 'val 'next cenv)))
(let ((lex-addr (find-variable var cenv)))
(end-with-linkage
linkage
(preserving
'(env)
get-value-code
(make-instruction-sequence
'(env val)
(list target)
(if (eq? lex-addr 'not-found)
`((perform (op set-variable-value!)
(const ,var)
(reg val)
(reg env))
(assign ,target (const ok)))
`((perform (op lexical-address-set!)
(const ,lex-addr)
(reg val)
(reg env))
(assign ,target (const ok))))))))))
Example/Output:
Since i developed this on top of other previous changes, here i tested by enabling and disabling the open code changes from ex-4.38.
Output after disabling the open-code changes from ex-4.38.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
1 ]=>
(compile '((lambda (x y)
(lambda (a b c d e)
((lambda (y z) (* x y z))
(* a b x)
(+ c d x))))
3
4) 'val 'next the-empty-cenv)
;;output
((env)
(env proc argl continue val)
(
(assign proc (op make-compiled-procedure) (label entry2) (reg env))
(goto (label after-lambda1))
entry2
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (x y)) (reg argl) (reg env))
(assign val (op make-compiled-procedure) (label entry4) (reg env))
(goto (reg continue))
entry4
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (a b c d e)) (reg argl) (reg env))
(assign proc (op make-compiled-procedure) (label entry12) (reg env))
(goto (label after-lambda11))
entry12
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (y z)) (reg argl) (reg env))
(assign proc (op lookup-variable-value) (const *) (reg env))
(assign val (op lexical-address-lookup) (const (0 1)) (reg env))
(assign argl (op list) (reg val))
(assign val (op lexical-address-lookup) (const (0 0)) (reg env))
(assign argl (op cons) (reg val) (reg argl))
(assign val (op lexical-address-lookup) (const (2 0)) (reg env))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-branch15))
compiled-branch14
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-branch15
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
(goto (reg continue))
after-call13
after-lambda11
(save continue)
(save proc)
(save env)
(assign proc (op lookup-variable-value) (const +) (reg env))
(assign val (op lexical-address-lookup) (const (1 0)) (reg env))
(assign argl (op list) (reg val))
(assign val (op lexical-address-lookup) (const (0 3)) (reg env))
(assign argl (op cons) (reg val) (reg argl))
(assign val (op lexical-address-lookup) (const (0 2)) (reg env))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-branch10))
compiled-branch9
(assign continue (label after-call8))
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-branch10
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call8 (assign argl (op list) (reg val))
(restore env)
(save argl)
(assign proc (op lookup-variable-value) (const *) (reg env))
(assign val (op lexical-address-lookup) (const (1 0)) (reg env))
(assign argl (op list) (reg val))
(assign val (op lexical-address-lookup) (const (0 1)) (reg env))
(assign argl (op cons) (reg val) (reg argl))
(assign val (op lexical-address-lookup) (const (0 0)) (reg env))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-branch7))
compiled-branch6
(assign continue (label after-call5))
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-branch7
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call5 (restore argl)
(assign argl (op cons) (reg val) (reg argl))
(restore proc)
(restore continue)
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-branch18))
compiled-branch17
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-branch18
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
(goto (reg continue))
after-call16
after-lambda3 after-lambda1 (assign val (const 4))
(assign argl (op list) (reg val))
(assign val (const 3))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-branch21))
compiled-branch20
(assign continue (label after-call19))
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-branch21
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call19))
With open code changes included and output is as expected.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
1 ]=>
(compile '((lambda (x y)
(lambda (a b c d e)
((lambda (y z) (* x y z))
(* a b x)
(+ c d x))))
3
4) 'val 'next the-empty-cenv)
;;output:
((env)
(env proc argl continue val)
(
(assign proc (op make-compiled-procedure) (label entry2) (reg env))
(goto (label after-lambda1))
entry2
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (x y)) (reg argl) (reg env))
(assign val (op make-compiled-procedure) (label entry4) (reg env))
(goto (reg continue))
entry4
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (a b c d e)) (reg argl) (reg env))
(assign proc (op make-compiled-procedure) (label entry6) (reg env))
(goto (label after-lambda5))
entry6
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (y z)) (reg argl) (reg env))
(assign arg2 (op lexical-address-lookup) (const (0 1)) (reg env))
(save arg2)
(assign arg2 (op lexical-address-lookup) (const (0 0)) (reg env))
(assign arg1 (op lexical-address-lookup) (const (2 0)) (reg env))
(assign arg1 (op *) (reg arg1) (reg arg2))
(restore arg2)
(assign val (op *) (reg arg1) (reg arg2))
(goto (reg continue))
after-lambda5
(assign arg2 (op lexical-address-lookup) (const (1 0)) (reg env))
(save arg2)
(assign arg2 (op lexical-address-lookup) (const (0 3)) (reg env))
(assign arg1 (op lexical-address-lookup) (const (0 2)) (reg env))
(assign arg1 (op +) (reg arg1) (reg arg2))
(restore arg2)
(assign val (op +) (reg arg1) (reg arg2))
(assign argl (op list) (reg val))
(assign arg2 (op lexical-address-lookup) (const (1 0)) (reg env))
(save arg2)
(assign arg2 (op lexical-address-lookup) (const (0 1)) (reg env))
(assign arg1 (op lexical-address-lookup) (const (0 0)) (reg env))
(assign arg1 (op *) (reg arg1) (reg arg2))
(restore arg2)
(assign val (op *) (reg arg1) (reg arg2))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-branch9))
compiled-branch8
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-branch9
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
(goto (reg continue))
after-call7
after-lambda3
after-lambda1
(assign val (const 4))
(assign argl (op list) (reg val))
(assign val (const 3))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-branch12))
compiled-branch11
(assign continue (label after-call10))
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-branch12
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call10))