X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftn.lisp;h=79ce6dc01a90e1e4ee2895a160a2c2566ba6b253;hb=3641e3c73615bffcdd9c014e6663d80935e985ef;hp=3b07aac649be40cde62fb7c1c0da06a88fcf1051;hpb=c7dc5b2a1f56ed0583a0b3ea61b6ceb540c6f89e;p=sbcl.git diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp index 3b07aac..79ce6dc 100644 --- a/src/compiler/tn.lisp +++ b/src/compiler/tn.lisp @@ -23,15 +23,15 @@ (let ((n-component (gensym))) `(let ((,n-component (component-info ,component))) (do ((,tn (ir2-component-normal-tns ,n-component) (tn-next ,tn))) - ((null ,tn)) - ,@body) + ((null ,tn)) + ,@body) (do ((,tn (ir2-component-restricted-tns ,n-component) (tn-next ,tn))) - ((null ,tn)) - ,@body) + ((null ,tn)) + ,@body) (do ((,tn (ir2-component-wired-tns ,n-component) (tn-next ,tn))) - ((null ,tn) - ,result) - ,@body)))) + ((null ,tn) + ,result) + ,@body)))) (defun set-ir2-physenv-live-tns (value instance) (setf (ir2-physenv-live-tns instance) value)) @@ -52,57 +52,57 @@ (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 +;;; 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)) - :element-type 'bit :initial-element 0))) + (aliases (make-array (1+ (ir2-component-global-tn-counter 2comp)) + :element-type 'bit :initial-element 0))) (labels ((delete-some (getter setter) - (let ((prev nil)) - (do ((tn (funcall getter 2comp) (tn-next tn))) - ((null tn)) - (cond - ((or (used-p tn) - (and (eq (tn-kind tn) :specified-save) - (used-p (tn-save-tn tn)))) - (setq prev tn)) - (t - (delete-1 tn prev setter)))))) - (used-p (tn) - (or (tn-reads tn) (tn-writes tn) - (member (tn-kind tn) '(:component :environment)) - (not (zerop (sbit aliases (tn-number tn)))))) - (delete-1 (tn prev setter) - (if prev - (setf (tn-next prev) (tn-next tn)) - (funcall setter (tn-next tn) 2comp)) - (setf (tn-offset tn) nil) - (case (tn-kind tn) - (:environment - (clear-live tn - #'ir2-physenv-live-tns - #'set-ir2-physenv-live-tns)) - (:debug-environment - (clear-live tn - #'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)))) + (let ((prev nil)) + (do ((tn (funcall getter 2comp) (tn-next tn))) + ((null tn)) + (cond + ((or (used-p tn) + (and (eq (tn-kind tn) :specified-save) + (used-p (tn-save-tn tn)))) + (setq prev tn)) + (t + (delete-1 tn prev setter)))))) + (used-p (tn) + (or (tn-reads tn) (tn-writes tn) + (member (tn-kind tn) '(:component :environment)) + (not (zerop (sbit aliases (tn-number tn)))))) + (delete-1 (tn prev setter) + (if prev + (setf (tn-next prev) (tn-next tn)) + (funcall setter (tn-next tn) 2comp)) + (setf (tn-offset tn) nil) + (case (tn-kind tn) + (:environment + (clear-live tn + #'ir2-physenv-live-tns + #'set-ir2-physenv-live-tns)) + (:debug-environment + (clear-live tn + #'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 - #'set-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)) + ((null tn)) + (setf (sbit aliases (tn-number (tn-save-tn tn))) 1)) (delete-some #'ir2-component-normal-tns - #'set-ir2-component-normal-tns) + #'set-ir2-component-normal-tns) (delete-some #'ir2-component-restricted-tns - #'set-ir2-component-restricted-tns) + #'set-ir2-component-restricted-tns) (delete-some #'ir2-component-wired-tns - #'set-ir2-component-wired-tns))) + #'set-ir2-component-wired-tns))) (values)) ;;;; TN creation @@ -113,8 +113,8 @@ (defun make-normal-tn (type) (declare (type primitive-type type)) (let* ((component (component-info *component-being-compiled*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :normal type nil))) + (res (make-tn (incf (ir2-component-global-tn-counter component)) + :normal type nil))) (push-in tn-next res (ir2-component-normal-tns component)) res)) @@ -122,9 +122,9 @@ (defun make-representation-tn (ptype scn) (declare (type primitive-type ptype) (type sc-number scn)) (let* ((component (component-info *component-being-compiled*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :normal ptype - (svref *backend-sc-numbers* scn)))) + (res (make-tn (incf (ir2-component-global-tn-counter component)) + :normal ptype + (svref *backend-sc-numbers* scn)))) (push-in tn-next res (ir2-component-normal-tns component)) res)) @@ -134,11 +134,11 @@ ;;; temporaries. (defun make-wired-tn (ptype scn offset) (declare (type (or primitive-type null) ptype) - (type sc-number scn) (type unsigned-byte offset)) + (type sc-number scn) (type unsigned-byte offset)) (let* ((component (component-info *component-being-compiled*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :normal ptype - (svref *backend-sc-numbers* scn)))) + (res (make-tn (incf (ir2-component-global-tn-counter component)) + :normal ptype + (svref *backend-sc-numbers* scn)))) (setf (tn-offset res) offset) (push-in tn-next res (ir2-component-wired-tns component)) res)) @@ -148,30 +148,30 @@ (defun make-restricted-tn (ptype scn) (declare (type (or primitive-type null) ptype) (type sc-number scn)) (let* ((component (component-info *component-being-compiled*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :normal ptype - (svref *backend-sc-numbers* scn)))) + (res (make-tn (incf (ir2-component-global-tn-counter component)) + :normal ptype + (svref *backend-sc-numbers* scn)))) (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. @@ -180,10 +180,10 @@ (aver (eq (tn-kind tn) :normal)) (setf (tn-kind tn) :component) (push tn (ir2-component-component-tns (component-info - *component-being-compiled*))) + *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)) @@ -192,34 +192,50 @@ (setf (tn-save-tn tn) save) (setf (tn-save-tn save) tn) (push save - (ir2-component-specified-save-tns - (component-info *component-being-compiled*))) + (ir2-component-specified-save-tns + (component-info *component-being-compiled*))) tn) ;;; Create a constant TN. The implementation dependent ;;; IMMEDIATE-CONSTANT-SC function is used to determine whether the ;;; constant has an immediate representation. -(defun make-constant-tn (constant) +(defun make-constant-tn (constant boxedp) (declare (type constant constant)) - (let* ((component (component-info *component-being-compiled*)) - (immed (immediate-constant-sc (constant-value constant))) - (sc (svref *backend-sc-numbers* - (or immed (sc-number-or-lose 'constant)))) - (res (make-tn 0 :constant (primitive-type (leaf-type constant)) sc))) - (unless immed - (let ((constants (ir2-component-constants component))) - (setf (tn-offset res) (fill-pointer constants)) - (vector-push-extend constant constants))) - (push-in tn-next res (ir2-component-constant-tns component)) - (setf (tn-leaf res) constant) - res)) + (let* ((immed (immediate-constant-sc (constant-value constant))) + (use-immed-p (and immed + (or (not boxedp) + (boxed-immediate-sc-p immed))))) + (cond + ;; CONSTANT-TN uses two caches, one for boxed and one for unboxed uses. + ;; + ;; However, in the case of USE-IMMED-P we can have the same TN for both + ;; uses. The first two legs here take care of that by cross-pollinating the + ;; cached values. + ;; + ;; Similarly, when there is no immediate SC. + ((and (or use-immed-p (not immed)) boxedp (leaf-info constant))) + ((and (or use-immed-p (not immed)) (not boxedp) (constant-boxed-tn constant))) + (t + (let* ((component (component-info *component-being-compiled*)) + (sc (svref *backend-sc-numbers* + (if use-immed-p + immed + (sc-number-or-lose 'constant)))) + (res (make-tn 0 :constant (primitive-type (leaf-type constant)) sc))) + (unless use-immed-p + (let ((constants (ir2-component-constants component))) + (setf (tn-offset res) (fill-pointer constants)) + (vector-push-extend constant constants))) + (push-in tn-next res (ir2-component-constant-tns component)) + (setf (tn-leaf res) constant) + res))))) (defun make-load-time-value-tn (handle type) (let* ((component (component-info *component-being-compiled*)) - (sc (svref *backend-sc-numbers* - (sc-number-or-lose 'constant))) - (res (make-tn 0 :constant (primitive-type type) sc)) - (constants (ir2-component-constants component))) + (sc (svref *backend-sc-numbers* + (sc-number-or-lose 'constant))) + (res (make-tn 0 :constant (primitive-type type) sc)) + (constants (ir2-component-constants component))) (setf (tn-offset res) (fill-pointer constants)) (vector-push-extend (cons :load-time-value handle) constants) (push-in tn-next res (ir2-component-constant-tns component)) @@ -229,11 +245,11 @@ (defun make-alias-tn (tn) (declare (type tn tn)) (let* ((component (component-info *component-being-compiled*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :alias (tn-primitive-type tn) nil))) + (res (make-tn (incf (ir2-component-global-tn-counter component)) + :alias (tn-primitive-type tn) nil))) (setf (tn-save-tn res) tn) (push-in tn-next res - (ir2-component-alias-tns component)) + (ir2-component-alias-tns component)) res)) ;;; Return a load-time constant TN with the specified KIND and INFO. @@ -242,25 +258,25 @@ (defun make-load-time-constant-tn (kind info) (declare (type keyword kind)) (let* ((component (component-info *component-being-compiled*)) - (res (make-tn 0 - :constant - *backend-t-primitive-type* - (svref *backend-sc-numbers* - (sc-number-or-lose 'constant)))) - (constants (ir2-component-constants component))) + (res (make-tn 0 + :constant + *backend-t-primitive-type* + (svref *backend-sc-numbers* + (sc-number-or-lose 'constant)))) + (constants (ir2-component-constants component))) (do ((i 0 (1+ i))) - ((= i (length constants)) - (setf (tn-offset res) i) - (vector-push-extend (cons kind info) constants)) + ((= i (length constants)) + (setf (tn-offset res) i) + (vector-push-extend (cons kind info) constants)) (let ((entry (aref constants i))) - (when (and (consp entry) - (eq (car entry) kind) - (or (eq (cdr entry) info) - (and (consp info) - (equal (cdr entry) info)))) - (setf (tn-offset res) i) - (return)))) + (when (and (consp entry) + (eq (car entry) kind) + (or (eq (cdr entry) info) + (and (consp info) + (equal (cdr entry) info)))) + (setf (tn-offset res) i) + (return)))) (push-in tn-next res (ir2-component-constant-tns component)) res)) @@ -275,8 +291,8 @@ (declare (type tn tn) (type boolean write-p)) (let ((res (make-tn-ref tn write-p))) (if write-p - (push-in tn-ref-next res (tn-writes tn)) - (push-in tn-ref-next res (tn-reads tn))) + (push-in tn-ref-next res (tn-writes tn)) + (push-in tn-ref-next res (tn-reads tn))) res)) ;;; Make TN-REFS to reference each TN in TNs, linked together by @@ -287,13 +303,13 @@ (declare (list tns) (type boolean write-p) (type (or tn-ref null) more)) (if tns (let* ((first (reference-tn (first tns) write-p)) - (prev first)) - (dolist (tn (rest tns)) - (let ((res (reference-tn tn write-p))) - (setf (tn-ref-across prev) res) - (setq prev res))) - (setf (tn-ref-across prev) more) - first) + (prev first)) + (dolist (tn (rest tns)) + (let ((res (reference-tn tn write-p))) + (setf (tn-ref-across prev) res) + (setq prev res))) + (setf (tn-ref-across prev) more) + first) more)) ;;; Remove Ref from the references for its associated TN. @@ -324,58 +340,47 @@ ;;; 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)) + (type template template) (type tn x y)) (let ((arg (reference-tn x nil)) - (result (reference-tn y t))) - (multiple-value-bind (first last) - (funcall (template-emit-function template) node block template arg - result) - (insert-vop-sequence first last block before) - last))) + (result (reference-tn y t))) + (emit-and-insert-vop node block template arg result before))) ;;; 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)) + (type template template) (type tn x y)) (let ((arg (reference-tn x nil)) - (result (reference-tn y t))) - (multiple-value-bind (first last) - (funcall (template-emit-function template) node block template arg - result info) - (insert-vop-sequence first last block before) - last))) + (result (reference-tn y t))) + (emit-and-insert-vop node block template arg result before info))) ;;; 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)) + (type template template) (type tn x f y)) (let ((x-ref (reference-tn x nil)) - (f-ref (reference-tn f nil)) - (y-ref (reference-tn y t))) + (f-ref (reference-tn f nil)) + (y-ref (reference-tn y t))) (setf (tn-ref-across x-ref) f-ref) - (multiple-value-bind (first last) - (funcall (template-emit-function template) node block template x-ref - y-ref) - (insert-vop-sequence first last block before) - last))) + (emit-and-insert-vop node block template x-ref y-ref before))) ;;; 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)) + (type template template) (type tn y)) (let ((y-ref (reference-tn y t))) - (multiple-value-bind (first last) - (funcall (template-emit-function template) node block template nil - y-ref) - (insert-vop-sequence first last block before) - last))) + (emit-and-insert-vop node block template nil y-ref before))) ;;; Return the label marking the start of Block, assigning one if necessary. (defun block-label (block) (declare (type cblock block)) (let ((2block (block-info block))) (or (ir2-block-%label 2block) - (setf (ir2-block-%label 2block) (gen-label))))) + (setf (ir2-block-%label 2block) (gen-label))))) +(defun block-trampoline (block) + (declare (type cblock block)) + (let ((2block (block-info block))) + (or (ir2-block-%trampoline-label 2block) + (setf (ir2-block-%trampoline-label 2block) (gen-label))))) ;;; Return true if Block is emitted immediately after the block ended by Node. (defun drop-thru-p (node block) @@ -383,28 +388,39 @@ (let ((next-block (ir2-block-next (block-info (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 -;;; VOP. If Before is NIL, insert at the end. -(defun insert-vop-sequence (first last block before) - (declare (type vop first last) (type ir2-block block) - (type (or vop null) before)) +(defun register-drop-thru (block) + (declare (type cblock block)) + (let ((2block (block-info block))) + (setf (ir2-block-dropped-thru-to 2block) t)) + nil) + +;;; Insert a VOP into BLOCK, before the specified +;;; BEFORE VOP. If BEFORE is NIL, insert at the end. +(defun insert-vop (vop block before) + (declare (type vop vop) (type ir2-block block) + (type (or vop null) before)) (if before (let ((prev (vop-prev before))) - (setf (vop-prev first) prev) - (if prev - (setf (vop-next prev) first) - (setf (ir2-block-start-vop block) first)) - (setf (vop-next last) before) - (setf (vop-prev before) last)) + (setf (vop-prev vop) prev) + (if prev + (setf (vop-next prev) vop) + (setf (ir2-block-start-vop block) vop)) + (setf (vop-next vop) before) + (setf (vop-prev before) vop)) (let ((current (ir2-block-last-vop block))) - (setf (vop-prev first) current) - (setf (ir2-block-last-vop block) last) - (if current - (setf (vop-next current) first) - (setf (ir2-block-start-vop block) first)))) + (setf (vop-prev vop) current) + (setf (ir2-block-last-vop block) vop) + (if current + (setf (vop-next current) vop) + (setf (ir2-block-start-vop block) vop)))) (values)) +(defun emit-and-insert-vop (node block template arg result before + &optional info) + (let ((vop (emit-vop node block template arg result info))) + (insert-vop vop block before) + vop)) + ;;; Delete all of the TN-REFs associated with VOP and remove VOP from the IR2. (defun delete-vop (vop) (declare (type vop vop)) @@ -413,14 +429,14 @@ (delete-tn-ref ref)) (let ((prev (vop-prev vop)) - (next (vop-next vop)) - (block (vop-block vop))) + (next (vop-next vop)) + (block (vop-block vop))) (if prev - (setf (vop-next prev) next) - (setf (ir2-block-start-vop block) next)) + (setf (vop-next prev) next) + (setf (ir2-block-start-vop block) next)) (if next - (setf (vop-prev next) prev) - (setf (ir2-block-last-vop block) prev))) + (setf (vop-prev next) prev) + (setf (ir2-block-last-vop block) prev))) (values)) @@ -437,15 +453,24 @@ (and (eq (sc-sb (tn-sc x)) (sc-sb (tn-sc y))) (eql (tn-offset x) (tn-offset y)) (not (or (eq (tn-kind x) :constant) - (eq (tn-kind y) :constant))))) + (eq (tn-kind y) :constant))))) ;;; 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))) + (aver (eq (tn-kind tn) :constant)) (constant-value (tn-leaf tn))) +(defun immediate-tn-p (tn) + (declare (type tn tn)) + (let ((leaf (tn-leaf tn))) + ;; Leaves with KIND :CONSTANT can have NIL as the leaf if they + ;; represent load time values. + (and leaf + (eq (tn-kind tn) :constant) + (eq (immediate-constant-sc (constant-value leaf)) + (sc-number-or-lose 'sb!vm::immediate))))) + ;;; Force TN to be allocated in a SC that doesn't need to be saved: an ;;; unbounded non-save-p SC. We don't actually make it a real "restricted" TN, ;;; but since we change the SC to an unbounded one, we should always succeed in @@ -454,13 +479,13 @@ (declare (type tn tn)) (let ((sc (tn-sc tn))) (unless (and (not (sc-save-p sc)) - (eq (sb-kind (sc-sb sc)) :unbounded)) + (eq (sb-kind (sc-sb sc)) :unbounded)) (dolist (alt (sc-alternate-scs 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)) - (setf (tn-sc tn) alt) - (return))))) + (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)) + (setf (tn-sc tn) alt) + (return))))) (values))