Exercise 5.44.  In this section we have focused on the use of the 
compile-time environment to produce lexical addresses. But there are 
other uses for compile-time environments. For instance, in exercise 5.38 
we increased the efficiency of compiled code by open-coding primitive 
procedures. Our implementation treated the names of open-coded 
procedures as reserved words. If a program were to rebind such a name, 
the mechanism described in exercise 5.38 would still open-code it as a 
primitive, ignoring the new binding. For example, consider the procedure

(lambda (+ * a b x y)
  (+ (* a x) (* b y)))

which computes a linear combination of x and y. We might call it with 
arguments +matrix, *matrix, and four matrices, but the open-coding 
compiler would still open-code the + and the * in (+ (* a x) (* b y)) as 
primitive + and *. Modify the open-coding compiler to consult the 
compile-time environment in order to compile the correct code for 
expressions involving the names of primitive procedures. (The code will 
work correctly as long as the program does not define or set! these 
names.)

————————————————————————————————————————————————————————————————————————

Merging the changes from 5.38 (open-coding) and 5.40 (compilation 
environment) into 5.44-compiler-orig.scm:

$ diff3 -m 5.38-compiler.scm ch5-compiler.scm 5.40-compiler.scm >5.44-compiler-orig.scm

(and some manual fixes)

Also re-using find-variable from 5.41, just for its not-found return 
value, to see if the operator has been bound before open-coding it.

The only required change is to test, before open-coding a primitive 
procedure, that the name has not been bound in the compilation 
environment.

Here are the changes made after merging:

--- 5.44-compiler-orig.scm	2010-06-13 14:55:59.000000000 -0600
+++ 5.44-compiler.scm	2010-06-13 14:57:09.000000000 -0600
@@ -208,7 +208,8 @@
 ;;;combinations
 
 (define (compile-application exp target linkage env)
-  (if (memq (operator exp) '(= * - +))
+  (if (and (memq (operator exp) '(= * - +))
+           (eq? (find-variable (operator exp) env) 'not-found))
       (compile-appl-open-coded exp target linkage env)
       (compile-appl-other exp target linkage env)))

To test we compile a procedure where + can be open-coded while * cannot:

(compile '(define (f * x y) (+ (* x x) (* y y))) 'val 'next the-empty-environment)

((env)
 (val)
 ((assign val (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 proc (op lookup-variable-value) (const *) (reg env))
  (assign val (op lookup-variable-value) (const x) (reg env))
  (assign argl (op list) (reg val))
  (assign val (op lookup-variable-value) (const x) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch9))
  compiled-branch8
  (assign continue (label proc-return10))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  proc-return10
  (assign arg1 (reg val))
  (goto (label after-call7))
  primitive-branch9
  (assign arg1 (op apply-primitive-procedure) (reg proc) (reg argl))
  after-call7
  (assign proc (op lookup-variable-value) (const *) (reg env))
  (assign val (op lookup-variable-value) (const y) (reg env))
  (assign argl (op list) (reg val))
  (assign val (op lookup-variable-value) (const y) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch5))
  compiled-branch4
  (assign continue (label proc-return6))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  proc-return6
  (assign arg2 (reg val))
  (goto (label after-call3))
  primitive-branch5
  (assign arg2 (op apply-primitive-procedure) (reg proc) (reg argl))
  after-call3
  (assign val (op +) (reg arg1) (reg arg2))
  (goto (reg continue))
  after-lambda1
  (perform (op define-variable!) (const f) (reg val) (reg env))
  (assign val (const ok))))