scheme48/ps-compiler/simp/simplify.scm

; Part of Scheme 48 1.9.  See file COPYING for notices and license.

; Authors: Richard Kelsey


;   Post-CPS optimizer.  All simplifications are done by changing the
; structure of the node tree.
;
; There are two requirements for the simplifiers:
;    1) Only the node being simplified and its descendents may be changed.
;    2) If a node is changed the NODE-SIMPLIFIED? flag of that node and all
;       its ancestors must be set to false.

; No way to simplify literal or reference nodes.

(define (simplify-node node)
  (cond ((call-node? node)
	 (simplify-call node))
	((lambda-node? node)
	 (simplify-lambda-body node))))

(define (simplify-global-reference ref)
  (let ((value (variable-known-value (reference-variable ref))))
    (if value
	(replace ref (vector->node value)))))

(define (simplify-lambda-body lambda-node)
  (let loop ()
    (let ((node (lambda-body lambda-node)))
      (cond ((not (node-simplified? node))
	     (set-node-simplified?! node #t)
             (simplify-call node)
             (loop))))))

(define (default-simplifier call)
  (simplify-args call 0))

; Utility used by many simplifiers - simplify the specified children.

(define (simplify-args call start)
  (let* ((vec (call-args call))
         (len (vector-length vec)))
    (do ((i start (+ i '1)))
        ((>= i len))
      (really-simplify-arg vec i))))

; Keep simplifying a node until it stops changing.

(define (simplify-arg call index)
  (really-simplify-arg (call-args call) index))

(define (really-simplify-arg vec index)
  (let loop ((node (vector-ref vec index)))
    (cond ((not (node-simplified? node))
	   (set-node-simplified?! node #t)
	   (case (node-variant node)
	     ((reference)
	      (if (global-variable? (reference-variable node))
		  (simplify-global-reference node)))
	     ((call)
	      (simplify-call node))
	     ((lambda)
	      (simplify-lambda-body node)))
	   (loop (vector-ref vec index))))))

; Remove any unused arguments to L-NODE
; Could substitute identical arguments as well...

(define (simplify-known-lambda l-node)
  (let ((unused (filter (lambda (var) (not (used? var)))
			(if (eq? 'proc (lambda-type l-node))
			    (cdr (lambda-variables l-node))
			    (lambda-variables l-node)))))
    (if (not (null? unused))
	(let ((refs (find-calls l-node)))
	  (for-each (lambda (var)
		      (let ((index (+ 1 (variable-index var))))
			(for-each (lambda (ref)
				    (remove-ith-argument (node-parent ref)
							 index
							 var))
				  refs)
			(remove-variable l-node var)))
		    unused)))))
    
; VAR is used to get the appropriate representation

(define (remove-ith-argument call index var)
  (let ((value (detach (call-arg call index))))
    (remove-call-arg call index)
    (move-body call
	       (lambda (call)
		 (let-nodes ((c1 (let 1 l1 value))
			     (l1 (var) call))
		   c1)))))