0.8alpha.0.15:

[sbcl.git] / src / compiler / ir1-translators.lisp

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index d22a012..ce06123 100644 (file)
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -35,6 +35,8 @@
         (node (make-if :test pred
                        :consequent then-block
                        :alternative else-block)))
         (node (make-if :test pred
                        :consequent then-block
                        :alternative else-block)))

+    ;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the
+    ;; order of the following two forms is important

     (setf (continuation-dest pred) node)
     (ir1-convert start pred test)
     (link-node-to-previous-continuation node pred)
     (setf (continuation-dest pred) node)
     (ir1-convert start pred test)
     (link-node-to-previous-continuation node pred)

@@ -268,14 +270,17 @@
                      :format-arguments (list ,@args))))))
     `(lambda (definition)
       (unless (list-of-length-at-least-p definition 2)
                      :format-arguments (list ,@args))))))
     `(lambda (definition)
       (unless (list-of-length-at-least-p definition 2)

-       ,(make-error-form "The list ~S is too short to be a legal local macro definition." 'definition))
+       ,(make-error-form
+         "The list ~S is too short to be a legal local macro definition."
+         'definition))

       (destructuring-bind (name arglist &body body) definition
        (unless (symbolp name)
          ,(make-error-form "The local macro name ~S is not a symbol." 'name))
        (unless (listp arglist)
       (destructuring-bind (name arglist &body body) definition
        (unless (symbolp name)
          ,(make-error-form "The local macro name ~S is not a symbol." 'name))
        (unless (listp arglist)

-         ,(make-error-form "The local macro argument list ~S is not a list." 'arglist))
-       (let ((whole (gensym "WHOLE"))
-             (environment (gensym "ENVIRONMENT")))
+         ,(make-error-form
+           "The local macro argument list ~S is not a list."
+           'arglist))
+       (with-unique-names (whole environment)

          (multiple-value-bind (body local-decls)
              (parse-defmacro arglist whole body name 'macrolet
                              :environment environment)
          (multiple-value-bind (body local-decls)
              (parse-defmacro arglist whole body name 'macrolet
                              :environment environment)

@@ -344,15 +349,6 @@
    macrobindings
    (lambda (&key vars)
      (ir1-translate-locally body start cont :vars vars))))
    macrobindings
    (lambda (&key vars)
      (ir1-translate-locally body start cont :vars vars))))

-
-;;; not really a special form, but..
-(def-ir1-translator declare ((&rest stuff) start cont)
-  (declare (ignore stuff))
-  ;; We ignore START and CONT too, but we can't use DECLARE IGNORE to
-  ;; tell the compiler about it here, because the DEF-IR1-TRANSLATOR
-  ;; macro would put the DECLARE in the wrong place, so..
-  start cont
-  (compiler-error "misplaced declaration"))

 \f
 ;;;; %PRIMITIVE
 ;;;;
 \f
 ;;;; %PRIMITIVE
 ;;;;

@@ -435,64 +431,22 @@
   be a lambda expression."
   (if (consp thing)
       (case (car thing)
   be a lambda expression."
   (if (consp thing)
       (case (car thing)

-       ((lambda)
+       ((lambda named-lambda instance-lambda lambda-with-lexenv)

         (reference-leaf start
                         cont
         (reference-leaf start
                         cont

-                        (ir1-convert-lambda thing
-                                            :debug-name (debug-namify
-                                                         "#'~S" thing)
-                                            :allow-debug-catch-tag t)))
-       ((setf)
+                        (ir1-convert-lambdalike
+                         thing
+                         :debug-name (debug-namify "#'~S" thing)
+                         :allow-debug-catch-tag t)))
+       ((setf sb!pcl::class-predicate sb!pcl::slot-accessor)

         (let ((var (find-lexically-apparent-fun
                     thing "as the argument to FUNCTION")))
           (reference-leaf start cont var)))
         (let ((var (find-lexically-apparent-fun
                     thing "as the argument to FUNCTION")))
           (reference-leaf start cont var)))

-       ((instance-lambda)
-        (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))
-                                       :debug-name (debug-namify "#'~S"
-                                                                 thing)
-                                       :allow-debug-catch-tag t)))
-          (setf (getf (functional-plist res) :fin-function) t)
-          (reference-leaf start cont res)))

        (t
         (compiler-error "~S is not a legal function name." thing)))
       (let ((var (find-lexically-apparent-fun
                  thing "as the argument to FUNCTION")))
        (reference-leaf start cont var))))
        (t
         (compiler-error "~S is not a legal function name." thing)))
       (let ((var (find-lexically-apparent-fun
                  thing "as the argument to FUNCTION")))
        (reference-leaf start cont var))))

-
-;;; `(NAMED-LAMBDA ,NAME ,@REST) is like `(FUNCTION (LAMBDA ,@REST)),
-;;; except that the value of NAME is passed to the compiler for use in
-;;; creation of debug information for the resulting function.
-;;;
-;;; NAME can be a legal function name or some arbitrary other thing.
-;;;
-;;; If NAME is a legal function name, then the caller should be
-;;; planning to set (FDEFINITION NAME) to the created function.
-;;; (Otherwise the debug names will be inconsistent and thus
-;;; unnecessarily confusing.)
-;;;
-;;; Arbitrary other things are appropriate for naming things which are
-;;; not the FDEFINITION of NAME. E.g.
-;;;   NAME = (:FLET FOO BAR)
-;;; for the FLET function in
-;;;   (DEFUN BAR (X)
-;;;     (FLET ((FOO (Y) (+ X Y)))
-;;;       FOO))
-;;; or
-;;;   NAME = (:METHOD PRINT-OBJECT :AROUND (STARSHIP T))
-;;; for the function used to implement
-;;;   (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...).
-(def-ir1-translator named-lambda ((name &rest rest) start cont)
-  (let* ((fun (if (legal-fun-name-p name)
-                  (ir1-convert-lambda `(lambda ,@rest)
-                                      :source-name name
-                                     :allow-debug-catch-tag t)
-                  (ir1-convert-lambda `(lambda ,@rest)
-                                      :debug-name name
-                                     :allow-debug-catch-tag t)))
-         (leaf (reference-leaf start cont fun)))
-    (when (legal-fun-name-p name)
-      (assert-global-function-definition-type name fun))
-    leaf))

 \f
 ;;;; FUNCALL
 
 \f
 ;;;; FUNCALL
 

@@ -579,15 +533,17 @@
   During evaluation of the Forms, bind the Vars to the result of evaluating the
   Value forms. The variables are bound in parallel after all of the Values are
   evaluated."
   During evaluation of the Forms, bind the Vars to the result of evaluating the
   Value forms. The variables are bound in parallel after all of the Values are
   evaluated."

-  (multiple-value-bind (forms decls) (parse-body body nil)
-    (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
-      (let ((fun-cont (make-continuation)))
-        (let* ((*lexenv* (process-decls decls vars nil cont))
-               (fun (ir1-convert-lambda-body
-                     forms vars
-                     :debug-name (debug-namify "LET ~S" bindings))))
-          (reference-leaf start fun-cont fun))
-        (ir1-convert-combination-args fun-cont cont values)))))
+  (if (null bindings)
+      (ir1-translate-locally  body start cont)
+      (multiple-value-bind (forms decls) (parse-body body nil)
+        (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
+          (let ((fun-cont (make-continuation)))
+            (let* ((*lexenv* (process-decls decls vars nil cont))
+                   (fun (ir1-convert-lambda-body
+                         forms vars
+                         :debug-name (debug-namify "LET ~S" bindings))))
+              (reference-leaf start fun-cont fun))
+            (ir1-convert-combination-args fun-cont cont values))))))

 
 (def-ir1-translator let* ((bindings &body body)
                          start cont)
 
 (def-ir1-translator let* ((bindings &body body)
                          start cont)

@@ -754,7 +710,9 @@
 ;;; many branches there are going to be.
 (defun ir1ize-the-or-values (type cont lexenv place)
   (declare (type continuation cont) (type lexenv lexenv))
 ;;; many branches there are going to be.
 (defun ir1ize-the-or-values (type cont lexenv place)
   (declare (type continuation cont) (type lexenv lexenv))

-  (let* ((atype (if (typep type 'ctype) type (compiler-values-specifier-type type)))
+  (let* ((atype (if (typep type 'ctype)
+                   type
+                   (compiler-values-specifier-type type)))

         (old-atype (or (lexenv-find cont type-restrictions)
                         *wild-type*))
          (old-ctype (or (lexenv-find cont weakend-type-restrictions)
         (old-atype (or (lexenv-find cont type-restrictions)
                         *wild-type*))
          (old-ctype (or (lexenv-find cont weakend-type-restrictions)

@@ -762,7 +720,8 @@
         (intersects (values-types-equal-or-intersect old-atype atype))
         (new-atype (values-type-intersection old-atype atype))
          (new-ctype (values-type-intersection
         (intersects (values-types-equal-or-intersect old-atype atype))
         (new-atype (values-type-intersection old-atype atype))
          (new-ctype (values-type-intersection

-                     old-ctype (maybe-weaken-check atype (lexenv-policy lexenv)))))
+                     old-ctype
+                    (maybe-weaken-check atype (lexenv-policy lexenv)))))

     (when (null (find-uses cont))
       (setf (continuation-asserted-type cont) new-atype)
       (setf (continuation-type-to-check cont) new-ctype))
     (when (null (find-uses cont))
       (setf (continuation-asserted-type cont) new-atype)
       (setf (continuation-type-to-check cont) new-ctype))

@@ -855,7 +814,10 @@
   (declare (type continuation start cont) (type basic-var var))
   (let ((dest (make-continuation)))
     (ir1-convert start dest value)
   (declare (type continuation start cont) (type basic-var var))
   (let ((dest (make-continuation)))
     (ir1-convert start dest value)

-    (assert-continuation-type dest (leaf-type var) (lexenv-policy *lexenv*))
+    (assert-continuation-type dest
+                              (or (lexenv-find var type-restrictions)
+                                  (leaf-type var))
+                              (lexenv-policy *lexenv*))

     (let ((res (make-set :var var :value dest)))
       (setf (continuation-dest dest) res)
       (setf (leaf-ever-used var) t)
     (let ((res (make-set :var var :value dest)))
       (setf (continuation-dest dest) res)
       (setf (leaf-ever-used var) t)

@@ -922,45 +884,40 @@
     (setf (functional-kind fun) :cleanup)
     (reference-leaf start cont fun)))
 
     (setf (functional-kind fun) :cleanup)
     (reference-leaf start cont fun)))
 

-;;; We represent the possibility of the control transfer by making an
-;;; "escape function" that does a lexical exit, and instantiate the
-;;; cleanup using %WITHIN-CLEANUP.

 (def-ir1-translator catch ((tag &body body) start cont)
   #!+sb-doc
   "Catch Tag Form*
 (def-ir1-translator catch ((tag &body body) start cont)
   #!+sb-doc
   "Catch Tag Form*

-  Evaluates Tag and instantiates it as a catcher while the body forms are
-  evaluated in an implicit PROGN. If a THROW is done to Tag within the dynamic
+  Evaluate TAG and instantiate it as a catcher while the body forms are
+  evaluated in an implicit PROGN. If a THROW is done to TAG within the dynamic

   scope of the body, then control will be transferred to the end of the body
   and the thrown values will be returned."
   scope of the body, then control will be transferred to the end of the body
   and the thrown values will be returned."

+  ;; We represent the possibility of the control transfer by making an
+  ;; "escape function" that does a lexical exit, and instantiate the
+  ;; cleanup using %WITHIN-CLEANUP.

   (ir1-convert
    start cont
   (ir1-convert
    start cont

-   (let ((exit-block (gensym "EXIT-BLOCK-")))
+   (with-unique-names (exit-block)

      `(block ,exit-block
        (%within-cleanup
            :catch
            (%catch (%escape-fun ,exit-block) ,tag)
          ,@body)))))
 
      `(block ,exit-block
        (%within-cleanup
            :catch
            (%catch (%escape-fun ,exit-block) ,tag)
          ,@body)))))
 

-;;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the
-;;; cleanup forms into a local function so that they can be referenced
-;;; both in the case where we are unwound and in any local exits. We
-;;; use %CLEANUP-FUN on this to indicate that reference by
-;;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of
-;;; an XEP.

 (def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
   #!+sb-doc
   "Unwind-Protect Protected Cleanup*
 (def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
   #!+sb-doc
   "Unwind-Protect Protected Cleanup*

-  Evaluate the form Protected, returning its values. The cleanup forms are
-  evaluated whenever the dynamic scope of the Protected form is exited (either
+  Evaluate the form PROTECTED, returning its values. The CLEANUP forms are
+  evaluated whenever the dynamic scope of the PROTECTED form is exited (either

   due to normal completion or a non-local exit such as THROW)."
   due to normal completion or a non-local exit such as THROW)."

+  ;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the
+  ;; cleanup forms into a local function so that they can be referenced
+  ;; both in the case where we are unwound and in any local exits. We
+  ;; use %CLEANUP-FUN on this to indicate that reference by
+  ;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of
+  ;; an XEP.

   (ir1-convert
    start cont
   (ir1-convert
    start cont

-   (let ((cleanup-fun (gensym "CLEANUP-FUN-"))
-        (drop-thru-tag (gensym "DROP-THRU-TAG-"))
-        (exit-tag (gensym "EXIT-TAG-"))
-        (next (gensym "NEXT"))
-        (start (gensym "START"))
-        (count (gensym "COUNT")))
+   (with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count)

      `(flet ((,cleanup-fun () ,@cleanup nil))
        ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
        ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
      `(flet ((,cleanup-fun () ,@cleanup nil))
        ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
        ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,

@@ -979,30 +936,28 @@
 \f
 ;;;; multiple-value stuff
 
 \f
 ;;;; multiple-value stuff
 

-;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an
-;;; MV-COMBINATION.
-;;;
-;;; If there are no arguments, then we convert to a normal
-;;; combination, ensuring that a MV-COMBINATION always has at least
-;;; one argument. This can be regarded as an optimization, but it is
-;;; more important for simplifying compilation of MV-COMBINATIONS.

 (def-ir1-translator multiple-value-call ((fun &rest args) start cont)
   #!+sb-doc
   "MULTIPLE-VALUE-CALL Function Values-Form*
 (def-ir1-translator multiple-value-call ((fun &rest args) start cont)
   #!+sb-doc
   "MULTIPLE-VALUE-CALL Function Values-Form*

-  Call Function, passing all the values of each Values-Form as arguments,
-  values from the first Values-Form making up the first argument, etc."
+  Call FUNCTION, passing all the values of each VALUES-FORM as arguments,
+  values from the first VALUES-FORM making up the first argument, etc."

   (let* ((fun-cont (make-continuation))
         (node (if args
   (let* ((fun-cont (make-continuation))
         (node (if args

+                  ;; If there are arguments, MULTIPLE-VALUE-CALL
+                  ;; turns into an MV-COMBINATION.

                   (make-mv-combination fun-cont)
                   (make-mv-combination fun-cont)

+                  ;; If there are no arguments, then we convert to a
+                  ;; normal combination, ensuring that a MV-COMBINATION
+                  ;; always has at least one argument. This can be
+                  ;; regarded as an optimization, but it is more
+                  ;; important for simplifying compilation of
+                  ;; MV-COMBINATIONS.

                   (make-combination fun-cont))))
     (ir1-convert start fun-cont
                 (if (and (consp fun) (eq (car fun) 'function))
                     fun
                     `(%coerce-callable-to-fun ,fun)))
     (setf (continuation-dest fun-cont) node)
                   (make-combination fun-cont))))
     (ir1-convert start fun-cont
                 (if (and (consp fun) (eq (car fun) 'function))
                     fun
                     `(%coerce-callable-to-fun ,fun)))
     (setf (continuation-dest fun-cont) node)

-    (assert-continuation-type fun-cont
-                             (specifier-type '(or function symbol))
-                              (lexenv-policy *lexenv*))

     (collect ((arg-conts))
       (let ((this-start fun-cont))
        (dolist (arg args)
     (collect ((arg-conts))
       (let ((this-start fun-cont))
        (dolist (arg args)