1.0.20.23: get rid of IGNORE-ERRORS in SB-INTROSPECT

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

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 5adc631..ca486d1 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -21,6 +21,14 @@
     (vop move node block x y))
   (values))
 
     (vop move node block x y))
   (values))
 

+;;; Determine whether we should emit a single-stepper breakpoint
+;;; around a call / before a vop.
+(defun emit-step-p (node)
+  (if (and (policy node (> insert-step-conditions 1))
+           (typep node 'combination))
+      (combination-step-info node)
+      nil))
+

 ;;; If there is any CHECK-xxx template for TYPE, then return it,
 ;;; otherwise return NIL.
 (defun type-check-template (type)
 ;;; If there is any CHECK-xxx template for TYPE, then return it,
 ;;; otherwise return NIL.
 (defun type-check-template (type)

@@ -44,17 +52,15 @@
   (emit-move-template node block (type-check-template type) value result)
   (values))
 
   (emit-move-template node block (type-check-template type) value result)
   (values))
 

-;;; Allocate an indirect value cell. Maybe do some clever stack
-;;; allocation someday.
-;;;
-;;; FIXME: DO-MAKE-VALUE-CELL is a bad name, since it doesn't make
-;;; clear what's the distinction between it and the MAKE-VALUE-CELL
-;;; VOP, and since the DO- further connotes iteration, which has
-;;; nothing to do with this. Clearer, more systematic names, anyone?
+;;; Allocate an indirect value cell.

 (defevent make-value-cell-event "Allocate heap value cell for lexical var.")
 (defevent make-value-cell-event "Allocate heap value cell for lexical var.")

-(defun do-make-value-cell (node block value res)
+(defun emit-make-value-cell (node block value res)

   (event make-value-cell-event node)
   (event make-value-cell-event node)

-  (vop make-value-cell node block value res))
+  (let ((leaf (tn-leaf res)))
+    (vop make-value-cell node block value
+         ;; FIXME: See bug 419
+         (and leaf (eq :truly (leaf-dynamic-extent leaf)))
+         res)))

 \f
 ;;;; leaf reference
 
 \f
 ;;;; leaf reference
 

@@ -128,13 +134,7 @@
              (vop value-cell-ref node block tn res)
              (emit-move node block tn res))))
       (constant
              (vop value-cell-ref node block tn res)
              (emit-move node block tn res))))
       (constant

-       (if (legal-immediate-constant-p leaf)
-           (emit-move node block (constant-tn leaf) res)
-           (let* ((name (leaf-source-name leaf))
-                  (name-tn (emit-constant name)))
-             (if (policy node (zerop safety))
-                 (vop fast-symbol-value node block name-tn res)
-                 (vop symbol-value node block name-tn res)))))
+       (emit-move node block (constant-tn leaf) res))

       (functional
        (ir2-convert-closure node block leaf res))
       (global-var
       (functional
        (ir2-convert-closure node block leaf res))
       (global-var

@@ -299,7 +299,7 @@
                (emit-move node block val tn)))))
       (global-var
        (ecase (global-var-kind leaf)
                (emit-move node block val tn)))))
       (global-var
        (ecase (global-var-kind leaf)

-         ((:special :global)
+         ((:special)

           (aver (symbolp (leaf-source-name leaf)))
           (vop set node block (emit-constant (leaf-source-name leaf)) val)))))
     (when locs
           (aver (symbolp (leaf-source-name leaf)))
           (vop set node block (emit-constant (leaf-source-name leaf)) val)))))
     (when locs

@@ -594,61 +594,49 @@
     (ir2-convert-conditional node block (template-or-lose 'if-eq)
                              test-ref () node t)))
 
     (ir2-convert-conditional node block (template-or-lose 'if-eq)
                              test-ref () node t)))
 

-;;; Return a list of primitive-types that we can pass to
-;;; LVAR-RESULT-TNS describing the result types we want for a
-;;; template call. We duplicate here the determination of output type
-;;; that was done in initially selecting the template, so we know that
-;;; the types we find are allowed by the template output type
-;;; restrictions.
-(defun find-template-result-types (call template rtypes)
-  (declare (type combination call)
-           (type template template) (list rtypes))
-  (declare (ignore template))
-  (let* ((dtype (node-derived-type call))
-         (type dtype)
-         (types (mapcar #'primitive-type
-                        (if (values-type-p type)
-                            (append (values-type-required type)
-                                    (values-type-optional type))
-                            (list type)))))
-    (let ((nvals (length rtypes))
-          (ntypes (length types)))
-      (cond ((< ntypes nvals)
-             (append types
-                     (make-list (- nvals ntypes)
-                                :initial-element *backend-t-primitive-type*)))
-            ((> ntypes nvals)
-             (subseq types 0 nvals))
-            (t
-             types)))))
-
-;;; Return a list of TNs usable in a CALL to TEMPLATE delivering
-;;; values to LVAR. As an efficiency hack, we pick off the common case
-;;; where the LVAR is fixed values and has locations that satisfy the
-;;; result restrictions. This can fail when there is a type check or a
-;;; values count mismatch.
-(defun make-template-result-tns (call lvar template rtypes)
+;;; Return a list of primitive-types that we can pass to LVAR-RESULT-TNS
+;;; describing the result types we want for a template call. We are really
+;;; only interested in the number of results required: in normal case
+;;; TEMPLATE-RESULTS-OK has already checked them.
+(defun find-template-result-types (call rtypes)
+  (let* ((type (node-derived-type call))
+         (types
+          (mapcar #'primitive-type
+                  (if (values-type-p type)
+                      (append (args-type-required type)
+                              (args-type-optional type))
+                      (list type))))
+         (primitive-t *backend-t-primitive-type*))
+    (loop for rtype in rtypes
+          for type = (or (pop types) primitive-t)
+          collect type)))
+
+;;; Return a list of TNs usable in a CALL to TEMPLATE delivering values to
+;;; LVAR. As an efficiency hack, we pick off the common case where the LVAR is
+;;; fixed values and has locations that satisfy the result restrictions. This
+;;; can fail when there is a type check or a values count mismatch.
+(defun make-template-result-tns (call lvar rtypes)

   (declare (type combination call) (type (or lvar null) lvar)
   (declare (type combination call) (type (or lvar null) lvar)

-           (type template template) (list rtypes))
+           (list rtypes))

   (let ((2lvar (when lvar (lvar-info lvar))))
     (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :fixed))
         (let ((locs (ir2-lvar-locs 2lvar)))
           (if (and (= (length rtypes) (length locs))
                    (do ((loc locs (cdr loc))
   (let ((2lvar (when lvar (lvar-info lvar))))
     (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :fixed))
         (let ((locs (ir2-lvar-locs 2lvar)))
           (if (and (= (length rtypes) (length locs))
                    (do ((loc locs (cdr loc))

-                        (rtype rtypes (cdr rtype)))
+                        (rtypes rtypes (cdr rtypes)))

                        ((null loc) t)
                      (unless (operand-restriction-ok
                        ((null loc) t)
                      (unless (operand-restriction-ok

-                              (car rtype)
+                              (car rtypes)

                               (tn-primitive-type (car loc))
                               :t-ok nil)
                        (return nil))))
               locs
               (lvar-result-tns
                lvar
                               (tn-primitive-type (car loc))
                               :t-ok nil)
                        (return nil))))
               locs
               (lvar-result-tns
                lvar

-               (find-template-result-types call template rtypes))))
+               (find-template-result-types call rtypes))))

         (lvar-result-tns
          lvar
         (lvar-result-tns
          lvar

-         (find-template-result-types call template rtypes)))))
+         (find-template-result-types call rtypes)))))

 
 ;;; Get the operands into TNs, make TN-REFs for them, and then call
 ;;; the template emit function.
 
 ;;; Get the operands into TNs, make TN-REFs for them, and then call
 ;;; the template emit function.

@@ -663,13 +651,15 @@
       (if (eq rtypes :conditional)
           (ir2-convert-conditional call block template args info-args
                                    (lvar-dest lvar) nil)
       (if (eq rtypes :conditional)
           (ir2-convert-conditional call block template args info-args
                                    (lvar-dest lvar) nil)

-          (let* ((results (make-template-result-tns call lvar template rtypes))
+          (let* ((results (make-template-result-tns call lvar rtypes))

                  (r-refs (reference-tn-list results t)))
             (aver (= (length info-args)
                      (template-info-arg-count template)))
             (when (and lvar (lvar-dynamic-extent lvar))
               (vop current-stack-pointer call block
                    (ir2-lvar-stack-pointer (lvar-info lvar))))
                  (r-refs (reference-tn-list results t)))
             (aver (= (length info-args)
                      (template-info-arg-count template)))
             (when (and lvar (lvar-dynamic-extent lvar))
               (vop current-stack-pointer call block
                    (ir2-lvar-stack-pointer (lvar-info lvar))))

+            (when (emit-step-p call)
+              (vop sb!vm::step-instrument-before-vop call block))

             (if info-args
                 (emit-template call block template args r-refs info-args)
                 (emit-template call block template args r-refs))
             (if info-args
                 (emit-template call block template args r-refs info-args)
                 (emit-template call block template args r-refs))

@@ -685,7 +675,7 @@
          (info (lvar-value info))
          (lvar (node-lvar call))
          (rtypes (template-result-types template))
          (info (lvar-value info))
          (lvar (node-lvar call))
          (rtypes (template-result-types template))

-         (results (make-template-result-tns call lvar template rtypes))
+         (results (make-template-result-tns call lvar rtypes))

          (r-refs (reference-tn-list results t)))
     (multiple-value-bind (args info-args)
         (reference-args call block (cddr (combination-args call)) template)
          (r-refs (reference-tn-list results t)))
     (multiple-value-bind (args info-args)
         (reference-args call block (cddr (combination-args call)) template)

@@ -699,6 +689,12 @@
 
       (move-lvar-result call block results lvar)))
   (values))
 
       (move-lvar-result call block results lvar)))
   (values))

+
+(defoptimizer (%%primitive derive-type) ((template info &rest args))
+  (let ((type (template-type (lvar-value template))))
+    (if (fun-type-p type)
+        (fun-type-returns type)
+        *wild-type*)))

 \f
 ;;;; local call
 
 \f
 ;;;; local call
 

@@ -714,7 +710,7 @@
             (let ((src (lvar-tn node block arg))
                   (dest (leaf-info var)))
               (if (lambda-var-indirect var)
             (let ((src (lvar-tn node block arg))
                   (dest (leaf-info var)))
               (if (lambda-var-indirect var)

-                  (do-make-value-cell node block src dest)
+                  (emit-make-value-cell node block src dest)

                   (emit-move node block src dest)))))
         (lambda-vars fun) (basic-combination-args node))
   (values))
                   (emit-move node block src dest)))))
         (lambda-vars fun) (basic-combination-args node))
   (values))

@@ -748,7 +744,7 @@
              ((lambda-var-indirect var)
               (let ((temp
                      (make-normal-tn *backend-t-primitive-type*)))
              ((lambda-var-indirect var)
               (let ((temp
                      (make-normal-tn *backend-t-primitive-type*)))

-                (do-make-value-cell node block actual temp)
+                (emit-make-value-cell node block actual temp)

                 (temps temp)))
              ((member actual (locs))
               (let ((temp (make-normal-tn (tn-primitive-type loc))))
                 (temps temp)))
              ((member actual (locs))
               (let ((temp (make-normal-tn (tn-primitive-type loc))))

@@ -954,11 +950,13 @@
           (vop* tail-call-named node block
                 (fun-tn old-fp return-pc pass-refs)
                 (nil)
           (vop* tail-call-named node block
                 (fun-tn old-fp return-pc pass-refs)
                 (nil)

-                nargs)
+                nargs
+                (emit-step-p node))

           (vop* tail-call node block
                 (fun-tn old-fp return-pc pass-refs)
                 (nil)
           (vop* tail-call node block
                 (fun-tn old-fp return-pc pass-refs)
                 (nil)

-                nargs))))
+                nargs
+                (emit-step-p node)))))

 
   (values))
 
 
   (values))
 

@@ -998,9 +996,9 @@
           (fun-lvar-tn node block (basic-combination-fun node))
         (if named
             (vop* call-named node block (fp fun-tn args) (loc-refs)
           (fun-lvar-tn node block (basic-combination-fun node))
         (if named
             (vop* call-named node block (fp fun-tn args) (loc-refs)

-                  arg-locs nargs nvals)
+                  arg-locs nargs nvals (emit-step-p node))

             (vop* call node block (fp fun-tn args) (loc-refs)
             (vop* call node block (fp fun-tn args) (loc-refs)

-                  arg-locs nargs nvals))
+                  arg-locs nargs nvals (emit-step-p node)))

         (move-lvar-result node block locs lvar))))
   (values))
 
         (move-lvar-result node block locs lvar))))
   (values))
 

@@ -1016,34 +1014,13 @@
           (fun-lvar-tn node block (basic-combination-fun node))
         (if named
             (vop* multiple-call-named node block (fp fun-tn args) (loc-refs)
           (fun-lvar-tn node block (basic-combination-fun node))
         (if named
             (vop* multiple-call-named node block (fp fun-tn args) (loc-refs)

-                  arg-locs nargs)
+                  arg-locs nargs (emit-step-p node))

             (vop* multiple-call node block (fp fun-tn args) (loc-refs)
             (vop* multiple-call node block (fp fun-tn args) (loc-refs)

-                  arg-locs nargs)))))
+                  arg-locs nargs (emit-step-p node))))))

   (values))
 
 ;;; stuff to check in PONDER-FULL-CALL
 ;;;
   (values))
 
 ;;; stuff to check in PONDER-FULL-CALL
 ;;;

-;;; There are some things which are intended always to be optimized
-;;; away by DEFTRANSFORMs and such, and so never compiled into full
-;;; calls. This has been a source of bugs so many times that it seems
-;;; worth listing some of them here so that we can check the list
-;;; whenever we compile a full call.
-;;;
-;;; FIXME: It might be better to represent this property by setting a
-;;; flag in DEFKNOWN, instead of representing it by membership in this
-;;; list.
-(defvar *always-optimized-away*
-  '(;; This should always be DEFTRANSFORMed away, but wasn't in a bug
-    ;; reported to cmucl-imp 2000-06-20.
-    %instance-ref
-    ;; These should always turn into VOPs, but wasn't in a bug which
-    ;; appeared when LTN-POLICY stuff was being tweaked in
-    ;; sbcl-0.6.9.16. in sbcl-0.6.0
-    data-vector-set
-    data-vector-ref))
-
-;;; more stuff to check in PONDER-FULL-CALL
-;;;

 ;;; These came in handy when troubleshooting cold boot after making
 ;;; major changes in the package structure: various transforms and
 ;;; VOPs and stuff got attached to the wrong symbol, so that
 ;;; These came in handy when troubleshooting cold boot after making
 ;;; major changes in the package structure: various transforms and
 ;;; VOPs and stuff got attached to the wrong symbol, so that

@@ -1087,10 +1064,14 @@
     ;; functions are actually optimized away. Thus, we skip the check
     ;; in that case.
     (unless *failure-p*
     ;; functions are actually optimized away. Thus, we skip the check
     ;; in that case.
     (unless *failure-p*

-      (when (memq fname *always-optimized-away*)
-        (/show (policy node speed) (policy node safety))
-        (/show (policy node compilation-speed))
-        (bug "full call to ~S" fname)))
+      ;; check to see if we know anything about the function
+      (let ((info (info :function :info fname)))
+        ;; if we know something, check to see if the full call was valid
+        (when (and info (ir1-attributep (fun-info-attributes info)
+                                        always-translatable))
+          (/show (policy node speed) (policy node safety))
+          (/show (policy node compilation-speed))
+          (bug "full call to ~S" fname))))

 
     (when (consp fname)
       (aver (legal-fun-name-p fname))
 
     (when (consp fname)
       (aver (legal-fun-name-p fname))

@@ -1138,9 +1119,6 @@
       (if (ir2-physenv-closure env)
           (let ((closure (make-normal-tn *backend-t-primitive-type*)))
             (vop setup-closure-environment node block start-label closure)
       (if (ir2-physenv-closure env)
           (let ((closure (make-normal-tn *backend-t-primitive-type*)))
             (vop setup-closure-environment node block start-label closure)

-            ;; KLUDGE: see the comment around the definition of
-            ;; CLOSURE objects in src/compiler/objdef.lisp
-            (vop funcallable-instance-lexenv node block closure closure)

             (let ((n -1))
               (dolist (loc (ir2-physenv-closure env))
                 (vop closure-ref node block closure (incf n) (cdr loc)))))
             (let ((n -1))
               (dolist (loc (ir2-physenv-closure env))
                 (vop closure-ref node block closure (incf n) (cdr loc)))))

@@ -1157,7 +1135,7 @@
             (let ((pass (standard-arg-location n))
                   (home (leaf-info arg)))
               (if (lambda-var-indirect arg)
             (let ((pass (standard-arg-location n))
                   (home (leaf-info arg)))
               (if (lambda-var-indirect arg)

-                  (do-make-value-cell node block pass home)
+                  (emit-make-value-cell node block pass home)

                   (emit-move node block pass home))))
           (incf n))))
 
                   (emit-move node block pass home))))
           (incf n))))
 

@@ -1192,6 +1170,13 @@
                (ir2-physenv-return-pc-pass env)
                (ir2-physenv-return-pc env))
 
                (ir2-physenv-return-pc-pass env)
                (ir2-physenv-return-pc env))
 

+    #!+unwind-to-frame-and-call-vop
+    (when (and (lambda-allow-instrumenting fun)
+               (not (lambda-inline-expanded fun))
+               (lambda-return fun)
+               (policy fun (>= insert-debug-catch 2)))
+      (vop sb!vm::bind-sentinel node block))
+

     (let ((lab (gen-label)))
       (setf (ir2-physenv-environment-start env) lab)
       (vop note-environment-start node block lab)))
     (let ((lab (gen-label)))
       (setf (ir2-physenv-environment-start env) lab)
       (vop note-environment-start node block lab)))

@@ -1217,6 +1202,11 @@
          (old-fp (ir2-physenv-old-fp env))
          (return-pc (ir2-physenv-return-pc env))
          (returns (tail-set-info (lambda-tail-set fun))))
          (old-fp (ir2-physenv-old-fp env))
          (return-pc (ir2-physenv-return-pc env))
          (returns (tail-set-info (lambda-tail-set fun))))

+    #!+unwind-to-frame-and-call-vop
+    (when (and (lambda-allow-instrumenting fun)
+               (not (lambda-inline-expanded fun))
+               (policy fun (>= insert-debug-catch 2)))
+      (vop sb!vm::unbind-sentinel node block))

     (cond
      ((and (eq (return-info-kind returns) :fixed)
            (not (xep-p fun)))
     (cond
      ((and (eq (return-info-kind returns) :fixed)
            (not (xep-p fun)))

@@ -1278,7 +1268,7 @@
             (when (leaf-refs var)
               (let ((dest (leaf-info var)))
                 (if (lambda-var-indirect var)
             (when (leaf-refs var)
               (let ((dest (leaf-info var)))
                 (if (lambda-var-indirect var)

-                    (do-make-value-cell node block src dest)
+                    (emit-make-value-cell node block src dest)

                     (emit-move node block src dest)))))
           (lvar-tns node block lvar
                             (mapcar (lambda (x)
                     (emit-move node block src dest)))))
           (lvar-tns node block lvar
                             (mapcar (lambda (x)

@@ -1314,11 +1304,13 @@
        ((and 2lvar
              (eq (ir2-lvar-kind 2lvar) :unknown))
         (vop* multiple-call-variable node block (start fun nil)
        ((and 2lvar
              (eq (ir2-lvar-kind 2lvar) :unknown))
         (vop* multiple-call-variable node block (start fun nil)

-              ((reference-tn-list (ir2-lvar-locs 2lvar) t))))
+              ((reference-tn-list (ir2-lvar-locs 2lvar) t))
+              (emit-step-p node)))

        (t
         (let ((locs (standard-result-tns lvar)))
           (vop* call-variable node block (start fun nil)
        (t
         (let ((locs (standard-result-tns lvar)))
           (vop* call-variable node block (start fun nil)

-                ((reference-tn-list locs t)) (length locs))
+                ((reference-tn-list locs t)) (length locs)
+                (emit-step-p node))

           (move-lvar-result node block locs lvar)))))))
 
 ;;; Reset the stack pointer to the start of the specified
           (move-lvar-result node block locs lvar)))))))
 
 ;;; Reset the stack pointer to the start of the specified

@@ -1437,20 +1429,35 @@
              (progn
                (labels ((,unbind (vars)
                           (declare (optimize (speed 2) (debug 0)))
              (progn
                (labels ((,unbind (vars)
                           (declare (optimize (speed 2) (debug 0)))

-                          (dolist (var vars)
-                            (%primitive bind nil var)
-                            (makunbound var)))
+                          (let ((unbound-marker (%primitive make-other-immediate-type
+                                                            0 sb!vm:unbound-marker-widetag)))
+                            (dolist (var vars)
+                              ;; CLHS says "bound and then made to have no value" -- user
+                              ;; should not be able to tell the difference between that and this.
+                              (about-to-modify-symbol-value var "bind ~S")
+                              (%primitive bind unbound-marker var))))

                         (,bind (vars vals)
                           (declare (optimize (speed 2) (debug 0)))
                           (cond ((null vars))
                                 ((null vals) (,unbind vars))
                         (,bind (vars vals)
                           (declare (optimize (speed 2) (debug 0)))
                           (cond ((null vars))
                                 ((null vals) (,unbind vars))

-                                (t (%primitive bind
-                                               (car vals)
-                                               (car vars))
-                                   (,bind (cdr vars) (cdr vals))))))
+                                (t
+                                 (let ((val (car vals))
+                                       (var (car vars)))
+                                   (about-to-modify-symbol-value var "bind ~S" val)
+                                   (%primitive bind val var))
+                                 (,bind (cdr vars) (cdr vals))))))

                  (,bind ,vars ,vals))
                nil
                ,@body)
                  (,bind ,vars ,vals))
                nil
                ,@body)

+          ;; Technically ANSI CL doesn't allow declarations at the
+          ;; start of the cleanup form. SBCL happens to allow for
+          ;; them, due to the way the UNWIND-PROTECT ir1 translation
+          ;; is implemented; the cleanup forms are directly spliced
+          ;; into an FLET definition body. And a declaration here
+          ;; actually has exactly the right scope for what we need
+          ;; (ensure that debug instrumentation is not emitted for the
+          ;; cleanup function). -- JES, 2007-06-16
+          (declare (optimize (insert-debug-catch 0)))

           (%primitive unbind-to-here ,n-save-bs))))))
 \f
 ;;;; non-local exit
           (%primitive unbind-to-here ,n-save-bs))))))
 \f
 ;;;; non-local exit

@@ -1537,7 +1544,7 @@
     (ecase kind
       ((:block :tagbody)
        (if (nlx-info-safe-p info)
     (ecase kind
       ((:block :tagbody)
        (if (nlx-info-safe-p info)

-           (do-make-value-cell node block res (ir2-nlx-info-home 2info))
+           (emit-make-value-cell node block res (ir2-nlx-info-home 2info))

            (emit-move node block res (ir2-nlx-info-home 2info))))
       (:unwind-protect
        (vop set-unwind-protect node block block-tn))
            (emit-move node block res (ir2-nlx-info-home 2info))))
       (:unwind-protect
        (vop set-unwind-protect node block block-tn))