From bdf98d92c90e6808a0219e1ff39486636d485790 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Sat, 26 Apr 2003 18:39:30 +0000 Subject: [PATCH] Fix for compiled test cases of the form (PROGN (FBOUNDP 42) T), which don't signal an error in safe code because such calls are flushed when the called function is FLUSHABLE and the value of the call is not used. * src/compiler/ir1opt.lisp (flush-dead-code): Suppress flushing of flushable known functions if safety = 3. --- compiler/ir1opt.lisp | 24 ++++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp index dd2fd0dd2..09d4bd95b 100644 --- a/compiler/ir1opt.lisp +++ b/compiler/ir1opt.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.75 2003/04/24 13:59:34 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.76 2003/04/26 18:39:30 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -486,10 +486,23 @@ (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)))))) + (if (policy node (= safety 3)) + ;; Don't flush calls to flushable functions if + ;; their value is unused in safe code, because + ;; this means something like (PROGN (FBOUNDP 42) + ;; T) won't signal an error. KLUDGE: The right + ;; thing to do here is probably teaching + ;; MAYBE-NEGATE-CHECK and friends to accept nil + ;; continuation-dests instead of faking one. + ;; Can't be bothered at present. + ;; Gerd, 2003-04-26. + (setf (continuation-dest cont) + (continuation-next cont)) + (progn + (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))) @@ -1146,7 +1159,6 @@ (local-call-analyze *current-component*))) (undefined-value)) - ;;; Constant-Fold-Call -- Internal ;;; ;;; Replace a call to a foldable function of constant arguments with the -- GitLab