;;; An INLINEP value describes how a function is called. The values
;;; have these meanings:
-;;; NIL No declaration seen: do whatever you feel like, but don't
-;;; dump an inline expansion.
+;;; NIL No declaration seen: do whatever you feel like, but don't
+;;; dump an inline expansion.
;;; :NOTINLINE NOTINLINE declaration seen: always do full function call.
-;;; :INLINE INLINE declaration seen: save expansion, expanding to it
-;;; if policy favors.
+;;; :INLINE INLINE declaration seen: save expansion, expanding to it
+;;; if policy favors.
;;; :MAYBE-INLINE
-;;; Retain expansion, but only use it opportunistically.
+;;; Retain expansion, but only use it opportunistically.
+;;; :MAYBE-INLINE is quite different from :INLINE. As explained
+;;; by APD on #lisp 2005-11-26: "MAYBE-INLINE lambda is
+;;; instantiated once per component, INLINE - for all
+;;; references (even under #'without FUNCALL)."
(deftype inlinep () '(member :inline :maybe-inline :notinline nil))
\f
;;;; source-hacking defining forms
-;;; to be passed to PARSE-DEFMACRO when we want compiler errors
-;;; instead of real errors
-#!-sb-fluid (declaim (inline convert-condition-into-compiler-error))
-(defun convert-condition-into-compiler-error (datum &rest stuff)
- (if (stringp datum)
- (apply #'compiler-error datum stuff)
- (compiler-error "~A"
- (if (symbolp datum)
- (apply #'make-condition datum stuff)
- datum))))
-
;;; Parse a DEFMACRO-style lambda-list, setting things up so that a
;;; compiler error happens if the syntax is invalid.
;;;
;;; list. START-VAR, NEXT-VAR and RESULT-VAR are bound to the start and
;;; result continuations for the resulting IR1. KIND is the function
;;; kind to associate with NAME.
-(defmacro def-ir1-translator (name (lambda-list start-var next-var result-var
- &key (kind :special-form))
- &body body)
+(defmacro def-ir1-translator (name (lambda-list start-var next-var result-var)
+ &body body)
(let ((fn-name (symbolicate "IR1-CONVERT-" name))
- (n-form (gensym))
- (n-env (gensym)))
- (multiple-value-bind (body decls doc)
- (parse-defmacro lambda-list n-form body name "special form"
- :environment n-env
- :error-fun 'convert-condition-into-compiler-error
- :wrap-block nil)
- `(progn
- (declaim (ftype (function (ctran ctran (or lvar null) t) (values))
- ,fn-name))
- (defun ,fn-name (,start-var ,next-var ,result-var ,n-form)
- (let ((,n-env *lexenv*))
- ,@decls
- ,body
- (values)))
- ,@(when doc
- `((setf (fdocumentation ',name 'function) ,doc)))
- ;; FIXME: Evidently "there can only be one!" -- we overwrite any
- ;; other :IR1-CONVERT value. This deserves a warning, I think.
- (setf (info :function :ir1-convert ',name) #',fn-name)
- (setf (info :function :kind ',name) ,kind)
- ;; It's nice to do this for error checking in the target
- ;; SBCL, but it's not nice to do this when we're running in
- ;; the cross-compilation host Lisp, which owns the
- ;; SYMBOL-FUNCTION of its COMMON-LISP symbols.
- #-sb-xc-host
- ,@(when (eq kind :special-form)
- `((setf (symbol-function ',name)
- (lambda (&rest rest)
- (declare (ignore rest))
- (error 'special-form-function
- :name ',name)))))))))
+ (guard-name (symbolicate name "-GUARD")))
+ (with-unique-names (whole-var n-env)
+ (multiple-value-bind (body decls doc)
+ (parse-defmacro lambda-list whole-var body name "special form"
+ :environment n-env
+ :error-fun 'compiler-error
+ :wrap-block nil)
+ `(progn
+ (declaim (ftype (function (ctran ctran (or lvar null) t) (values))
+ ,fn-name))
+ (defun ,fn-name (,start-var ,next-var ,result-var ,whole-var
+ &aux (,n-env *lexenv*))
+ (declare (ignorable ,start-var ,next-var ,result-var))
+ ,@decls
+ ,body
+ (values))
+ #-sb-xc-host
+ ;; It's nice to do this for error checking in the target
+ ;; SBCL, but it's not nice to do this when we're running in
+ ;; the cross-compilation host Lisp, which owns the
+ ;; SYMBOL-FUNCTION of its COMMON-LISP symbols. These guard
+ ;; functions also provide the documentation for special forms.
+ (progn
+ (defun ,guard-name (&rest args)
+ ,@(when doc (list doc))
+ (declare (ignore args))
+ (error 'special-form-function :name ',name))
+ (let ((fun #',guard-name))
+ (setf (%simple-fun-arglist fun) ',lambda-list
+ (%simple-fun-name fun) ',name
+ (symbol-function ',name) fun)
+ (fmakunbound ',guard-name)))
+ ;; FIXME: Evidently "there can only be one!" -- we overwrite any
+ ;; other :IR1-CONVERT value. This deserves a warning, I think.
+ (setf (info :function :ir1-convert ',name) #',fn-name)
+ ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to
+ ;; the 1990s?
+ (setf (info :function :kind ',name) :special-form)
+ ',name)))))
;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the
;;; syntax is invalid.)
;;; OPTIMIZE parameters, then the POLICY macro should be used to
;;; determine when to pass.
(defmacro source-transform-lambda (lambda-list &body body)
- (let ((n-form (gensym))
- (n-env (gensym))
- (name (gensym)))
+ (with-unique-names (whole-var n-env name)
(multiple-value-bind (body decls)
- (parse-defmacro lambda-list n-form body "source transform" "form"
- :environment n-env
- :error-fun `(lambda (&rest stuff)
- (declare (ignore stuff))
- (return-from ,name
- (values nil t)))
+ (parse-defmacro lambda-list whole-var body "source transform" "form"
+ :environment n-env
+ :error-fun `(lambda (&rest stuff)
+ (declare (ignore stuff))
+ (return-from ,name
+ (values nil t)))
:wrap-block nil)
- `(lambda (,n-form &aux (,n-env *lexenv*))
+ `(lambda (,whole-var &aux (,n-env *lexenv*))
,@decls
(block ,name
,body)))))
(collect ((res 0 logior))
(dolist (name names)
(let ((mask (cdr (assoc name alist))))
- (unless mask
- (error "unknown attribute name: ~S" name))
- (res mask)))
+ (unless mask
+ (error "unknown attribute name: ~S" name))
+ (res mask)))
(res)))
) ; EVAL-WHEN
(def!macro !def-boolean-attribute (name &rest attribute-names)
(let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
- (test-name (symbolicate name "-ATTRIBUTEP"))
+ (test-name (symbolicate name "-ATTRIBUTEP"))
(decoder-name (symbolicate "DECODE-" name "-ATTRIBUTES")))
(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.
+ (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.
+ (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)
+ `(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)
(defun ,decoder-name (attributes)
(loop for (name . mask) in ,translations-name
when (logtest mask attributes)
;; 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)
+ translations-name
+ attribute-names
+ get-setf-expansion-fun-name)
+ (declare (ignore attribute-names))
`(define-setf-expander ,test-name (place &rest attributes
- &environment env)
+ &environment env)
"Automagically generated boolean attribute setter. See
!DEF-BOOLEAN-ATTRIBUTE."
#-sb-xc-host (declare (type sb!c::lexenv env))
;; 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))))))
+ (,get-setf-expansion-fun-name place env)
+ (when (cdr stores)
+ (error "multiple store variables for ~S" place))
+ (let ((newval (sb!xc:gensym))
+ (n-place (sb!xc: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)
+ translations-name
+ &rest attribute-names)
(guts-of-!def-boolean-attribute-setter test-name
- translations-name
- attribute-names
- 'get-setf-expansion)))
+ translations-name
+ attribute-names
+ 'get-setf-expansion)))
+
+;;; Otherwise the source locations for DEFTRANSFORM, DEFKNOWN, &c
+;;; would be off by one toplevel form as their source locations are
+;;; determined before cross-compiling where the above PROGN is not
+;;; seen.
+#+sb-xc (progn)
;;; And now for some gratuitous pseudo-abstraction...
;;;
-;;; ATTRIBUTES-UNION
+;;; ATTRIBUTES-UNION
;;; Return the union of all the sets of boolean attributes which are its
;;; arguments.
;;; ATTRIBUTES-INTERSECTION
;;; 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)
;;; Given a DEFTRANSFORM-style lambda-list, generate code that parses
;;; the arguments of a combination with respect to that
-;;; lambda-list. BODY is the the list of forms which are to be
+;;; lambda-list. BODY is the list of forms which are to be
;;; evaluated within the bindings. ARGS is the variable that holds
;;; list of argument lvars. ERROR-FORM is a form which is evaluated
;;; when the syntax of the supplied arguments is incorrect or a
;;; non-constant argument keyword is supplied. Defaults and other gunk
;;; are ignored. The second value is a list of all the arguments
;;; bound. We make the variables IGNORABLE so that we don't have to
-;;; manually declare them Ignore if their only purpose is to make the
+;;; manually declare them IGNORE if their only purpose is to make the
;;; syntax work.
(defun parse-deftransform (lambda-list body args error-form)
(multiple-value-bind (req opt restp rest keyp keys allowp)
(parse-lambda-list lambda-list)
(let* ((min-args (length req))
- (max-args (+ min-args (length opt)))
- (n-keys (gensym)))
+ (max-args (+ min-args (length opt)))
+ (n-keys (gensym)))
(collect ((binds)
- (vars)
- (pos 0 +)
- (keywords))
- (dolist (arg req)
- (vars arg)
- (binds `(,arg (nth ,(pos) ,args)))
- (pos 1))
-
- (dolist (arg opt)
- (let ((var (if (atom arg) arg (first arg))))
- (vars var)
- (binds `(,var (nth ,(pos) ,args)))
- (pos 1)))
-
- (when restp
- (vars rest)
- (binds `(,rest (nthcdr ,(pos) ,args))))
-
- (dolist (spec keys)
- (if (or (atom spec) (atom (first spec)))
- (let* ((var (if (atom spec) spec (first spec)))
- (key (keywordicate var)))
- (vars var)
- (binds `(,var (find-keyword-lvar ,n-keys ,key)))
- (keywords key))
- (let* ((head (first spec))
- (var (second head))
- (key (first head)))
- (vars var)
- (binds `(,var (find-keyword-lvar ,n-keys ,key)))
- (keywords key))))
-
- (let ((n-length (gensym))
- (limited-legal (not (or restp keyp))))
- (values
- `(let ((,n-length (length ,args))
- ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args)))))
- (unless (and
- ;; FIXME: should be PROPER-LIST-OF-LENGTH-P
- ,(if limited-legal
- `(<= ,min-args ,n-length ,max-args)
- `(<= ,min-args ,n-length))
- ,@(when keyp
- (if allowp
- `((check-key-args-constant ,n-keys))
- `((check-transform-keys ,n-keys ',(keywords))))))
- ,error-form)
- (let ,(binds)
- (declare (ignorable ,@(vars)))
- ,@body))
- (vars)))))))
+ (vars)
+ (pos 0 +)
+ (keywords))
+ (dolist (arg req)
+ (vars arg)
+ (binds `(,arg (nth ,(pos) ,args)))
+ (pos 1))
+
+ (dolist (arg opt)
+ (let ((var (if (atom arg) arg (first arg))))
+ (vars var)
+ (binds `(,var (nth ,(pos) ,args)))
+ (pos 1)))
+
+ (when restp
+ (vars rest)
+ (binds `(,rest (nthcdr ,(pos) ,args))))
+
+ (dolist (spec keys)
+ (if (or (atom spec) (atom (first spec)))
+ (let* ((var (if (atom spec) spec (first spec)))
+ (key (keywordicate var)))
+ (vars var)
+ (binds `(,var (find-keyword-lvar ,n-keys ,key)))
+ (keywords key))
+ (let* ((head (first spec))
+ (var (second head))
+ (key (first head)))
+ (vars var)
+ (binds `(,var (find-keyword-lvar ,n-keys ,key)))
+ (keywords key))))
+
+ (let ((n-length (gensym))
+ (limited-legal (not (or restp keyp))))
+ (values
+ `(let ((,n-length (length ,args))
+ ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args)))))
+ (unless (and
+ ;; FIXME: should be PROPER-LIST-OF-LENGTH-P
+ ,(if limited-legal
+ `(<= ,min-args ,n-length ,max-args)
+ `(<= ,min-args ,n-length))
+ ,@(when keyp
+ (if allowp
+ `((check-key-args-constant ,n-keys))
+ `((check-transform-keys ,n-keys ',(keywords))))))
+ ,error-form)
+ (let ,(binds)
+ (declare (ignorable ,@(vars)))
+ ,@body))
+ (vars)))))))
) ; EVAL-WHEN
\f
;;; transform fails even if INHIBIT-WARNINGS=SPEED (but not if
;;; INHIBIT-WARNINGS>SPEED).
(defmacro deftransform (name (lambda-list &optional (arg-types '*)
- (result-type '*)
- &key result policy node defun-only
- eval-name important)
- &body body-decls-doc)
+ (result-type '*)
+ &key result policy node defun-only
+ eval-name important)
+ &body body-decls-doc)
(when (and eval-name defun-only)
(error "can't specify both DEFUN-ONLY and EVAL-NAME"))
(multiple-value-bind (body decls doc) (parse-body body-decls-doc)
- (let ((n-args (gensym))
- (n-node (or node (gensym)))
- (n-decls (gensym))
- (n-lambda (gensym))
- (decls-body `(,@decls ,@body)))
+ (let ((n-args (sb!xc:gensym))
+ (n-node (or node (sb!xc:gensym)))
+ (n-decls (sb!xc:gensym))
+ (n-lambda (sb!xc:gensym))
+ (decls-body `(,@decls ,@body)))
(multiple-value-bind (parsed-form vars)
- (parse-deftransform lambda-list
- (if policy
- `((unless (policy ,n-node ,policy)
- (give-up-ir1-transform))
- ,@decls-body)
- body)
- n-args
- '(give-up-ir1-transform))
- (let ((stuff
- `((,n-node)
- (let* ((,n-args (basic-combination-args ,n-node))
- ,@(when result
- `((,result (node-lvar ,n-node)))))
- (multiple-value-bind (,n-lambda ,n-decls)
- ,parsed-form
- (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda))
- ,n-lambda
- `(lambda ,',lambda-list
- (declare (ignorable ,@',vars))
- ,@,n-decls
- ,,n-lambda)))))))
- (if defun-only
- `(defun ,name ,@(when doc `(,doc)) ,@stuff)
- `(%deftransform
- ,(if eval-name name `',name)
- ,(if eval-name
- ``(function ,,arg-types ,,result-type)
- `'(function ,arg-types ,result-type))
- (lambda ,@stuff)
- ,doc
- ,(if important t nil))))))))
+ (parse-deftransform lambda-list
+ (if policy
+ `((unless (policy ,n-node ,policy)
+ (give-up-ir1-transform))
+ ,@decls-body)
+ body)
+ n-args
+ '(give-up-ir1-transform))
+ (let ((stuff
+ `((,n-node)
+ (let* ((,n-args (basic-combination-args ,n-node))
+ ,@(when result
+ `((,result (node-lvar ,n-node)))))
+ (multiple-value-bind (,n-lambda ,n-decls)
+ ,parsed-form
+ (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda))
+ ,n-lambda
+ `(lambda ,',lambda-list
+ (declare (ignorable ,@',vars))
+ ,@,n-decls
+ ,,n-lambda)))))))
+ (if defun-only
+ `(defun ,name ,@(when doc `(,doc)) ,@stuff)
+ `(%deftransform
+ ,(if eval-name name `',name)
+ ,(if eval-name
+ ``(function ,,arg-types ,,result-type)
+ `'(function ,arg-types ,result-type))
+ (lambda ,@stuff)
+ ,doc
+ ,(if important t nil))))))))
\f
;;;; DEFKNOWN and DEFOPTIMIZER
;;; 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)
+ &body keys)
+ #-sb-xc-host
+ (when (member 'unsafe attributes)
+ (style-warn "Ignoring legacy attribute UNSAFE. Replaced by its inverse: DX-SAFE.")
+ (setf attributes (remove 'unsafe attributes)))
(when (and (intersection attributes '(any call unwind))
- (intersection attributes '(movable)))
+ (intersection attributes '(movable)))
(error "function cannot have both good and bad attributes: ~S" attributes))
(when (member 'any attributes)
- (setq attributes (union '(call unsafe unwind) attributes)))
+ (setq attributes (union '(call unwind) attributes)))
(when (member 'flushable attributes)
(pushnew 'unsafely-flushable attributes))
`(%defknown ',(if (and (consp name)
- (not (legal-fun-name-p name)))
- name
- (list name))
- '(sfunction ,arg-types ,result-type)
- (ir1-attributes ,@attributes)
- ,@keys))
+ (not (legal-fun-name-p name)))
+ name
+ (list name))
+ '(sfunction ,arg-types ,result-type)
+ (ir1-attributes ,@attributes)
+ ,@keys))
;;; Create a function which parses combination args according to WHAT
;;; and LAMBDA-LIST, where WHAT is either a function name or a list
;;; the rest of the optimizer function's lambda-list. LTN-ANNOTATE
;;; methods are passed an additional POLICY argument, and IR2-CONVERT
;;; methods are passed an additional IR2-BLOCK argument.
-(defmacro defoptimizer (what (lambda-list &optional (n-node (gensym))
- &rest vars)
- &body body)
- (let ((name (if (symbolp what) what
- (symbolicate (first what) "-" (second what) "-OPTIMIZER"))))
-
- (let ((n-args (gensym)))
- `(progn
- (defun ,name (,n-node ,@vars)
- (let ((,n-args (basic-combination-args ,n-node)))
- ,(parse-deftransform lambda-list body n-args
- `(return-from ,name nil))))
- ,@(when (consp what)
- `((setf (,(symbolicate "FUN-INFO-" (second what))
- (fun-info-or-lose ',(first what)))
- #',name)))))))
+(defmacro defoptimizer (what (lambda-list &optional (n-node (sb!xc:gensym))
+ &rest vars)
+ &body body)
+ (flet ((function-name (name)
+ (etypecase name
+ (symbol name)
+ ((cons (eql setf) (cons symbol null))
+ (symbolicate (car name) "-" (cadr name))))))
+ (let ((name (if (symbolp what)
+ what
+ (symbolicate (function-name (first what))
+ "-" (second what) "-OPTIMIZER"))))
+
+ (let ((n-args (gensym)))
+ `(progn
+ (defun ,name (,n-node ,@vars)
+ (declare (ignorable ,@vars))
+ (let ((,n-args (basic-combination-args ,n-node)))
+ ,(parse-deftransform lambda-list body n-args
+ `(return-from ,name nil))))
+ ,@(when (consp what)
+ `((setf (,(let ((*package* (symbol-package 'sb!c::fun-info)))
+ (symbolicate "FUN-INFO-" (second what)))
+ (fun-info-or-lose ',(first what)))
+ #',name))))))))
\f
;;;; IR groveling macros
(unless (member ends '(nil :head :tail :both))
(error "losing ENDS value: ~S" ends))
(let ((n-component (gensym))
- (n-tail (gensym)))
+ (n-tail (gensym)))
`(let* ((,n-component ,component)
- (,n-tail ,(if (member ends '(:both :tail))
- nil
- `(component-tail ,n-component))))
+ (,n-tail ,(if (member ends '(:both :tail))
+ nil
+ `(component-tail ,n-component))))
(do ((,block-var ,(if (member ends '(:both :head))
- `(component-head ,n-component)
- `(block-next (component-head ,n-component)))
- (block-next ,block-var)))
- ((eq ,block-var ,n-tail) ,result)
- ,@body))))
+ `(component-head ,n-component)
+ `(block-next (component-head ,n-component)))
+ (block-next ,block-var)))
+ ((eq ,block-var ,n-tail) ,result)
+ ,@body))))
;;; like DO-BLOCKS, only iterating over the blocks in reverse order
(defmacro do-blocks-backwards ((block-var component &optional ends result) &body body)
(unless (member ends '(nil :head :tail :both))
(error "losing ENDS value: ~S" ends))
(let ((n-component (gensym))
- (n-head (gensym)))
+ (n-head (gensym)))
`(let* ((,n-component ,component)
- (,n-head ,(if (member ends '(:both :head))
- nil
- `(component-head ,n-component))))
+ (,n-head ,(if (member ends '(:both :head))
+ nil
+ `(component-head ,n-component))))
(do ((,block-var ,(if (member ends '(:both :tail))
- `(component-tail ,n-component)
- `(block-prev (component-tail ,n-component)))
- (block-prev ,block-var)))
- ((eq ,block-var ,n-head) ,result)
- ,@body))))
+ `(component-tail ,n-component)
+ `(block-prev (component-tail ,n-component)))
+ (block-prev ,block-var)))
+ ((eq ,block-var ,n-head) ,result)
+ ,@body))))
;;; Iterate over the uses of LVAR, binding NODE to each one
;;; successively.
-;;;
-;;; XXX Could change it not to replicate the code someday perhaps...
(defmacro do-uses ((node-var lvar &optional result) &body body)
(with-unique-names (uses)
`(let ((,uses (lvar-uses ,lvar)))
- (if (listp ,uses)
- (dolist (,node-var ,uses ,result)
- ,@body)
- (block nil
- (let ((,node-var ,uses))
- ,@body))))))
+ (block nil
+ (flet ((do-1-use (,node-var)
+ ,@body))
+ (if (listp ,uses)
+ (dolist (node ,uses)
+ (do-1-use node))
+ (do-1-use ,uses)))
+ ,result))))
;;; Iterate over the nodes in BLOCK, binding NODE-VAR to the each node
;;; and LVAR-VAR to the node's LVAR. The only keyword option is
(t (return)))))
,@(when lvar-var
`((,lvar-var (when (valued-node-p ,node-var)
- (node-lvar ,node-var))
- (when (valued-node-p ,node-var)
- (node-lvar ,node-var))))))
+ (node-lvar ,node-var))
+ (when (valued-node-p ,node-var)
+ (node-lvar ,node-var))))))
(nil)
,@body
,@(when restart-p
;;; Like DO-NODES, only iterating in reverse order. Should be careful
;;; with block being split under us.
-(defmacro do-nodes-backwards ((node-var lvar block) &body body)
+(defmacro do-nodes-backwards ((node-var lvar block &key restart-p) &body body)
(let ((n-block (gensym))
- (n-prev (gensym)))
+ (n-prev (gensym)))
`(loop with ,n-block = ,block
- for ,node-var = (block-last ,n-block) then (ctran-use ,n-prev)
+ for ,node-var = (block-last ,n-block) then
+ ,(if restart-p
+ `(if (eq ,n-block (ctran-block ,n-prev))
+ (ctran-use ,n-prev)
+ (block-last ,n-block))
+ `(ctran-use ,n-prev))
for ,n-prev = (when ,node-var (node-prev ,node-var))
and ,lvar = (when (and ,node-var (valued-node-p ,node-var))
- (node-lvar ,node-var))
- while ,node-var
+ (node-lvar ,node-var))
+ while ,(if restart-p
+ `(and ,node-var (not (block-to-be-deleted-p ,n-block)))
+ node-var)
do (progn
,@body))))
;;; after the original conversion pass has finished.
(defmacro with-ir1-environment-from-node (node &rest forms)
`(flet ((closure-needing-ir1-environment-from-node ()
- ,@forms))
+ ,@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)))
+ (*lexenv* (node-lexenv node))
+ (*current-path* (node-source-path node)))
(aver-live-component *current-component*)
(funcall fun)))
+(defmacro with-source-paths (&body forms)
+ (with-unique-names (source-paths)
+ `(let* ((,source-paths (make-hash-table :test 'eq))
+ (*source-paths* ,source-paths))
+ (unwind-protect
+ (progn ,@forms)
+ (clrhash ,source-paths)))))
+
;;; Bind the hashtables used for keeping track of global variables,
;;; functions, etc. Also establish condition handlers.
(defmacro with-ir1-namespace (&body forms)
`(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)
- (style-warning #'compiler-style-warning-handler)
- (warning #'compiler-warning-handler))
- ,@forms)))
+ (*free-funs* (make-hash-table :test 'equal))
+ (*constants* (make-hash-table :test 'equal)))
+ (unwind-protect
+ (progn ,@forms)
+ (clrhash *free-funs*)
+ (clrhash *free-vars*)
+ (clrhash *constants*))))
;;; Look up NAME in the lexical environment namespace designated by
;;; SLOT, returning the <value, T>, or <NIL, NIL> if no entry. The
(once-only ((n-res `(assoc ,name (,(let ((*package* (symbol-package 'lexenv-funs)))
(symbolicate "LEXENV-" slot))
*lexenv*)
- :test ,(or test '#'eq))))
+ :test ,(or test '#'eq))))
`(if ,n-res
- (values (cdr ,n-res) t)
- (values nil nil))))
+ (values (cdr ,n-res) t)
+ (values nil nil))))
(defmacro with-component-last-block ((component block) &body body)
(with-unique-names (old-last-block)
(defun event-action (name)
(event-info-action (event-info-or-lose name)))
(declaim (ftype (function (symbol (or function null)) (or function null))
- %set-event-action))
+ %set-event-action))
(defun %set-event-action (name new-value)
(setf (event-info-action (event-info-or-lose name))
- new-value))
+ new-value))
(defsetf event-action %set-event-action)
;;; Return the non-negative integer which represents the level of
(declaim (ftype (function (symbol unsigned-byte) unsigned-byte) %set-event-level))
(defun %set-event-level (name new-value)
(setf (event-info-level (event-info-or-lose name))
- new-value))
+ new-value))
(defsetf event-level %set-event-level)
;;; Define a new kind of event. NAME is a symbol which names the event
(let ((var-name (symbolicate "*" name "-EVENT-INFO*")))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar ,var-name
- (make-event-info :name ',name
- :description ',description
- :var ',var-name
- :level ,level))
+ (make-event-info :name ',name
+ :description ',description
+ :var ',var-name
+ :level ,level))
(setf (gethash ',name *event-info*) ,var-name)
',name)))
(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)))
- *event-info*)
+ (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)
- (event-info-description event)))
+ (event-info-description event)))
(values))
(values))
(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))
- *event-info*)
+ (declare (ignore k))
+ (setf (event-info-count v) 0))
+ *event-info*)
(values))
\f
;;;; functions on directly-linked lists (linked through specialized
;;; function NEXT. KEY, TEST and TEST-NOT are the same as for generic
;;; sequence functions.
(defun find-in (next
- element
- list
- &key
- (key #'identity)
- (test #'eql test-p)
- (test-not #'eql not-p))
+ element
+ list
+ &key
+ (key #'identity)
+ (test #'eql test-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
(do ((current list (funcall next current)))
- ((null current) nil)
- (unless (funcall test-not (funcall key current) element)
- (return current)))
+ ((null current) nil)
+ (unless (funcall test-not (funcall key current) element)
+ (return current)))
(do ((current list (funcall next current)))
- ((null current) nil)
- (when (funcall test (funcall key current) element)
- (return current)))))
+ ((null current) nil)
+ (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.
(defun position-in (next
- element
- list
- &key
- (key #'identity)
- (test #'eql test-p)
- (test-not #'eql not-p))
+ element
+ list
+ &key
+ (key #'identity)
+ (test #'eql test-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
(do ((current list (funcall next current))
- (i 0 (1+ i)))
- ((null current) nil)
- (unless (funcall test-not (funcall key current) element)
- (return i)))
+ (i 0 (1+ i)))
+ ((null current) nil)
+ (unless (funcall test-not (funcall key current) element)
+ (return i)))
(do ((current list (funcall next current))
- (i 0 (1+ i)))
- ((null current) nil)
- (when (funcall test (funcall key current) element)
- (return i)))))
+ (i 0 (1+ i)))
+ ((null current) nil)
+ (when (funcall test (funcall key current) element)
+ (return i)))))
;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
(when (cdr stores)
(error "multiple store variables for ~S" place))
(let ((n-item (gensym))
- (n-place (gensym))
- (n-current (gensym))
- (n-prev (gensym)))
+ (n-place (gensym))
+ (n-current (gensym))
+ (n-prev (gensym)))
`(let* (,@(mapcar #'list temps vals)
- (,n-place ,access)
- (,n-item ,item))
- (if (eq ,n-place ,n-item)
- (let ((,(first stores) (,next ,n-place)))
- ,store)
- (do ((,n-prev ,n-place ,n-current)
- (,n-current (,next ,n-place)
- (,next ,n-current)))
- ((eq ,n-current ,n-item)
- (setf (,next ,n-prev)
- (,next ,n-current)))))
- (values)))))
+ (,n-place ,access)
+ (,n-item ,item))
+ (if (eq ,n-place ,n-item)
+ (let ((,(first stores) (,next ,n-place)))
+ ,store)
+ (do ((,n-prev ,n-place ,n-current)
+ (,n-current (,next ,n-place)
+ (,next ,n-current)))
+ ((eq ,n-current ,n-item)
+ (setf (,next ,n-prev)
+ (,next ,n-current)))))
+ (values)))))
;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
;;; Push ITEM onto a list linked by the accessor function NEXT that is
(when (cdr stores)
(error "multiple store variables for ~S" place))
`(let (,@(mapcar #'list temps vals)
- (,(first stores) ,item))
+ (,(first stores) ,item))
(setf (,next ,(first stores)) ,access)
,store
(values))))
(defmacro position-or-lose (&rest args)
`(or (position ,@args)
(error "shouldn't happen?")))
+
+;;; user-definable compiler io syntax
+
+;;; We use WITH-SANE-IO-SYNTAX to provide safe defaults, and provide
+;;; *COMPILER-PRINT-VARIABLE-ALIST* for user customization.
+(defvar *compiler-print-variable-alist* nil
+ #!+sb-doc
+ "an association list describing new bindings for special variables
+to be used by the compiler for error-reporting, etc. Eg.
+
+ ((*PRINT-LENGTH* . 10) (*PRINT-LEVEL* . 6) (*PRINT-PRETTY* . NIL))
+
+The variables in the CAR positions are bound to the values in the CDR
+during the execution of some debug commands. When evaluating arbitrary
+expressions in the debugger, the normal values of the printer control
+variables are in effect.
+
+Initially empty, *COMPILER-PRINT-VARIABLE-ALIST* is Typically used to
+specify bindings for printer control variables.")
+
+(defmacro with-compiler-io-syntax (&body forms)
+ `(with-sane-io-syntax
+ (progv
+ (nreverse (mapcar #'car *compiler-print-variable-alist*))
+ (nreverse (mapcar #'cdr *compiler-print-variable-alist*))
+ ,@forms)))
+
+;;; Like DESTRUCTURING-BIND, but generates a COMPILER-ERROR on failure
+(defmacro compiler-destructuring-bind (lambda-list thing context
+ &body body)
+ (let ((whole-name (gensym "WHOLE")))
+ (multiple-value-bind (body local-decls)
+ (parse-defmacro lambda-list whole-name body nil
+ context
+ :anonymousp t
+ :doc-string-allowed nil
+ :wrap-block nil
+ :error-fun 'compiler-error)
+ `(let ((,whole-name ,thing))
+ (declare (type list ,whole-name))
+ ,@local-decls
+ ,body))))
projects / sbcl.git / blobdiff