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
(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))
(let* ((use (principal-lvar-use lvar))
(lvar-type (lvar-type lvar))
@ -163,27 +163,36 @@
(node-source-form use))
(t
'.anonymous.))))))
(asserted t)
(defined-type (and (global-var-p leaf)
(case (leaf-where-from leaf)
(:declared
(leaf-type leaf))
((:defined :defined-here)
(if (or (and (defined-fun-p leaf)
(eq (defined-fun-inlinep leaf) 'notinline))
declared-only
(and defined-here
(eq (leaf-where-from leaf) :defined))
(fun-lexically-notinline-p (leaf-%source-name leaf)
(node-lexenv (lvar-dest lvar))))
lvar-type
(global-ftype (leaf-%source-name leaf))))
(:defined
(cond ((or defined-here
asserted-type
(and (defined-fun-p leaf)
(eq (defined-fun-inlinep leaf) 'notinline))
(fun-lexically-notinline-p (leaf-%source-name leaf)
(node-lexenv (lvar-dest lvar))))
(setf asserted nil)
lvar-type)
(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
(global-var-defined-type leaf)))))
(entry-fun (if (and (functional-p leaf)
(eq (functional-kind leaf) :external))
(functional-entry-fun leaf)
leaf))
(asserted t)
(lvar-type (cond ((and defined-type
(neq defined-type *universal-type*))
defined-type)
@ -235,8 +244,7 @@
(if (or (fun-lexically-notinline-p fun-name
(node-lexenv (lvar-dest lvar)))
(and (neq (info :function :where-from fun-name) :declared)
(or defined-here
declared-only)))
asserted-type))
lvar-type
(global-ftype fun-name)))
((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)
(defun map-combination-args-and-types (fun call &optional info
unknown-keys-fun
declared-only
(asserted-type declared-only))
defined-here
asserted-type)
(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)
(annotation (and info
(fun-info-annotation info)))
@ -1046,8 +1046,7 @@ and no value was provided for it." name))))))))))
call
info
nil
t
nil))))
t))))
(values))
;;;; FIXME: Move to some other file.

30
src/compiler/ir1opt.lisp
View file

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

8
src/compiler/seqtran.lisp
View file

@ -501,7 +501,7 @@
(not key))
(eq-comparable-type-p (lvar-type item)))
(t
(let ((type (lvar-fun-type key t t t)))
(let ((type (lvar-fun-type key t t)))
(when (fun-type-p type)
(eq-comparable-type-p
(single-value-type (fun-type-returns type)))))))
@ -1990,7 +1990,7 @@
(lvar-fun-is key '(identity)))))
(flet ((fun-accepts-type (fun-lvar argument)
(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)
(let ((arg (nth argument (fun-type-n-arg-types (1+ argument) fun-type))))
(when arg
@ -3106,14 +3106,14 @@
start
end
&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)
(let* ((initial-value-type (and initial-value
(lvar-type initial-value)))
(sequence-type (lvar-type sequence))
(element-type
(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)
nil)
((fun-type-p key-type)

2
src/compiler/srctran.lisp
View file

@ -5590,7 +5590,7 @@
#+sb-thread
(progn
(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)
(let ((null-p (not (and (constant-lvar-p waitp)
(lvar-value waitp)

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

@ -183,7 +183,7 @@
(declare (type (real 1) x))
(setq 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 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)))
(aref x y)))
(assert-error (bubblesort (make-array 10) 9))
(assert-error (bubblesort (eval '(make-array 10)) 9))
(define-symbol-macro %trash% what)
(locally

3
tests/compiler.impure.lisp
View file

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