guile-prescheme/ps-compiler/simp/call.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/call.scm

(define-module (ps-compiler simp call)
  #:use-module (prescheme scheme48)
  #:use-module (ps-compiler node arch)
  #:use-module (ps-compiler node let-nodes)
  #:use-module (ps-compiler node node)
  #:use-module (ps-compiler node node-equal)
  #: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 simplify)
  #:use-module (ps-compiler util util)
  #:export (simplify-allocation
            simplify-known-call
            simplify-known-tail-call
            simplify-unknown-call
            simplify-return
            simplify-jump
            ;; simplify-undefined-value
            simplify-test expand-test simplify-test?))

(define (simplify-jump call)
  (cond ((lambda-node? (call-arg call 0))
         (set-call-primop! call (get-primop (enum primop-enum let)))
         (set-call-exits! call 1)
         (set-node-simplified?! call #f))
        (else
         (default-simplifier call))))

(define simplify-return simplify-jump)

;; If the procedure is a lambda-node:
;;   1. note that we know where the continuation lambda is used (and turn any
;;      tail-calls using it into regular calls)
;;   2. change the primop to LET
;;   3. the procedure is now the continuation
;;   4. the continuation is now a jump lambda
;;   5. change the primop used to call the continuation to jump
;;   6. swap the cont and proc.
;;   (CALL <cont> (LAMBDA (c . vars) ...) . args))
;;     =>
;;   (LET (LAMBDA (c . vars) ...) <cont> . args)
;; If the continuation just returns somewhere else, replace UNKNOWN-CALL
;; with UNKNOWN-TAIL-CALL.

(define (simplify-known-call call)
  (let ((proc (call-arg call 1))
        (cont (call-arg call 0)))
    (cond ((lambda-node? proc)
           (determine-continuation-protocol cont (list proc))
           (set-call-primop! call (get-primop (enum primop-enum let)))
           (change-lambda-type proc 'cont)
           (change-lambda-type cont 'jump)
           (for-each (lambda (ref)
                       (set-call-primop! (node-parent ref)
                                         (get-primop (enum primop-enum jump))))
                     (variable-refs (car (lambda-variables proc))))
           (move cont
                 (lambda (cont)
                   (detach proc)
                   (attach call 1 cont)
                   proc)))
          ((trivial-continuation? cont)
           (replace cont (detach (call-arg (lambda-body cont) 0)))
           (set-call-primop! call (get-primop (enum primop-enum tail-call)))
           (set-call-exits! call 0))
          (else
           (default-simplifier call)))))

;;  (CALL (CONT (v1 ... vN) (RETURN c v1 ... vN)) ...args...)

(define (trivial-continuation? cont)
  (let ((body (lambda-body cont)))
    (and (calls-this-primop? body 'return)
         (= (length (lambda-variables cont))
            (- (call-arg-count body ) 1))
         (let loop ((vars (lambda-variables cont)) (i 1))
           (cond ((null? vars)
                  #t)
                 ((and (reference-node? (call-arg body i))
                       (eq? (car vars)
                            (reference-variable (call-arg body i))))
                  (loop (cdr vars) (+ i 1)))
                 (else #f))))))

;; The same as the above, except that the continuation is a reference node
;; and not a lambda, so we substitute it for the proc's continuation variable.

(define (simplify-known-tail-call call)
  (let ((proc (call-arg call 1))
        (cont (call-arg call 0)))
    (cond ((lambda-node? proc)
           (set-call-primop! call (get-primop (enum primop-enum let)))
           (change-lambda-type proc 'cont)
           (substitute (car (lambda-variables proc)) cont #t)
           (set-lambda-variables! proc (cdr (lambda-variables proc)))
           (remove-call-arg call 0)
           (set-call-exits! call 1)  ;; must be after REMOVE-CALL-ARG
           (mark-changed proc))
          (else
           (default-simplifier call)))))

(define (simplify-test call)
  (simplify-arg call 2)
  (let ((value (call-arg call 2)))
    (cond ((literal-node? value)
           (fold-conditional call (if (eq? false-value (literal-value value))
                                      1
                                      0)))
          ((reference-node? value)
           (simplify-variable-test call (reference-variable value)))
          ((collapse-multiple-zero-bit-tests call)
           )
          (else
           (default-simplifier call)))))

(define (simplify-variable-test call var)
  (cond ((flag-assq 'test (variable-flags var))
         => (lambda (pair)
              (fold-conditional call (cdr pair))))
        (else
         (let ((pair (cons 'test 0))
               (flags (variable-flags var)))
           (set-variable-flags! var (cons pair flags))
           (simplify-arg call 0)
           (set-cdr! pair 1)
           (simplify-arg call 1)
           (set-variable-flags! var flags)))))

(define (fold-conditional call index)
  (replace-body call (detach-body (lambda-body (call-arg call index)))))

;; (if (and (= 0 (bitwise-and 'j x))
;;          (= 0 (bitwise-and 'j y)))
;;     ...)
;; =>
;; (if (= 0 (bitwise-and (bitwise-or x y) 'j))
;;     ...)
;; This comes up in the Scheme48 VM.

(define (collapse-multiple-zero-bit-tests test)
  (receive (mask first-arg)
      (zero-bit-test (call-arg test 2))
    (if mask
        (let ((false-exit (call-arg test 1))
              (true-exit (call-arg test 0)))
          (simplify-lambda-body true-exit)
          (simplify-lambda-body false-exit)
          (let ((call (lambda-body true-exit)))
            (if (and (eq? 'test (primop-id (call-primop call)))
                     (node-equal? false-exit (call-arg call 1)))
                (receive (new-mask second-arg)
                    (zero-bit-test (call-arg call 2))
                  (if (and new-mask (= mask new-mask))
                      (fold-zero-bit-tests test first-arg second-arg
                                           (call-arg call 0))
                      #f))
                #f)))
        #f)))

;; = and bitwise-and always have any literal node as arg1
;;
;; 1. call to =
;; 2. first arg is literal 0
;; 3. second arg is call to and
;; 4. first arg of and-call is numeric literal
;; 5. second arg of and-call has no side-effects (reads are okay)
;;  Returns #f or the two arguments to bitwise-and.

(define (zero-bit-test call)
  (if (eq? '= (primop-id (call-primop call)))
      (let ((literal-0 (call-arg call 0))
            (bitwise-and-call (call-arg call 1)))
        (if (and (literal-node? literal-0)
                 (number? (literal-value literal-0))
                 (= 0 (literal-value literal-0))
                 (call-node? bitwise-and-call)
                 (eq? 'bitwise-and (primop-id (call-primop bitwise-and-call)))
                 (literal-node? (call-arg bitwise-and-call 0))
                 (number? (literal-value (call-arg bitwise-and-call 0)))
                 (not (side-effects? (call-arg bitwise-and-call 1) 'read)))
            (values (literal-value (call-arg bitwise-and-call 0))
                    (call-arg bitwise-and-call 1))
            (values #f #f)))
      (values #f #f)))

(define (fold-zero-bit-tests test first-arg second-arg true-cont)
  (detach second-arg)
  (replace (call-arg test 0) (detach true-cont))
  (move first-arg
        (lambda (first-arg)
          (let-nodes ((call (bitwise-ior 0 first-arg second-arg)))
            call))))

(define (expand-test call)
  (bug "Trying to expand a call to TEST (~D) ~S"
       (node-hash (node-parent (nontrivial-ancestor call)))
       call))

;; TEST can be simplified using any literal value.
;; The check for reference nodes is a heuristic.  It will only help if the
;; two tests end up being sequential.

(define (simplify-test? call index value)
  (cond ((literal-node? value)
         #t)
        ((reference-node? value)
         (any? (lambda (r)
                 (eq? 'test (primop-id (call-primop (node-parent r)))))
               (variable-refs (reference-variable value))))
        (else
         #f)))

(define (simplify-unknown-call call)
  (simplify-args call 0)
  (let ((proc (call-arg call 1)))
    (cond ((lambda-node? proc)
           (determine-lambda-protocol proc (list proc))
           (mark-changed proc))
          ((and (reference-node? proc)
                (variable-simplifier (reference-variable proc)))
           => (lambda (proc)
                (proc call))))))

;; Simplify a cell.  A set-once cell is one that is set only once and does
;; not escape.  If such a cell is set to a value that can be hoisted (without
;; moving variables out of scope) to the point the cell is created the cell
;; is replace with the value.

;; This should make use of the type of the cell.

(define (simplify-allocation call)
  (set-node-simplified?! call #t)
  (simplify-args call 0)    ;; simplify all arguments, including continuation
  (let ((var (car (lambda-variables (call-arg call 0)))))
    (if (every? cell-use? (variable-refs var))
        (receive (uses sets)
            (partition-list (lambda (n)
                              (eq? 'contents
                                   (primop-id (call-primop (node-parent n)))))
                            (variable-refs var))
          (simplify-cell-part call uses sets)))))

(define (cell-use? ref)
  (let ((call (node-parent ref)))
    (case (primop-id (call-primop call))
      ((contents)
       #t)
      ((set-contents)
       (= (node-index ref) set/owner))
      (else
       #f))))

(define (simplify-cell-part call my-uses my-sets)
  (cond ((null? my-uses)
         (for-each (lambda (n) (remove-body (node-parent n)))
                   my-sets))
        ((null? my-sets)
         (for-each (lambda (n)
                     (replace-call-with-value
                      (node-parent n)
                      (make-undefined-literal)))
                   my-uses))
;;        ((null? (cdr my-sets))
;;         (set-literal-value! (call-arg call 1) 'single-set)
;;         (really-simplify-single-set call (car my-sets) my-uses))
        (else
         (if (neq? 'small (literal-value (call-arg call 1)))
             (set-literal-value! (call-arg call 1) 'small)))))