X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=4b3aaf3a2a1fa54cddab8281568b6e8e0badb6be;hb=dfa55a883f94470267b626dae77ce7e7dfac3df6;hp=66d35aab6ae8fde32b7af5ad526b5faaf59fea98;hpb=82e0a78df47685519b12683f495d7ae19e07d3cf;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 66d35aa..4b3aaf3 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -96,14 +96,14 @@
 ;;; has changed.
 (declaim (ftype (function (node continuation) (values)) add-continuation-use))
 (defun add-continuation-use (node cont)
-  (assert (not (node-cont node)))
+  (aver (not (node-cont node)))
   (let ((block (continuation-block cont)))
     (ecase (continuation-kind cont)
       (:deleted)
       (:unused
-       (assert (not block))
+       (aver (not block))
        (let ((block (node-block node)))
-	 (assert block)
+	 (aver block)
 	 (setf (continuation-block cont) block))
        (setf (continuation-kind cont) :inside-block)
        (setf (continuation-use cont) node))
@@ -135,7 +135,7 @@
 ;;; potential optimization opportunities.
 (defun substitute-continuation (new old)
   (declare (type continuation old new))
-  (assert (not (continuation-dest new)))
+  (aver (not (continuation-dest new)))
   (let ((dest (continuation-dest old)))
     (etypecase dest
       ((or ref bind))
@@ -187,7 +187,7 @@
   (declare (type continuation cont))
   (ecase (continuation-kind cont)
     (:unused
-     (assert (not (continuation-block cont)))
+     (aver (not (continuation-block cont)))
      (let* ((head (component-head *current-component*))
 	    (next (block-next head))
 	    (new-block (make-block cont)))
@@ -273,21 +273,21 @@
   #!-sb-fluid (declare (inline node-home-lambda))
   (lambda-environment (node-home-lambda (block-last block))))
 
-;;; Return the Top Level Form number of path, i.e. the ordinal number of
-;;; its orignal source's top-level form in its compilation unit.
+;;; Return the Top Level Form number of path, i.e. the ordinal number
+;;; of its original source's top-level form in its compilation unit.
 (defun source-path-tlf-number (path)
   (declare (list path))
   (car (last path)))
 
-;;; Return the (reversed) list for the path in the orignal source (with the
-;;; TLF number last.)
+;;; Return the (reversed) list for the path in the original source
+;;; (with the Top Level Form number last).
 (defun source-path-original-source (path)
   (declare (list path) (inline member))
   (cddr (member 'original-source-start path :test #'eq)))
 
-;;; Return the Form Number of Path's orignal source inside the Top Level
-;;; Form that contains it. This is determined by the order that we walk the
-;;; subforms of the top level source form.
+;;; Return the Form Number of Path's original source inside the Top
+;;; Level Form that contains it. This is determined by the order that
+;;; we walk the subforms of the top level source form.
 (defun source-path-form-number (path)
   (declare (list path) (inline member))
   (cadr (member 'original-source-start path :test #'eq)))
@@ -323,8 +323,7 @@
 			 options
 			 (lambda (lexenv-lambda default))
 			 (cleanup (lexenv-cleanup default))
-			 (policy (lexenv-policy default))
-			 (interface-policy (lexenv-interface-policy default)))
+			 (policy (lexenv-policy default)))
   (macrolet ((frob (var slot)
 	       `(let ((old (,slot default)))
 		  (if ,var
@@ -336,21 +335,8 @@
      (frob blocks lexenv-blocks)
      (frob tags lexenv-tags)
      (frob type-restrictions lexenv-type-restrictions)
-     lambda cleanup policy interface-policy
+     lambda cleanup policy 
      (frob options lexenv-options))))
-
-;;; Return a POLICY that defaults any unsupplied optimize qualities in
-;;; the INTERFACE-POLICY with the corresponding ones from the POLICY.
-(defun make-interface-policy (lexenv)
-  (declare (type lexenv lexenv))
-  (let ((ipolicy (lexenv-interface-policy lexenv))
-	(policy (lexenv-policy lexenv)))
-    (let ((result policy))
-      (dolist (quality '(speed safety space))
-	(let ((iquality-entry (assoc quality ipolicy)))
-	  (when iquality-entry
-	    (push iquality-entry result))))
-      result)))
 
 ;;;; flow/DFO/component hackery
 
@@ -367,7 +353,7 @@
 (defun %link-blocks (block1 block2)
   (declare (type cblock block1 block2) (inline member))
   (let ((succ1 (block-succ block1)))
-    (assert (not (member block2 succ1 :test #'eq)))
+    (aver (not (member block2 succ1 :test #'eq)))
     (cons block2 succ1)))
 
 ;;; Like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If this leaves a
@@ -383,7 +369,7 @@
 	     (prev succ1 succ))
 	    ((eq (car succ) block2)
 	     (setf (cdr prev) (cdr succ)))
-	  (assert succ))))
+	  (aver succ))))
 
   (let ((new-pred (delq block1 (block-pred block2))))
     (setf (block-pred block2) new-pred)
@@ -444,7 +430,7 @@
   (declare (type cblock block after))
   (let ((next (block-next after))
 	(comp (block-component after)))
-    (assert (not (eq (component-kind comp) :deleted)))
+    (aver (not (eq (component-kind comp) :deleted)))
     (setf (block-component block) comp)
     (setf (block-next after) block)
     (setf (block-prev block) after)
@@ -488,7 +474,7 @@
 	 (last (block-last block))
 	 (last-cont (node-cont last)))
     (unless (eq last node)
-      (assert (and (eq (continuation-kind start) :inside-block)
+      (aver (and (eq (continuation-kind start) :inside-block)
 		   (not (block-delete-p block))))
       (let* ((succ (block-succ block))
 	     (new-block
@@ -571,8 +557,8 @@
 ;;; be called on functions that never had any references, since otherwise
 ;;; DELETE-REF will handle the deletion.
 (defun delete-functional (fun)
-  (assert (and (null (leaf-refs fun))
-	       (not (functional-entry-function fun))))
+  (aver (and (null (leaf-refs fun))
+	     (not (functional-entry-function fun))))
   (etypecase fun
     (optional-dispatch (delete-optional-dispatch fun))
     (clambda (delete-lambda fun)))
@@ -597,7 +583,7 @@
   (declare (type clambda leaf))
   (let ((kind (functional-kind leaf))
 	(bind (lambda-bind leaf)))
-    (assert (not (member kind '(:deleted :optional :top-level))))
+    (aver (not (member kind '(:deleted :optional :top-level))))
     (setf (functional-kind leaf) :deleted)
     (setf (lambda-bind leaf) nil)
     (dolist (let (lambda-lets leaf))
@@ -610,7 +596,7 @@
 	(let* ((bind-block (node-block bind))
 	       (component (block-component bind-block))
 	       (return (lambda-return leaf)))
-	  (assert (null (leaf-refs leaf)))
+	  (aver (null (leaf-refs leaf)))
 	  (unless (leaf-ever-used leaf)
 	    (let ((*compiler-error-context* bind))
 	      (compiler-note "deleting unused function~:[.~;~:*~%  ~S~]"
@@ -655,12 +641,12 @@
   (declare (type optional-dispatch leaf))
   (let ((entry (functional-entry-function leaf)))
     (unless (and entry (leaf-refs entry))
-      (assert (or (not entry) (eq (functional-kind entry) :deleted)))
+      (aver (or (not entry) (eq (functional-kind entry) :deleted)))
       (setf (functional-kind leaf) :deleted)
 
       (flet ((frob (fun)
 	       (unless (eq (functional-kind fun) :deleted)
-		 (assert (eq (functional-kind fun) :optional))
+		 (aver (eq (functional-kind fun) :optional))
 		 (setf (functional-kind fun) nil)
 		 (let ((refs (leaf-refs fun)))
 		   (cond ((null refs)
@@ -696,7 +682,7 @@
 	     (clambda
 	      (ecase (functional-kind leaf)
 		((nil :let :mv-let :assignment :escape :cleanup)
-		 (assert (not (functional-entry-function leaf)))
+		 (aver (not (functional-entry-function leaf)))
 		 (delete-lambda leaf))
 		(:external
 		 (delete-lambda leaf))
@@ -730,7 +716,7 @@
   (declare (type continuation cont))
 
   (unless (eq (continuation-kind cont) :deleted)
-    (assert (continuation-dest cont))
+    (aver (continuation-dest cont))
     (setf (continuation-dest cont) nil)
     (do-uses (use cont)
       (let ((prev (node-prev use)))
@@ -766,7 +752,7 @@
 ;;; people to ignore them, and to cause them to be deleted eventually.
 (defun delete-continuation (cont)
   (declare (type continuation cont))
-  (assert (not (eq (continuation-kind cont) :deleted)))
+  (aver (not (eq (continuation-kind cont) :deleted)))
 
   (do-uses (use cont)
     (let ((prev (node-prev use)))
@@ -797,16 +783,17 @@
 
   (values))
 
-;;; This function does what is necessary to eliminate the code in it from
-;;; the IR1 representation. This involves unlinking it from its predecessors
-;;; and successors and deleting various node-specific semantic information.
+;;; This function does what is necessary to eliminate the code in it
+;;; from the IR1 representation. This involves unlinking it from its
+;;; predecessors and successors and deleting various node-specific
+;;; semantic information.
 ;;;
-;;; We mark the Start as has having no next and remove the last node from
-;;; its Cont's uses. We also flush the DEST for all continuations whose values
-;;; are received by nodes in the block.
+;;; We mark the START as has having no next and remove the last node
+;;; from its CONT's uses. We also flush the DEST for all continuations
+;;; whose values are received by nodes in the block.
 (defun delete-block (block)
   (declare (type cblock block))
-  (assert (block-component block) () "Block is already deleted.")
+  (aver (block-component block)) ; else block is already deleted!
   (note-block-deletion block)
   (setf (block-delete-p block) t)
 
@@ -847,8 +834,7 @@
       (bind
        (let ((lambda (bind-lambda node)))
 	 (unless (eq (functional-kind lambda) :deleted)
-	   (assert (member (functional-kind lambda)
-			   '(:let :mv-let :assignment)))
+	   (aver (member (functional-kind lambda) '(:let :mv-let :assignment)))
 	   (delete-lambda lambda))))
       (exit
        (let ((value (exit-value node))
@@ -877,7 +863,7 @@
 (defun delete-return (node)
   (declare (type creturn node))
   (let ((fun (return-lambda node)))
-    (assert (lambda-return fun))
+    (aver (lambda-return fun))
     (setf (lambda-return fun) nil))
   (values))
 
@@ -989,7 +975,7 @@
     (unless (eq (continuation-kind cont) :deleted)
       (delete-continuation-use node)
       (when (eq (continuation-kind cont) :unused)
-	(assert (not (continuation-dest cont)))
+	(aver (not (continuation-dest cont)))
 	(delete-continuation cont)))
 
     (setf (block-type-asserted block) t)
@@ -1007,11 +993,11 @@
 	   (setf (node-prev node) nil)
 	   nil)
 	  (t
-	   (assert (eq prev-kind :block-start))
-	   (assert (eq node last))
+	   (aver (eq prev-kind :block-start))
+	   (aver (eq node last))
 	   (let* ((succ (block-succ block))
 		  (next (first succ)))
-	     (assert (and succ (null (cdr succ))))
+	     (aver (and succ (null (cdr succ))))
 	     (cond
 	      ((member block succ)
 	       (with-ir1-environment node
@@ -1024,8 +1010,8 @@
 	       (setf (node-prev node) nil)
 	       nil)
 	      (t
-	       (assert (eq (block-start-cleanup block)
-			   (block-end-cleanup block)))
+	       (aver (eq (block-start-cleanup block)
+			 (block-end-cleanup block)))
 	       (unlink-blocks block next)
 	       (dolist (pred (block-pred block))
 		 (change-block-successor pred block next))
@@ -1054,7 +1040,7 @@
 ;;; deletion.
 (defun delete-component (component)
   (declare (type component component))
-  (assert (null (component-new-functions component)))
+  (aver (null (component-new-functions component)))
   (setf (component-kind component) :deleted)
   (do-blocks (block component)
     (setf (block-delete-p block) t))
@@ -1087,7 +1073,7 @@
 	   (type index num-args))
   (let ((outside (continuation-dest cont))
 	(inside (continuation-use cont)))
-    (assert (combination-p outside))
+    (aver (combination-p outside))
     (unless (combination-p inside)
       (give-up-ir1-transform))
     (let ((inside-fun (combination-fun inside)))
@@ -1230,7 +1216,7 @@
 ;;; Return the COMBINATION node that is the call to the let Fun.
 (defun let-combination (fun)
   (declare (type clambda fun))
-  (assert (member (functional-kind fun) '(:let :mv-let)))
+  (aver (member (functional-kind fun) '(:let :mv-let)))
   (continuation-dest (node-cont (first (leaf-refs fun)))))
 
 ;;; Return the initial value continuation for a let variable or NIL if none.
@@ -1244,7 +1230,7 @@
 #!-sb-fluid (declaim (inline combination-lambda))
 (defun combination-lambda (call)
   (declare (type basic-combination call))
-  (assert (eq (basic-combination-kind call) :local))
+  (aver (eq (basic-combination-kind call) :local))
   (ref-leaf (continuation-use (basic-combination-fun call))))
 
 (defvar *inline-expansion-limit* 200
@@ -1272,21 +1258,26 @@
 
 (declaim (special *current-path*))
 
-;;; We bind print level and length when printing out messages so that we don't
-;;; dump huge amounts of garbage.
+;;; We bind print level and length when printing out messages so that
+;;; we don't dump huge amounts of garbage.
+;;;
+;;; FIXME: It's not possible to get the defaults right for everyone.
+;;; So: Should these variables be in the SB-EXT package? Or should we
+;;; just get rid of them completely and just use the bare
+;;; CL:*PRINT-FOO* variables instead?
 (declaim (type (or unsigned-byte null)
 	       *compiler-error-print-level*
 	       *compiler-error-print-length*
 	       *compiler-error-print-lines*))
-(defvar *compiler-error-print-level* 3
+(defvar *compiler-error-print-level* 5
   #!+sb-doc
-  "The value for *PRINT-LEVEL* when printing compiler error messages.")
-(defvar *compiler-error-print-length* 5
+  "the value for *PRINT-LEVEL* when printing compiler error messages")
+(defvar *compiler-error-print-length* 10
   #!+sb-doc
-  "The value for *PRINT-LENGTH* when printing compiler error messages.")
-(defvar *compiler-error-print-lines* 5
+  "the value for *PRINT-LENGTH* when printing compiler error messages")
+(defvar *compiler-error-print-lines* 12
   #!+sb-doc
-  "The value for *PRINT-LINES* when printing compiler error messages.")
+  "the value for *PRINT-LINES* when printing compiler error messages")
 
 (defvar *enclosing-source-cutoff* 1
   #!+sb-doc
@@ -1306,7 +1297,8 @@
 (defstruct (compiler-error-context
 	    #-no-ansi-print-object
 	    (:print-object (lambda (x stream)
-			     (print-unreadable-object (x stream :type t)))))
+			     (print-unreadable-object (x stream :type t))))
+	    (:copier nil))
   ;; A list of the stringified CARs of the enclosing non-original source forms
   ;; exceeding the *enclosing-source-cutoff*.
   (enclosing-source nil :type list)
@@ -1404,7 +1396,7 @@
 	    (current (rest rpath)))
 	(loop
 	  (when (atom form)
-	    (assert (null current))
+	    (aver (null current))
 	    (return))
 	  (let ((head (first form)))
 	    (when (symbolp head)
@@ -1512,10 +1504,10 @@
   (setq *last-message-count* 0))
 
 ;;; Print out the message, with appropriate context if we can find it.
-;;; If If the context is different from the context of the last
-;;; message we printed, then we print the context. If the original
-;;; source is different from the source we are working on, then we
-;;; print the current source in addition to the original source.
+;;; If the context is different from the context of the last message
+;;; we printed, then we print the context. If the original source is
+;;; different from the source we are working on, then we print the
+;;; current source in addition to the original source.
 ;;;
 ;;; We suppress printing of messages identical to the previous, but
 ;;; record the number of times that the message is repeated.
@@ -1607,9 +1599,10 @@
 
 (defun print-compiler-condition (condition)
   (declare (type condition condition))
-  (let (;; These different classes of conditions have different effects
-	;; on the return codes of COMPILE-FILE, so it's nice for users to be
-	;; able to pick them out by lexical search through the output.
+  (let (;; These different classes of conditions have different
+	;; effects on the return codes of COMPILE-FILE, so it's nice
+	;; for users to be able to pick them out by lexical search
+	;; through the output.
 	(what (etypecase condition
 		(style-warning 'style-warning)
 		(warning 'warning)
@@ -1637,7 +1630,7 @@
 (defun compiler-note (format-string &rest format-args)
   (unless (if *compiler-error-context*
 	      (policy *compiler-error-context* (= inhibit-warnings 3))
-	      (policy nil (= inhibit-warnings 3)))
+	      (policy *lexenv* (= inhibit-warnings 3)))
     (incf *compiler-note-count*)
     (print-compiler-message (format nil "note: ~A" format-string)
 			    format-args))
@@ -1667,13 +1660,13 @@
   (force-output *error-output*)
   (values))
 
-;;; Return a string that somehow names the code in Component. We use
+;;; Return a string that somehow names the code in COMPONENT. We use
 ;;; the source path for the bind node for an arbitrary entry point to
 ;;; find the source context, then return that as a string.
 (declaim (ftype (function (component) simple-string) find-component-name))
 (defun find-component-name (component)
   (let ((ep (first (block-succ (component-head component)))))
-    (assert ep () "no entry points?")
+    (aver ep) ; else no entry points??
     (multiple-value-bind (form context)
 	(find-original-source
 	 (node-source-path (continuation-next (block-start ep))))
@@ -1696,8 +1689,8 @@
 (defvar *warnings-p*)
 
 ;;; condition handlers established by the compiler. We re-signal the
-;;; condition, if it is not handled, we increment our warning counter
-;;; and print the error message.
+;;; condition, then if it isn't handled, we increment our warning
+;;; counter and print the error message.
 (defun compiler-error-handler (condition)
   (signal condition)
   (incf *compiler-error-count*)
@@ -1738,9 +1731,8 @@
 ;;; the compiler, hence the BOUNDP check.
 (defun note-undefined-reference (name kind)
   (unless (and
-	   ;; (POLICY NIL ..) isn't well-defined except in IR1
-	   ;; conversion. This BOUNDP test seems to be a test for
-	   ;; whether IR1 conversion is going on.
+	   ;; Check for boundness so we don't blow up if we're called
+	   ;; when IR1 conversion isn't going on.
 	   (boundp '*lexenv*)
 	   ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
 	   ;; isn't a good idea; we should have INHIBIT-WARNINGS
@@ -1748,7 +1740,7 @@
 	   ;; sure what the BOUNDP '*LEXENV* test above is for; it's
 	   ;; likely a good idea, but it probably deserves an
 	   ;; explanatory comment.
-	   (policy nil (= inhibit-warnings 3)))
+	   (policy *lexenv* (= inhibit-warnings 3)))
     (let* ((found (dolist (warning *undefined-warnings* nil)
 		    (when (and (equal (undefined-warning-name warning) name)
 			       (eq (undefined-warning-kind warning) kind))
@@ -1784,11 +1776,11 @@
 	  (return-from careful-call (values nil nil))))))
    t))
 
-;;;; utilities used at run-time for parsing keyword args in IR1
+;;;; utilities used at run-time for parsing &KEY args in IR1
 
-;;; This function is used by the result of Parse-Deftransform to find
-;;; the continuation for the value of the keyword argument Key in the
-;;; list of continuations Args. It returns the continuation if the
+;;; This function is used by the result of PARSE-DEFTRANSFORM to find
+;;; the continuation for the value of the &KEY argument KEY in the
+;;; list of continuations ARGS. It returns the continuation if the
 ;;; keyword is present, or NIL otherwise. The legality and
 ;;; constantness of the keywords should already have been checked.
 (declaim (ftype (function (list keyword) (or continuation null))
@@ -1799,24 +1791,24 @@
     (when (eq (continuation-value (first arg)) key)
       (return (second arg)))))
 
-;;; This function is used by the result of Parse-Deftransform to
-;;; verify that alternating continuations in Args are constant and
+;;; This function is used by the result of PARSE-DEFTRANSFORM to
+;;; verify that alternating continuations in ARGS are constant and
 ;;; that there is an even number of args.
-(declaim (ftype (function (list) boolean) check-keywords-constant))
-(defun check-keywords-constant (args)
+(declaim (ftype (function (list) boolean) check-key-args-constant))
+(defun check-key-args-constant (args)
   (do ((arg args (cddr arg)))
       ((null arg) t)
     (unless (and (rest arg)
 		 (constant-continuation-p (first arg)))
       (return nil))))
 
-;;; This function is used by the result of Parse-Deftransform to
-;;; verify that the list of continuations Args is a well-formed
-;;; keyword arglist and that only keywords present in the list Keys
-;;; are supplied.
+;;; This function is used by the result of PARSE-DEFTRANSFORM to
+;;; verify that the list of continuations ARGS is a well-formed &KEY
+;;; arglist and that only keywords present in the list KEYS are
+;;; supplied.
 (declaim (ftype (function (list list) boolean) check-transform-keys))
 (defun check-transform-keys (args keys)
-  (and (check-keywords-constant args)
+  (and (check-key-args-constant args)
        (do ((arg args (cddr arg)))
 	   ((null arg) t)
 	 (unless (member (continuation-value (first arg)) keys)
@@ -1829,9 +1821,8 @@
 (defun %event (info node)
   (incf (event-info-count info))
   (when (and (>= (event-info-level info) *event-note-threshold*)
-	     (if node
-		 (policy node (= inhibit-warnings 0))
-		 (policy nil (= inhibit-warnings 0))))
+	     (policy (or node *lexenv*)
+		     (= inhibit-warnings 0)))
     (let ((*compiler-error-context* node))
       (compiler-note (event-info-description info))))