X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftn.lisp;h=d5e6f772b53b81038632b355516eb98a17547bd8;hb=e511ed14d4a20cb9de2523f052b0f23a1dde1115;hp=413209266046db15b3b144ed170839988bfa12ff;hpb=1a6def3955b715472eb2c75b15660912b9f90173;p=sbcl.git diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp index 4132092..d5e6f77 100644 --- a/src/compiler/tn.lisp +++ b/src/compiler/tn.lisp @@ -16,10 +16,10 @@ ;;; 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))) @@ -33,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)) @@ -65,26 +83,26 @@ (:environment (clear-live tn #'ir2-physenv-live-tns - #'(setf ir2-physenv-live-tns))) + #'set-ir2-physenv-live-tns)) (:debug-environment (clear-live tn #'ir2-physenv-debug-live-tns - #'(setf ir2-physenv-debug-live-tns))))) + #'set-ir2-physenv-debug-live-tns)))) (clear-live (tn getter setter) (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 @@ -136,24 +154,24 @@ (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 physenv-live-tn (tn env) - (declare (type tn tn) (type physenv env)) +;;; 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-physenv tn) env) - (push tn (ir2-physenv-live-tns (physenv-info env))) + (setf (tn-physenv tn) physenv) + (push tn (ir2-physenv-live-tns (physenv-info physenv))) tn) -(defun physenv-debug-live-tn (tn env) - (declare (type tn tn) (type physenv env)) +(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-physenv tn) env) - (push tn (ir2-physenv-debug-live-tns (physenv-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. @@ -165,7 +183,7 @@ *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)) (aver (eq (tn-kind save) :normal)) @@ -220,7 +238,7 @@ ;;; 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 anew load-time constant slot. +;;; 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*)) @@ -249,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))) @@ -260,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 @@ -286,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) @@ -314,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)) @@ -326,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)) @@ -340,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)) @@ -386,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))) @@ -408,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. @@ -425,6 +442,7 @@ ;;; Return the value of an immediate constant TN. (defun tn-value (tn) (declare (type tn tn)) + ;; FIXME: What is :CACHED-CONSTANT? (aver (member (tn-kind tn) '(:constant :cached-constant))) (constant-value (tn-leaf tn))) @@ -438,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))