X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fcheckgen.lisp;h=f7375d9b95d6826f020428ff5c42b158e6b56218;hb=ad1aa2961d81ed8db9dac59068c6861199c29a3a;hp=3986bf6cec3e9d7759c3100ca86c2d00f1a896b4;hpb=e0814eee6f6dea52db010b45a330100f2fe65832;p=sbcl.git diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 3986bf6..f7375d9 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -24,12 +24,12 @@ ;;; ;;; We special-case NULL, since it does have a source tranform and is ;;; interesting to us. -(defun function-cost (name) +(defun fun-guessed-cost (name) (declare (symbol name)) (let ((info (info :function :info name)) (call-cost (template-cost (template-or-lose 'call-named)))) (if info - (let ((templates (function-info-templates info))) + (let ((templates (fun-info-templates info))) (if templates (template-cost (first templates)) (case name @@ -49,29 +49,29 @@ (let ((found (cdr (assoc type *backend-type-predicates* :test #'type=)))) (if found - (+ (function-cost found) (function-cost 'eq)) + (+ (fun-guessed-cost found) (fun-guessed-cost 'eq)) nil)))) (typecase type (compound-type (reduce #'+ (compound-type-types type) :key 'type-test-cost)) (member-type (* (length (member-type-members type)) - (function-cost 'eq))) + (fun-guessed-cost 'eq))) (numeric-type (* (if (numeric-type-complexp type) 2 1) - (function-cost + (fun-guessed-cost (if (csubtypep type (specifier-type 'fixnum)) 'fixnump 'numberp)) (+ 1 (if (numeric-type-low type) 1 0) (if (numeric-type-high type) 1 0)))) (cons-type (+ (type-test-cost (specifier-type 'cons)) - (function-cost 'car) + (fun-guessed-cost 'car) (type-test-cost (cons-type-car-type type)) - (function-cost 'cdr) + (fun-guessed-cost 'cdr) (type-test-cost (cons-type-cdr-type type)))) (t - (function-cost 'typep))))) + (fun-guessed-cost 'typep))))) ;;;; checking strategy determination @@ -109,8 +109,9 @@ min-type *universal-type*))))) -;;; Like VALUES-TYPES, only mash any complex function types to FUNCTION. -(defun no-function-values-types (type) +;;; This is like VALUES-TYPES, only we mash any complex function types +;;; to FUNCTION. +(defun no-fun-values-types (type) (declare (type ctype type)) (multiple-value-bind (res count) (values-types type) (values (mapcar (lambda (type) @@ -145,7 +146,7 @@ (defun maybe-negate-check (cont types force-hairy) (declare (type continuation cont) (list types)) (multiple-value-bind (ptypes count) - (no-function-values-types (continuation-proven-type cont)) + (no-fun-values-types (continuation-proven-type cont)) (if (eq count :unknown) (if (and (every #'type-check-template types) (not force-hairy)) (values :simple types) @@ -215,7 +216,7 @@ (let ((type (continuation-asserted-type cont)) (dest (continuation-dest cont))) (aver (not (eq type *wild-type*))) - (multiple-value-bind (types count) (no-function-values-types type) + (multiple-value-bind (types count) (no-fun-values-types type) (cond ((not (eq count :unknown)) (if (or (exit-p dest) (and (return-p dest) @@ -275,12 +276,12 @@ (cond ((eq cont (basic-combination-fun dest)) t) ((eq kind :local) t) ((member kind '(:full :error)) nil) - ((function-info-ir2-convert kind) t) + ((fun-info-ir2-convert kind) t) (t - (dolist (template (function-info-templates kind) nil) + (dolist (template (fun-info-templates kind) nil) (when (eq (template-ltn-policy template) :fast-safe) (multiple-value-bind (val win) - (valid-function-use dest (template-type template)) + (valid-fun-use dest (template-type template)) (when (or val (not win)) (return t))))))))) (t t)))) @@ -360,7 +361,7 @@ ;; said that somewhere in here we ;; Set the new block's start and end cleanups to the *start* ;; cleanup of PREV's block. This overrides the incorrect - ;; default from WITH-BELATED-IR1-ENVIRONMENT. + ;; default from WITH-IR1-ENVIRONMENT-FROM-NODE. ;; Unfortunately I can't find any code which corresponds to this. ;; Perhaps it was a stale comment? Or perhaps I just don't ;; understand.. -- WHN 19990521 @@ -403,7 +404,7 @@ ;;; context. If the value is a constant, we print it specially. We ;;; ignore nodes whose type is NIL, since they are supposed to never ;;; return. -(defun do-type-warning (node) +(defun emit-type-warning (node) (declare (type node node)) (let* ((*compiler-error-context* node) (cont (node-cont node)) @@ -421,16 +422,16 @@ pos))))))) (cond ((eq dtype *empty-type*)) ((and (ref-p node) (constant-p (ref-leaf node))) - (compiler-warning "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S" - what atype-spec (constant-value (ref-leaf node)))) + (compiler-warn "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S" + what atype-spec (constant-value (ref-leaf node)))) (t - (compiler-warning + (compiler-warn "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>" what (type-specifier dtype) atype-spec)))) (values)) ;;; Mark CONT as being a continuation with a manifest type error. We -;;; set the kind to :ERROR, and clear any FUNCTION-INFO if the +;;; set the kind to :ERROR, and clear any FUN-INFO if the ;;; continuation is an argument to a known call. The last is done so ;;; that the back end doesn't have to worry about type errors in ;;; arguments to known functions. This clearing is inhibited for @@ -443,8 +444,8 @@ (when (and (combination-p dest) (let ((kind (basic-combination-kind dest))) (or (eq kind :full) - (and (function-info-p kind) - (not (function-info-ir2-convert kind)))))) + (and (fun-info-p kind) + (not (fun-info-ir2-convert kind)))))) (setf (basic-combination-kind dest) :error))) (values)) @@ -490,7 +491,7 @@ (node-derived-type use) atype) (mark-error-continuation cont) (unless (policy node (= inhibit-warnings 3)) - (do-type-warning use)))))) + (emit-type-warning use)))))) (when (eq type-check t) (cond ((probable-type-check-p cont) (conts cont))