From fdcbe9458df7ddd577fbd5a2ba0423d2558b0d78 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Thu, 21 Dec 2023 22:51:21 +0100 Subject: [PATCH] cmp: better dead code elimination Eliminate dead branches in IF/AND/OR forms if the type of the object returned by the test form is known to be null or non-null. Get rid of unnecessary tests in AND/OR forms if we know that a clause cannot short-circuit the evaluation. Replace NOT forms by T or NIL constants if we know that the argument is null or non-null. --- src/cmp/cmpbackend-cxx/cmppass2-eval.lsp | 120 ++++++++++++++++------- src/cmp/cmpcond.lsp | 25 +++++ 2 files changed, 108 insertions(+), 37 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp index 097f184b0..ab166ce36 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp @@ -43,20 +43,29 @@ until (member (c1form-name form) '(CL:GO CL:RETURN-FROM)))) (defun c2if (c1form fmla form1 form2) - (declare (ignore c1form)) ;; FIXME! Optimize when FORM1 or FORM2 are constants - (cond ((and (eq *destination* 'TRASH) + (cond ((type-true-p (c1form-primary-type fmla)) + ;; The true branch is always taken + (warn-dead-code form2 c1form "the test ~S always evaluates to true" fmla) + (let ((*destination* 'TRASH)) + (c2expr* fmla)) + (c2expr form1)) + ((type-false-p (c1form-primary-type fmla)) + ;; The false branch is always taken + (warn-dead-code form1 c1form "the test ~S always evaluates to false" fmla) + (let ((*destination* 'TRASH)) + (c2expr* fmla)) + (c2expr form2)) + ((and (eq *destination* 'TRASH) (eq (c1form-name form2) 'LOCATION)) - ;; Optimize (IF condition true-branch) or a situation in which - ;; the false branch can be discarded. + ;; The value produced by the false branch is not used (with-exit-label (false-label *exit*) (let ((*destination* `(JUMP-FALSE ,false-label))) (c2expr* fmla)) (c2expr form1))) ((and (eq *destination* 'TRASH) (eq (c1form-name form1) 'LOCATION)) - ;; Optimize (IF condition useless-value false-branch) when - ;; the true branch can be discarded. + ;; The value produced by the true branch is not used (with-exit-label (true-label *exit*) (let ((*destination* `(JUMP-TRUE ,true-label))) (c2expr* fmla)) @@ -79,7 +88,15 @@ (defun c2fmla-not (c1form arg) (declare (ignore c1form)) (let ((dest *destination*)) - (cond ((jump-true-destination-p dest) + (cond ((type-true-p (c1form-primary-type arg)) + (let ((*destination* 'TRASH)) + (c2expr* arg)) + (c2expr (c1nil))) + ((type-false-p (c1form-primary-type arg)) + (let ((*destination* 'TRASH)) + (c2expr* arg)) + (c2expr (c1t))) + ((jump-true-destination-p dest) (let ((*destination* `(JUMP-FALSE ,@(cdr dest)))) (c2expr arg))) ((jump-false-destination-p dest) @@ -90,38 +107,67 @@ (unwind-exit (negate-argument arg dest))))))) (defun c2fmla-and (c1form butlast last) - (declare (ignore c1form)) - (if (jump-false-destination-p *destination*) - (progn - (mapc #'c2expr* butlast) - (c2expr last)) - (with-exit-label (normal-exit) - (with-exit-label (false-label) - (let ((*destination* `(JUMP-FALSE ,false-label))) - (mapc #'c2expr* butlast)) - (c2expr last)) - (unwind-exit *vv-nil*)))) + (flet ((c2expr-and-arguments (eval-dest exit-dest) + (loop with *destination* = eval-dest + for expr in butlast + for remaining-exprs on butlast + for type = (c1form-primary-type expr) + do (cond ((type-false-p type) + (warn-dead-code (append (rest remaining-exprs) (list last)) c1form + "the test ~S always evaluates to false" expr) + (let ((*destination* exit-dest)) + (c2expr* expr)) + (return-from c2expr-and-arguments)) + ((type-true-p type) + (let ((*destination* 'TRASH)) + (c2expr* expr))) + (t + (c2expr* expr))) + finally + (let ((*destination* exit-dest)) + (c2expr last))))) + (if (jump-false-destination-p *destination*) + (c2expr-and-arguments *destination* *destination*) + (with-exit-label (normal-exit) + (with-exit-label (false-label) + (c2expr-and-arguments `(JUMP-FALSE ,false-label) *destination*)) + (unwind-exit *vv-nil*))))) (defun c2fmla-or (c1form butlast last) - (declare (ignore c1form)) - (cond ((jump-true-destination-p *destination*) - (mapc #'c2expr* butlast) - (c2expr last)) - ((jump-false-destination-p *destination*) - (with-exit-label (true-label) - (let ((*destination* `(JUMP-TRUE ,true-label))) - (mapc #'c2expr* butlast)) - (c2expr last)) - (unwind-exit *vv-t*)) - (t - (with-exit-label (common-exit) - (with-exit-label (normal-exit) - (dolist (f butlast) - (let ((*destination* 'VALUE0)) - (c2expr* f)) - (unwind-cond normal-exit :jump-t 'VALUE0)) - (c2expr last)) - (unwind-exit 'VALUE0))))) + (flet ((c2expr-or-arguments (eval-dest exit-dest operation) + (loop with *destination* = eval-dest + for expr in butlast + for remaining-exprs on butlast + for type = (c1form-primary-type expr) + do (cond ((type-true-p type) + (warn-dead-code (append (rest remaining-exprs) (list last)) c1form + "the test ~S always evaluates to true" expr) + (let ((*destination* 'VALUE0)) + (c2expr* expr)) + (return-from c2expr-or-arguments)) + ((type-false-p type) + (let ((*destination* 'TRASH)) + (c2expr* expr))) + (t + (funcall operation expr))) + finally + (let ((*destination* exit-dest)) + (c2expr last))))) + (cond ((jump-true-destination-p *destination*) + (c2expr-or-arguments *destination* *destination* #'c2expr*)) + ((jump-false-destination-p *destination*) + (with-exit-label (true-label) + (c2expr-or-arguments `(JUMP-TRUE ,true-label) *destination* #'c2expr*)) + (unwind-exit *vv-t*)) + (t + (with-exit-label (common-exit) + (with-exit-label (normal-exit) + (c2expr-or-arguments *destination* *destination* + (lambda (expr) + (let ((*destination* 'VALUE0)) + (c2expr* expr)) + (unwind-cond normal-exit :jump-t 'VALUE0)))) + (unwind-exit 'VALUE0)))))) (defun c2mv-prog1 (c1form form body) (declare (ignore c1form)) diff --git a/src/cmp/cmpcond.lsp b/src/cmp/cmpcond.lsp index 2de33253c..299d29f24 100644 --- a/src/cmp/cmpcond.lsp +++ b/src/cmp/cmpcond.lsp @@ -104,6 +104,22 @@ "Circular references in creation form for ~S." (compiler-message-form c))))) +(define-condition dead-code (compiler-note style-warning) + ((dead-forms :initarg :dead-forms :initform nil) + (context :initarg :context :initform nil) + (explanation :initarg :explanation :initform "") + (explanation-args :initarg :explanation-args :initform nil)) + (:report + (lambda (c stream) + (let ((dead-forms (slot-value c 'dead-forms))) + (compiler-message-report stream c + "Eliminating the form~P ~{~S~^, ~} in ~S: ~?." + (length dead-forms) + (mapcar #'c1form-form dead-forms) + (c1form-form (slot-value c 'context)) + (slot-value c 'explanation) + (mapcar #'c1form-form (slot-value c 'explanation-args))))))) + (defun print-compiler-message (c stream) (unless (typep c *suppress-compiler-messages*) #+cmu-format @@ -194,6 +210,15 @@ (defun undefined-variable (sym) (do-cmpwarn 'compiler-undefined-variable :name sym)) +(defun warn-dead-code (dead-forms context explanation &rest explanation-args) + (do-cmpwarn 'dead-code + :dead-forms (if (listp dead-forms) + dead-forms + (list dead-forms)) + :context context + :explanation explanation + :explanation-args explanation-args)) + (defun baboon (&key (format-control "A bug was found in the compiler") format-arguments) (signal 'compiler-internal-error