From 5ef7f500a505f5711b1c76ff8c15f443d4815367 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 4 Apr 2004 14:07:24 +0000 Subject: [PATCH] 0.8.9.16: Make NOTINLINE calls to known functions have their return types derived. ... depun the BASIC-COMBINATION-KIND slot; add FUN-INFO slot to hold any applicable fun-info; ... add a couple of clauses to optimizing routines; ... test case for new behaviour, and also adjust NOTINLINE IDENTITY declarations in other tests --- src/compiler/checkgen.lisp | 44 +++++++++++++++++++++------------------ src/compiler/debug.lisp | 2 +- src/compiler/ir1final.lisp | 2 +- src/compiler/ir1opt.lisp | 48 +++++++++++++++++++++++++++++++------------ src/compiler/ir1util.lisp | 20 ++++++++++-------- src/compiler/ir2tran.lisp | 7 ++++--- src/compiler/ltn.lisp | 20 ++++++++++-------- src/compiler/node.lisp | 17 ++++++++------- src/compiler/srctran.lisp | 2 +- tests/compiler.pure.lisp | 8 ++++++++ tests/defstruct.impure.lisp | 12 +++++------ version.lisp-expr | 2 +- 12 files changed, 113 insertions(+), 71 deletions(-) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 2f9f907..8d04f94 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -332,26 +332,30 @@ nil) ((basic-combination-p dest) (let ((kind (basic-combination-kind dest))) - (cond ((eq cont (basic-combination-fun dest)) t) - ((eq kind :local) t) - ((eq kind :full) - (and (combination-p dest) - (not (values-subtypep ; explicit THE - (continuation-externally-checkable-type cont) - (continuation-type-to-check cont))))) - - ((eq kind :error) nil) - ;; :ERROR means that we have an invalid syntax of - ;; the call and the callee will detect it before - ;; thinking about types. - - ((fun-info-ir2-convert kind) t) - (t - (dolist (template (fun-info-templates kind) nil) - (when (eq (template-ltn-policy template) :fast-safe) - (multiple-value-bind (val win) - (valid-fun-use dest (template-type template)) - (when (or val (not win)) (return t))))))))) + (cond + ((eq cont (basic-combination-fun dest)) t) + (t + (ecase kind + (:local t) + (:full + (and (combination-p dest) + (not (values-subtypep ; explicit THE + (continuation-externally-checkable-type cont) + (continuation-type-to-check cont))))) + ;; :ERROR means that we have an invalid syntax of + ;; the call and the callee will detect it before + ;; thinking about types. + (:error nil) + (:known + (let ((info (basic-combination-fun-info dest))) + (if (fun-info-ir2-convert info) + t + (dolist (template (fun-info-templates info) nil) + (when (eq (template-ltn-policy template) + :fast-safe) + (multiple-value-bind (val win) + (valid-fun-use dest (template-type template)) + (when (or val (not win)) (return t))))))))))))) (t t)))) ;;; Return a lambda form that we can convert to do a hairy type check diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index ac06242..92b70a5 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -965,7 +965,7 @@ (let ((kind (basic-combination-kind node))) (format t "~(~A~A ~A~) " (if (node-tail-p node) "tail " "") - (if (fun-info-p kind) "known" kind) + kind (type-of node)) (print-lvar (basic-combination-fun node)) (dolist (arg (basic-combination-args node)) diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index 4dd2925..7fa816e 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -20,7 +20,7 @@ (defun note-failed-optimization (node failures) (declare (type combination node) (list failures)) (unless (or (node-deleted node) - (not (fun-info-p (combination-kind node)))) + (not (eq :known (combination-kind node)))) (let ((*compiler-error-context* node)) (dolist (failure failures) (let ((what (cdr failure)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index c7ac819..f630293 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -391,8 +391,9 @@ (delete-ref node) (unlink-node node)) (combination - (let ((info (combination-kind node))) - (when (fun-info-p info) + (let ((kind (combination-kind node)) + (info (combination-fun-info node))) + (when (and (eq kind :known) (fun-info-p info)) (let ((attr (fun-info-attributes info))) (when (and (not (ir1-attributep attr call)) ;; ### For now, don't delete potentially @@ -639,23 +640,36 @@ (propagate-fun-change node) (maybe-terminate-block node nil)) (let ((args (basic-combination-args node)) - (kind (basic-combination-kind node))) - (case kind + (kind (basic-combination-kind node)) + (info (basic-combination-fun-info node))) + (ecase kind (:local (let ((fun (combination-lambda node))) (if (eq (functional-kind fun) :let) (propagate-let-args node fun) (propagate-local-call-args node fun)))) - ((:full :error) + (:error (dolist (arg args) (when arg (setf (lvar-reoptimize arg) nil)))) - (t + (:full + (dolist (arg args) + (when arg + (setf (lvar-reoptimize arg) nil))) + (when info + (let ((fun (fun-info-derive-type info))) + (when fun + (let ((res (funcall fun node))) + (when res + (derive-node-type node (coerce-to-values res)) + (maybe-terminate-block node nil))))))) + (:known + (aver info) (dolist (arg args) (when arg (setf (lvar-reoptimize arg) nil))) - (let ((attr (fun-info-attributes kind))) + (let ((attr (fun-info-attributes info))) (when (and (ir1-attributep attr foldable) ;; KLUDGE: The next test could be made more sensitive, ;; only suppressing constant-folding of functions with @@ -681,16 +695,16 @@ (constant-fold-call node) (return-from ir1-optimize-combination))) - (let ((fun (fun-info-derive-type kind))) + (let ((fun (fun-info-derive-type info))) (when fun (let ((res (funcall fun node))) (when res (derive-node-type node (coerce-to-values res)) (maybe-terminate-block node nil))))) - (let ((fun (fun-info-optimizer kind))) + (let ((fun (fun-info-optimizer info))) (unless (and fun (funcall fun node)) - (dolist (x (fun-info-transforms kind)) + (dolist (x (fun-info-transforms info)) #!+sb-show (when *show-transforms-p* (let* ((lvar (basic-combination-fun node)) @@ -777,7 +791,11 @@ (defined-fun-inlinep leaf) :no-chance))) (cond - ((eq inlinep :notinline) (values nil nil)) + ((eq inlinep :notinline) + (let ((info (info :function :info (leaf-source-name leaf)))) + (when info + (setf (basic-combination-fun-info call) info)) + (values nil nil))) ((not (and (global-var-p leaf) (eq (global-var-kind leaf) :global-function))) (values leaf nil)) @@ -812,7 +830,10 @@ (t (let ((info (info :function :info (leaf-source-name leaf)))) (if info - (values leaf (setf (basic-combination-kind call) info)) + (values leaf + (progn + (setf (basic-combination-kind call) :known) + (setf (basic-combination-fun-info call) info))) (values leaf nil))))))) ;;; Check whether CALL satisfies TYPE. If so, apply the type to the @@ -1170,7 +1191,8 @@ (() (null (rest sets)) :exit-if-null) (set-use (principal-lvar-use (set-value set))) (() (and (combination-p set-use) - (fun-info-p (combination-kind set-use)) + (eq (combination-kind set-use) :known) + (fun-info-p (combination-fun-info set-use)) (not (node-to-be-deleted-p set-use)) (eq (combination-fun-source-name set-use) '+)) :exit-if-null) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index a8d177c..538e95a 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1374,8 +1374,8 @@ (append before-args inside-args after-args)) (change-ref-leaf (lvar-uses inside-fun) (find-free-fun 'list "???")) - (setf (combination-kind inside) - (info :function :info 'list)) + (setf (combination-fun-info inside) (info :function :info 'list) + (combination-kind inside) :known) (setf (node-derived-type inside) *wild-type*) (flush-dest lvar) (values)))))) @@ -1601,13 +1601,15 @@ (declare (type combination call)) (let ((kind (basic-combination-kind call))) (or (eq kind :full) - (and (fun-info-p kind) - (not (fun-info-ir2-convert kind)) - (dolist (template (fun-info-templates kind) t) - (when (eq (template-ltn-policy template) :fast-safe) - (multiple-value-bind (val win) - (valid-fun-use call (template-type template)) - (when (or val (not win)) (return nil))))))))) + (and (eq kind :known) + (let ((info (basic-combination-fun-info call))) + (and + (not (fun-info-ir2-convert info)) + (dolist (template (fun-info-templates info) t) + (when (eq (template-ltn-policy template) :fast-safe) + (multiple-value-bind (val win) + (valid-fun-use call (template-type template)) + (when (or val (not win)) (return nil))))))))))) ;;;; careful call diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 3cb5de2..f54563c 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1639,13 +1639,14 @@ (ir2-convert-ref node 2block))))) (combination (let ((kind (basic-combination-kind node))) - (case kind + (ecase kind (:local (ir2-convert-local-call node 2block)) (:full (ir2-convert-full-call node 2block)) - (t - (let ((fun (fun-info-ir2-convert kind))) + (:known + (let* ((info (basic-combination-fun-info node)) + (fun (fun-info-ir2-convert info))) (cond (fun (funcall fun node 2block)) ((eq (basic-combination-info node) :full) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index b38fa17..794e135 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -159,7 +159,8 @@ ;;; can bail out to here. (defun ltn-default-call (call) (declare (type combination call)) - (let ((kind (basic-combination-kind call))) + (let ((kind (basic-combination-kind call)) + (info (basic-combination-fun-info call))) (annotate-fun-lvar (basic-combination-fun call)) (dolist (arg (basic-combination-args call)) @@ -169,8 +170,9 @@ (annotate-1-value-lvar arg)) (cond - ((and (fun-info-p kind) - (fun-info-ir2-convert kind)) + ((and (eq kind :known) + (fun-info-p info) + (fun-info-ir2-convert info)) (setf (basic-combination-info call) :funny) (setf (node-tail-p call) nil)) (t @@ -566,7 +568,7 @@ (declare (type combination call) (type ltn-policy ltn-policy)) (let ((safe-p (ltn-policy-safe-p ltn-policy)) - (current (fun-info-templates (basic-combination-kind call))) + (current (fun-info-templates (basic-combination-fun-info call))) (fallback nil) (rejected nil)) (loop @@ -670,7 +672,7 @@ (or template (template-or-lose 'call-named))) *efficiency-note-cost-threshold*))) - (dolist (try (fun-info-templates (basic-combination-kind call))) + (dolist (try (fun-info-templates (basic-combination-fun-info call))) (when (> (template-cost try) max-cost) (return)) ; FIXME: UNLESS'd be cleaner. (let ((guard (template-guard try))) (when (and (or (not guard) (funcall guard)) @@ -740,7 +742,7 @@ (defun ltn-analyze-known-call (call) (declare (type combination call)) (let ((ltn-policy (node-ltn-policy call)) - (method (fun-info-ltn-annotate (basic-combination-kind call))) + (method (fun-info-ltn-annotate (basic-combination-fun-info call))) (args (basic-combination-args call))) (when method (funcall method call ltn-policy) @@ -768,7 +770,7 @@ (and (leaf-has-source-name-p funleaf) (eq (lvar-fun-name (combination-fun call)) (leaf-source-name funleaf)) - (let ((info (basic-combination-kind call))) + (let ((info (basic-combination-fun-info call))) (not (or (fun-info-ir2-convert info) (ir1-attributep (fun-info-attributes info) recursive)))))) @@ -847,10 +849,10 @@ (etypecase node (ref) (combination - (case (basic-combination-kind node) + (ecase (basic-combination-kind node) (:local (ltn-analyze-local-call node)) ((:full :error) (ltn-default-call node)) - (t + (:known (ltn-analyze-known-call node)))) (cif (ltn-analyze-if node)) (creturn (ltn-analyze-return node)) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index b0bdde3..701d86e 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -1154,13 +1154,16 @@ (args nil :type list) ;; the kind of function call being made. :LOCAL means that this is a ;; local call to a function in the same component, and that argument - ;; syntax checking has been done, etc. Calls to known global - ;; functions are represented by storing the FUN-INFO for the - ;; function in this slot. :FULL is a call to an (as yet) unknown - ;; function. :ERROR is like :FULL, but means that we have discovered - ;; that the call contains an error, and should not be reconsidered - ;; for optimization. - (kind :full :type (or (member :local :full :error) fun-info)) + ;; syntax checking has been done, etc. Calls to known global + ;; functions are represented by storing :KNOWN in this slot and the + ;; FUN-INFO for that function in the FUN-INFO slot. :FULL is a call + ;; to an (as yet) unknown function, or to a known function declared + ;; NOTINLINE. :ERROR is like :FULL, but means that we have + ;; discovered that the call contains an error, and should not be + ;; reconsidered for optimization. + (kind :full :type (member :local :full :error :known)) + ;; if a call to a known global function, contains the FUN-INFO. + (fun-info nil :type (or fun-info null)) ;; some kind of information attached to this node by the back end (info nil)) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 6b554db..71a2313 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2537,7 +2537,7 @@ (cut-node (node &aux did-something) (when (and (not (block-delete-p (node-block node))) (combination-p node) - (fun-info-p (basic-combination-kind node))) + (eq (basic-combination-kind node) :known)) (let* ((fun-ref (lvar-use (combination-fun node))) (fun-name (leaf-source-name (ref-leaf fun-ref))) (modular-fun (find-modular-version fun-name width))) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 41d58f4..09457e9 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1163,3 +1163,11 @@ (type (unsigned-byte 32) i)) (deref a i)))) (compiler-note () (error "The code is not optimized."))) + +(handler-case + (compile nil '(lambda (x) + (declare (type (integer -100 100) x)) + (declare (optimize speed)) + (declare (notinline identity)) + (1+ (identity x)))) + (compiler-note () (error "IDENTITY derive-type not applied."))) diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index 029babd..cc4c796 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -25,15 +25,17 @@ ;;; An &AUX variable in a boa-constructor without a default value ;;; means "do not initialize slot" and does not cause type error +(declaim (notinline opaque-identity)) +(defun opaque-identity (x) x) + (defstruct (boa-saux (:constructor make-boa-saux (&aux a (b 3) (c)))) (a #\! :type (integer 1 2)) (b #\? :type (integer 3 4)) (c #\# :type (integer 5 6))) (let ((s (make-boa-saux))) - (declare (notinline identity)) (locally (declare (optimize (safety 3)) (inline boa-saux-a)) - (assert (raises-error? (identity (boa-saux-a s)) type-error))) + (assert (raises-error? (opaque-identity (boa-saux-a s)) type-error))) (setf (boa-saux-a s) 1) (setf (boa-saux-c s) 5) (assert (eql (boa-saux-a s) 1)) @@ -42,10 +44,9 @@ ; these two checks should be ; kept separated (let ((s (make-boa-saux))) - (declare (notinline identity)) (locally (declare (optimize (safety 0)) (inline boa-saux-a)) - (assert (eql (identity (boa-saux-a s)) 0))) + (assert (eql (opaque-identity (boa-saux-a s)) 0))) (setf (boa-saux-a s) 1) (setf (boa-saux-c s) 5) (assert (eql (boa-saux-a s) 1)) @@ -53,10 +54,9 @@ (assert (eql (boa-saux-c s) 5))) (let ((s (make-boa-saux))) - (declare (notinline identity)) (locally (declare (optimize (safety 3)) (notinline boa-saux-a)) - (assert (raises-error? (identity (boa-saux-a s)) type-error))) + (assert (raises-error? (opaque-identity (boa-saux-a s)) type-error))) (setf (boa-saux-a s) 1) (setf (boa-saux-c s) 5) (assert (eql (boa-saux-a s) 1)) diff --git a/version.lisp-expr b/version.lisp-expr index 4d67f25..fd665fb 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.9.15" +"0.8.9.16" -- 1.7.10.4