`((setf (symbol-function ',name)
(lambda (&rest rest)
(declare (ignore rest))
- (error "can't FUNCALL the SYMBOL-FUNCTION of ~
- special forms")))))))))
+ (error 'special-form-function
+ :name ',name)))))))))
;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the
;;; syntax is invalid.)
) ; 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:
;;;
;;;
;;; NAME-attributes attribute-name*
;;; Return a set of the named attributes.
-;;;
-;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
-;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
-;;; #+SB-XC-HOST
-;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
-;;; arrangement, in order to get it to work in cross-compilation. This
-;;; duplication should be removed, perhaps by rewriting the macro in a
-;;; more cross-compiler-friendly way, or perhaps just by using some
-;;; (MACROLET ((FROB ..)) .. FROB .. FROB) form, but I don't want to
-;;; do it now, because the system isn't running yet, so it'd be too
-;;; hard to check that my changes were correct -- WHN 19990806
-(def!macro def-boolean-attribute (name &rest attribute-names)
-
- (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
- (test-name (symbolicate name "-ATTRIBUTEP")))
- (collect ((alist))
- (do ((mask 1 (ash mask 1))
- (names attribute-names (cdr names)))
- ((null names))
- (alist (cons (car names) mask)))
-
- `(progn
-
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter ,translations-name ',(alist)))
-
- (defmacro ,test-name (attributes &rest attribute-names)
- "Automagically generated boolean attribute test function. See
- Def-Boolean-Attribute."
- `(logtest ,(compute-attribute-mask attribute-names
- ,translations-name)
- (the attributes ,attributes)))
-
- (define-setf-expander ,test-name (place &rest attributes
- &environment env)
- "Automagically generated boolean attribute setter. See
- Def-Boolean-Attribute."
- #-sb-xc-host (declare (type sb!c::lexenv env))
- ;; FIXME: It would be better if &ENVIRONMENT arguments
- ;; were automatically declared to have type LEXENV by the
- ;; hairy-argument-handling code.
- (multiple-value-bind (temps values stores set get)
- (get-setf-expansion place env)
- (when (cdr stores)
- (error "multiple store variables for ~S" place))
- (let ((newval (gensym))
- (n-place (gensym))
- (mask (compute-attribute-mask attributes
- ,translations-name)))
- (values `(,@temps ,n-place)
- `(,@values ,get)
- `(,newval)
- `(let ((,(first stores)
- (if ,newval
- (logior ,n-place ,mask)
- (logand ,n-place ,(lognot mask)))))
- ,set
- ,newval)
- `(,',test-name ,n-place ,@attributes)))))
-
- (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
- "Automagically generated boolean attribute creation function. See
- Def-Boolean-Attribute."
- (compute-attribute-mask attribute-names ,translations-name))))))
-;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
+#+sb-xc-host
+(progn
+ (def!macro !def-boolean-attribute (name &rest attribute-names)
+
+ (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
+ (test-name (symbolicate name "-ATTRIBUTEP")))
+ (collect ((alist))
+ (do ((mask 1 (ash mask 1))
+ (names attribute-names (cdr names)))
+ ((null names))
+ (alist (cons (car names) mask)))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter ,translations-name ',(alist)))
+ (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
+ "Automagically generated boolean attribute creation function.
+ See !DEF-BOOLEAN-ATTRIBUTE."
+ (compute-attribute-mask attribute-names ,translations-name))
+ (defmacro ,test-name (attributes &rest attribute-names)
+ "Automagically generated boolean attribute test function.
+ See !DEF-BOOLEAN-ATTRIBUTE."
+ `(logtest ,(compute-attribute-mask attribute-names
+ ,translations-name)
+ (the attributes ,attributes)))
+ ;; This definition transforms strangely under UNCROSS, in a
+ ;; way that DEF!MACRO doesn't understand, so we delegate it
+ ;; to a submacro then define the submacro differently when
+ ;; building the xc and when building the target compiler.
+ (!def-boolean-attribute-setter ,test-name
+ ,translations-name
+ ,@attribute-names)))))
+
+ ;; It seems to be difficult to express in DEF!MACRO machinery what
+ ;; to do with target-vs-host GET-SETF-EXPANSION in here, so we just
+ ;; hack it by hand, passing a different GET-SETF-EXPANSION-FUN-NAME
+ ;; in the host DEFMACRO and target DEFMACRO-MUNDANELY cases.
+ (defun guts-of-!def-boolean-attribute-setter (test-name
+ translations-name
+ attribute-names
+ get-setf-expansion-fun-name)
+ `(define-setf-expander ,test-name (place &rest attributes
+ &environment env)
+ "Automagically generated boolean attribute setter. See
+ !DEF-BOOLEAN-ATTRIBUTE."
+ #-sb-xc-host (declare (type sb!c::lexenv env))
+ ;; FIXME: It would be better if &ENVIRONMENT arguments were
+ ;; automatically declared to have type LEXENV by the
+ ;; hairy-argument-handling code.
+ (multiple-value-bind (temps values stores set get)
+ (,get-setf-expansion-fun-name place env)
+ (when (cdr stores)
+ (error "multiple store variables for ~S" place))
+ (let ((newval (gensym))
+ (n-place (gensym))
+ (mask (compute-attribute-mask attributes ,translations-name)))
+ (values `(,@temps ,n-place)
+ `(,@values ,get)
+ `(,newval)
+ `(let ((,(first stores)
+ (if ,newval
+ (logior ,n-place ,mask)
+ (logand ,n-place ,(lognot mask)))))
+ ,set
+ ,newval)
+ `(,',test-name ,n-place ,@attributes))))))
+ ;; We define the host version here, and the just-like-it-but-different
+ ;; target version later, after DEFMACRO-MUNDANELY has been defined.
+ (defmacro !def-boolean-attribute-setter (test-name
+ translations-name
+ &rest attribute-names)
+ (guts-of-!def-boolean-attribute-setter test-name
+ translations-name
+ attribute-names
+ 'get-setf-expansion)))
;;; And now for some gratuitous pseudo-abstraction...
;;;
;;; ATTRIBUTES-INTERSECTION
;;; Return the intersection of all the sets of boolean attributes which
;;; are its arguments.
-;;; ATTRIBUTES=
-;;; True if the attributes present in Attr1 are identical to
-;;; those in Attr2.
+;;; ATTRIBUTES
+;;; True if the attributes present in ATTR1 are identical to
+;;; 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)
;;; 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"))
,(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))))))))
\f
;;;; DEFKNOWN and DEFOPTIMIZER
;;; 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)))
+ (not (legal-fun-name-p name)))
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
,(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)))))))
\f
;;;; IR groveling macros
`(eq ,node-var (block-last ,n-block))
`(eq ,cont-var ,n-last-cont))
(return nil))))))
-;;; like Do-Nodes, only iterating in reverse order
+;;; like DO-NODES, only iterating in reverse order
(defmacro do-nodes-backwards ((node-var cont-var block) &body body)
(let ((n-block (gensym))
(n-start (gensym))
(when (eq ,n-next ,n-start)
(return nil))))))
-;;; Bind the IR1 context variables so that IR1 conversion can be done
-;;; after the main conversion pass has finished.
-;;;
-;;; The lexical environment is presumably already null...
-(defmacro with-ir1-environment (node &rest forms)
- (let ((n-node (gensym)))
- `(let* ((,n-node ,node)
- (*current-component* (block-component (node-block ,n-node)))
- (*lexenv* (node-lexenv ,n-node))
- (*current-path* (node-source-path ,n-node)))
- ,@forms)))
+;;; Bind the IR1 context variables to the values associated with NODE,
+;;; so that new, extra IR1 conversion related to NODE can be done
+;;; after the original conversion pass has finished.
+(defmacro with-ir1-environment-from-node (node &rest forms)
+ `(flet ((closure-needing-ir1-environment-from-node ()
+ ,@forms))
+ (%with-ir1-environment-from-node
+ ,node
+ #'closure-needing-ir1-environment-from-node)))
+(defun %with-ir1-environment-from-node (node fun)
+ (declare (type node node) (type function fun))
+ (let ((*current-component* (node-component node))
+ (*lexenv* (node-lexenv node))
+ (*current-path* (node-source-path node)))
+ (aver-live-component *current-component*)
+ (funcall fun)))
;;; Bind the hashtables used for keeping track of global variables,
-;;; functions, &c. Also establish condition handlers.
+;;; 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)
;;; :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))
\f
;;;; the EVENT statistics/trace utility
new-value))
(defsetf event-level %set-event-level)
-;;; Define a new kind of event. Name is a symbol which names the event
-;;; and Description is a string which describes the event. Level
+;;; Define a new kind of event. NAME is a symbol which names the event
+;;; and DESCRIPTION is a string which describes the event. Level
;;; (default 0) is the level of significance associated with this
;;; event; it is used to determine whether to print a Note when the
;;; event happens.
(declaim (type unsigned-byte *event-note-threshold*))
(defvar *event-note-threshold* 1)
-;;; Note that the event with the specified Name has happened. Node is
+;;; Note that the event with the specified NAME has happened. NODE is
;;; evaluated to determine the node to which the event happened.
(defmacro event (name &optional node)
;; Increment the counter and do any action. Mumble about the event if
(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)
(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))
\f
;;;; functions on directly-linked lists (linked through specialized
;;;; NEXT operations)
-#!-sb-fluid (declaim (inline find-in position-in map-in))
+#!-sb-fluid (declaim (inline find-in position-in))
-;;; Find Element in a null-terminated List linked by the accessor
-;;; function Next. Key, Test and Test-Not are the same as for generic
+;;; Find ELEMENT in a null-terminated LIST linked by the accessor
+;;; function NEXT. KEY, TEST and TEST-NOT are the same as for generic
;;; sequence functions.
(defun find-in (next
element
&key
(key #'identity)
(test #'eql test-p)
- (test-not nil not-p))
+ (test-not #'eql not-p))
+ (declare (type function next key test test-not))
(when (and test-p not-p)
(error "It's silly to supply both :TEST and :TEST-NOT arguments."))
(if not-p
(when (funcall test (funcall key current) element)
(return current)))))
-;;; Return the position of Element (or NIL if absent) in a
-;;; null-terminated List linked by the accessor function Next. Key,
-;;; Test and Test-Not are the same as for generic sequence functions.
+;;; Return the position of ELEMENT (or NIL if absent) in a
+;;; null-terminated LIST linked by the accessor function NEXT. KEY,
+;;; TEST and TEST-NOT are the same as for generic sequence functions.
(defun position-in (next
element
list
&key
(key #'identity)
(test #'eql test-p)
- (test-not nil not-p))
+ (test-not #'eql not-p))
+ (declare (type function next key test test-not))
(when (and test-p not-p)
(error "It's silly to supply both :TEST and :TEST-NOT arguments."))
(if not-p
(when (funcall test (funcall key current) element)
(return i)))))
-;;; Map FUNCTION over the elements in a null-terminated LIST linked by the
-;;; accessor function NEXT, returning an ordinary list of the results.
-(defun map-in (next function list)
- (collect ((res))
- (do ((current list (funcall next current)))
- ((null current))
- (res (funcall function current)))
- (res)))
;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
projects / sbcl.git / blobdiff