Let register allocation handle unused TNs due to constant folding

[sbcl.git] / src / compiler / macros.lisp

diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index 700f7e4..48af2fb 100644 (file)
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -40,7 +40,8 @@
 ;;; 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)))
+  (let ((fn-name (symbolicate "IR1-CONVERT-" 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"
@@ -56,24 +57,28 @@
              ,@decls
              ,body
              (values))
-           ,@(when doc
-                   `((setf (fdocumentation ',name 'function) ,doc)))
+           #-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)
-           ;; 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
@@ -206,8 +211,8 @@
            (,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)
@@ -229,6 +234,12 @@
                                            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
@@ -398,10 +409,10 @@
   (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
@@ -496,7 +507,7 @@
 ;;; 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
@@ -972,3 +983,19 @@ specify bindings for printer control variables.")
         (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))))