X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftn.lisp;h=d5e6f772b53b81038632b355516eb98a17547bd8;hb=d2561c6826f9e590d9174007f9642237d79a46df;hp=ee80ba8d385bb228d0a1466a8cd13530344b362b;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp
index ee80ba8..d5e6f77 100644
--- a/src/compiler/tn.lisp
+++ b/src/compiler/tn.lisp
@@ -12,17 +12,14 @@
 
 (in-package "SB!C")
 
-(file-comment
-  "$Header$")
-
 ;;; The component that is currently being compiled. TNs are allocated
 ;;; in this component.
 (defvar *component-being-compiled*)
 
+;;; DO-PACKED-TNS (TN-Var Component [Result]) Declaration* Form*
+;;;
+;;; Iterate over all packed TNs allocated in COMPONENT.
 (defmacro do-packed-tns ((tn component &optional result) &body body)
-  #!+sb-doc
-  "Do-Packed-TNs (TN-Var Component [Result]) Declaration* Form*
-  Iterate over all packed TNs allocated in Component."
   (let ((n-component (gensym)))
     `(let ((,n-component (component-info ,component)))
        (do ((,tn (ir2-component-normal-tns ,n-component) (tn-next ,tn)))
@@ -36,10 +33,28 @@
 	    ,result)
 	 ,@body))))
 
-;;; Remove all TNs with no references from the lists of unpacked TNs. We
-;;; null out the Offset so that nobody will mistake deleted wired TNs for
-;;; properly packed TNs. We mark non-deleted alias TNs so that aliased TNs
-;;; aren't considered to be unreferenced.
+(defun set-ir2-physenv-live-tns (value instance)
+  (setf (ir2-physenv-live-tns instance) value))
+
+(defun set-ir2-physenv-debug-live-tns (value instance)
+  (setf (ir2-physenv-debug-live-tns instance) value))
+
+(defun set-ir2-component-alias-tns (value instance)
+  (setf (ir2-component-alias-tns instance) value))
+
+(defun set-ir2-component-normal-tns (value instance)
+  (setf (ir2-component-normal-tns instance) value))
+
+(defun set-ir2-component-restricted-tns (value instance)
+  (setf (ir2-component-restricted-tns instance) value))
+
+(defun set-ir2-component-wired-tns (value instance)
+  (setf (ir2-component-wired-tns instance) value))
+
+;;; Remove all TNs with no references from the lists of unpacked TNs.
+;;; We null out the OFFSET so that nobody will mistake deleted wired
+;;; TNs for properly packed TNs. We mark non-deleted alias TNs so that
+;;; aliased TNs aren't considered to be unreferenced.
 (defun delete-unreferenced-tns (component)
   (let* ((2comp (component-info component))
 	 (aliases (make-array (1+ (ir2-component-global-tn-counter 2comp))
@@ -67,27 +82,27 @@
 	       (case (tn-kind tn)
 		 (:environment
 		  (clear-live tn
-			      #'ir2-environment-live-tns
-			      #'(setf ir2-environment-live-tns)))
+			      #'ir2-physenv-live-tns
+			      #'set-ir2-physenv-live-tns))
 		 (:debug-environment
 		  (clear-live tn
-			      #'ir2-environment-debug-live-tns
-			      #'(setf ir2-environment-debug-live-tns)))))
+			      #'ir2-physenv-debug-live-tns
+			      #'set-ir2-physenv-debug-live-tns))))
 	     (clear-live (tn getter setter)
-	       (let ((env (environment-info (tn-environment tn))))
+	       (let ((env (physenv-info (tn-physenv tn))))
 		 (funcall setter (delete tn (funcall getter env)) env))))
       (declare (inline used-p delete-some delete-1 clear-live))
       (delete-some #'ir2-component-alias-tns
-		   #'(setf ir2-component-alias-tns))
+		   #'set-ir2-component-alias-tns)
       (do ((tn (ir2-component-alias-tns 2comp) (tn-next tn)))
 	  ((null tn))
 	(setf (sbit aliases (tn-number (tn-save-tn tn))) 1))
       (delete-some #'ir2-component-normal-tns
-		   #'(setf ir2-component-normal-tns))
+		   #'set-ir2-component-normal-tns)
       (delete-some #'ir2-component-restricted-tns
-		   #'(setf ir2-component-restricted-tns))
+		   #'set-ir2-component-restricted-tns)
       (delete-some #'ir2-component-wired-tns
-		   #'(setf ir2-component-wired-tns))))
+		   #'set-ir2-component-wired-tns)))
   (values))
 
 ;;;; TN creation
@@ -139,39 +154,40 @@
     (push-in tn-next res (ir2-component-restricted-tns component))
     res))
 
-;;; Make TN be live throughout environment. Return TN. In the DEBUG case,
-;;; the TN is treated normally in blocks in the environment which reference the
-;;; TN, allowing targeting to/from the TN. This results in move efficient
-;;; code, but may result in the TN sometimes not being live when you want it.
-(defun environment-live-tn (tn env)
-  (declare (type tn tn) (type environment env))
-  (assert (eq (tn-kind tn) :normal))
+;;; Make TN be live throughout PHYSENV. Return TN. In the DEBUG case,
+;;; the TN is treated normally in blocks in the environment which
+;;; reference the TN, allowing targeting to/from the TN. This results
+;;; in move efficient code, but may result in the TN sometimes not
+;;; being live when you want it.
+(defun physenv-live-tn (tn physenv)
+  (declare (type tn tn) (type physenv physenv))
+  (aver (eq (tn-kind tn) :normal))
   (setf (tn-kind tn) :environment)
-  (setf (tn-environment tn) env)
-  (push tn (ir2-environment-live-tns (environment-info env)))
+  (setf (tn-physenv tn) physenv)
+  (push tn (ir2-physenv-live-tns (physenv-info physenv)))
   tn)
-(defun environment-debug-live-tn (tn env)
-  (declare (type tn tn) (type environment env))
-  (assert (eq (tn-kind tn) :normal))
+(defun physenv-debug-live-tn (tn physenv)
+  (declare (type tn tn) (type physenv physenv))
+  (aver (eq (tn-kind tn) :normal))
   (setf (tn-kind tn) :debug-environment)
-  (setf (tn-environment tn) env)
-  (push tn (ir2-environment-debug-live-tns (environment-info env)))
+  (setf (tn-physenv tn) physenv)
+  (push tn (ir2-physenv-debug-live-tns (physenv-info physenv)))
   tn)
 
 ;;; Make TN be live throughout the current component. Return TN.
 (defun component-live-tn (tn)
   (declare (type tn tn))
-  (assert (eq (tn-kind tn) :normal))
+  (aver (eq (tn-kind tn) :normal))
   (setf (tn-kind tn) :component)
   (push tn (ir2-component-component-tns (component-info
 					 *component-being-compiled*)))
   tn)
 
-;;; Specify that Save be used as the save location for TN. TN is returned.
+;;; Specify that SAVE be used as the save location for TN. TN is returned.
 (defun specify-save-tn (tn save)
   (declare (type tn tn save))
-  (assert (eq (tn-kind save) :normal))
-  (assert (and (not (tn-save-tn tn)) (not (tn-save-tn save))))
+  (aver (eq (tn-kind save) :normal))
+  (aver (and (not (tn-save-tn tn)) (not (tn-save-tn save))))
   (setf (tn-kind save) :specified-save)
   (setf (tn-save-tn tn) save)
   (setf (tn-save-tn save) tn)
@@ -181,8 +197,8 @@
   tn)
 
 ;;; Create a constant TN. The implementation dependent
-;;; Immediate-Constant-SC function is used to determine whether the constant
-;;; has an immediate representation.
+;;; IMMEDIATE-CONSTANT-SC function is used to determine whether the
+;;; constant has an immediate representation.
 (defun make-constant-tn (constant)
   (declare (type constant constant))
   (let* ((component (component-info *component-being-compiled*))
@@ -220,9 +236,9 @@
 	     (ir2-component-alias-tns component))
     res))
 
-;;; Return a load-time constant TN with the specified Kind and Info. If the
-;;; desired Constants entry already exists, then reuse it, otherwise allocate a
-;;; new load-time constant slot.
+;;; Return a load-time constant TN with the specified KIND and INFO.
+;;; If the desired CONSTANTS entry already exists, then reuse it,
+;;; otherwise allocate a new load-time constant slot.
 (defun make-load-time-constant-tn (kind info)
   (declare (type keyword kind))
   (let* ((component (component-info *component-being-compiled*))
@@ -251,9 +267,10 @@
 
 ;;;; TN referencing
 
-;;; Make a TN-Ref that references TN and return it. Write-P should be true
-;;; if this is a write reference, otherwise false. All we do other than
-;;; calling the constructor is add the reference to the TN's references.
+;;; Make a TN-REF that references TN and return it. WRITE-P should be
+;;; true if this is a write reference, otherwise false. All we do
+;;; other than calling the constructor is add the reference to the
+;;; TN's references.
 (defun reference-tn (tn write-p)
   (declare (type tn tn) (type boolean write-p))
   (let ((res (make-tn-ref tn write-p)))
@@ -262,10 +279,10 @@
 	(push-in tn-ref-next res (tn-reads tn)))
     res))
 
-;;; Make TN-Refs to reference each TN in TNs, linked together by
-;;; TN-Ref-Across. Write-P is the Write-P value for the refs. More is
-;;; stuck in the TN-Ref-Across of the ref for the last TN, or returned as the
-;;; result if there are no TNs.
+;;; Make TN-REFS to reference each TN in TNs, linked together by
+;;; TN-REF-ACROSS. WRITE-P is the WRITE-P value for the refs. MORE is
+;;; stuck in the TN-REF-ACROSS of the ref for the last TN, or returned
+;;; as the result if there are no TNs.
 (defun reference-tn-list (tns write-p &optional more)
   (declare (list tns) (type boolean write-p) (type (or tn-ref null) more))
   (if tns
@@ -288,7 +305,7 @@
   (values))
 
 ;;; Do stuff to change the TN referenced by Ref. We remove Ref from its
-;;; old TN's refs, add ref to TN's refs, and set the TN-Ref-TN.
+;;; old TN's refs, add ref to TN's refs, and set the TN-REF-TN.
 (defun change-tn-ref-tn (ref tn)
   (declare (type tn-ref ref) (type tn tn))
   (delete-tn-ref ref)
@@ -300,10 +317,11 @@
 
 ;;;; miscellaneous utilities
 
-;;; Emit a move-like template determined at run-time, with X as the argument
-;;; and Y as the result. Useful for move, coerce and type-check templates. If
-;;; supplied, then insert before VOP, otherwise insert at then end of the
-;;; block. Returns the last VOP inserted.
+;;; Emit a move-like template determined at run-time, with X as the
+;;; argument and Y as the result. Useful for move, coerce and
+;;; type-check templates. If supplied, then insert before VOP,
+;;; otherwise insert at then end of the block. Returns the last VOP
+;;; inserted.
 (defun emit-move-template (node block template x y &optional before)
   (declare (type node node) (type ir2-block block)
 	   (type template template) (type tn x y))
@@ -315,7 +333,7 @@
       (insert-vop-sequence first last block before)
       last)))
 
-;;; Like EMIT-MOVE-TEMPLATE, except that we pass in Info args too.
+;;; like EMIT-MOVE-TEMPLATE, except that we pass in INFO args too
 (defun emit-load-template (node block template x y info &optional before)
   (declare (type node node) (type ir2-block block)
 	   (type template template) (type tn x y))
@@ -327,7 +345,7 @@
       (insert-vop-sequence first last block before)
       last)))
 
-;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes two args.
+;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes two args
 (defun emit-move-arg-template (node block template x f y &optional before)
   (declare (type node node) (type ir2-block block)
 	   (type template template) (type tn x f y))
@@ -341,7 +359,7 @@
       (insert-vop-sequence first last block before)
       last)))
 
-;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes no args.
+;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes no args
 (defun emit-context-template (node block template y &optional before)
   (declare (type node node) (type ir2-block block)
 	   (type template template) (type tn y))
@@ -363,7 +381,7 @@
 (defun drop-thru-p (node block)
   (declare (type node node) (type cblock block))
   (let ((next-block (ir2-block-next (block-info (node-block node)))))
-    (assert (eq node (block-last (node-block node))))
+    (aver (eq node (block-last (node-block node))))
     (eq next-block (block-info block))))
 
 ;;; Link a list of VOPs from First to Last into Block, Before the specified
@@ -387,7 +405,7 @@
 	    (setf (ir2-block-start-vop block) first))))
   (values))
 
-;;; Delete all of the TN-Refs associated with VOP and remove VOP from the IR2.
+;;; Delete all of the TN-REFs associated with VOP and remove VOP from the IR2.
 (defun delete-vop (vop)
   (declare (type vop vop))
   (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
@@ -409,10 +427,8 @@
 ;;; Return a list of N normal TNs of the specified primitive type.
 (defun make-n-tns (n ptype)
   (declare (type unsigned-byte n) (type primitive-type ptype))
-  (collect ((res))
-    (dotimes (i n)
-      (res (make-normal-tn ptype)))
-    (res)))
+  (loop repeat n
+        collect (make-normal-tn ptype)))
 
 ;;; Return true if X and Y are packed in the same location, false otherwise.
 ;;; This is false if either operand is constant.
@@ -426,7 +442,8 @@
 ;;; Return the value of an immediate constant TN.
 (defun tn-value (tn)
   (declare (type tn tn))
-  (assert (member (tn-kind tn) '(:constant :cached-constant)))
+  ;; FIXME: What is :CACHED-CONSTANT?
+  (aver (member (tn-kind tn) '(:constant :cached-constant)))
   (constant-value (tn-leaf tn)))
 
 ;;; Force TN to be allocated in a SC that doesn't need to be saved: an
@@ -439,7 +456,7 @@
     (unless (and (not (sc-save-p sc))
 		 (eq (sb-kind (sc-sb sc)) :unbounded))
       (dolist (alt (sc-alternate-scs sc)
-		   (error "SC ~S has no :unbounded :save-p NIL alternate SC."
+		   (error "SC ~S has no :UNBOUNDED :SAVE-P NIL alternate SC."
 			  (sc-name sc)))
 	(when (and (not (sc-save-p alt))
 		   (eq (sb-kind (sc-sb alt)) :unbounded))