guile-prescheme/ps-compiler/simp/let.scm

;;; Ported from Scheme 48 1.9.  See file COPYING for notices and license.
;;;
;;; Port Author: Andrew Whatson
;;;
;;; Original Authors: Richard Kelsey
;;;
;;;   scheme48-1.9.2/ps-compiler/simp/let.scm

(define-module (ps-compiler simp let)
  #:use-module (prescheme scheme48)
  #:use-module (ps-compiler node arch)
  #:use-module (ps-compiler node node)
  #:use-module (ps-compiler node node-util)
  #:use-module (ps-compiler node primop)
  #:use-module (ps-compiler node variable)
  #:use-module (ps-compiler param)
  #:use-module (ps-compiler simp join)
  #:use-module (ps-compiler simp simplify)
  #:use-module (ps-compiler util util)
  #:export (simplify-let))

;;; Simplifying LET nodes, i.e. calls to the LET primop.
;;;
;;; 1. Change the procedure to a JUMP procedure if necessary.
;;; 2. Check that the right number of arguments are present.
;;; 3. Substitute any values that can be substituted without reference to
;;;    how they are used in the body; then remove the call if it is no
;;;    longer necessary.
;;; 4. Try harder.

(define (simplify-let call)
  (let ((proc (call-arg call 0)))
    (if (eq? (lambda-type proc) 'jump)
        (change-lambda-type proc 'cont))
    (cond ((n= (length (lambda-variables proc))
               (- (call-arg-count call) 1))
           (bug "wrong number of arguments in ~S" call))
          ((or (null? (lambda-variables proc))
               (substitute-let-arguments proc call quick-substitute))
           (remove-body call))
          (else
           (really-simplify-let proc call)))))

;; A value can be quickly substituted if it is a leaf node or if it has no
;; side-effects and is used only once.

(define (quick-substitute var val)
  (or (literal-node? val)
      (reference-node? val)
      (and (not (side-effects? val))
           (null? (cdr (variable-refs var))))))

;; Simplify the arguments and then repeatedly simplify the body of PROC
;; and try substituting the arguments.
;; If all the arguments can be substituted the call node is removed.
;;
;; SUBSTITUTE-JOIN-ARGUMENTS copies arguments in an attempt to remove
;; conditionals via constant folding.

(define (really-simplify-let proc call)
  (simplify-args call 1)
  (let loop ()
    (set-node-simplified?! proc #t)
    (simplify-lambda-body proc)
    (cond ((substitute-let-arguments proc call slow-substitute)
           (remove-body call))
          ((substitute-join-arguments proc call)
           (loop))
          ((not (node-simplified? proc))
           (loop)))))

(define *duplicate-lambda-size* '-1)   ;; don't duplicate anything
(define *duplicate-jump-lambda-size* 1) ;; duplicate one call

(define (slow-substitute var val)
  (cond ((or (literal-node? val) (reference-node? val))
         #t)
        ((call-node? val)
         (let ((refs (variable-refs var)))
           (and (not (null? refs))
                (null? (cdr refs))
                (or (not (side-effects? val 'allocate))
                    (and (not (side-effects? val 'allocate 'read))
                         (not-used-between? val (car refs)))))))
        ((every? called-node? (variable-refs var))
         (simplify-known-cont-calls (variable-refs var) val)
         (or (null? (cdr (variable-refs var)))
             (case (lambda-type val)
               ((proc known-proc)
                (small-node? val *duplicate-lambda-size*))
               ((jump)
                (small-node? val *duplicate-jump-lambda-size*))
               (else
                #f))))
        (else #f)))

;; This only detects the following situation:
;; (let (lambda (... var ...) (primop ... var ...))
;;      ... value ...)
;; where the reference to VAR is contained within nested, non-writing calls
;; This depends on there being no simple calls with WRITE side-effects

(define (not-used-between? call ref)
  (let ((top (lambda-body (call-arg (node-parent call) 0))))
    (let loop ((call (node-parent ref)))
      (cond ((eq? call top) #t)
            ((or (not (call-node? call))
                 (eq? 'write (primop-side-effects (call-primop call))))
             #f)
            (else (loop (node-parent call)))))))

(define (simplify-known-cont-calls refs l-node)
  (case (lambda-type l-node)
    ((proc)
     (determine-lambda-protocol l-node refs))
    ((cont)
     (bug "CONT lambda bound by LET ~S" l-node)))
  (if (calls-known? l-node)
      (simplify-known-lambda l-node)))

;; ($some-RETURN <proc> . <args>)
;;   =>
;; ($JUMP <proc> . <args>)

;; could check argument reps as well

(define (add-return-mark call l-node arg-count)
  (if (not (= (call-arg-count call) (+ arg-count 1)))
      (bug '"call ~S to join ~S has the wrong number of arguments"
           call l-node))
  (set-call-primop! call (get-primop (enum primop-enum jump))))

;; Removed arguments to a lambda-node in call position.
;; If any arguments are actually removed
;; REMOVE-NULL-ARGUMENTS shortens the argument vector.

(define (substitute-let-arguments node call gone-proc)
  (let* ((vec (call-args call))
         (c (do ((vars (lambda-variables node) (cdr vars))
                 (i 1 (+ i 1))
                 (c 0 (if (keep-var-val (car vars) (vector-ref vec i) gone-proc)
                          c
                          (+ 1 c))))
                ((null? vars) c))))
    (cond ((= (+ c 1) (call-arg-count call)) #t)
          ((= c 0)                           #f)
          (else
           (remove-unused-variables node)
           (remove-null-arguments call (- (call-arg-count call) c))
           #f))))

(define (keep-var-val var val gone-proc)
  (cond ((and (unused? var)
              (or (not (call-node? val))
                  (not (side-effects? val 'allocate 'read))))
         (erase (detach val))
         #f)
        ((gone-proc var val)
         (substitute var val #t)
         #f)
        (else '#t)))

;; VAL is simple enough to be substituted in more than one location if
;; its body is a call with all leaf nodes.
;; -- no longer used --
;;(define (simple-lambda? val)
;;  (vector-every? (lambda (n)
;;                   (and (not (lambda-node? n))
;;                 (call-args (lambda-body val))))

(define (called-anywhere? var)
  (any? called-node? (variable-refs var)))