;;; 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)))
,result)
,@body))))
\f
-;;; 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))
(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))
\f
;;;; TN creation
(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*)))
;;; 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)
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*))
(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*))
\f
;;;; 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))
(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))
(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))
(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))
(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
;;; 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
projects / sbcl.git / blobdiff