X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fbyte-comp.lisp;h=d23f8d71efcdfc502fba56483576f30c788c464c;hb=dfa55a883f94470267b626dae77ce7e7dfac3df6;hp=25b72f1c21bc284608781aa6816f0c38adfa9c9b;hpb=a8f2656f635d81ec326303f47e0612fb1f35fd91;p=sbcl.git

diff --git a/src/compiler/byte-comp.lisp b/src/compiler/byte-comp.lisp
index 25b72f1..d23f8d7 100644
--- a/src/compiler/byte-comp.lisp
+++ b/src/compiler/byte-comp.lisp
@@ -13,9 +13,10 @@
 (in-package "SB!C")
 
 ;;;; the fasl file format that we use
-(defconstant byte-fasl-file-version 2)
+(defconstant byte-fasl-file-version 3)
 ;;; 1 = before about sbcl-0.6.9.8
 ;;; 2 = merged package SB-CONDITIONS into SB-KERNEL around sbcl-0.6.9.8
+;;; 3 = deleted obsolete CONS-UNIQUE-TAG bytecode in sbcl-0.6.11.8
 
 ;;; ### remaining work:
 ;;;
@@ -77,7 +78,7 @@
        (declare (type sb!assem:segment segment)
 		(ignore posn))
        (let ((target (sb!assem:label-position label)))
-	 (assert (<= 0 target (1- (ash 1 24))))
+	 (aver (<= 0 target (1- (ash 1 24))))
 	 (output-byte segment (ldb (byte 8 16) target))
 	 (output-byte segment (ldb (byte 8 8) target))
 	 (output-byte segment (ldb (byte 8 0) target))))))
@@ -115,7 +116,7 @@
        (declare (type sb!assem:segment segment)
 		(ignore posn))
        (let ((target (sb!assem:label-position label)))
-	 (assert (<= 0 target (1- (ash 1 24))))
+	 (aver (<= 0 target (1- (ash 1 24))))
 	 (output-byte segment kind)
 	 (output-byte segment (ldb (byte 8 16) target))
 	 (output-byte segment (ldb (byte 8 8) target))
@@ -193,7 +194,7 @@
 ;;; number of bits devoted to coding byte-inline functions.
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
-  (defstruct inline-function-info
+  (defstruct (inline-function-info (:copier nil))
     ;; the name of the function that we convert into calls to this
     (function (required-argument) :type symbol)
     ;; the name of the function that the interpreter should call to
@@ -222,7 +223,6 @@
 	       (setf-symbol-value (t symbol) (values))
 	       (%byte-special-bind (t symbol) (values))
 	       (%byte-special-unbind () (values))
-	       (cons-unique-tag () t)   ; obsolete...
 	       (%negate (fixnum) fixnum)
 	       (< (fixnum fixnum) t)
 	       (> (fixnum fixnum) t)
@@ -269,10 +269,10 @@
 
 ;;;; annotations hung off the IR1 while compiling
 
-(defstruct byte-component-info
+(defstruct (byte-component-info (:copier nil))
   (constants (make-array 10 :adjustable t :fill-pointer 0)))
 
-(defstruct byte-lambda-info
+(defstruct (byte-lambda-info (:copier nil))
   (label nil :type (or null label))
   (stack-size 0 :type index)
   ;; FIXME: should be INTERESTING-P T :TYPE BOOLEAN
@@ -281,16 +281,17 @@
 (defun block-interesting (block)
   (byte-lambda-info-interesting (lambda-info (block-home-lambda block))))
 
-(defstruct byte-lambda-var-info
+(defstruct (byte-lambda-var-info (:copier nil))
   (argp nil :type (member t nil))
   (offset 0 :type index))
 
-(defstruct byte-nlx-info
+(defstruct (byte-nlx-info (:copier nil))
   (stack-slot nil :type (or null index))
   (label (sb!assem:gen-label) :type sb!assem:label)
   (duplicate nil :type (member t nil)))
 
 (defstruct (byte-block-info
+	    (:copier nil)
 	    (:include block-annotation)
 	    (:constructor make-byte-block-info
 			  (block &key produces produces-sset consumes
@@ -337,7 +338,8 @@
 (defstruct (byte-continuation-info
 	    (:include sset-element)
 	    (:constructor make-byte-continuation-info
-			  (continuation results placeholders)))
+			  (continuation results placeholders))
+	    (:copier nil))
   (continuation (required-argument) :type continuation)
   (results (required-argument)
 	   :type (or (member :fdefinition :eq-test :unknown) index))
@@ -360,7 +362,7 @@
   ;; times on the same continuation. So we can't assert that we
   ;; haven't done it.
   #+nil
-  (assert (null (continuation-info cont)))
+  (aver (null (continuation-info cont)))
   (setf (continuation-info cont)
 	(make-byte-continuation-info cont results placeholders))
   (values))
@@ -465,7 +467,7 @@
 	      (if (continuation-function-name fun) :fdefinition 1))))
       (cond ((mv-combination-p call)
 	     (cond ((eq name '%throw)
-		    (assert (= (length args) 2))
+		    (aver (= (length args) 2))
 		    (annotate-continuation (first args) 1)
 		    (annotate-continuation (second args) :unknown)
 		    (setf (node-tail-p call) nil)
@@ -486,7 +488,7 @@
 		  (let ((leaf (ref-leaf (continuation-use fun))))
 		    (and (slot-accessor-p leaf)
 			 (or (policy call (zerop safety))
-			     (not (find 't args
+			     (not (find t args
 					:key #'continuation-type-check)))
 			 (if (consp name)
 			     (not (continuation-dest (node-cont call)))
@@ -608,7 +610,7 @@
 	     (consume (cont)
 	       (cond ((not (or (eq cont :nlx-entry) (interesting cont))))
 		     (stack
-		      (assert (eq (car stack) cont))
+		      (aver (eq (car stack) cont))
 		      (pop stack))
 		     (t
 		      (adjoin-cont cont total-consumes)
@@ -703,10 +705,10 @@
   (let ((new-stack stack))
     (dolist (cont stuff)
       (cond ((eq cont :nlx-entry)
-	     (assert (find :nlx-entry new-stack))
+	     (aver (find :nlx-entry new-stack))
 	     (setq new-stack (remove :nlx-entry new-stack :count 1)))
 	    (t
-	     (assert (eq (car new-stack) cont))
+	     (aver (eq (car new-stack) cont))
 	     (pop new-stack))))
     new-stack))
 
@@ -754,7 +756,7 @@
 		   (incf fixed results))))))
 	  (flush-fixed)))
       (when (pops)
-	(assert pred)
+	(aver pred)
 	(let ((cleanup-block
 	       (insert-cleanup-code pred block
 				    (continuation-next (block-start block))
@@ -777,7 +779,7 @@
 	  (t
 	   ;; We have already processed the successors of this block. Just
 	   ;; make sure we thing the stack is the same now as before.
-	   (assert (equal (byte-block-info-start-stack info) stack)))))
+	   (aver (equal (byte-block-info-start-stack info) stack)))))
   (values))
 
 ;;; Do lifetime flow analysis on values pushed on the stack, then call
@@ -1001,8 +1003,8 @@
     (cond ((not (eq (lambda-environment (lambda-var-home var)) env))
 	   ;; This is not this guy's home environment. So we need to
 	   ;; get it the value cell out of the closure, and fill it in.
-	   (assert indirect)
-	   (assert (not make-value-cells))
+	   (aver indirect)
+	   (aver (not make-value-cells))
 	   (output-byte-with-operand segment byte-push-arg
 				     (closure-position var env))
 	   (output-do-inline-function segment 'value-cell-setf))
@@ -1010,7 +1012,7 @@
 	   (let* ((pushp (and indirect (not make-value-cells)))
 		  (byte-code (if pushp byte-push-local byte-pop-local))
 		  (info (leaf-info var)))
-	     (assert (not (byte-lambda-var-info-argp info)))
+	     (aver (not (byte-lambda-var-info-argp info)))
 	     (when (and indirect make-value-cells)
 	       ;; Replace the stack top with a value cell holding the
 	       ;; stack top.
@@ -1081,7 +1083,7 @@
 	(let ((desired (byte-continuation-info-results info))
 	      (placeholders (byte-continuation-info-placeholders info)))
 	  (unless (zerop placeholders)
-	    (assert (eql desired (1+ placeholders)))
+	    (aver (eql desired (1+ placeholders)))
 	    (setq desired 1))
 
 	  (flet ((do-check ()
@@ -1205,9 +1207,9 @@
 	    (leaf (ref-leaf ref)))
 	(cond
 	 ((eq values :fdefinition)
-	  (assert (and (global-var-p leaf)
-		       (eq (global-var-kind leaf)
-			   :global-function)))
+	  (aver (and (global-var-p leaf)
+		     (eq (global-var-kind leaf)
+			 :global-function)))
 	  (let* ((name (global-var-name leaf))
 		 (found (gethash name *two-arg-functions*)))
 	    (output-push-fdefinition
@@ -1223,10 +1225,14 @@
 	 (t
 	  (etypecase leaf
 	    (constant
-	     (output-push-constant-leaf segment leaf))
+             (cond ((legal-immediate-constant-p leaf)
+                     (output-push-constant-leaf segment leaf))
+                   (t
+                     (output-push-constant segment (leaf-name leaf))
+                     (output-do-inline-function segment 'symbol-value))))
 	    (clambda
-	     (let* ((refered-env (lambda-environment leaf))
-		    (closure (environment-closure refered-env)))
+	     (let* ((referred-env (lambda-environment leaf))
+		    (closure (environment-closure referred-env)))
 	       (if (null closure)
 		   (output-push-load-time-constant segment :entry leaf)
 		   (let ((my-env (node-environment ref)))
@@ -1266,13 +1272,22 @@
       ;; Someone wants the value, so copy it.
       (output-do-xop segment 'dup))
     (etypecase leaf
-      (global-var
+      (global-var        
        (ecase (global-var-kind leaf)
 	 ((:special :global)
 	  (output-push-constant segment (global-var-name leaf))
 	  (output-do-inline-function segment 'setf-symbol-value))))
       (lambda-var
-       (output-set-lambda-var segment leaf (node-environment set))))
+        ;; Note: It's important to test for whether there are any
+        ;; references to the variable before we actually try to set it.
+        ;; (Setting a lexical variable with no refs caused bugs ca. CMU
+        ;; CL 18c, because the compiler deletes such variables.)
+        (cond ((leaf-refs leaf)                
+                (output-set-lambda-var segment leaf (node-environment set)))
+              ;; If no one wants the value, then pop it, else leave it
+              ;; for them.
+              ((eql values 0)
+                (output-byte-with-operand segment byte-pop-n 1)))))
     (unless (eql values 0)
       (checked-canonicalize-values segment cont 1)))
   (values))
@@ -1296,7 +1311,7 @@
 	   (output-set-lambda-var segment var env t))))
       ((nil :optional :cleanup)
        ;; We got us a local call.
-       (assert (not (eq num-args :unknown)))
+       (aver (not (eq num-args :unknown)))
        ;; Push any trailing placeholder args...
        (dolist (x (reverse (basic-combination-args call)))
 	 (when x (return))
@@ -1352,7 +1367,7 @@
     (cond
      (info
       ;; It's an inline function.
-      (assert (not (node-tail-p call)))
+      (aver (not (node-tail-p call)))
       (let* ((type (inline-function-info-type info))
 	     (desired-args (function-type-nargs type))
 	     (supplied-results
@@ -1360,7 +1375,7 @@
 			 (values-types (function-type-returns type))))
 	     (leaf (ref-leaf (continuation-use (basic-combination-fun call)))))
 	(cond ((slot-accessor-p leaf)
-	       (assert (= num-args (1- desired-args)))
+	       (aver (= num-args (1- desired-args)))
 	       (output-push-int segment (dsd-index (slot-accessor-slot leaf))))
 	      (t
 	       (canonicalize-values segment desired-args num-args)))
@@ -1407,10 +1422,10 @@
 		     0))
 	       num-args segment)
       (return))
-    (assert (member (byte-continuation-info-results
-		     (continuation-info
-		      (basic-combination-fun call)))
-		    '(1 :fdefinition)))
+    (aver (member (byte-continuation-info-results
+		   (continuation-info
+		    (basic-combination-fun call)))
+		  '(1 :fdefinition)))
     (generate-byte-code-for-full-call segment call cont num-args))
   (values))
 
@@ -1616,8 +1631,8 @@
   (progn segment) ; ignorable.
   ;; We don't have to do anything, because everything is handled by
   ;; the IF byte-generator.
-  (assert (eq results :eq-test))
-  (assert (eql num-args 2))
+  (aver (eq results :eq-test))
+  (aver (eql num-args 2))
   (values))
 
 (defoptimizer (values byte-compile)
@@ -1627,7 +1642,7 @@
 (defknown %byte-pop-stack (index) (values))
 
 (defoptimizer (%byte-pop-stack byte-annotate) ((count) node)
-  (assert (constant-continuation-p count))
+  (aver (constant-continuation-p count))
   (annotate-continuation count 0)
   (annotate-continuation (basic-combination-fun node) 0)
   (setf (node-tail-p node) nil)
@@ -1635,7 +1650,7 @@
 
 (defoptimizer (%byte-pop-stack byte-compile)
 	      ((count) node results num-args segment)
-  (assert (and (zerop num-args) (zerop results)))
+  (aver (and (zerop num-args) (zerop results)))
   (output-byte-with-operand segment byte-pop-n (continuation-value count)))
 
 (defoptimizer (%special-bind byte-annotate) ((var value) node)
@@ -1647,7 +1662,7 @@
 
 (defoptimizer (%special-bind byte-compile)
 	      ((var value) node results num-args segment)
-  (assert (and (eql num-args 1) (zerop results)))
+  (aver (and (eql num-args 1) (zerop results)))
   (output-push-constant segment (leaf-name (continuation-value var)))
   (output-do-inline-function segment '%byte-special-bind))
 
@@ -1659,7 +1674,7 @@
 
 (defoptimizer (%special-unbind byte-compile)
 	      ((var) node results num-args segment)
-  (assert (and (zerop num-args) (zerop results)))
+  (aver (and (zerop num-args) (zerop results)))
   (output-do-inline-function segment '%byte-special-unbind))
 
 (defoptimizer (%catch byte-annotate) ((nlx-info tag) node)
@@ -1672,18 +1687,18 @@
 (defoptimizer (%catch byte-compile)
 	      ((nlx-info tag) node results num-args segment)
   (progn node) ; ignore
-  (assert (and (= num-args 1) (zerop results)))
+  (aver (and (= num-args 1) (zerop results)))
   (output-do-xop segment 'catch)
   (let ((info (nlx-info-info (continuation-value nlx-info))))
     (output-reference segment (byte-nlx-info-label info))))
 
 (defoptimizer (%cleanup-point byte-compile) (() node results num-args segment)
   (progn node segment) ; ignore
-  (assert (and (zerop num-args) (zerop results))))
+  (aver (and (zerop num-args) (zerop results))))
 
 (defoptimizer (%catch-breakup byte-compile) (() node results num-args segment)
   (progn node) ; ignore
-  (assert (and (zerop num-args) (zerop results)))
+  (aver (and (zerop num-args) (zerop results)))
   (output-do-xop segment 'breakup))
 
 (defoptimizer (%lexical-exit-breakup byte-annotate) ((nlx-info) node)
@@ -1694,7 +1709,7 @@
 
 (defoptimizer (%lexical-exit-breakup byte-compile)
 	      ((nlx-info) node results num-args segment)
-  (assert (and (zerop num-args) (zerop results)))
+  (aver (and (zerop num-args) (zerop results)))
   (let ((nlx-info (continuation-value nlx-info)))
     (when (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
 	    (:block
@@ -1715,7 +1730,7 @@
 (defoptimizer (%nlx-entry byte-compile)
 	      ((nlx-info) node results num-args segment)
   (progn node results) ; ignore
-  (assert (eql num-args 0))
+  (aver (eql num-args 0))
   (let* ((info (continuation-value nlx-info))
 	 (byte-info (nlx-info-info info)))
     (output-label segment (byte-nlx-info-label byte-info))
@@ -1737,7 +1752,7 @@
 
 (defoptimizer (%unwind-protect byte-compile)
 	      ((nlx-info cleanup-fun) node results num-args segment)
-  (assert (and (zerop num-args) (zerop results)))
+  (aver (and (zerop num-args) (zerop results)))
   (output-do-xop segment 'unwind-protect)
   (output-reference segment
 		    (byte-nlx-info-label
@@ -1747,7 +1762,7 @@
 (defoptimizer (%unwind-protect-breakup byte-compile)
 	      (() node results num-args segment)
   (progn node) ; ignore
-  (assert (and (zerop num-args) (zerop results)))
+  (aver (and (zerop num-args) (zerop results)))
   (output-do-xop segment 'breakup))
 
 (defoptimizer (%continue-unwind byte-annotate) ((a b c) node)
@@ -1761,8 +1776,8 @@
 (defoptimizer (%continue-unwind byte-compile)
 	      ((a b c) node results num-args segment)
   (progn node) ; ignore
-  (assert (member results '(0 nil)))
-  (assert (eql num-args 0))
+  (aver (member results '(0 nil)))
+  (aver (eql num-args 0))
   (output-do-xop segment 'breakup))
 
 (defoptimizer (%load-time-value byte-annotate) ((handle) node)
@@ -1774,7 +1789,7 @@
 (defoptimizer (%load-time-value byte-compile)
 	      ((handle) node results num-args segment)
   (progn node) ; ignore
-  (assert (zerop num-args))
+  (aver (zerop num-args))
   (output-push-load-time-constant segment :load-time-value
 				  (continuation-value handle))
   (canonicalize-values segment results 1))
@@ -1783,7 +1798,7 @@
 (defun make-xep-for (lambda)
   (flet ((entry-point-for (entry)
 	   (let ((info (lambda-info entry)))
-	     (assert (byte-lambda-info-interesting info))
+	     (aver (byte-lambda-info-interesting info))
 	     (sb!assem:label-position (byte-lambda-info-label info)))))
     (let ((entry (lambda-entry-function lambda)))
       (etypecase entry
@@ -1795,17 +1810,22 @@
 	     (dolist (var (nthcdr (optional-dispatch-max-args entry)
 				  (optional-dispatch-arglist entry)))
 	       (let ((arg-info (lambda-var-arg-info var)))
-		 (assert arg-info)
+		 (aver arg-info)
 		 (ecase (arg-info-kind arg-info)
 		   (:rest
-		    (assert (not rest-arg-p))
+		    (aver (not rest-arg-p))
 		    (incf num-more)
 		    (setf rest-arg-p t))
 		   (:keyword
+		    ;; FIXME: Since ANSI specifies that &KEY arguments
+		    ;; needn't actually be keywords, :KEY would be a
+		    ;; better label for this behavior than :KEYWORD is,
+		    ;; and (KEY-ARGS) would be a better name for the
+		    ;; accumulator than (KEYWORDS) is.
 		    (let ((s-p (arg-info-supplied-p arg-info))
 			  (default (arg-info-default arg-info)))
 		      (incf num-more (if s-p 2 1))
-		      (keywords (list (arg-info-keyword arg-info)
+		      (keywords (list (arg-info-key arg-info)
 				      (if (constantp default)
 					  (eval default)
 					  nil)