common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Simplify lvar-fun-type

Browse source
This commit is contained in:
Stas Boukarev 2023-07-19 14:52:43 +03:00
parent 65620d6315
commit 723602dd7b
8 changed files with 46 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
src/compiler/callable-args.lisp
View file

@ -150,7 +150,7 @@
(when lvar (when lvar
(call lvar annotation))))))))) (call lvar annotation)))))))))
(defun lvar-fun-type (lvar &optional defined-here declared-only asserted-type) (defun lvar-fun-type (lvar &optional defined-here asserted-type)
;; Handle #'function, 'function and (lambda (x y)) ;; Handle #'function, 'function and (lambda (x y))
(let* ((use (principal-lvar-use lvar)) (let* ((use (principal-lvar-use lvar))
(lvar-type (lvar-type lvar)) (lvar-type (lvar-type lvar))
@ -163,27 +163,36 @@
(node-source-form use)) (node-source-form use))
(t (t
'.anonymous.)))))) '.anonymous.))))))
(asserted t)
(defined-type (and (global-var-p leaf) (defined-type (and (global-var-p leaf)
(case (leaf-where-from leaf) (case (leaf-where-from leaf)
(:declared (:declared
(leaf-type leaf)) (leaf-type leaf))
((:defined :defined-here) (:defined
(if (or (and (defined-fun-p leaf) (cond ((or defined-here
(eq (defined-fun-inlinep leaf) 'notinline)) asserted-type
declared-only (and (defined-fun-p leaf)
(and defined-here (eq (defined-fun-inlinep leaf) 'notinline))
(eq (leaf-where-from leaf) :defined)) (fun-lexically-notinline-p (leaf-%source-name leaf)
(fun-lexically-notinline-p (leaf-%source-name leaf) (node-lexenv (lvar-dest lvar))))
(node-lexenv (lvar-dest lvar)))) (setf asserted nil)
lvar-type lvar-type)
(global-ftype (leaf-%source-name leaf)))) (t
(global-ftype (leaf-%source-name leaf)))))
(:defined-here
(cond ((or (and (defined-fun-p leaf)
(eq (defined-fun-inlinep leaf) 'notinline))
(fun-lexically-notinline-p (leaf-%source-name leaf)
(node-lexenv (lvar-dest lvar))))
lvar-type)
(t
(global-ftype (leaf-%source-name leaf)))))
(t (t
(global-var-defined-type leaf))))) (global-var-defined-type leaf)))))
(entry-fun (if (and (functional-p leaf) (entry-fun (if (and (functional-p leaf)
(eq (functional-kind leaf) :external)) (eq (functional-kind leaf) :external))
(functional-entry-fun leaf) (functional-entry-fun leaf)
leaf)) leaf))
(asserted t)
(lvar-type (cond ((and defined-type (lvar-type (cond ((and defined-type
(neq defined-type *universal-type*)) (neq defined-type *universal-type*))
defined-type) defined-type)
@ -235,8 +244,7 @@
(if (or (fun-lexically-notinline-p fun-name (if (or (fun-lexically-notinline-p fun-name
(node-lexenv (lvar-dest lvar))) (node-lexenv (lvar-dest lvar)))
(and (neq (info :function :where-from fun-name) :declared) (and (neq (info :function :where-from fun-name) :declared)
(or defined-here asserted-type))
declared-only)))
lvar-type lvar-type
(global-ftype fun-name))) (global-ftype fun-name)))
((functional-p leaf) ((functional-p leaf)

9
src/compiler/ctype.lisp
View file

@ -908,10 +908,10 @@ and no value was provided for it." name))))))))))
;;; Call FUN with (arg-lvar arg-type lvars &optional annotation) ;;; Call FUN with (arg-lvar arg-type lvars &optional annotation)
(defun map-combination-args-and-types (fun call &optional info (defun map-combination-args-and-types (fun call &optional info
unknown-keys-fun unknown-keys-fun
declared-only defined-here
(asserted-type declared-only)) asserted-type)
(declare (type function fun) (type combination call)) (declare (type function fun) (type combination call))
(binding* ((type (lvar-fun-type (combination-fun call) declared-only declared-only asserted-type)) (binding* ((type (lvar-fun-type (combination-fun call) defined-here asserted-type))
(nil (fun-type-p type) :exit-if-null) (nil (fun-type-p type) :exit-if-null)
(annotation (and info (annotation (and info
(fun-info-annotation info))) (fun-info-annotation info)))
@ -1046,8 +1046,7 @@ and no value was provided for it." name))))))))))
call call
info info
nil nil
t t))))
nil))))
(values)) (values))
;;;; FIXME: Move to some other file. ;;;; FIXME: Move to some other file.

30
src/compiler/ir1opt.lisp
View file

@ -257,20 +257,15 @@
(let ((dest (lvar-dest lvar))) (let ((dest (lvar-dest lvar)))
(when (combination-p dest) (when (combination-p dest)
;; TODO: MV-COMBINATION ;; TODO: MV-COMBINATION
(let* ((fun (combination-fun dest)) (when (call-full-like-p dest)
(fun-type (lvar-type fun))) (map-combination-args-and-types
(when (and (call-full-like-p dest) (lambda (arg type &rest args)
(fun-type-p fun-type) (declare (ignore args))
;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)). (when (eq arg lvar)
(not (fun-type-wild-args fun-type))) (return-from lvar-externally-checkable-type
(map-combination-args-and-types (coerce-to-values type))))
(lambda (arg type &rest args) dest
(declare (ignore args)) nil nil t t)))
(when (eq arg lvar)
(return-from lvar-externally-checkable-type
(coerce-to-values type))))
dest
nil nil t))))
*wild-type*)) *wild-type*))
;;;; interface routines used by optimizers ;;;; interface routines used by optimizers
@ -1142,7 +1137,7 @@
(cond ((global-var-p leaf) (cond ((global-var-p leaf)
(values (leaf-type leaf) (leaf-defined-type leaf))) (values (leaf-type leaf) (leaf-defined-type leaf)))
((eq kind :unknown-keys) ((eq kind :unknown-keys)
(values (lvar-fun-type fun t t t) nil)) (values (lvar-fun-type fun t t) nil))
(t (t
(values nil nil))) (values nil nil)))
(when (or (and (eq kind :unknown-keys) (when (or (and (eq kind :unknown-keys)
@ -1427,8 +1422,7 @@
(derive-node-type call (tail-set-type (lambda-tail-set fun)))))) (derive-node-type call (tail-set-type (lambda-tail-set fun))))))
(:full (:full
(multiple-value-bind (leaf info) (multiple-value-bind (leaf info)
(multiple-value-bind (type name leaf asserted) (multiple-value-bind (type name leaf asserted) (lvar-fun-type fun-lvar)
(lvar-fun-type fun-lvar t t)
(declare (ignore name)) (declare (ignore name))
(validate-call-type call type leaf nil asserted)) (validate-call-type call type leaf nil asserted))
(cond ((functional-p leaf) (cond ((functional-p leaf)
@ -2347,7 +2341,7 @@
(setf (lvar-reoptimize arg) nil)) (setf (lvar-reoptimize arg) nil))
(when fun-changed (when fun-changed
(setf (lvar-reoptimize fun) nil) (setf (lvar-reoptimize fun) nil)
(let ((type (lvar-fun-type fun t t t))) (let ((type (lvar-fun-type fun t t)))
(when (fun-type-p type) (when (fun-type-p type)
(derive-node-type node (fun-type-returns type)))) (derive-node-type node (fun-type-returns type))))
(maybe-terminate-block node nil) (maybe-terminate-block node nil)

8
src/compiler/seqtran.lisp
View file

@ -501,7 +501,7 @@
(not key)) (not key))
(eq-comparable-type-p (lvar-type item))) (eq-comparable-type-p (lvar-type item)))
(t (t
(let ((type (lvar-fun-type key t t t))) (let ((type (lvar-fun-type key t t)))
(when (fun-type-p type) (when (fun-type-p type)
(eq-comparable-type-p (eq-comparable-type-p
(single-value-type (fun-type-returns type))))))) (single-value-type (fun-type-returns type)))))))
@ -1990,7 +1990,7 @@
(lvar-fun-is key '(identity))))) (lvar-fun-is key '(identity)))))
(flet ((fun-accepts-type (fun-lvar argument) (flet ((fun-accepts-type (fun-lvar argument)
(when fun-lvar (when fun-lvar
(let ((fun-type (lvar-fun-type fun-lvar t t t))) (let ((fun-type (lvar-fun-type fun-lvar t t)))
(when (fun-type-p fun-type) (when (fun-type-p fun-type)
(let ((arg (nth argument (fun-type-n-arg-types (1+ argument) fun-type)))) (let ((arg (nth argument (fun-type-n-arg-types (1+ argument) fun-type))))
(when arg (when arg
@ -3106,14 +3106,14 @@
start start
end end
&allow-other-keys)) &allow-other-keys))
(multiple-value-bind (fun-type name) (lvar-fun-type fun t t t) (multiple-value-bind (fun-type name) (lvar-fun-type fun t t)
(when (fun-type-p fun-type) (when (fun-type-p fun-type)
(let* ((initial-value-type (and initial-value (let* ((initial-value-type (and initial-value
(lvar-type initial-value))) (lvar-type initial-value)))
(sequence-type (lvar-type sequence)) (sequence-type (lvar-type sequence))
(element-type (element-type
(cond ((and key (cond ((and key
(multiple-value-bind (key-type name) (lvar-fun-type key t t t) (multiple-value-bind (key-type name) (lvar-fun-type key t t)
(cond ((eq name 'identity) (cond ((eq name 'identity)
nil) nil)
((fun-type-p key-type) ((fun-type-p key-type)

2
src/compiler/srctran.lisp
View file

@ -5590,7 +5590,7 @@
#+sb-thread #+sb-thread
(progn (progn
(defoptimizer (sb-thread::call-with-mutex derive-type) ((function mutex waitp timeout)) (defoptimizer (sb-thread::call-with-mutex derive-type) ((function mutex waitp timeout))
(let ((type (lvar-fun-type function t t t))) (let ((type (lvar-fun-type function t t)))
(when (fun-type-p type) (when (fun-type-p type)
(let ((null-p (not (and (constant-lvar-p waitp) (let ((null-p (not (and (constant-lvar-p waitp)
(lvar-value waitp) (lvar-value waitp)

2
tests/compiler-1.impure-cload.lisp
View file

@ -183,7 +183,7 @@
(declare (type (real 1) x)) (declare (type (real 1) x))
(setq x z)) (setq x z))
(list x z)) (list x z))
(assert-error (bug231b nil 1) type-error) (assert-error (bug231b (eval 'nil) 1) type-error)
(assert-error (bug231b 0 1.5) type-error) (assert-error (bug231b 0 1.5) type-error)
(assert-error (bug231b 0 0) type-error) (assert-error (bug231b 0 0) type-error)

2
tests/compiler-2.impure-cload.lisp
View file

@ -74,7 +74,7 @@
(optimize (speed 3) (safety 3) (space 0) (debug 0))) (optimize (speed 3) (safety 3) (space 0) (debug 0)))
(aref x y))) (aref x y)))
(assert-error (bubblesort (make-array 10) 9)) (assert-error (bubblesort (eval '(make-array 10)) 9))
(define-symbol-macro %trash% what) (define-symbol-macro %trash% what)
(locally (locally

3
tests/compiler.impure.lisp
View file

@ -1606,8 +1606,7 @@
;;;; bug 305: INLINE/NOTINLINE causing local ftype to be lost ;;;; bug 305: INLINE/NOTINLINE causing local ftype to be lost
(test-util:with-test (:name (compile inline notinline) (test-util:with-test (:name (compile inline notinline))
:fails-on :sbcl)
(labels ((compile-lambda (type sense allow-notes) (labels ((compile-lambda (type sense allow-notes)
(nth-value (nth-value
4 (test-util:checked-compile 4 (test-util:checked-compile