;;; if policy favors.
;;; :MAYBE-INLINE
;;; 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
;;; kind to associate with NAME.
(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 '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
- &aux (,n-env *lexenv*))
- (declare (ignorable ,start-var ,next-var ,result-var))
- ,@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)
- ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to
- ;; the 1990s?
- (setf (info :function :kind ',name) :special-form)
- ;; 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
- (let ((fun (lambda (&rest rest)
- (declare (ignore rest))
- (error 'special-form-function :name ',name))))
- (setf (%simple-fun-arglist fun) ',lambda-list)
- (setf (symbol-function ',name) fun))
- ',name))))
+ (let ((fn-name (symbolicate "IR1-CONVERT-" name)))
+ (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))
+ ,@(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)
+ ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to
+ ;; the 1990s?
+ (setf (info :function :kind ',name) :special-form)
+ ;; 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
+ (let ((fun (lambda (&rest rest)
+ (declare (ignore rest))
+ (error 'special-form-function :name ',name))))
+ (setf (%simple-fun-arglist fun) ',lambda-list)
+ (setf (symbol-function ',name) fun))
+ ',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"
+ (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)))))
translations-name
attribute-names
get-setf-expansion-fun-name)
+ (declare (ignore attribute-names))
`(define-setf-expander ,test-name (place &rest attributes
&environment env)
"Automagically generated boolean attribute setter. See
(,get-setf-expansion-fun-name place env)
(when (cdr stores)
(error "multiple store variables for ~S" place))
- (let ((newval (gensym))
- (n-place (gensym))
+ (let ((newval (sb!xc:gensym))
+ (n-place (sb!xc:gensym))
(mask (compute-attribute-mask attributes ,translations-name)))
(values `(,@temps ,n-place)
`(,@values ,get)
(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))
+ (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
;;; 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)
(when (and (intersection attributes '(any call unwind))
(intersection attributes '(movable)))
(error "function cannot have both good and bad attributes: ~S" attributes))
;;; 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))
+(defmacro defoptimizer (what (lambda-list &optional (n-node (sb!xc:gensym))
&rest vars)
&body body)
(let ((name (if (symbolp what) what
;;; 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
projects / sbcl.git / blobdiff