Skip to content
Snippets Groups Projects
ir1opt.lisp 56.5 KiB
Newer Older
wlott's avatar
wlott committed
	    (setf (leaf-ever-used leaf) t)
	    
	    (delete-continuation-use call)
	    (add-continuation-use call dummy)
	    (prev-link node dummy)
	    (add-continuation-use node cont)
	    (setf (continuation-next cont) next)
	    (when (eq call (block-last block))
	      (setf (block-last block) node))
ram's avatar
ram committed
	    (reoptimize-continuation cont))))
       (t
	(let ((dummies (loop repeat (length args)
			     collect (gensym))))
	  (transform-call
	   call
	   `(lambda ,dummies
	      (declare (ignore ,@dummies))
	      (values ,@(mapcar #'(lambda (x) `',x) values)))))))))
wlott's avatar
wlott committed
  
  (undefined-value))


;;;; Local call optimization:

;;; Propagate-To-Refs  --  Internal
;;;
;;;    Propagate Type to Leaf and its Refs, marking things changed.  If the
;;; leaf type is a function type, then just leave it alone, since TYPE is never
;;; going to be more specific than that (and TYPE-INTERSECTION would choke.)
;;;
(defun propagate-to-refs (leaf type)
  (declare (type leaf leaf) (type ctype type))
  (let ((var-type (leaf-type leaf)))
    (unless (function-type-p var-type)
      (let ((int (type-intersection var-type type)))
	(when (type/= int var-type)
	  (setf (leaf-type leaf) int)
	  (dolist (ref (leaf-refs leaf))
	    (derive-node-type ref int))))
      (undefined-value))))


;;; PROPAGATE-FROM-SETS  --  Internal
;;;
;;;    Figure out the type of a LET variable that has sets.  We compute the
;;; union of the initial value Type and the types of all the set values and to
;;; a PROPAGATE-TO-REFS with this type.
;;;
(defun propagate-from-sets (var type)
wlott's avatar
wlott committed
    (dolist (set (basic-var-sets var))
      (res (continuation-type (set-value set)))
      (setf (node-reoptimize set) nil))
    (propagate-to-refs var (res)))
  (undefined-value))


;;; IR1-OPTIMIZE-SET  --  Internal
;;;
;;;    If a let variable, find the initial value's type and do
;;; PROPAGATE-FROM-SETS.  We also derive the VALUE's type as the node's type. 
;;;
(defun ir1-optimize-set (node)
  (declare (type cset node))
  (let ((var (set-var node)))
    (when (and (lambda-var-p var) (leaf-refs var))
      (let ((home (lambda-var-home var)))
	(when (eq (functional-kind home) :let)
	  (let ((iv (let-var-initial-value var)))
	    (setf (continuation-reoptimize iv) nil)
	    (propagate-from-sets var (continuation-type iv)))))))
  
  (derive-node-type node (continuation-type (set-value node)))
  (undefined-value))


;;; CONSTANT-REFERENCE-P  --  Interface
ram's avatar
ram committed
;;;
;;;    Return true if the value of Ref will always be the same (and is thus
;;; legal to substitute.)  Even though the value of a FUNCTIONAL really can't
;;; change, we consider it non-constant when it is marker :NOTINLINE, since
;;; this is used as a flag to inhibit local call conversion, and must not be
;;; lost.
ram's avatar
ram committed
;;;
(defun constant-reference-p (ref)
  (declare (type ref ref))
  (let ((leaf (ref-leaf ref)))
    (typecase leaf
      (constant t)
      (functional
       (not (eq (ref-inlinep ref) :notinline)))
ram's avatar
ram committed
      (lambda-var
       (null (lambda-var-sets leaf)))
      (global-var
       (case (global-var-kind leaf)
	 (:global-function
	  (not (eq (ref-inlinep ref) :notinline)))
	 (:constant t))))))


;;; SUBSTITUTE-SINGLE-USE-CONTINUATION  --  Internal
;;;
;;;    If we have a non-set let var with a single use, then (if possible)
;;; replace the variable reference's CONT with the arg continuation.  This is
;;; inhibited when:
;;; -- CONT has other uses, or
;;; -- CONT receives multiple values, or
;;; -- the reference is in a different environment from the variable, or
;;; -- either continuation has a funky TYPE-CHECK annotation.
;;; -- the continuations have incompatible assertions, so the new asserted type
;;;    would be NIL.
;;; -- the var's DEST has a different policy than the ARG's (think safety).
ram's avatar
ram committed
;;;
;;;    We change the Ref to be a reference to NIL with unused value, and let it
;;; be flushed as dead code.  A side-effect of this substitution is to delete
;;; the variable.
;;;
(defun substitute-single-use-continuation (arg var)
  (declare (type continuation arg) (type lambda-var var))
  (let* ((ref (first (leaf-refs var)))
	 (cont (node-cont ref))
	 (cont-atype (continuation-asserted-type cont))
ram's avatar
ram committed
	 (dest (continuation-dest cont)))
    (when (and (eq (continuation-use cont) ref)
	       dest
	       (not (typep dest '(or creturn exit mv-combination)))
		   (lambda-home (lambda-var-home var)))
	       (member (continuation-type-check arg) '(t nil))
	       (member (continuation-type-check cont) '(t nil))
	       (not (eq (values-type-intersection
			 cont-atype
			 (continuation-asserted-type arg))
			*empty-type*))
	       (eq (lexenv-cookie (node-lexenv dest))
		   (lexenv-cookie (node-lexenv (continuation-dest arg)))))
      (assert (member (continuation-kind arg)
		      '(:block-start :deleted-block-start :inside-block)))
      (assert-continuation-type arg cont-atype)
      (setf (node-derived-type ref) *wild-type*)
ram's avatar
ram committed
      (change-ref-leaf ref (find-constant nil))
      (substitute-continuation arg cont)
      (reoptimize-continuation arg)
      t)))


ram's avatar
ram committed
;;; DELETE-LET  --  Interface
;;;
;;;    Delete a Let, removing the call and bind nodes, and warning about any
;;; unreferenced variables.  Note that FLUSH-DEAD-CODE will come along right
;;; away and delete the REF and then the lambda, since we flush the FUN
;;; continuation. 
;;;
(defun delete-let (fun)
  (declare (type clambda fun))
  (assert (member (functional-kind fun) '(:let :mv-let)))
ram's avatar
ram committed
  (note-unreferenced-vars fun)
  (let ((call (let-combination fun)))
    (flush-dest (basic-combination-fun call))
ram's avatar
ram committed
    (unlink-node call)
    (unlink-node (lambda-bind fun))
    (setf (lambda-bind fun) nil))
  (undefined-value))


wlott's avatar
wlott committed
;;; Propagate-Let-Args  --  Internal
;;;
;;;    This function is called when one of the arguments to a LET changes.  We
;;; look at each changed argument.  If the corresponding variable is set, then
;;; we call PROPAGATE-FROM-SETS.  Otherwise, we consider substituting for the
;;; variable, and also propagate derived-type information for the arg to all
;;; the Var's refs.
;;;
;;;    Substitution is inhibited when the arg leaf's derived type isn't a
;;; subtype of the argument's asserted type.  This prevents type checking from
;;; being defeated, and also ensures that the best representation for the
;;; variable can be used.
wlott's avatar
wlott committed
;;;
;;;     Substitution of individual references is inhibited if the reference is
;;; in a different component from the home.  This can only happen with closures
;;; over top-level lambda vars.  In such cases, the references may have already
;;; been compiled, and thus can't be retroactively modified.
;;;
ram's avatar
ram committed
;;;    If all of the variables are deleted (have no references) when we are
;;; done, then we delete the let.
;;;
wlott's avatar
wlott committed
;;;    Note that we are responsible for clearing the Continuation-Reoptimize
;;; flags.
;;;
(defun propagate-let-args (call fun)
  (declare (type combination call) (type clambda fun))
ram's avatar
ram committed
  (loop for arg in (combination-args call)
        and var in (lambda-vars fun) do
    (when (and arg (continuation-reoptimize arg))
      (setf (continuation-reoptimize arg) nil)
      (cond
       ((lambda-var-sets var)
	(propagate-from-sets var (continuation-type arg)))
       ((let ((use (continuation-use arg)))
	  (when (ref-p use)
	    (let ((leaf (ref-leaf use)))
	      (when (and (constant-reference-p use)
			 (values-subtypep (leaf-type leaf)
					  (continuation-asserted-type arg)))
		(propagate-to-refs var (continuation-type arg))
		(let ((this-comp (block-component (node-block use))))
		  (substitute-leaf-if
		   #'(lambda (ref)
		       (cond ((eq (block-component (node-block ref))
				  this-comp)
			      t)
			     (t
			      (assert (eq (functional-kind (lambda-home fun))
					  :top-level))
			      nil)))
		   leaf var))
ram's avatar
ram committed
		t)))))
       ((and (null (rest (leaf-refs var)))
ram's avatar
ram committed
	     (substitute-single-use-continuation arg var)))
       (t
	(propagate-to-refs var (continuation-type arg))))))
  
  (when (every #'null (combination-args call))
    (delete-let fun))

wlott's avatar
wlott committed
  (undefined-value))


;;; Propagate-Local-Call-Args  --  Internal
;;;
;;;    This function is called when one of the args to a non-let local call
;;; changes.  For each changed argument corresponding to an unset variable, we
;;; compute the union of the types across all calls and propagate this type
;;; information to the var's refs.
;;;
;;;    If the function has an XEP, then we don't do anything, since we won't
;;; discover anything.
;;;
;;;    We can clear the Continuation-Reoptimize flags for arguments in all calls
;;; corresponding to changed arguments in Call, since the only use in IR1
;;; optimization of the Reoptimize flag for local call args is right here.
;;;
(defun propagate-local-call-args (call fun)
  (declare (type combination call) (type clambda fun))

  (unless (functional-entry-function fun)
    (let* ((vars (lambda-vars fun))
	   (union (mapcar #'(lambda (arg var)
			      (when (and arg
					 (continuation-reoptimize arg)
					 (null (basic-var-sets var)))
				(continuation-type arg)))
			  (basic-combination-args call)
			  vars))
	   (this-ref (continuation-use (basic-combination-fun call))))
      
      (dolist (arg (basic-combination-args call))
	(when arg
	  (setf (continuation-reoptimize arg) nil)))
      
      (dolist (ref (leaf-refs fun))
	(unless (eq ref this-ref)
	  (setq union
		(mapcar #'(lambda (this-arg old)
			    (when old
			      (setf (continuation-reoptimize this-arg) nil)
			      (type-union (continuation-type this-arg) old)))
			(basic-combination-args
			 (continuation-dest (node-cont ref)))
			union))))
      
      (mapc #'(lambda (var type)
		(when type
		  (propagate-to-refs var type)))
	    vars union)))
  
  (undefined-value))

ram's avatar
ram committed
;;;; Multiple values optimization:

;;; IR1-OPTIMIZE-MV-COMBINATION  --  Internal
;;;
;;;    Do stuff to notice a change to a MV combination node.  There are two
;;; main branches here:
;;;  -- If the call is local, then it is already a MV let, or should become one.
;;;     Note that although all :LOCAL MV calls must eventually be converted to
;;;     :MV-LETs, there can be a window when the call is local, but has not
;;;     been let converted yet.  This is because the entry-point lambdas may
;;;     have stray references (in other entry points) that have not been
;;;     deleted yet.
;;;  -- The call is full.  This case is somewhat similar to the non-MV
;;;     combination optimization: we propagate return type information and
;;;     notice non-returning calls.  We also have an optimization
;;;     which tries to convert MV-CALLs into MV-binds.
;;;
(defun ir1-optimize-mv-combination (node)
  (cond
   ((eq (basic-combination-kind node) :local)
    (let ((fun (basic-combination-fun node)))
      (when (continuation-reoptimize fun)
	(setf (continuation-reoptimize fun) nil)
	(maybe-let-convert (combination-lambda node))))
    (setf (continuation-reoptimize (first (basic-combination-args node))) nil)
    (when (eq (functional-kind (combination-lambda node)) :mv-let)
      (unless (convert-mv-bind-to-let node)
	(ir1-optimize-mv-bind node))))
   (t
    (let* ((fun (basic-combination-fun node))
	   (fun-changed (continuation-reoptimize fun))
	   (args (basic-combination-args node)))
      (when fun-changed
	(setf (continuation-reoptimize fun) nil)
	(let ((type (continuation-type fun)))
	  (when (function-type-p type)
	    (derive-node-type node (function-type-returns type))))
	(maybe-terminate-block node nil)
	(let ((use (continuation-use fun)))
	  (when (and (ref-p use) (functional-p (ref-leaf use))
		     (not (eq (ref-inlinep use) :notinline)))
	    (convert-call-if-possible use node)
	    (maybe-let-convert (ref-leaf use)))))
      (unless (or (eq (basic-combination-kind node) :local)
		  (eq (continuation-function-name fun) '%throw))
	(ir1-optimize-mv-call node))
      (dolist (arg args)
	(setf (continuation-reoptimize arg) nil)))))
;;; IR1-OPTIMIZE-MV-BIND  --  Internal
;;;
;;;    Propagate derived type info from the values continuation to the vars.
;;;
(defun ir1-optimize-mv-bind (node)
  (declare (type mv-combination node))
  (let ((arg (first (basic-combination-args node)))
	(vars (lambda-vars (combination-lambda node))))
    (multiple-value-bind (types nvals)
			 (values-types (continuation-derived-type arg))
      (unless (eq nvals :unknown)
	(mapc #'(lambda (var type)
		  (if (basic-var-sets var)
		      (propagate-from-sets var type)
		      (propagate-to-refs var type)))
		vars
		(append types
			(make-list (max (- (length vars) nvals) 0)
				   :initial-element *null-type*)))))

    (setf (continuation-reoptimize arg) nil))
  (undefined-value))

ram's avatar
ram committed

;;; IR1-OPTIMIZE-MV-CALL  --  Internal
;;;
;;;    If possible, convert a general MV call to an MV-BIND.  We can do this
;;; if:
;;; -- The call has only one argument, and
;;; -- The function has a known fixed number of arguments, or
;;; -- The argument yields a known fixed number of values.
;;;
;;; What we do is change the function in the MV-CALL to be a lambda that "looks
;;; like an MV bind", which allows IR1-OPTIMIZE-MV-COMBINATION to notice that
;;; this call can be converted (the next time around.)  This new lambda just
;;; calls the actual function with the MV-BIND variables as arguments.  Note
;;; that this new MV bind is not let-converted immediately, as there are going
;;; to be stray references from the entry-point functions until they get
;;; deleted.
;;;
;;; In order to avoid loss of argument count checking, we only do the
;;; transformation according to a known number of expected argument if safety
;;; is unimportant.  We can always convert if we know the number of actual
;;; values, since the normal call that we build will still do any appropriate
;;; argument count checking.
;;;
;;; We only attempt the transformation if the called function is a constant
;;; reference.  This allows us to just splice the leaf into the new function,
;;; instead of trying to somehow bind the function expression.  The leaf must
;;; be constant because we are evaluating it again in a different place.  This
;;; also has the effect of squelching multiple warnings when there is an
;;; argument count error.
;;;
(defun ir1-optimize-mv-call (node)
  (let ((fun (basic-combination-fun node))
	(*compiler-error-context* node)
	(ref (continuation-use (basic-combination-fun node)))
	(args (basic-combination-args node)))
    (unless (and (ref-p ref) (constant-reference-p ref)
		 args (null (rest args)))
      (return-from ir1-optimize-mv-call))

    (multiple-value-bind (min max)
			 (function-type-nargs (continuation-type fun))
      (let ((total-nvals 
	     (multiple-value-bind
		 (types nvals)
		 (values-types (continuation-derived-type (first args)))
	       (declare (ignore types))
	       (if (eq nvals :unknown) nil nvals))))

	(when total-nvals
	  (when (and min (< total-nvals min))
	    (compiler-warning
	     "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
	     at least ~R."
	     total-nvals min)
	    (setf (ref-inlinep ref) :notinline)
	    (return-from ir1-optimize-mv-call))
	  (when (and max (> total-nvals max))
	    (compiler-warning
	     "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
	     at most ~R."
	     total-nvals max)
	    (setf (ref-inlinep ref) :notinline)
	    (return-from ir1-optimize-mv-call)))

	(let ((count (cond (total-nvals)
			   ((and (policy node (zerop safety)) (eql min max))
			    min)
			   (t nil))))
	  (when count
	    (with-ir1-environment node
	      (let* ((dums (loop repeat count collect (gensym)))
		     (ignore (gensym))
		     (fun (ir1-convert-lambda
			   `(lambda (&optional ,@dums &rest ,ignore)
			      (declare (ignore ,ignore))
			      (funcall ,(ref-leaf ref) ,@dums)))))
		(change-ref-leaf ref fun)
		(assert (eq (basic-combination-kind node) :full))
		(local-call-analyze *current-component*)
		(assert (eq (basic-combination-kind node) :local)))))))))
  (undefined-value))


;;; CONVERT-MV-BIND-TO-LET  --  Internal
ram's avatar
ram committed
;;;
;;; If we see:
;;;    (multiple-value-bind (x y)
;;;                         (values xx yy)
;;;      ...)
;;; Convert to:
;;;    (let ((x xx)
;;;          (y yy))
;;;      ...)
;;;
;;; What we actually do is convert the VALUES combination into a normal let
;;; combination calling the original :MV-LET lambda.  If there are extra args to
ram's avatar
ram committed
;;; VALUES, discard the corresponding continuations.  If there are insufficient
;;; args, insert references to NIL.
;;;
(defun convert-mv-bind-to-let (call)
  (declare (type mv-combination call))
  (let* ((arg (first (basic-combination-args call)))
	 (use (continuation-use arg)))
    (when (and (combination-p use)
	       (eq (continuation-function-name (combination-fun use))
		   'values))
      (let* ((fun (combination-lambda call))
ram's avatar
ram committed
	     (vars (lambda-vars fun))
	     (vals (combination-args use))
ram's avatar
ram committed
	     (nvars (length vars))
	     (nvals (length vals)))
	(cond ((> nvals nvars)
	       (mapc #'flush-dest (subseq vals nvars))
	       (setq vals (subseq vals 0 nvars)))
	      ((< nvals nvars)
	       (with-ir1-environment use
		 (let ((node-prev (node-prev use)))
		   (setf (node-prev use) nil)
ram's avatar
ram committed
		   (setf (continuation-next node-prev) nil)
		   (collect ((res vals))
		     (loop as cont = (make-continuation use)
ram's avatar
ram committed
			   and prev = node-prev then cont
			   repeat (- nvars nvals)
			   do (reference-constant prev cont nil)
			      (res cont))
		     (setq vals (res)))
		   (prev-link use (car (last vals)))))))
	(setf (combination-args use) vals)
	(flush-dest (combination-fun use))
	(let ((fun-cont (basic-combination-fun call)))
	  (setf (continuation-dest fun-cont) use)
	  (setf (combination-fun use) fun-cont))
	(setf (combination-kind use) :local)
ram's avatar
ram committed
	(setf (functional-kind fun) :let)
	(flush-dest (first (basic-combination-args call)))
	(unlink-node call)
ram's avatar
ram committed
	(when vals
	  (reoptimize-continuation (first vals)))
	(propagate-to-args use fun))
      t)))


;;; VALUES-LIST IR1 optimizer  --  Internal
;;;
;;; If we see:
;;;    (values-list (list x y z))
;;;
;;; Convert to:
;;;    (values x y z)
;;;
;;; In implementation, this is somewhat similar to CONVERT-MV-BIND-TO-LET.  We
;;; grab the args of LIST and make them args of the VALUES-LIST call, flushing
;;; the old argument continuation (allowing the LIST to be flushed.)
;;;
(defoptimizer (values-list optimizer) ((list) node)
  (let ((use (continuation-use list)))
    (when (and (combination-p use)
	       (eq (continuation-function-name (combination-fun use))
		   'list))
      (change-ref-leaf (continuation-use (combination-fun node))
		       (find-free-function 'values "in a strange place"))
      (setf (combination-kind node) :full)
      (let ((args (combination-args use)))
	(dolist (arg args)
	  (setf (continuation-dest arg) node))
	(setf (combination-args use) nil)
	(flush-dest list)
	(setf (combination-args node) args))
ram's avatar
ram committed
      t)))


;;; VALUES IR1 transform  --  Internal
;;;
;;;    If VALUES appears in a non-MV context, then effectively convert it to a
;;; PROG1.  This allows the computation of the additional values to become dead
;;; code.
;;;
(deftransform values ((&rest vals) * * :node node)
  (when (typep (continuation-dest (node-cont node))
	       '(or creturn exit mv-combination))
    (give-up))
  (setf (node-derived-type node) *wild-type*)
  (if vals
      (let ((dummies (loop repeat (1- (length vals))
ram's avatar
ram committed
		       collect (gensym))))
	`(lambda (val ,@dummies)
	   (declare (ignore ,@dummies))
	   val))
      'nil))
ram's avatar
ram committed

wlott's avatar
wlott committed

;;; Flush-Dead-Code  --  Internal
;;;
;;;    Delete any nodes in Block whose value is unused and have no
;;; side-effects.  We can delete sets of lexical variables when the set
;;; variable has no references.
;;;
;;; [### For now, don't delete potentially flushable calls when they have the
;;; Call attribute.  Someday we should look at the funcitonal args to determine
;;; if they have any side-effects.] 
;;;
(defun flush-dead-code (block)
  (declare (type cblock block))
  (do-nodes-backwards (node cont block)
    (unless (continuation-dest cont)
      (typecase node
	(ref
	 (delete-ref node)
	 (unlink-node node))
	(combination
	 (let ((info (combination-kind node)))
	   (when (function-info-p info)	     
	     (let ((attr (function-info-attributes info)))
	       (when (and (ir1-attributep attr flushable)
			  (not (ir1-attributep attr call)))
		 (flush-dest (combination-fun node))
		 (dolist (arg (combination-args node))
		   (flush-dest arg))
		 (unlink-node node))))))
	(mv-combination
	 (when (eq (basic-combination-kind node) :local)
	   (let ((fun (combination-lambda node)))
	     (when (dolist (var (lambda-vars fun) t)
		     (when (or (leaf-refs var)
			       (lambda-var-sets var))
		       (return nil)))
	       (flush-dest (first (basic-combination-args node)))
	       (delete-let fun)))))
wlott's avatar
wlott committed
	(exit
	 (let ((value (exit-value node)))
	   (when value
	     (flush-dest value)
	     (setf (exit-value node) nil))))
	(cset
	 (let ((var (set-var node)))
	   (when (and (lambda-var-p var)
		      (null (leaf-refs var)))
	     (flush-dest (set-value node))
	     (setf (basic-var-sets var)
		   (delete node (basic-var-sets var)))
	     (unlink-node node)))))))

  (setf (block-flush-p block) nil)
  (undefined-value))