X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmacros.lisp;h=941cef49e11bb4b249b1cd85cb71368faa56a8db;hb=91392754bf1d241cd6913c728268caf18eae1485;hp=c91b3f0b011834b2cbcbe059ca7819917d18df29;hpb=a0e89f991d9bb20341ea9a944c8fe2acf7f96b21;p=sbcl.git diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index c91b3f0..941cef4 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -149,7 +149,7 @@ ) ; EVAL-WHEN ;;; Define a new class of boolean attributes, with the attributes -;;; having the specified Attribute-Names. Name is the name of the +;;; having the specified ATTRIBUTE-NAMES. NAME is the name of the ;;; class, which is used to generate some macros to manipulate sets of ;;; the attributes: ;;; @@ -239,10 +239,10 @@ ;;; those in Attr2. (defmacro attributes-union (&rest attributes) `(the attributes - (logior ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes)))) + (logior ,@(mapcar (lambda (x) `(the attributes ,x)) attributes)))) (defmacro attributes-intersection (&rest attributes) `(the attributes - (logand ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes)))) + (logand ,@(mapcar (lambda (x) `(the attributes ,x)) attributes)))) (declaim (ftype (function (attributes attributes) boolean) attributes=)) #!-sb-fluid (declaim (inline attributes=)) (defun attributes= (attr1 attr2) @@ -386,13 +386,10 @@ ;;; which means efficiency notes will be generated when this ;;; transform fails even if INHIBIT-WARNINGS=SPEED (but not if ;;; INHIBIT-WARNINGS>SPEED). -;;; :WHEN {:NATIVE | :BYTE | :BOTH} -;;; - Indicates whether this transform applies to native code, -;;; byte-code or both (default :native.) (defmacro deftransform (name (lambda-list &optional (arg-types '*) (result-type '*) &key result policy node defun-only - eval-name important (when :native)) + eval-name important) &body body-decls-doc) (when (and eval-name defun-only) (error "can't specify both DEFUN-ONLY and EVAL-NAME")) @@ -431,10 +428,9 @@ ,(if eval-name ``(function ,,arg-types ,,result-type) `'(function ,arg-types ,result-type)) - #'(lambda ,@stuff) + (lambda ,@stuff) ,doc - ,(if important t nil) - ,when))))))) + ,(if important t nil)))))))) ;;;; DEFKNOWN and DEFOPTIMIZER @@ -451,66 +447,28 @@ ;;; Declare the function NAME to be a known function. We construct a ;;; type specifier for the function by wrapping (FUNCTION ...) around ;;; the ARG-TYPES and RESULT-TYPE. ATTRIBUTES is an unevaluated list -;;; of boolean attributes of the function. These attributes are -;;; meaningful here: -;;; -;;; CALL -;;; May call functions that are passed as arguments. In order -;;; to determine what other effects are present, we must find -;;; the effects of all arguments that may be functions. -;;; -;;; UNSAFE -;;; May incorporate arguments in the result or somehow pass -;;; them upward. -;;; -;;; UNWIND -;;; May fail to return during correct execution. Errors -;;; are O.K. -;;; -;;; ANY -;;; The (default) worst case. Includes all the other bad -;;; things, plus any other possible bad thing. -;;; -;;; FOLDABLE -;;; May be constant-folded. The function has no side effects, -;;; but may be affected by side effects on the arguments. E.g. -;;; SVREF, MAPC. -;;; -;;; FLUSHABLE -;;; May be eliminated if value is unused. The function has -;;; no side effects except possibly CONS. If a function is -;;; defined to signal errors, then it is not flushable even -;;; if it is movable or foldable. -;;; -;;; MOVABLE -;;; May be moved with impunity. Has no side effects except -;;; possibly CONS, and is affected only by its arguments. -;;; -;;; PREDICATE -;;; A true predicate likely to be open-coded. This is a -;;; hint to IR1 conversion that it should ensure calls always -;;; appear as an IF test. Not usually specified to DEFKNOWN, -;;; since this is implementation dependent, and is usually -;;; automatically set by the DEFINE-VOP :CONDITIONAL option. -;;; -;;; NAME may also be a list of names, in which case the same -;;; information is given to all the names. The keywords specify the -;;; initial values for various optimizers that the function might -;;; have. +;;; of boolean attributes of the function. See their description in +;;; (DEF-BOOLEAN-ATTRIBUTE IR1). NAME may also be a list of names, in +;;; which case the same information is given to all the names. The +;;; keywords specify the initial values for various optimizers that +;;; the function might have. (defmacro defknown (name arg-types result-type &optional (attributes '(any)) &rest keys) (when (and (intersection attributes '(any call unwind)) (intersection attributes '(movable))) (error "function cannot have both good and bad attributes: ~S" attributes)) + (when (member 'any attributes) + (setf attributes (union '(call unsafe unwind) attributes))) + (when (member 'flushable attributes) + (pushnew 'unsafely-flushable attributes)) + `(%defknown ',(if (and (consp name) (not (eq (car name) 'setf))) name (list name)) '(function ,arg-types ,result-type) - (ir1-attributes ,@(if (member 'any attributes) - (union '(call unsafe unwind) attributes) - attributes)) + (ir1-attributes ,@attributes) ,@keys)) ;;; Create a function which parses combination args according to WHAT @@ -547,8 +505,8 @@ ,(parse-deftransform lambda-list body n-args `(return-from ,name nil)))) ,@(when (consp what) - `((setf (,(symbolicate "FUNCTION-INFO-" (second what)) - (function-info-or-lose ',(first what))) + `((setf (,(symbolicate "FUN-INFO-" (second what)) + (fun-info-or-lose ',(first what))) #',name))))))) ;;;; IR groveling macros @@ -685,7 +643,7 @@ #'closure-needing-ir1-environment-from-node))) (defun %with-ir1-environment-from-node (node fun) (declare (type node node) (type function fun)) - (let ((*current-component* (block-component (node-block node))) + (let ((*current-component* (node-component node)) (*lexenv* (node-lexenv node)) (*current-path* (node-source-path node))) (aver-live-component *current-component*) @@ -694,8 +652,8 @@ ;;; Bind the hashtables used for keeping track of global variables, ;;; functions, etc. Also establish condition handlers. (defmacro with-ir1-namespace (&body forms) - `(let ((*free-variables* (make-hash-table :test 'eq)) - (*free-functions* (make-hash-table :test 'equal)) + `(let ((*free-vars* (make-hash-table :test 'eq)) + (*free-funs* (make-hash-table :test 'equal)) (*constants* (make-hash-table :test 'equal)) (*source-paths* (make-hash-table :test 'eq))) (handler-bind ((compiler-error #'compiler-error-handler) @@ -708,11 +666,18 @@ ;;; :TEST keyword may be used to determine the name equality ;;; predicate. (defmacro lexenv-find (name slot &key test) - (once-only ((n-res `(assoc ,name (,(symbolicate "LEXENV-" slot) *lexenv*) + (once-only ((n-res `(assoc ,name (,(let ((*package* (symbol-package 'lexenv-funs))) + (symbolicate "LEXENV-" slot)) + *lexenv*) :test ,(or test '#'eq)))) `(if ,n-res (values (cdr ,n-res) t) (values nil nil)))) + +;;; +(defmacro with-continuation-type-assertion ((cont ctype context) &body body) + `(let ((*lexenv* (ir1ize-the-or-values ,ctype ,cont *lexenv* ,context))) + ,@body)) ;;;; the EVENT statistics/trace utility @@ -815,10 +780,10 @@ (declaim (ftype (function (&optional unsigned-byte stream) (values)) event-statistics)) (defun event-statistics (&optional (min-count 1) (stream *standard-output*)) (collect ((info)) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (>= (event-info-count v) min-count) - (info v))) + (maphash (lambda (k v) + (declare (ignore k)) + (when (>= (event-info-count v) min-count) + (info v))) *event-info*) (dolist (event (sort (info) #'> :key #'event-info-count)) (format stream "~6D: ~A~%" (event-info-count event) @@ -828,9 +793,9 @@ (declaim (ftype (function nil (values)) clear-event-statistics)) (defun clear-event-statistics () - (maphash #'(lambda (k v) - (declare (ignore k)) - (setf (event-info-count v) 0)) + (maphash (lambda (k v) + (declare (ignore k)) + (setf (event-info-count v) 0)) *event-info*) (values))