sicp-ex-5.38

  
  
  
 (a) 
 ;; in compile 
 ((open-code? exp) (compile-open-code exp target linkage)) 
  
  (define (open-code? exp) 
     (memq (car exp) '(+ - * /))) 
  
 (define (spread-arguments operand1 operand2) 
  (let ((op1 (compile operand1 'arg1 'next)) 
            (op2 (compile operand2 'arg2 'next))) 
   (list op1 op2))) 
  
 (b) 
  
 ;; This procedure has a bug. It does not save the environment 
 ;; Around the compilation of the first arg. Becuase of this it 
 ;; will give incorrect results for recursive procedures. In my answer 
 ;; Below I have fixed this. 
 (define (compile-open-code exp target linkage) 
  (let ((op (car exp)) 
            (args (spread-arguments (cadr exp) (caddr exp)))) 
   (end-with-linkage linkage 
    (append-instruction-sequences 
         (car args) 
         (preserving '(arg1) 
          (cadr args) 
          (make-instruction-sequence '(arg1 arg2) (list target) 
           `((assign ,target (op ,op) (reg arg1) (reg arg2))))))))) 

  
 ; (d) 
 ; these include the answer to 5.44 
  
 (define (compile-+ exp target linkage compile-time-environment) 
   (if (overwrite? (operator exp) 
                   compile-time-environment) 
       (compile-application exp target linkage compile-time-environment) 
       (let ((operands (operands exp))) 
         (if (< 2 (length operands)) 
             (compile (two-by-two '+ operands) target linkage compile-time-environment) 
             (let ((operands (spread-arguments operands compile-time-environment))) 
               (end-with-linkage 
                linkage 
                (preserving 
                 '(env continue) 
                 operands 
                 (make-instruction-sequence 
                  '(arg1 arg2) (list target) 
                  `((assign ,target (op +) (reg arg1) (reg arg2))))))))))) 
  
 (define (compile-* exp target linkage compile-time-environment) 
   (if (overwrite? (operator exp) 
                   compile-time-environment) 
       (compile-application exp target linkage compile-time-environment) 
    (let ((operands (operands exp))) 
      (if (< 2 (length operans)) 
          (compile  
           (two-by-two '* operands) target linkage compile-time-environment) 
          (let ((operands (spread-arguments operands compile-time-environment))) 
            (end-with-linkage 
             linkage 
             (preserving 
              '(env continue) 
              operands 
              (make-instruction-sequence 
               '(arg1 arg2) (list target) 
               `((assign ,target (op *) (reg arg1) (reg arg2))))))))))) 
  
 (define (-? exp) 
   (tagged-list? exp '-)) 
 (define (compile-- exp target linkage compile-time-environment) 
   (let ((operands (spread-arguments (operands exp) compile-time-environment))) 
     (end-with-linkage 
      linkage 
      (preserving 
       '(env continue) 
       operands 
       (make-instruction-sequence 
        '(arg1 arg2) (list target) 
        `((assign ,target (op -) (reg arg1) (reg arg2)))))))) 
  
 (define (/? exp) 
   (tagged-list? exp '/)) 
 (define (compile-/ exp target linkage compile-time-environment) 
   (let ((operands (spread-arguments (operands exp) compile-time-environment))) 
     (end-with-linkage 
      linkage 
      (preserving 
       '(env continue) 
       operands 
       (make-instruction-sequence 
        '(arg1 arg2) (list target) 
        `((assign ,target (op /) (reg arg1) (reg arg2)))))))) 
  
 (define (two-by-two proc operands) 
   (if (> 2 (length operands)) 
       (car operands) 
       (list proc (car operands) 
             (two-by-two proc (cdr operands))))) 

  
  
  
 (define (+? exp) 
   (tagged-list? exp '+)) 
 ;;设定只处理两个参数的情况 
 (define (spread-arguments argl) 
   (let ((operand-code1 (compile (car argl) 'arg1 'next)) 
         (operand-code2 (compile (cadr argl) 'arg2 'next))) 
     (preserving '(env) 
                 operand-code1 
                 (make-instruction-sequence 
                  (list-union '(arg1) 
                              (registers-needed operand-code2)) 
                  (list-difference (registers-modified operand-code2) 
                                   '(arg1)) 
                  (append '((save arg1)) 
                          (statements operand-code2) 
                          '((restore arg1))))))) 
 (define (compile-+ exp target linkage) 
   (let ((operand-codes (spread-arguments (operands exp)))) 
     (end-with-linkage 
      linkage 
      (preserving '(continue) 
                  operand-codes 
                  (make-instruction-sequence 
                   '() 
                   `(target) 
                   `((assign ,target (op +) (reg arg1) (reg arg2)))))))) 
  
 (define t7 (compile-test '(+ (+ a 1) (+ 3 2)))) 
 ;;the result of t7 
 (assign arg1 (op lookup-variable-value) (const a) (reg env)) 
 (save arg1) 
 (assign arg2 (const 1)) 
 (restore arg1) 
 (assign arg1 (op +) (reg arg1) (reg arg2)) 
 (save arg1) 
 (assign arg1 (const 3)) 
 (save arg1) 
 (assign arg2 (const 2)) 
 (restore arg1) 
 (assign arg2 (op +) (reg arg1) (reg arg2)) 
 (restore arg1) 
 (assign val (op +) (reg arg1) (reg arg2)) 
  
 ;;d 
 (define (compile-++ exp target linkage) 
   (compile-+ (construct exp) target linkage)) 
 (define (construct exp) 
   (if (> (length (operands exp)) 
          2) 
       (append (list (car exp) 
                     (cadr exp)) 
               (list (append (list (car exp)) 
                             (cddr exp)))) 
       exp)) 
        

Obviously, there are many redundant work will be created in donald's answer :-)

A solution with verification support (You can quickly verify your answer).

  
 (define all-regs '(env proc val argl continue arg1 arg2)) 
  
 ;; a clause for the dispatch of compile that handles the application of an open-coded primitive 
  
 ((open-code-application? exp) (compile-open-code exp target linkage)) 
  
 (define (open-code-application? exp) 
   (memq (car exp) '(+ - * / =))) 
  
 (define (second-operand operands) (cadr operands)) 
  
 (define (spread-arguments operands) 
   (let ([arg1-code (compile (first-operand operands) 'arg1 'next)] 
         [arg2-code (compile (second-operand operands) 'arg2 'next)]) 
     (if (= (length operands) 2) 
         (values arg1-code arg2-code) 
         (error "Unsupported arity!" operands)))) 
  
 (define (compile-open-code exp target linkage) 
   (let-values ([(arg1-code arg2-code) (spread-arguments (operands exp))]) 
     (end-with-linkage 
      linkage 
      (preserving 
       '(env) 
       arg1-code 
       (preserving 
        '(arg1) 
        arg2-code 
        (make-instruction-sequence 
         '(arg1 arg2)                    ;in fact, arg2 can be omitted. 
         (list target) 
         `((assign ,target (op ,(operator exp)) (reg arg1) (reg arg2))))))))) 
  
 ;;; verification support 
 (load "ch5-regsim.scm") 
 ;;; modified version 
 (define (lookup-prim symbol operations) (eval symbol)) 
 ;; (define exp '(begin (define (square x) (* x x)) (define x 4)  (+ x (square 2)))) 
 ;; (define exp '(begin (define (square x) (* x x)) (define x 4) (+ (square 2) x))) 
  
 (define exp '(begin 
                (define (factorial n) 
                  (if (= n 1) 
                      1 
                      (* (factorial (- n 1)) n))) 
                (factorial 5))) 
  
 (define demo-machine 
   (make-machine 
    all-regs 
    '() 
    (statements (compile exp 'val 'next)))) 
  
 (define the-global-environment (setup-environment)) 
 (set-register-contents! demo-machine 'env (get-global-environment)) 
 (start demo-machine) 
 (pretty-print (get-register-contents demo-machine 'val)) 
  
 ;; part d 
 (define (spread-arguments operands) 
   (let ([arg1-code (compile (first-operand operands) 'arg1 'next)] 
         (rest-codes (map (lambda (op) (compile op 'arg2 'next)) 
                          (rest-operands operands)))) 
     (if (>= (length operands) 2) 
         (cons arg1-code rest-codes) 
         (error "Unsupported arity!" operands)))) 
  
 (define (compile-open-code exp target linkage) 
   (define (compile-open-code-rest operand-codes) 
     (if (null? (cdr operand-codes)) 
         (preserving 
          '(arg1) 
          (car operand-codes) 
          (make-instruction-sequence 
            '(arg1 arg2)                 ;in fact, arg2 can be omitted. 
            (list target) 
            `((assign ,target (op ,(operator exp)) (reg arg1) (reg arg2))))) 
  
         (preserving 
          '(arg1 env) 
          (car operand-codes) 
          (append-instruction-sequences 
           (make-instruction-sequence 
            '(arg1 arg2)                 ;in fact, arg2 can be omitted. 
            '(arg1) 
            `((assign arg1 (op ,(operator exp)) (reg arg1) (reg arg2)))) 
           (compile-open-code-rest (cdr operand-codes)) 
           )))) 
  
   ;; we evaluate the first operand and the second operand, 
   ;; then assign the values to the corresponding registers sequentially. 
   ;; By accumulating arg2 into arg1, we have the accumulation of the first 
   ;; two operands. After that, we evaluate the third and put its value into 
   ;; arg2. As above, we accumulate arg2 into arg1 so that we have the 
   ;; accumulation of the first three oprands. And so on, until we reach 
   ;; the last operand of the operands, this time, we put the accumulation 
   ;; of arg1 and arg2 into the target register. 
    
   (let ([operand-codes (spread-arguments (operands exp))]) 
     (end-with-linkage 
      linkage 
      (preserving 
       '(env) 
       (car operand-codes) 
       (compile-open-code-rest (cdr operand-codes)))))) 

Part A
======

  (define (spread-arguments operands)
    (if (= 2 (length operands))     
        (preserving '(env)
                    (compile (car operands) 'arg1 'next)
                    (preserving '(arg1)
                                (compile (cadr operands) 'arg2 'next)
                                (make-instruction-sequence
                                 '(arg1) '() '())))
        (error \"Spread-arguments expects 2 args -- COMPILE\" operands)))


Part B
======

(define (compile exp target linkage)
  (cond ((self-evaluating? exp)
        ...
        ((=? exp) (compile-= exp target linkage))
        ((*? exp) (compile-* exp target linkage))
        ...
        (else
         (error \"Unknown expression type -- COMPILE\" exp))))

  (define (=? exp) (tagged-list? exp '=))
  (define (compile-= exp target linkage)
    (compile-2arg-open-code '= (operands exp) target linkage))

  (define (*? exp) (tagged-list? exp '*))
  (define (compile-* exp target linkage)
    (compile-2arg-open-code '* (operands exp) target linkage))

  ...

  (define (compile-2arg-open-code operator operands target linkage)
    (end-with-linkage
     linkage
     (append-instruction-sequences
      (spread-arguments operands)
      (make-instruction-sequence
       '(arg1 arg2)
       `(,target)
       `((assign ,target (op ,operator) (reg arg1) (reg arg2)))))))


Part C
======

With these modifications there are half as many instructions in the lambda
body than before (58 before, 29 after).  We could therefore expect it to run
about twice as fast.


Part D
======

  (define (*? exp) (tagged-list? exp '*))
  (define (compile-* exp target linkage)
    (compile-multi-arg-open-code '* (operands exp) target linkage '1))

  (define (+? exp) (tagged-list? exp '+))
  (define (compile-+ exp target linkage)
    (compile-multi-arg-open-code '+ (operands exp) target linkage '0))

  (define (compile-multi-arg-open operator operands target linkage op-id)
    (let ((operand-count (length operands)))
      (cond
        ((= 0 operand-count) (compile op-id target linkage))
        ((= 1 operand-count) (compile (car operands) target linkage))
        (else
         (end-with-linkage
          linkage
          (preserving
           '(env)
           (compile (car operands) 'arg1 'next)
           (compile-open-code-reduce operator (cdr operands) target)))))))
    
  (define (compile-open-code-reduce operator operands target)
    (let* ((is-last-operand (null? (cdr operands)))
           (trgt (if is-last-operand target 'arg1))
           (open-code-apply
            (preserving '(arg1)
                        (compile (car operands) 'arg2 'next)
                        (make-instruction-sequence
                         '(arg1 arg2)
                         `(,trgt)
                         `((assign ,trgt (op ,operator)
                                   (reg arg1) (reg arg2)))))))
      (if is-last-operand
          open-code-apply
          (preserving
           '(env)
           open-code-apply
           (compile-open-code-reduce operator (cdr operands) target)))))


Simple Example
==============

  (compile
   '(+ 1 2 3 4 5)
   'val
   'next)

Output:
-------

  (()
   (arg1 arg2 val)
   ((assign arg1 (const 1))
    (assign arg2 (const 2))
    (assign arg1 (op +) (reg arg1) (reg arg2))
    (assign arg2 (const 3))
    (assign arg1 (op +) (reg arg1) (reg arg2))
    (assign arg2 (const 4))
    (assign arg1 (op +) (reg arg1) (reg arg2))
    (assign arg2 (const 5))
    (assign val (op +) (reg arg1) (reg arg2))))


More Complex Example
====================

  (compile
   '(* (*) (* 2) (values 3) (* 4 five))
   'val
   'return)

Output:
-------

  ((env continue)
   (proc argl arg1 arg2 val)
   ((save continue)
    (assign arg1 (const 1))
    (assign arg2 (const 2))
    (assign arg1 (op *) (reg arg1) (reg arg2))
    (save env)
    (assign proc (op lookup-variable-value) (const values) (reg env))
    (assign val (const 3))
    (assign argl (op list) (reg val))
    (test (op primitive-procedure?) (reg proc))
    (branch (label primitive-branch1))
    compiled-branch2
    (assign continue (label proc-return4))
    (assign val (op compiled-procedure-entry) (reg proc))
    (goto (reg val))
    proc-return4
    (assign arg2 (reg val))
    (goto (label after-call3))
    primitive-branch1
    (assign arg2 (op apply-primitive-procedure) (reg proc) (reg argl))
    after-call3
    (assign arg1 (op *) (reg arg1) (reg arg2))
    (restore env)
    (save arg1)
    (assign arg1 (const 4))
    (assign arg2 (op lookup-variable-value) (const five) (reg env))
    (assign arg2 (op *) (reg arg1) (reg arg2))
    (restore arg1)
    (assign val (op *) (reg arg1) (reg arg2))
    (restore continue)
    (goto (reg continue))))