path: root/backend/box.scm

;;; box.scm -- determine which expressions need to be boxed
;;;
;;; author  :  Sandra Loosemore
;;; date    :  03 Apr 1993
;;;
;;; 
;;; This phase determines whether expressions need to be boxed or unboxed.
;;;
;;; In the case of an expression that needs to be boxed, it determines 
;;; whether it can be evaluated eagerly and boxed or whether a delay
;;; must be constructed.
;;;
;;; In the case of an expression that needs to be unboxed, it determines
;;; whether it is already known to have been evaluated and can simply
;;; be unboxed instead of checking for a delay that must be forced.
;;;
;;; This phase may mark previously non-strict variables as strict if their
;;; initializers can be evaluated eagerly.  However, doing this evaluation
;;; eagerly never causes any other non-strict variables to be forced,
;;; so there is no need to propagate this strictness information backwards
;;; (as happens in the var-strictness-walk pass).


;;;======================================================================
;;; Top-level function
;;;======================================================================


;;; Complexity computation

(define-integrable delay-complexity 10)
(define-integrable unbox-complexity 1)
(define-integrable box-complexity 2)
(define-integrable sel-complexity 1)
(define-integrable is-constructor-complexity 1)
(define-integrable pack-complexity 2)
(define-integrable con-number-complexity 1)

(define (add-complexity c1 c2)
  (cond ((not c1)
	 '#f)
	((not c2)
	 '#f)
	(else
	 ;; *** We might want to establish an arbitrary cutoff here.
	 ;; *** e.g., if complexity > N then set it to '#f.
	 (the fixnum (+ (the fixnum c1) (the fixnum c2))))))



;;; The second argument to the walker is a list of things
;;; that are known to have been forced already.
;;; The third argument is a list of variables that have not yet
;;; been initialized.
;;; Walkers return two values:  a new value for already-forced and
;;; the complexity of the expression.

;;; This helper function sets the unboxed? and cheap? bits for the
;;; code generator, and adjusts the basic complexity to account for
;;; forces, boxes, and delays.
;;;
;;; The basic decision tree for the code generator should be:
;;; if unboxed?
;;;    then if strict-result?
;;;            then generate x                                   (1)
;;;            else if cheap?
;;;                    then generate (unbox x)                   (2)
;;;                    else generate (force x)                   (3)
;;;    else if strict-result?
;;;            then if cheap?
;;;                    then generate (box x)                     (4)
;;;                    else generate (delay x)                   (5)
;;;            else if cheap?
;;;                    then generate x                           (6)
;;;                    then generate (delay (force x))           (7)
;;; See function do-codegen in codegen.scm.


(define (do-box-analysis object already-forced uninitialized unboxed?)
  (setf (flic-exp-unboxed? object) unboxed?)
  (multiple-value-bind (result complexity)
      (box-analysis object already-forced uninitialized)
    (setf complexity
	  (if unboxed?
	      ;; If the expression returns a boxed value and we want
	      ;; an unboxed one, we may need to do a force.
	      (if (flic-exp-strict-result? object)
		  (begin                                       ; case (1)
		    ;; this flic-exp-cheap? bit is used only by
		    ;; exp-would-be-cheap? below -- not by codegen
		    (setf (flic-exp-cheap? object)
			  (if complexity '#t '#f))
		    complexity)      
		  (if (already-forced? object already-forced)
		      (begin                                   ; case (2)
			(setf (flic-exp-cheap? object) '#t)
			(add-complexity complexity unbox-complexity))
		      (begin                                   ; case (3)
			(setf (flic-exp-cheap? object) '#f)
			'#f)))
	      ;; We want a boxed value.  If the expression already
	      ;; returns a boxed value, return its complexity directly;
	      ;; otherwise return the cost of either boxing or delaying it.
	      (if (flic-exp-strict-result? object)
		  (if complexity
		      (begin                                   ; case (4)
			(setf (flic-exp-cheap? object) '#t)
			(add-complexity complexity box-complexity))
		      (begin                                   ; case (5)
			(setf (flic-exp-cheap? object) '#f)
			delay-complexity))
		  (if complexity
		      (begin
			(setf (flic-exp-cheap? object) '#t)    ; case (6)
			complexity)
		      (begin                                   ; case (7)
		        (setf (flic-exp-cheap? object) '#f)
			delay-complexity)))
	    ))
    (values
      (if unboxed?
	  (note-already-forced object result)
	  result)
      complexity)))




;;;======================================================================
;;; Code walk
;;;======================================================================


(define *local-function-calls* '())

(define-flic-walker box-analysis (object already-forced uninitialized))

(define-box-analysis flic-lambda (object already-forced uninitialized)
  (do-box-analysis (flic-lambda-body object) already-forced uninitialized '#t)
  (values already-forced 0))

(define-box-analysis flic-let (object already-forced uninitialized)
  (let ((bindings    (flic-let-bindings object)))
    (dynamic-let ((*local-function-calls*  (dynamic *local-function-calls*)))
      (dolist (var bindings)
	;; Note local functions
	(when (and (not (var-toplevel? var))
		   (is-type? 'flic-lambda (var-value var))
		   (not (var-standard-refs? var)))
	  (push (cons var '()) (dynamic *local-function-calls*))))
      (multiple-value-bind (already-forced complexity)
	  (box-analysis-let-aux object already-forced uninitialized)
	(dolist (var bindings)
	  ;; Go back and reexamine local functions to see whether
	  ;; we can make more arguments strict, based on the values
	  ;; the function is actually called with.
	  (let ((stuff  (assq var (dynamic *local-function-calls*))))
	    (when stuff
	      (maybe-make-more-arguments-strict var (cdr stuff)))))
	(values already-forced complexity)))))

(define (box-analysis-let-aux object already-forced uninitialized)
  (let ((recursive?  (flic-let-recursive? object))
	(bindings    (flic-let-bindings object))
	(body        (flic-let-body object)))
    (when recursive? (setf uninitialized (append bindings uninitialized)))
    (dolist (var bindings)
      (let* ((value   (var-value var))
	     (strict? (var-strict? var))
	     (result  (do-box-analysis value already-forced uninitialized
				       strict?)))
	(cond (strict?
	       ;; Propagate information about things forced.
	       (setf already-forced result))
	      ((and (flic-exp-cheap? value)
		    (flic-exp-strict-result? value))
	       ;; The value expression is cheap unboxed value, so mark
	       ;; the variable as strict.
	       (setf (var-strict? var) '#t)
	       (setf (flic-exp-unboxed? value) '#t))))
      (when recursive? (pop uninitialized)))
    ;; *** Could be smarter about computing complexity.
    (values
      (do-box-analysis body already-forced uninitialized '#t)
      '#f)))

(define (maybe-make-more-arguments-strict var calls)
  (setf (var-strictness var)
	(maybe-make-more-arguments-strict-aux
	  (flic-lambda-vars (var-value var))
	  calls)))

(define (maybe-make-more-arguments-strict-aux vars calls)
  (if (null? vars)
      '()
      (let ((var  (car vars)))
	;; If the variable is not already strict, check to see
	;; whether it's always called with "cheap" arguments.
	(when (and (not (var-strict? var))
		   (every-1 (lambda (call)
			      (exp-would-be-cheap? (car call) var))
			    calls))
	  (setf (var-strict? var) '#t)
	  (dolist (call calls)
	    (setf (flic-exp-unboxed? (car call)) '#t)))
	(cons (var-strict? var)
	      (maybe-make-more-arguments-strict-aux
	       (cdr vars)
	       (map (function cdr) calls))))
    ))


;;; Look for one special fixed-point case: argument used as counter-type
;;; variable.  Otherwise ignore fixed points.

(define (exp-would-be-cheap? exp var)
  (or (and (flic-exp-cheap? exp)
	   (flic-exp-strict-result? exp))
      (and (is-type? 'flic-ref exp)
	   (eq? (flic-ref-var exp) var))
      (and (is-type? 'flic-app exp)
	   (is-type? 'flic-ref (flic-app-fn exp))
	   (var-complexity (flic-ref-var (flic-app-fn exp)))
	   (every-1 (lambda (a) (exp-would-be-cheap? a var))
		    (flic-app-args exp)))
      ))



(define-box-analysis flic-app (object already-forced uninitialized)
  (let ((fn         (flic-app-fn object))
	(args       (flic-app-args object))
	(saturated? (flic-app-saturated? object)))
    (cond ((and saturated? (is-type? 'flic-ref fn))
	   (let* ((var    (flic-ref-var fn))
		  (stuff  (assq var (dynamic *local-function-calls*))))
	     (when stuff
	       (push args (cdr stuff)))
	     (box-analysis-app-aux
	       (var-strictness var) (var-complexity var)
	       args already-forced uninitialized)))
	  ((and saturated? (is-type? 'flic-pack fn))
	   (box-analysis-app-aux
	     (con-slot-strict? (flic-pack-con fn)) pack-complexity
	     args already-forced uninitialized))
	  (else
	   ;; The function is going to be forced but all the arguments
	   ;; are non-strict.
	   (dolist (a args)
	     (do-box-analysis a already-forced uninitialized '#f))
	   (values 
	     (do-box-analysis fn already-forced uninitialized '#t)
	     '#f))
	  )))
	  


;;; Propagation of already-forced information depends on whether or
;;; not the implementation evaluates function arguments in left-to-right
;;; order.  If not, we can still propagate this information upwards.

(define (box-analysis-app-aux
	   strictness complexity args already-forced uninitialized)
  (let ((result   already-forced))
    (dolist (a args)
      (let ((strict?  (pop strictness)))
	(multiple-value-bind (new-result new-complexity)
	    (do-box-analysis a already-forced uninitialized strict?)
	  (when strict?
	    (setf result
		  (if left-to-right-evaluation
		      (setf already-forced new-result)
		      (union-already-forced
		        new-result already-forced result))))
	  (setf complexity (add-complexity complexity new-complexity)))))
    (values result complexity)))


(define-box-analysis flic-ref (object already-forced uninitialized)
  (values
    already-forced
    (if (memq (flic-ref-var object) uninitialized)
	'#f
	0)))

(define-box-analysis flic-const (object already-forced uninitialized)
  (declare (ignore object uninitialized))
  (values already-forced 0))

(define-box-analysis flic-pack (object already-forced uninitialized)
  (declare (ignore object uninitialized))
  (values already-forced 0))


;;; For case-block and and, already-forced information can be propagated 
;;; sequentially in the clauses.  But only the first expression is 
;;; guaranteed to be evaluated, so only it can propagate the information
;;; outwards.

(define-box-analysis flic-case-block (object already-forced uninitialized)
  (values
    (box-analysis-sequence
      (flic-case-block-exps object) already-forced uninitialized)
    '#f))

(define-box-analysis flic-and (object already-forced uninitialized)
  (values
    (box-analysis-sequence
      (flic-and-exps object) already-forced uninitialized)
    '#f))

(define (box-analysis-sequence exps already-forced uninitialized)
  (let ((result
	  (setf already-forced
		(do-box-analysis
		  (car exps) already-forced uninitialized '#t))))
    (dolist (e (cdr exps))
      (setf already-forced
	    (do-box-analysis e already-forced uninitialized '#t)))
    (values result already-forced)))


(define-box-analysis flic-return-from (object already-forced uninitialized)
  (values
    (do-box-analysis
      (flic-return-from-exp object) already-forced uninitialized '#t)
    '#f))


;;; For if, the test propagates to both branches and the result.
;;; Look for an important optimization:
;;; in (if (and e1 e2 ...) e-then e-else),
;;; e-then can inherit already-forced information from all of the ei
;;; rather than only from e1.
;;; *** Could be smarter about the complexity, I suppose....
;;; *** Also could intersect already-forced results from both
;;; *** branches.

(define-box-analysis flic-if (object already-forced uninitialized)
  (if (is-type? 'flic-and (flic-if-test-exp object))
      (box-analysis-if-and-aux object already-forced uninitialized)
      (box-analysis-if-other-aux object already-forced uninitialized)))

(define (box-analysis-if-other-aux object already-forced uninitialized)
  (setf already-forced
	(do-box-analysis
	  (flic-if-test-exp object) already-forced uninitialized '#t))
  (do-box-analysis (flic-if-then-exp object) already-forced uninitialized '#t)
  (do-box-analysis (flic-if-else-exp object) already-forced uninitialized '#t)
  (values already-forced '#f))

(define (box-analysis-if-and-aux object already-forced uninitialized)
  (let* ((test-exp  (flic-if-test-exp object))
	 (subexps   (flic-and-exps test-exp))
	 (then-exp  (flic-if-then-exp object))
	 (else-exp  (flic-if-else-exp object)))
    (setf (flic-exp-unboxed? test-exp) '#t)
    (multiple-value-bind (result1 resultn)
	(box-analysis-sequence subexps already-forced uninitialized)
      (do-box-analysis then-exp resultn uninitialized '#t)
      (do-box-analysis else-exp result1 uninitialized '#t)
      (values result1 '#f))))


(define-box-analysis flic-sel (object already-forced uninitialized)
  (multiple-value-bind (result complexity)
      (do-box-analysis
        (flic-sel-exp object) already-forced uninitialized '#t)
    (values result (add-complexity sel-complexity complexity))))

(define-box-analysis flic-is-constructor (object already-forced uninitialized)
  (multiple-value-bind (result complexity)
      (do-box-analysis
        (flic-is-constructor-exp object) already-forced uninitialized '#t)
    (values result (add-complexity is-constructor-complexity complexity))))

(define-box-analysis flic-con-number (object already-forced uninitialized)
  (multiple-value-bind (result complexity)
      (do-box-analysis
        (flic-con-number-exp object) already-forced uninitialized '#t)
    (values result (add-complexity con-number-complexity complexity))))

(define-box-analysis flic-void (object already-forced uninitialized)
  (declare (ignore object uninitialized))
  (values already-forced 0))




;;;======================================================================
;;; Already-forced bookkeeping
;;;======================================================================


;;; For now, we only keep track of variables that have been forced,
;;; and not data structure accesses.

(define (already-forced? object already-forced)
  (and (is-type? 'flic-ref object)
       (memq (flic-ref-var object) already-forced)))

(define (note-already-forced object already-forced)
  (if (is-type? 'flic-ref object)
      (cons (flic-ref-var object) already-forced)
      already-forced))

(define (union-already-forced new tail result)
  (cond ((eq? new tail)
	 result)
	((memq (car new) result)
	 (union-already-forced (cdr new) tail result))
	(else
	 (union-already-forced (cdr new) tail (cons (car new) result)))
	))