1.0.47.4: Fix slot-documentation for SB-POSIX:TERMIOS slot CC.

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

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 947389f..ebec113 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -56,12 +56,7 @@
 (defevent make-value-cell-event "Allocate heap value cell for lexical var.")
 (defun emit-make-value-cell (node block value res)
   (event make-value-cell-event node)
 (defevent make-value-cell-event "Allocate heap value cell for lexical var.")
 (defun emit-make-value-cell (node block value res)
   (event make-value-cell-event node)

-  (let ((leaf (tn-leaf res)))
-    (vop make-value-cell node block value
-         (and leaf (leaf-dynamic-extent leaf)
-              ;; FIXME: See bug 419
-              (policy node (> stack-allocate-value-cells 1)))
-         res)))
+  (vop make-value-cell node block value nil res))

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

@@ -130,10 +125,17 @@
          (res (first locs)))
     (etypecase leaf
       (lambda-var
          (res (first locs)))
     (etypecase leaf
       (lambda-var

-       (let ((tn (find-in-physenv leaf (node-physenv node))))
-         (if (lambda-var-indirect leaf)
-             (vop value-cell-ref node block tn res)
-             (emit-move node block tn res))))
+       (let ((tn (find-in-physenv leaf (node-physenv node)))
+             (indirect (lambda-var-indirect leaf))
+             (explicit (lambda-var-explicit-value-cell leaf)))
+         (cond
+          ((and indirect explicit)
+           (vop value-cell-ref node block tn res))
+          ((and indirect
+                (not (eq (node-physenv node)
+                         (lambda-physenv (lambda-var-home leaf)))))
+           (vop ancestor-frame-ref node block tn (leaf-info leaf) res))
+          (t (emit-move node block tn res)))))

       (constant
        (emit-move node block (constant-tn leaf) res))
       (functional
       (constant
        (emit-move node block (constant-tn leaf) res))
       (functional

@@ -142,12 +144,18 @@
        (let ((unsafe (policy node (zerop safety)))
              (name (leaf-source-name leaf)))
          (ecase (global-var-kind leaf)
        (let ((unsafe (policy node (zerop safety)))
              (name (leaf-source-name leaf)))
          (ecase (global-var-kind leaf)

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

             (aver (symbolp name))
             (let ((name-tn (emit-constant name)))
             (aver (symbolp name))
             (let ((name-tn (emit-constant name)))

-              (if unsafe
+              (if (or unsafe (info :variable :always-bound name))

                   (vop fast-symbol-value node block name-tn res)
                   (vop symbol-value node block name-tn res))))
                   (vop fast-symbol-value node block name-tn res)
                   (vop symbol-value node block name-tn res))))

+           (:global
+            (aver (symbolp name))
+            (let ((name-tn (emit-constant name)))
+              (if (or unsafe (info :variable :always-bound name))
+                  (vop fast-symbol-global-value node block name-tn res)
+                  (vop symbol-global-value node block name-tn res))))

            (:global-function
             (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
               (if unsafe
            (:global-function
             (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
               (if unsafe

@@ -231,6 +239,21 @@
              (emit-move ref ir2-block entry res)))))
   (values))
 
              (emit-move ref ir2-block entry res)))))
   (values))
 

+(defun closure-initial-value (what this-env current-fp)
+  (declare (type (or nlx-info lambda-var clambda) what)
+           (type physenv this-env)
+           (type (or tn null) current-fp))
+  ;; If we have an indirect LAMBDA-VAR that does not require an
+  ;; EXPLICIT-VALUE-CELL, and is from this environment (not from being
+  ;; closed over), we need to store the current frame pointer.
+  (if (and (lambda-var-p what)
+           (lambda-var-indirect what)
+           (not (lambda-var-explicit-value-cell what))
+           (eq (lambda-physenv (lambda-var-home what))
+               this-env))
+    current-fp
+    (find-in-physenv what this-env)))
+

 (defoptimizer (%allocate-closures ltn-annotate) ((leaves) node ltn-policy)
   ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
   (when (lvar-dynamic-extent leaves)
 (defoptimizer (%allocate-closures ltn-annotate) ((leaves) node ltn-policy)
   ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
   (when (lvar-dynamic-extent leaves)

@@ -247,7 +270,11 @@
         (vop current-stack-pointer call 2block
              (ir2-lvar-stack-pointer (lvar-info leaves))))
       (dolist (leaf (lvar-value leaves))
         (vop current-stack-pointer call 2block
              (ir2-lvar-stack-pointer (lvar-info leaves))))
       (dolist (leaf (lvar-value leaves))

-        (binding* ((xep (functional-entry-fun leaf) :exit-if-null)
+        (binding* ((xep (awhen (functional-entry-fun leaf)
+                          ;; if the xep's been deleted then we can skip it
+                          (if (eq (functional-kind it) :deleted)
+                              nil it))
+                        :exit-if-null)

                    (nil (aver (xep-p xep)))
                    (entry-info (lambda-info xep) :exit-if-null)
                    (tn (entry-info-closure-tn entry-info) :exit-if-null)
                    (nil (aver (xep-p xep)))
                    (entry-info (lambda-info xep) :exit-if-null)
                    (tn (entry-info-closure-tn entry-info) :exit-if-null)

@@ -268,11 +295,16 @@
                     ;; putting of all closures after all creations
                     ;; (though it may require more registers).
                     (if (lambda-p what)
                     ;; putting of all closures after all creations
                     ;; (though it may require more registers).
                     (if (lambda-p what)

-                        (delayed (list tn (find-in-physenv what this-env) n))
-                        (vop closure-init call 2block
-                             tn
-                             (find-in-physenv what this-env)
-                             n)))))))
+                      (delayed (list tn (find-in-physenv what this-env) n))
+                      (let ((initial-value (closure-initial-value
+                                            what this-env nil)))
+                        (if initial-value
+                          (vop closure-init call 2block
+                               tn initial-value n)
+                          ;; An initial-value of NIL means to stash
+                          ;; the frame pointer... which requires a
+                          ;; different VOP.
+                          (vop closure-init-from-fp call 2block tn n)))))))))

       (loop for (tn what n) in (delayed)
             do (vop closure-init call 2block
                     tn what n))))
       (loop for (tn what n) in (delayed)
             do (vop closure-init call 2block
                     tn what n))))

@@ -294,15 +326,25 @@
     (etypecase leaf
       (lambda-var
        (when (leaf-refs leaf)
     (etypecase leaf
       (lambda-var
        (when (leaf-refs leaf)

-         (let ((tn (find-in-physenv leaf (node-physenv node))))
-           (if (lambda-var-indirect leaf)
-               (vop value-cell-set node block tn val)
-               (emit-move node block val tn)))))
+         (let ((tn (find-in-physenv leaf (node-physenv node)))
+               (indirect (lambda-var-indirect leaf))
+               (explicit (lambda-var-explicit-value-cell leaf)))
+           (cond
+            ((and indirect explicit)
+             (vop value-cell-set node block tn val))
+            ((and indirect
+                  (not (eq (node-physenv node)
+                           (lambda-physenv (lambda-var-home leaf)))))
+             (vop ancestor-frame-set node block tn val (leaf-info leaf)))
+            (t (emit-move node block val tn))))))

       (global-var
       (global-var

+       (aver (symbolp (leaf-source-name leaf)))

        (ecase (global-var-kind leaf)
          ((:special)
        (ecase (global-var-kind leaf)
          ((:special)

-          (aver (symbolp (leaf-source-name leaf)))
-          (vop set node block (emit-constant (leaf-source-name leaf)) val)))))
+          (vop set node block (emit-constant (leaf-source-name leaf)) val))
+         ((:global)
+          (vop %set-symbol-global-value node
+               block (emit-constant (leaf-source-name leaf)) val)))))

     (when locs
       (emit-move node block val (first locs))
       (move-lvar-result node block locs lvar)))
     (when locs
       (emit-move node block val (first locs))
       (move-lvar-result node block locs lvar)))

@@ -572,16 +614,28 @@
   (declare (type node node) (type ir2-block block)
            (type template template) (type (or tn-ref null) args)
            (list info-args) (type cif if) (type boolean not-p))
   (declare (type node node) (type ir2-block block)
            (type template template) (type (or tn-ref null) args)
            (list info-args) (type cif if) (type boolean not-p))

-  (aver (= (template-info-arg-count template) (+ (length info-args) 2)))

   (let ((consequent (if-consequent if))
   (let ((consequent (if-consequent if))

-        (alternative (if-alternative if)))
-    (cond ((drop-thru-p if consequent)
+        (alternative (if-alternative if))
+        (flags       (and (consp (template-result-types template))
+                          (rest (template-result-types template)))))
+    (aver (= (template-info-arg-count template)
+             (+ (length info-args)
+                (if flags 0 2))))
+    (when not-p
+      (rotatef consequent alternative)
+      (setf not-p nil))
+    (when (drop-thru-p if consequent)
+      (rotatef consequent alternative)
+      (setf not-p t))
+    (cond ((not flags)

            (emit-template node block template args nil
            (emit-template node block template args nil

-                          (list* (block-label alternative) (not not-p)
-                                 info-args)))
+                          (list* (block-label consequent) not-p
+                                 info-args))
+           (unless (drop-thru-p if alternative)
+             (vop branch node block (block-label alternative))))

           (t
           (t

-           (emit-template node block template args nil
-                          (list* (block-label consequent) not-p info-args))
+           (emit-template node block template args nil info-args)
+           (vop branch-if node block (block-label consequent) flags not-p)

            (unless (drop-thru-p if alternative)
              (vop branch node block (block-label alternative)))))))
 
            (unless (drop-thru-p if alternative)
              (vop branch node block (block-label alternative)))))))
 

@@ -649,7 +703,7 @@
     (multiple-value-bind (args info-args)
         (reference-args call block (combination-args call) template)
       (aver (not (template-more-results-type template)))
     (multiple-value-bind (args info-args)
         (reference-args call block (combination-args call) template)
       (aver (not (template-more-results-type template)))

-      (if (eq rtypes :conditional)
+      (if (template-conditional-p template)

           (ir2-convert-conditional call block template args info-args
                                    (lvar-dest lvar) nil)
           (let* ((results (make-template-result-tns call lvar rtypes))
           (ir2-convert-conditional call block template args info-args
                                    (lvar-dest lvar) nil)
           (let* ((results (make-template-result-tns call lvar rtypes))

@@ -681,7 +735,7 @@
     (multiple-value-bind (args info-args)
         (reference-args call block (cddr (combination-args call)) template)
       (aver (not (template-more-results-type template)))
     (multiple-value-bind (args info-args)
         (reference-args call block (cddr (combination-args call)) template)
       (aver (not (template-more-results-type template)))

-      (aver (not (eq rtypes :conditional)))
+      (aver (not (template-conditional-p template)))

       (aver (null info-args))
 
       (if info
       (aver (null info-args))
 
       (if info

@@ -710,7 +764,8 @@
           (when arg
             (let ((src (lvar-tn node block arg))
                   (dest (leaf-info var)))
           (when arg
             (let ((src (lvar-tn node block arg))
                   (dest (leaf-info var)))

-              (if (lambda-var-indirect var)
+              (if (and (lambda-var-indirect var)
+                       (lambda-var-explicit-value-cell var))

                   (emit-make-value-cell node block src dest)
                   (emit-move node block src dest)))))
         (lambda-vars fun) (basic-combination-args node))
                   (emit-make-value-cell node block src dest)
                   (emit-move node block src dest)))))
         (lambda-vars fun) (basic-combination-args node))

@@ -728,9 +783,15 @@
 ;;; OLD-FP. If null, then the call is to the same environment (an
 ;;; :ASSIGNMENT), so we only move the arguments, and leave the
 ;;; environment alone.
 ;;; OLD-FP. If null, then the call is to the same environment (an
 ;;; :ASSIGNMENT), so we only move the arguments, and leave the
 ;;; environment alone.

-(defun emit-psetq-moves (node block fun old-fp)
+;;;
+;;; CLOSURE-FP is for calling a closure that has "implicit" value
+;;; cells (stored in the allocating stack frame), and is the frame
+;;; pointer TN to use for values allocated in the outbound stack
+;;; frame.  This is distinct from OLD-FP for the specific case of a
+;;; tail-local-call.
+(defun emit-psetq-moves (node block fun old-fp &optional (closure-fp old-fp))

   (declare (type combination node) (type ir2-block block) (type clambda fun)
   (declare (type combination node) (type ir2-block block) (type clambda fun)

-           (type (or tn null) old-fp))
+           (type (or tn null) old-fp closure-fp))

   (let ((actuals (mapcar (lambda (x)
                            (when x
                              (lvar-tn node block x)))
   (let ((actuals (mapcar (lambda (x)
                            (when x
                              (lvar-tn node block x)))

@@ -742,7 +803,8 @@
               (loc (leaf-info var)))
           (when actual
             (cond
               (loc (leaf-info var)))
           (when actual
             (cond

-             ((lambda-var-indirect var)
+             ((and (lambda-var-indirect var)
+                   (lambda-var-explicit-value-cell var))

               (let ((temp
                      (make-normal-tn *backend-t-primitive-type*)))
                 (emit-make-value-cell node block actual temp)
               (let ((temp
                      (make-normal-tn *backend-t-primitive-type*)))
                 (emit-make-value-cell node block actual temp)

@@ -759,7 +821,7 @@
         (let ((this-1env (node-physenv node))
               (called-env (physenv-info (lambda-physenv fun))))
           (dolist (thing (ir2-physenv-closure called-env))
         (let ((this-1env (node-physenv node))
               (called-env (physenv-info (lambda-physenv fun))))
           (dolist (thing (ir2-physenv-closure called-env))

-            (temps (find-in-physenv (car thing) this-1env))
+            (temps (closure-initial-value (car thing) this-1env closure-fp))

             (locs (cdr thing)))
           (temps old-fp)
           (locs (ir2-physenv-old-fp called-env))))
             (locs (cdr thing)))
           (temps old-fp)
           (locs (ir2-physenv-old-fp called-env))))

@@ -772,9 +834,16 @@
 ;;; function's passing location.
 (defun ir2-convert-tail-local-call (node block fun)
   (declare (type combination node) (type ir2-block block) (type clambda fun))
 ;;; function's passing location.
 (defun ir2-convert-tail-local-call (node block fun)
   (declare (type combination node) (type ir2-block block) (type clambda fun))

-  (let ((this-env (physenv-info (node-physenv node))))
+  (let ((this-env (physenv-info (node-physenv node)))
+        (current-fp (make-stack-pointer-tn)))

     (multiple-value-bind (temps locs)
     (multiple-value-bind (temps locs)

-        (emit-psetq-moves node block fun (ir2-physenv-old-fp this-env))
+        (emit-psetq-moves node block fun
+                          (ir2-physenv-old-fp this-env) current-fp)
+
+      ;; If we're about to emit a move from CURRENT-FP then we need to
+      ;; initialize it.
+      (when (find current-fp temps)
+        (vop current-fp node block current-fp))

 
       (mapc (lambda (temp loc)
               (emit-move node block temp loc))
 
       (mapc (lambda (temp loc)
               (emit-move node block temp loc))

@@ -1135,7 +1204,8 @@
           (when (leaf-refs arg)
             (let ((pass (standard-arg-location n))
                   (home (leaf-info arg)))
           (when (leaf-refs arg)
             (let ((pass (standard-arg-location n))
                   (home (leaf-info arg)))

-              (if (lambda-var-indirect arg)
+              (if (and (lambda-var-indirect arg)
+                       (lambda-var-explicit-value-cell arg))

                   (emit-make-value-cell node block pass home)
                   (emit-move node block pass home))))
           (incf n))))
                   (emit-make-value-cell node block pass home)
                   (emit-move node block pass home))))
           (incf n))))

@@ -1242,15 +1312,21 @@
   (values))
 \f
 ;;;; debugger hooks
   (values))
 \f
 ;;;; debugger hooks

+;;;;
+;;;; These are used by the debugger to find the top function on the
+;;;; stack. They return the OLD-FP and RETURN-PC for the current
+;;;; function as multiple values.

 
 

-;;; This is used by the debugger to find the top function on the
-;;; stack. It returns the OLD-FP and RETURN-PC for the current
-;;; function as multiple values.
-(defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block)
+(defoptimizer (%caller-frame ir2-convert) (() node block)

   (let ((ir2-physenv (physenv-info (node-physenv node))))
     (move-lvar-result node block
   (let ((ir2-physenv (physenv-info (node-physenv node))))
     (move-lvar-result node block

-                      (list (ir2-physenv-old-fp ir2-physenv)
-                            (ir2-physenv-return-pc ir2-physenv))
+                      (list (ir2-physenv-old-fp ir2-physenv))
+                      (node-lvar node))))
+
+(defoptimizer (%caller-pc ir2-convert) (() node block)
+  (let ((ir2-physenv (physenv-info (node-physenv node))))
+    (move-lvar-result node block
+                      (list (ir2-physenv-return-pc ir2-physenv))

                       (node-lvar node))))
 \f
 ;;;; multiple values
                       (node-lvar node))))
 \f
 ;;;; multiple values

@@ -1268,7 +1344,8 @@
     (mapc (lambda (src var)
             (when (leaf-refs var)
               (let ((dest (leaf-info var)))
     (mapc (lambda (src var)
             (when (leaf-refs var)
               (let ((dest (leaf-info var)))

-                (if (lambda-var-indirect var)
+                (if (and (lambda-var-indirect var)
+                         (lambda-var-explicit-value-cell var))

                     (emit-make-value-cell node block src dest)
                     (emit-move node block src dest)))))
           (lvar-tns node block lvar
                     (emit-make-value-cell node block src dest)
                     (emit-move node block src dest)))))
           (lvar-tns node block lvar

@@ -1435,16 +1512,17 @@
                             (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.
                             (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")
+                              (about-to-modify-symbol-value var 'progv)

                               (%primitive bind unbound-marker var))))
                         (,bind (vars vals)
                               (%primitive bind unbound-marker var))))
                         (,bind (vars vals)

-                          (declare (optimize (speed 2) (debug 0)))
+                          (declare (optimize (speed 2) (debug 0)
+                                             (insert-debug-catch 0)))

                           (cond ((null vars))
                                 ((null vals) (,unbind vars))
                                 (t
                                  (let ((val (car vals))
                                        (var (car vars)))
                           (cond ((null vars))
                                 ((null vals) (,unbind vars))
                                 (t
                                  (let ((val (car vals))
                                        (var (car vars)))

-                                   (about-to-modify-symbol-value var "bind ~S" val)
+                                   (about-to-modify-symbol-value var 'progv val t)

                                    (%primitive bind val var))
                                  (,bind (cdr vars) (cdr vals))))))
                  (,bind ,vars ,vals))
                                    (%primitive bind val var))
                                  (,bind (cdr vars) (cdr vals))))))
                  (,bind ,vars ,vals))