X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fknownfun.lisp;h=8347fe574606df0f01e44c8605abe8e48938b2b5;hb=d319b944d934f3efbb01a2a345c46bafd40857d0;hp=6be6b403f201a119b9666950b380d06c4ed8687d;hpb=1c91b0bc7eb814af6a8c58a99a83a024716138e8;p=sbcl.git diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index 6be6b40..8347fe5 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -108,9 +108,12 @@ (ltn-annotate nil :type (or function null)) ;; If true, the special-case IR2 conversion method for this ;; function. This deals with funny functions, and anything else that - ;; can't be handled using the template mechanism. The Combination + ;; can't be handled using the template mechanism. The COMBINATION ;; node and the IR2-BLOCK are passed as arguments. (ir2-convert nil :type (or function null)) + ;; If true, the function can stack-allocate the result. The + ;; COMBINATION node is passed as an argument. + (stack-allocate-result nil :type (or function null)) ;; all the templates that could be used to translate this function ;; into IR2, sorted by increasing cost. (templates nil :type list) @@ -154,18 +157,18 @@ ;;; Grab the FUN-INFO and enter the function, replacing any old ;;; one with the same type and note. (declaim (ftype (function (t list function &optional (or string null) - (member t nil)) - *) - %deftransform)) + (member t nil)) + *) + %deftransform)) (defun %deftransform (name type fun &optional note important) (let* ((ctype (specifier-type type)) - (note (or note "optimize")) - (info (fun-info-or-lose name)) - (old (find-if (lambda (x) - (and (type= (transform-type x) ctype) - (string-equal (transform-note x) note) - (eq (transform-important x) important))) - (fun-info-transforms info)))) + (note (or note "optimize")) + (info (fun-info-or-lose name)) + (old (find-if (lambda (x) + (and (type= (transform-type x) ctype) + (string-equal (transform-note x) note) + (eq (transform-important x) important))) + (fun-info-transforms info)))) (cond (old (style-warn "Overwriting ~S" old) (setf (transform-function old) fun @@ -179,31 +182,31 @@ ;;; Make a FUN-INFO structure with the specified type, attributes ;;; and optimizers. (declaim (ftype (function (list list attributes &key - (:derive-type (or function null)) - (:optimizer (or function null))) - *) - %defknown)) + (:derive-type (or function null)) + (:optimizer (or function null))) + *) + %defknown)) (defun %defknown (names type attributes &key derive-type optimizer) (let ((ctype (specifier-type type)) - (info (make-fun-info :attributes attributes + (info (make-fun-info :attributes attributes :derive-type derive-type :optimizer optimizer)) - (target-env *info-environment*)) + (target-env *info-environment*)) (dolist (name names) (let ((old-fun-info (info :function :info name))) - (when old-fun-info - ;; This is handled as an error because it's generally a bad - ;; thing to blow away all the old optimization stuff. It's - ;; also a potential source of sneaky bugs: - ;; DEFKNOWN FOO - ;; DEFTRANSFORM FOO - ;; DEFKNOWN FOO ; possibly hidden inside some macroexpansion - ;; ; Now the DEFTRANSFORM doesn't exist in the target Lisp. - ;; However, it's continuable because it might be useful to do - ;; it when testing new optimization stuff interactively. - (cerror "Go ahead, overwrite it." - "~@" - old-fun-info name))) + (when old-fun-info + ;; This is handled as an error because it's generally a bad + ;; thing to blow away all the old optimization stuff. It's + ;; also a potential source of sneaky bugs: + ;; DEFKNOWN FOO + ;; DEFTRANSFORM FOO + ;; DEFKNOWN FOO ; possibly hidden inside some macroexpansion + ;; ; Now the DEFTRANSFORM doesn't exist in the target Lisp. + ;; However, it's continuable because it might be useful to do + ;; it when testing new optimization stuff interactively. + (cerror "Go ahead, overwrite it." + "~@" + old-fun-info name))) (setf (info :function :type name target-env) ctype) (setf (info :function :where-from name target-env) :declared) (setf (info :function :kind name target-env) :function) @@ -218,11 +221,11 @@ (declaim (ftype (sfunction (t) fun-info) fun-info-or-lose)) (defun fun-info-or-lose (name) (let (;; FIXME: Do we need this rebinding here? It's a literal - ;; translation of the old CMU CL rebinding to - ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*), - ;; and it's not obvious whether the rebinding to itself is - ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*. - (*info-environment* *info-environment*)) + ;; translation of the old CMU CL rebinding to + ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*), + ;; and it's not obvious whether the rebinding to itself is + ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*. + (*info-environment* *info-environment*)) (let ((old (info :function :info name))) (unless old (error "~S is not a known function." name)) (setf (info :function :info name) (copy-fun-info old))))) @@ -233,12 +236,12 @@ ;;; only be done when the result value is that argument. (defun result-type-first-arg (call) (declare (type combination call)) - (let ((cont (first (combination-args call)))) - (when cont (continuation-type cont)))) + (let ((lvar (first (combination-args call)))) + (when lvar (lvar-type lvar)))) (defun result-type-last-arg (call) (declare (type combination call)) - (let ((cont (car (last (combination-args call))))) - (when cont (continuation-type cont)))) + (let ((lvar (car (last (combination-args call))))) + (when lvar (lvar-type lvar)))) ;;; Derive the result type according to the float contagion rules, but ;;; always return a float. This is used for irrational functions that @@ -246,8 +249,8 @@ (defun result-type-float-contagion (call) (declare (type combination call)) (reduce #'numeric-contagion (combination-args call) - :key #'continuation-type - :initial-value (specifier-type 'single-float))) + :key #'lvar-type + :initial-value (specifier-type 'single-float))) ;;; Return a closure usable as a derive-type method for accessing the ;;; N'th argument. If arg is a list, result is a list. If arg is a @@ -255,23 +258,23 @@ (defun sequence-result-nth-arg (n) (lambda (call) (declare (type combination call)) - (let ((cont (nth (1- n) (combination-args call)))) - (when cont - (let ((type (continuation-type cont))) - (if (array-type-p type) - (specifier-type - `(vector ,(type-specifier (array-type-element-type type)))) - (let ((ltype (specifier-type 'list))) - (when (csubtypep type ltype) - ltype)))))))) + (let ((lvar (nth (1- n) (combination-args call)))) + (when lvar + (let ((type (lvar-type lvar))) + (if (array-type-p type) + (specifier-type + `(vector ,(type-specifier (array-type-element-type type)))) + (let ((ltype (specifier-type 'list))) + (when (csubtypep type ltype) + ltype)))))))) ;;; Derive the type to be the type specifier which is the Nth arg. (defun result-type-specifier-nth-arg (n) (lambda (call) (declare (type combination call)) - (let ((cont (nth (1- n) (combination-args call)))) - (when (and cont (constant-continuation-p cont)) - (careful-specifier-type (continuation-value cont)))))) + (let ((lvar (nth (1- n) (combination-args call)))) + (when (and lvar (constant-lvar-p lvar)) + (careful-specifier-type (lvar-value lvar)))))) ;;; Derive the type to be the type specifier which is the Nth arg, ;;; with the additional restriptions noted in the CLHS for STRING and @@ -280,37 +283,37 @@ (defun creation-result-type-specifier-nth-arg (n) (lambda (call) (declare (type combination call)) - (let ((cont (nth (1- n) (combination-args call)))) - (when (and cont (constant-continuation-p cont)) - (let* ((specifier (continuation-value cont)) - (lspecifier (if (atom specifier) (list specifier) specifier))) - (cond - ((eq (car lspecifier) 'string) - (destructuring-bind (string &rest size) - lspecifier - (declare (ignore string)) - (careful-specifier-type - `(vector character ,@(when size size))))) - ((eq (car lspecifier) 'simple-string) - (destructuring-bind (simple-string &rest size) - lspecifier - (declare (ignore simple-string)) - (careful-specifier-type - `(simple-array character ,@(if size (list size) '((*))))))) - (t - (let ((ctype (careful-specifier-type specifier))) - (if (and (array-type-p ctype) - (eq (array-type-specialized-element-type ctype) - *wild-type*)) - ;; I don't think I'm allowed to modify what I get - ;; back from SPECIFIER-TYPE; it is, after all, - ;; cached. Better copy it, then. - (let ((real-ctype (copy-structure ctype))) - (setf (array-type-element-type real-ctype) - *universal-type* - (array-type-specialized-element-type real-ctype) - *universal-type*) - real-ctype) - ctype))))))))) + (let ((lvar (nth (1- n) (combination-args call)))) + (when (and lvar (constant-lvar-p lvar)) + (let* ((specifier (lvar-value lvar)) + (lspecifier (if (atom specifier) (list specifier) specifier))) + (cond + ((eq (car lspecifier) 'string) + (destructuring-bind (string &rest size) + lspecifier + (declare (ignore string)) + (careful-specifier-type + `(vector character ,@(when size size))))) + ((eq (car lspecifier) 'simple-string) + (destructuring-bind (simple-string &rest size) + lspecifier + (declare (ignore simple-string)) + (careful-specifier-type + `(simple-array character ,@(if size (list size) '((*))))))) + (t + (let ((ctype (careful-specifier-type specifier))) + (if (and (array-type-p ctype) + (eq (array-type-specialized-element-type ctype) + *wild-type*)) + ;; I don't think I'm allowed to modify what I get + ;; back from SPECIFIER-TYPE; it is, after all, + ;; cached. Better copy it, then. + (let ((real-ctype (copy-structure ctype))) + (setf (array-type-element-type real-ctype) + *universal-type* + (array-type-specialized-element-type real-ctype) + *universal-type*) + real-ctype) + ctype))))))))) (/show0 "knownfun.lisp end of file")