X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Ftn.lisp;h=8ec52609027a14eb05b3b1a3a4a9bcc926b4830d;hb=1dfcd0ed5fc81f4355101c1eeb990a1f7d089e40;hp=c344725b68f7ce120de85ea4b2d1bd360d5008cf;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp index c344725..8ec5260 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)) @@ -64,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 @@ -136,29 +154,30 @@ (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 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)) + (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) env) + (push tn (ir2-physenv-live-tns (physenv-info env))) 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 env) + (declare (type tn tn) (type physenv env)) + (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) env) + (push tn (ir2-physenv-debug-live-tns (physenv-info env))) 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*))) @@ -167,8 +186,8 @@ ;;; 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) @@ -178,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*)) @@ -217,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*)) @@ -297,10 +316,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)) @@ -312,7 +332,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)) @@ -324,7 +344,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)) @@ -338,7 +358,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)) @@ -360,7 +380,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 @@ -423,7 +443,7 @@ ;;; Return the value of an immediate constant TN. (defun tn-value (tn) (declare (type tn tn)) - (assert (member (tn-kind tn) '(:constant :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