X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=cf611d432588a580149a170ec8502f5a80eefca0;hb=e73a30c901ab234291aefc9f1e73507650628892;hp=ad400313462df723e8197873def6e7c024d2dc64;hpb=6053e7f804b430144bb09e2d107ad4ab3fb97db4;p=sbcl.git

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index ad40031..cf611d4 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -559,6 +559,7 @@
 (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
@@ -857,6 +858,7 @@
 ;;;      lvar LOC.
 ;;;   -- We don't know what it is.
 (defun fun-lvar-tn (node block lvar)
+  (declare (ignore node block))
   (declare (type lvar lvar))
   (let ((2lvar (lvar-info lvar)))
     (if (eq (ir2-lvar-kind 2lvar) :delayed)
@@ -1208,16 +1210,16 @@
 (defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() 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))
-			      (node-lvar node))))
+                      (list (ir2-physenv-old-fp ir2-physenv)
+                            (ir2-physenv-return-pc ir2-physenv))
+                      (node-lvar node))))
 
 ;;;; multiple values
 
 ;;; This is almost identical to IR2-CONVERT-LET. Since LTN annotates
-;;; the lvarinuation for the correct number of values (with the lvar
-;;; user responsible for defaulting), we can just pick them up from
-;;; the lvar.
+;;; the lvar for the correct number of values (with the lvar user
+;;; responsible for defaulting), we can just pick them up from the
+;;; lvar.
 (defun ir2-convert-mv-bind (node block)
   (declare (type mv-combination node) (type ir2-block block))
   (let* ((lvar (first (basic-combination-args node)))
@@ -1280,6 +1282,27 @@
     (vop reset-stack-pointer node block
 	 (first (ir2-lvar-locs 2lvar)))))
 
+(defoptimizer (%nip-values ir2-convert) ((last-nipped last-preserved 
+						      &rest moved)
+                                         node block)
+  (let (;; pointer immediately after the nipped block
+	(2after (lvar-info (lvar-value last-nipped)))
+	;; pointer to the first nipped word
+        (2first (lvar-info (lvar-value last-preserved)))
+
+        (moved-tns (loop for lvar-ref in moved
+                         for lvar = (lvar-value lvar-ref)
+                         for 2lvar = (lvar-info lvar)
+                         ;when 2lvar
+                         collect (first (ir2-lvar-locs 2lvar)))))
+    (aver (eq (ir2-lvar-kind 2after) :unknown))
+    (aver (eq (ir2-lvar-kind 2first) :unknown))
+    (vop* %%nip-values node block
+	 ((first (ir2-lvar-locs 2after))
+          (first (ir2-lvar-locs 2first))
+          (reference-tn-list moved-tns nil))
+         ((reference-tn-list moved-tns t)))))
+
 ;;; Deliver the values TNs to LVAR using MOVE-LVAR-RESULT.
 (defoptimizer (values ir2-convert) ((&rest values) node block)
   (let ((tns (mapcar (lambda (x)
@@ -1331,6 +1354,9 @@
 (defoptimizer (%special-unbind ir2-convert) ((var) node block)
   (vop unbind node block))
 
+(defoptimizer (%dynamic-extent-start ir2-convert) (() node block) node block)
+(defoptimizer (%dynamic-extent-end ir2-convert) (() node block) node block)
+
 ;;; ### It's not clear that this really belongs in this file, or
 ;;; should really be done this way, but this is the least violation of
 ;;; abstraction in the current setup. We don't want to wire
@@ -1341,25 +1367,25 @@
    start next result
    (with-unique-names (bind unbind)
      (once-only ((n-save-bs '(%primitive current-binding-pointer)))
-                `(unwind-protect
-                      (progn
-                        (labels ((,unbind (vars)
-                                   (declare (optimize (speed 2) (debug 0)))
-                                   (dolist (var vars)
-                                     (%primitive bind nil var)
-                                     (makunbound var)))
-                                 (,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))))))
-                          (,bind ,vars ,vals))
-                        nil
-                        ,@body)
-                   (%primitive unbind-to-here ,n-save-bs))))))
+       `(unwind-protect
+             (progn
+               (labels ((,unbind (vars)
+                          (declare (optimize (speed 2) (debug 0)))
+                          (dolist (var vars)
+                            (%primitive bind nil var)
+                            (makunbound var)))
+                        (,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))))))
+                 (,bind ,vars ,vals))
+               nil
+               ,@body)
+          (%primitive unbind-to-here ,n-save-bs))))))
 
 ;;;; non-local exit
 
@@ -1636,13 +1662,14 @@
                (ir2-convert-ref node 2block)))))
 	(combination
 	 (let ((kind (basic-combination-kind node)))
-	   (case kind
+	   (ecase kind
 	     (:local
 	      (ir2-convert-local-call node 2block))
 	     (:full
 	      (ir2-convert-full-call node 2block))
-	     (t
-	      (let ((fun (fun-info-ir2-convert kind)))
+	     (:known
+	      (let* ((info (basic-combination-fun-info node))
+		     (fun (fun-info-ir2-convert info)))
 		(cond (fun
 		       (funcall fun node 2block))
 		      ((eq (basic-combination-info node) :full)