Improve knownfun declarations.

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

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index ca486d1..026dd5f 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -56,11 +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
-         ;; FIXME: See bug 419
-         (and leaf (eq :truly (leaf-dynamic-extent leaf)))
-         res)))
+  (vop make-value-cell node block value nil res))

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

@@ -95,29 +91,41 @@
 
 ;;; If LEAF already has a constant TN, return that, otherwise make a
 ;;; TN for it.
 
 ;;; If LEAF already has a constant TN, return that, otherwise make a
 ;;; TN for it.

-(defun constant-tn (leaf)
+(defun constant-tn (leaf boxedp)

   (declare (type constant leaf))
   (declare (type constant leaf))

-  (or (leaf-info leaf)
-      (setf (leaf-info leaf)
-            (make-constant-tn leaf))))
+  ;; When convenient we can have both a boxed and unboxed TN for
+  ;; constant.
+  (if boxedp
+      (or (constant-boxed-tn leaf)
+          (setf (constant-boxed-tn leaf) (make-constant-tn leaf t)))
+      (or (leaf-info leaf)
+          (setf (leaf-info leaf) (make-constant-tn leaf nil)))))

 
 ;;; Return a TN that represents the value of LEAF, or NIL if LEAF
 ;;; isn't directly represented by a TN. ENV is the environment that
 ;;; the reference is done in.
 
 ;;; Return a TN that represents the value of LEAF, or NIL if LEAF
 ;;; isn't directly represented by a TN. ENV is the environment that
 ;;; the reference is done in.

-(defun leaf-tn (leaf env)
+(defun leaf-tn (leaf env boxedp)

   (declare (type leaf leaf) (type physenv env))
   (typecase leaf
     (lambda-var
      (unless (lambda-var-indirect leaf)
        (find-in-physenv leaf env)))
   (declare (type leaf leaf) (type physenv env))
   (typecase leaf
     (lambda-var
      (unless (lambda-var-indirect leaf)
        (find-in-physenv leaf env)))

-    (constant (constant-tn leaf))
+    (constant (constant-tn leaf boxedp))

     (t nil)))
 
 ;;; This is used to conveniently get a handle on a constant TN during
 ;;; IR2 conversion. It returns a constant TN representing the Lisp
 ;;; object VALUE.
 (defun emit-constant (value)
     (t nil)))
 
 ;;; This is used to conveniently get a handle on a constant TN during
 ;;; IR2 conversion. It returns a constant TN representing the Lisp
 ;;; object VALUE.
 (defun emit-constant (value)

-  (constant-tn (find-constant value)))
+  (constant-tn (find-constant value) t))
+
+(defun boxed-ref-p (ref)
+  (let ((dest (lvar-dest (ref-lvar ref))))
+    (cond ((and (basic-combination-p dest) (eq :full (basic-combination-kind dest)))
+           t)
+          ;; Other cases?
+          (t
+           nil))))

 
 ;;; Convert a REF node. The reference must not be delayed.
 (defun ir2-convert-ref (node block)
 
 ;;; Convert a REF node. The reference must not be delayed.
 (defun ir2-convert-ref (node block)

@@ -129,32 +137,60 @@
          (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)))))
+           (let ((reffer (third (primitive-type-indirect-cell-type
+                                 (primitive-type (leaf-type leaf))))))
+             (if reffer
+                 (funcall reffer node block tn (leaf-info leaf) res)
+                 (vop ancestor-frame-ref node block tn (leaf-info leaf) res))))
+          (t (emit-move node block tn res)))))

       (constant
       (constant

-       (emit-move node block (constant-tn leaf) res))
+       (emit-move node block (constant-tn leaf (boxed-ref-p node)) res))

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

-       (let ((unsafe (policy node (zerop safety)))
-             (name (leaf-source-name leaf)))
-         (ecase (global-var-kind leaf)
-           ((:special :global)
-            (aver (symbolp name))
-            (let ((name-tn (emit-constant name)))
-              (if unsafe
-                  (vop fast-symbol-value node block name-tn res)
-                  (vop symbol-value node block name-tn res))))
-           (:global-function
-            (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
-              (if unsafe
-                  (vop fdefn-fun node block fdefn-tn res)
-                  (vop safe-fdefn-fun node block fdefn-tn res))))))))
+       (ir2-convert-global-var node block leaf res)))

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

+(defun ir2-convert-global-var (node block leaf res)
+  (let ((unsafe (policy node (zerop safety)))
+        (name (leaf-source-name leaf)))
+    (ecase (global-var-kind leaf)
+      ((:special :unknown)
+       (aver (symbolp name))
+       (let ((name-tn (emit-constant name)))
+         (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))))
+      (: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
+       (cond #-sb-xc-host
+             ((and (info :function :definition name)
+                   (info :function :info name))
+              ;; Known functions can be saved without going through fdefns,
+              ;; except during cross-compilation
+              (emit-move node block (make-load-time-constant-tn :known-fun name)
+                         res))
+             (t
+              (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
+                (if unsafe
+                    (vop fdefn-fun node block fdefn-tn res)
+                    (vop safe-fdefn-fun node block fdefn-tn res)))))))))
+

 ;;; some sanity checks for a CLAMBDA passed to IR2-CONVERT-CLOSURE
 (defun assertions-on-ir2-converted-clambda (clambda)
   ;; This assertion was sort of an experiment. It would be nice and
 ;;; some sanity checks for a CLAMBDA passed to IR2-CONVERT-CLOSURE
 (defun assertions-on-ir2-converted-clambda (clambda)
   ;; This assertion was sort of an experiment. It would be nice and

@@ -209,27 +245,56 @@
            (type ir2-block ir2-block)
            (type functional functional)
            (type tn res))
            (type ir2-block ir2-block)
            (type functional functional)
            (type tn res))

-  (aver (not (eql (functional-kind functional) :deleted)))
-  (unless (leaf-info functional)
-    (setf (leaf-info functional)
-          (make-entry-info :name (functional-debug-name functional))))
-  (let ((closure (etypecase functional
-                   (clambda
-                    (assertions-on-ir2-converted-clambda functional)
-                    (physenv-closure (get-lambda-physenv functional)))
-                   (functional
-                    (aver (eq (functional-kind functional) :toplevel-xep))
-                    nil))))
-
-    (cond (closure
-           (let* ((physenv (node-physenv ref))
-                  (tn (find-in-physenv functional physenv)))
-             (emit-move ref ir2-block tn res)))
-          (t
-           (let ((entry (make-load-time-constant-tn :entry functional)))
-             (emit-move ref ir2-block entry res)))))
+  (flet ((prepare ()
+           (aver (not (eql (functional-kind functional) :deleted)))
+           (unless (leaf-info functional)
+             (setf (leaf-info functional)
+                   (make-entry-info :name
+                                    (functional-debug-name functional))))))
+    (let ((closure (etypecase functional
+                     (clambda
+                      (assertions-on-ir2-converted-clambda functional)
+                      (physenv-closure (get-lambda-physenv functional)))
+                     (functional
+                      (aver (eq (functional-kind functional) :toplevel-xep))
+                      nil)))
+          global-var)
+      (cond (closure
+             (prepare)
+             (let* ((physenv (node-physenv ref))
+                    (tn (find-in-physenv functional physenv)))
+               (emit-move ref ir2-block tn res)))
+            ;; we're about to emit a reference to a "closure" that's actually
+            ;; an inlinable global function.
+            ((and (global-var-p (setf global-var
+                                      (functional-inline-expanded functional)))
+                  (eq :global-function (global-var-kind global-var)))
+             (ir2-convert-global-var ref ir2-block global-var res))
+            (t
+             ;; if we're here, we should have either a toplevel-xep (some
+             ;; global scope function in a different component) or an external
+             ;; reference to the "closure"'s body.
+             (prepare)
+             (aver (memq (functional-kind functional) '(:external :toplevel-xep)))
+             (let ((entry (make-load-time-constant-tn :entry functional)))
+               (emit-move ref ir2-block entry res))))))

   (values))
 
   (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)

@@ -246,7 +311,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)

@@ -267,11 +336,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))))

@@ -293,15 +367,29 @@
     (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)))))
+             (let ((setter (fourth (primitive-type-indirect-cell-type
+                                    (primitive-type (leaf-type leaf))))))
+             (if setter
+                 (funcall setter node block tn val (leaf-info 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)))

@@ -327,7 +415,7 @@
           (ecase (ir2-lvar-kind 2lvar)
             (:delayed
              (let ((ref (lvar-uses lvar)))
           (ecase (ir2-lvar-kind 2lvar)
             (:delayed
              (let ((ref (lvar-uses lvar)))

-               (leaf-tn (ref-leaf ref) (node-physenv ref))))
+               (leaf-tn (ref-leaf ref) (node-physenv ref) (boxed-ref-p ref))))

             (:fixed
              (aver (= (length (ir2-lvar-locs 2lvar)) 1))
              (first (ir2-lvar-locs 2lvar)))))
             (:fixed
              (aver (= (length (ir2-lvar-locs 2lvar)) 1))
              (first (ir2-lvar-locs 2lvar)))))

@@ -371,7 +459,7 @@
 ;;; an lvar.
 ;;;
 ;;; If the lvar isn't annotated (meaning the values are discarded) or
 ;;; an lvar.
 ;;;
 ;;; If the lvar isn't annotated (meaning the values are discarded) or

-;;; is unknown-values, the then we make temporaries for each supplied
+;;; is unknown-values, then we make temporaries for each supplied

 ;;; value, providing a place to compute the result in until we decide
 ;;; what to do with it (if anything.)
 ;;;
 ;;; value, providing a place to compute the result in until we decide
 ;;; what to do with it (if anything.)
 ;;;

@@ -420,7 +508,7 @@
 
 ;;; Return a list of TNs wired to the standard value passing
 ;;; conventions that can be used to receive values according to the
 
 ;;; Return a list of TNs wired to the standard value passing
 ;;; conventions that can be used to receive values according to the

-;;; unknown-values convention. This is used with together
+;;; unknown-values convention. This is used together with

 ;;; MOVE-LVAR-RESULT for delivering unknown values to a fixed values
 ;;; lvar.
 ;;;
 ;;; MOVE-LVAR-RESULT for delivering unknown values to a fixed values
 ;;; lvar.
 ;;;

@@ -478,7 +566,7 @@
 ;;; If necessary, emit coercion code needed to deliver the RESULTS to
 ;;; the specified lvar. NODE and BLOCK provide context for emitting
 ;;; code. Although usually obtained from STANDARD-RESULT-TNs or
 ;;; If necessary, emit coercion code needed to deliver the RESULTS to
 ;;; the specified lvar. NODE and BLOCK provide context for emitting
 ;;; code. Although usually obtained from STANDARD-RESULT-TNs or

-;;; LVAR-RESULT-TNs, RESULTS my be a list of any type or
+;;; LVAR-RESULT-TNs, RESULTS may be a list of any type or

 ;;; number of TNs.
 ;;;
 ;;; If the lvar is fixed values, then move the results into the lvar
 ;;; number of TNs.
 ;;;
 ;;; If the lvar is fixed values, then move the results into the lvar

@@ -571,18 +659,32 @@
   (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))
+           (if (drop-thru-p if alternative)
+               (register-drop-thru 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))
-           (unless (drop-thru-p if alternative)
-             (vop branch node block (block-label alternative)))))))
+           (emit-template node block template args nil info-args)
+           (vop branch-if node block (block-label consequent) flags not-p)
+           (if (drop-thru-p if alternative)
+               (register-drop-thru alternative)
+               (vop branch node block (block-label alternative)))))))

 
 ;;; Convert an IF that isn't the DEST of a conditional template.
 (defun ir2-convert-if (node block)
 
 ;;; Convert an IF that isn't the DEST of a conditional template.
 (defun ir2-convert-if (node block)

@@ -602,7 +704,7 @@
   (let* ((type (node-derived-type call))
          (types
           (mapcar #'primitive-type
   (let* ((type (node-derived-type call))
          (types
           (mapcar #'primitive-type

-                  (if (values-type-p type)
+                  (if (args-type-p type)

                       (append (args-type-required type)
                               (args-type-optional type))
                       (list type))))
                       (append (args-type-required type)
                               (args-type-optional type))
                       (list type))))

@@ -648,7 +750,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))

@@ -680,7 +782,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

@@ -709,7 +811,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))

@@ -727,9 +830,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)))

@@ -741,7 +850,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)

@@ -758,7 +868,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))))

@@ -771,9 +881,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))

@@ -877,7 +994,7 @@
           ((node-tail-p node)
            (ir2-convert-tail-local-call node block fun))
           (t
           ((node-tail-p node)
            (ir2-convert-tail-local-call node block fun))
           (t

-           (let ((start (block-label (lambda-block fun)))
+           (let ((start (block-trampoline (lambda-block fun)))

                  (returns (tail-set-info (lambda-tail-set fun)))
                  (lvar (node-lvar node)))
              (ecase (if returns
                  (returns (tail-set-info (lambda-tail-set fun)))
                  (lvar (node-lvar node)))
              (ecase (if returns

@@ -1134,7 +1251,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))))

@@ -1179,7 +1297,10 @@
 
     (let ((lab (gen-label)))
       (setf (ir2-physenv-environment-start env) lab)
 
     (let ((lab (gen-label)))
       (setf (ir2-physenv-environment-start env) lab)

-      (vop note-environment-start node block lab)))
+      (vop note-environment-start node block lab)
+      #!+sb-safepoint
+      (unless (policy fun (>= inhibit-safepoints 2))
+        (vop sb!vm::insert-safepoint node block))))

 
   (values))
 \f
 
   (values))
 \f

@@ -1241,15 +1362,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.
+
+(defoptimizer (%caller-frame ir2-convert) (() node block)
+  (let ((ir2-physenv (physenv-info (node-physenv node))))
+    (move-lvar-result node block
+                      (list (ir2-physenv-old-fp ir2-physenv))
+                      (node-lvar node))))

 
 

-;;; 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-pc 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-return-pc ir2-physenv))

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

@@ -1267,7 +1394,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

@@ -1394,7 +1522,17 @@
   (binding* ((lvar (node-lvar node) :exit-if-null)
              (2lvar (lvar-info lvar)))
     (ecase (ir2-lvar-kind 2lvar)
   (binding* ((lvar (node-lvar node) :exit-if-null)
              (2lvar (lvar-info lvar)))
     (ecase (ir2-lvar-kind 2lvar)

-      (:fixed (ir2-convert-full-call node block))
+      (:fixed
+       ;; KLUDGE: this is very much unsafe, and can leak random stack values.
+       ;; OTOH, I think the :FIXED case can only happen with (safety 0) in the
+       ;; first place.
+       ;;  -PK
+       (loop for loc in (ir2-lvar-locs 2lvar)
+             for idx upfrom 0
+             do (vop sb!vm::more-arg node block
+                     (lvar-tn node block context)
+                     (emit-constant idx)
+                     loc)))

       (:unknown
        (let ((locs (ir2-lvar-locs 2lvar)))
          (vop* %more-arg-values node block
       (:unknown
        (let ((locs (ir2-lvar-locs 2lvar)))
          (vop* %more-arg-values node block

@@ -1429,21 +1567,21 @@
              (progn
                (labels ((,unbind (vars)
                           (declare (optimize (speed 2) (debug 0)))
              (progn
                (labels ((,unbind (vars)
                           (declare (optimize (speed 2) (debug 0)))

-                          (let ((unbound-marker (%primitive make-other-immediate-type
-                                                            0 sb!vm:unbound-marker-widetag)))
+                          (let ((unbound-marker (%primitive make-unbound-marker)))

                             (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))

@@ -1654,6 +1792,48 @@
   (def list*))
 
 \f
   (def list*))
 
 \f

+(defoptimizer (mask-signed-field ir2-convert) ((width x) node block)
+  (block nil
+    (when (constant-lvar-p width)
+      (case (lvar-value width)
+        (#.(- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
+         (when (or (csubtypep (lvar-type x)
+                              (specifier-type 'word))
+                   (csubtypep (lvar-type x)
+                              (specifier-type 'sb!vm:signed-word)))
+           (let* ((lvar (node-lvar node))
+                  (temp (make-normal-tn
+                         (if (csubtypep (lvar-type x)
+                                        (specifier-type 'word))
+                             (primitive-type-of most-positive-word)
+                             (primitive-type-of
+                              (- (ash most-positive-word -1))))))
+                  (results (lvar-result-tns
+                            lvar
+                            (list (primitive-type-or-lose 'fixnum)))))
+             (emit-move node block (lvar-tn node block x) temp)
+             (vop sb!vm::move-from-word/fixnum node block
+                  temp (first results))
+             (move-lvar-result node block results lvar)
+             (return))))
+        (#.sb!vm:n-word-bits
+         (when (csubtypep (lvar-type x) (specifier-type 'word))
+           (let* ((lvar (node-lvar node))
+                  (temp (make-normal-tn
+                         (primitive-type-of most-positive-word)))
+                  (results (lvar-result-tns
+                            lvar
+                            (list (primitive-type
+                                   (specifier-type 'sb!vm:signed-word))))))
+             (emit-move node block (lvar-tn node block x) temp)
+             (vop sb!vm::word-move node block
+                  temp (first results))
+             (move-lvar-result node block results lvar)
+             (return))))))
+    (if (template-p (basic-combination-info node))
+        (ir2-convert-template node block)
+        (ir2-convert-full-call node block))))
+\f

 ;;; Convert the code in a component into VOPs.
 (defun ir2-convert (component)
   (declare (type component component))
 ;;; Convert the code in a component into VOPs.
 (defun ir2-convert (component)
   (declare (type component component))

@@ -1694,15 +1874,35 @@
                        2block
                        #!+sb-dyncount *dynamic-counts-tn* #!-sb-dyncount nil
                        num))))
                        2block
                        #!+sb-dyncount *dynamic-counts-tn* #!-sb-dyncount nil
                        num))))

+              #!+sb-safepoint
+              (let ((first-node (block-start-node block)))
+                (unless (or (and (bind-p first-node)
+                                 (xep-p (bind-lambda first-node)))
+                            (and (valued-node-p first-node)
+                                 (node-lvar first-node)
+                                 (eq (lvar-fun-name
+                                      (node-lvar first-node))
+                                     '%nlx-entry)))
+                  (when (and (rest (block-pred block))
+                             (block-loop block)
+                             (member (loop-kind (block-loop block))
+                                     '(:natural :strange))
+                             (eq block (loop-head (block-loop block)))
+                             (policy first-node (< inhibit-safepoints 2)))
+                    (vop sb!vm::insert-safepoint first-node 2block))))

             (ir2-convert-block block)
             (incf num))))))
   (values))
 
 ;;; If necessary, emit a terminal unconditional branch to go to the
 ;;; successor block. If the successor is the component tail, then
             (ir2-convert-block block)
             (incf num))))))
   (values))
 
 ;;; If necessary, emit a terminal unconditional branch to go to the
 ;;; successor block. If the successor is the component tail, then

-;;; there isn't really any successor, but if the end is an unknown,
-;;; non-tail call, then we emit an error trap just in case the
-;;; function really does return.
+;;; there isn't really any successor, but if the end is a non-tail
+;;; call to a function that's not *known* to never return, then we
+;;; emit an error trap just in case the function really does return.
+;;;
+;;; Trapping after known calls makes it easier to understand type
+;;; derivation bugs at runtime: they show up as nil-fun-returned-error,
+;;; rather than the execution of arbitrary code or error traps.

 (defun finish-ir2-block (block)
   (declare (type cblock block))
   (let* ((2block (block-info block))
 (defun finish-ir2-block (block)
   (declare (type cblock block))
   (let* ((2block (block-info block))

@@ -1713,15 +1913,20 @@
       (let ((target (first succ)))
         (cond ((eq target (component-tail (block-component block)))
                (when (and (basic-combination-p last)
       (let ((target (first succ)))
         (cond ((eq target (component-tail (block-component block)))
                (when (and (basic-combination-p last)

-                          (eq (basic-combination-kind last) :full))
+                          (or (eq (basic-combination-kind last) :full)
+                              (and (eq (basic-combination-kind last) :known)
+                                   (eq (basic-combination-info last) :full))))

                  (let* ((fun (basic-combination-fun last))
                         (use (lvar-uses fun))
                         (name (and (ref-p use)
                                    (leaf-has-source-name-p (ref-leaf use))
                  (let* ((fun (basic-combination-fun last))
                         (use (lvar-uses fun))
                         (name (and (ref-p use)
                                    (leaf-has-source-name-p (ref-leaf use))

-                                   (leaf-source-name (ref-leaf use)))))
+                                   (leaf-source-name (ref-leaf use))))
+                        (ftype (and (info :function :info name) ; only use the FTYPE if
+                                    (info :function :type name)))) ; NAME was DEFKNOWN

                    (unless (or (node-tail-p last)
                    (unless (or (node-tail-p last)

-                               (info :function :info name)
-                               (policy last (zerop safety)))
+                               (policy last (zerop safety))
+                               (and (fun-type-p ftype)
+                                    (eq *empty-type* (fun-type-returns ftype))))

                      (vop nil-fun-returned-error last 2block
                           (if name
                               (emit-constant name)
                      (vop nil-fun-returned-error last 2block
                           (if name
                               (emit-constant name)

@@ -1730,7 +1935,9 @@
                                 (aver (not named))
                                 tn)))))))
               ((not (eq (ir2-block-next 2block) (block-info target)))
                                 (aver (not named))
                                 tn)))))))
               ((not (eq (ir2-block-next 2block) (block-info target)))

-               (vop branch last 2block (block-label target)))))))
+               (vop branch last 2block (block-label target)))
+              (t
+               (register-drop-thru target))))))

 
   (values))
 
 
   (values))