mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
set-slot-old-p: consider pseudo-static constants as always old.
Even if there's no allocator.
This commit is contained in:
Stas Boukarev
parent
aa6294b756
commit
7354472bb5
|
|
@ -337,10 +337,13 @@ Please check that all strings which were not recognizable to the compiler
|
|||
;; SAVE-LISP-AND-DIE.
|
||||
#-sb-devel (!unintern-init-only-stuff)
|
||||
|
||||
;; A symbol whose INFO slot underwent any kind of manipulation
|
||||
;; such that it now has neither properties nor globaldb info,
|
||||
;; can have the slot set back to NIL if it wasn't already.
|
||||
|
||||
(do-all-symbols (symbol)
|
||||
(sb-kernel:logior-header-bits symbol sb-vm::+symbol-initial-core+)
|
||||
|
||||
;; A symbol whose INFO slot underwent any kind of manipulation
|
||||
;; such that it now has neither properties nor globaldb info,
|
||||
;; can have the slot set back to NIL if it wasn't already.
|
||||
(when (and (sb-kernel:symbol-%info symbol) ; "raw" value is something
|
||||
;; but both "cooked" values are empty
|
||||
(null (sb-kernel:symbol-dbinfo symbol))
|
||||
|
|
|
|||
|
|
@ -446,6 +446,7 @@
|
|||
;;; case where PROGV invokes UNBIND.
|
||||
;;; This is a mask tested against GET-HEADER-DATA, so skip over the payload size byte.
|
||||
(defconstant +symbol-fast-bindable+ #x100)
|
||||
(defconstant +symbol-initial-core+ #x200)
|
||||
|
||||
;;; Bit indices of the status bits in an INSTANCE header
|
||||
;;; that implement lazily computed stable hash codes.
|
||||
|
|
|
|||
|
|
@ -359,20 +359,25 @@
|
|||
;; If immediate non-pointer, elide the barrier
|
||||
(when (sc-is tn immediate)
|
||||
(let ((value (tn-value tn)))
|
||||
(when (or (sb-xc:typep value ' (or character sb-xc:fixnum
|
||||
#+64-bit single-float
|
||||
boolean))
|
||||
(and (symbolp value)
|
||||
#-sb-xc-host
|
||||
(and (immobile-space-obj-p value)
|
||||
(= (generation-of value) +pseudo-static-generation+))))
|
||||
(when (sb-xc:typep value '(or character sb-xc:fixnum
|
||||
#+64-bit single-float
|
||||
boolean))
|
||||
(return-from potential-heap-pointer-p nil))))
|
||||
(when (sb-c::unbound-marker-tn-p tn)
|
||||
(return-from potential-heap-pointer-p nil))
|
||||
;; And elide for things like (OR FIXNUM NULL)
|
||||
(let ((type (tn-ref-type tn-ref)))
|
||||
(when (csubtypep type (specifier-type '(or character sb-xc:fixnum boolean
|
||||
#+64-bit single-float)))
|
||||
(when (or (csubtypep type #1=(specifier-type '(or character sb-xc:fixnum boolean
|
||||
#+64-bit single-float)))
|
||||
(let ((diff (type-difference type #1#)))
|
||||
(and (member-type-p diff)
|
||||
#-sb-xc-host
|
||||
(loop for member in (member-type-members diff)
|
||||
always
|
||||
(and (eql (generation-of member) +pseudo-static-generation+)
|
||||
(or (not (sb-c::producing-fasl-file))
|
||||
(and (symbolp member)
|
||||
(logtest +symbol-initial-core+ (get-header-data member)))))))))
|
||||
(return-from potential-heap-pointer-p nil)))
|
||||
t)
|
||||
(boxed-tn-p (value-tn)
|
||||
|
|
|
|||
|
|
@ -514,77 +514,96 @@
|
|||
(dominates-p block1 block2)))))
|
||||
|
||||
(defun set-slot-old-p (node nth-value)
|
||||
(when (combination-p node)
|
||||
(when (lvar-fun-is (combination-fun node) '(initialize-vector))
|
||||
(return-from set-slot-old-p t))
|
||||
(let ((args (combination-args node)))
|
||||
(when (lvar-fun-is (combination-fun node) '(%%primitive))
|
||||
(pop args))
|
||||
(let* ((object-lvar (first args))
|
||||
(value-lvar (nth nth-value args))
|
||||
;; (object-ref (principal-lvar-ref object-lvar t))
|
||||
;; (object-lambda-var (and (ref-p object-ref)
|
||||
;; (ref-leaf object-ref)))
|
||||
;; (uses (lvar-uses value-lvar))
|
||||
(allocator (principal-lvar-ref-use object-lvar t)))
|
||||
(labels ((born-before-p (node)
|
||||
(block nil
|
||||
(map-all-uses
|
||||
(lambda (use)
|
||||
(cond ((and (ref-p use)
|
||||
(let ((var (ref-leaf use)))
|
||||
(or (constant-p var)
|
||||
(when (and (lambda-var-p var)
|
||||
(not (lambda-var-sets var)))
|
||||
(let ((home (lambda-var-home var)))
|
||||
(and (member (functional-kind home) '(:external :optional))
|
||||
(or (eq (node-environment node)
|
||||
(lambda-environment (if (eq (functional-kind home) :external)
|
||||
(main-entry (functional-entry-fun home))
|
||||
home)))
|
||||
(return)))))))))
|
||||
((not (node-dominates-p use node))
|
||||
(return))))
|
||||
value-lvar)
|
||||
t)))
|
||||
(let ((old-p (when (and (combination-p allocator)
|
||||
(or
|
||||
(lvar-fun-is (combination-fun allocator) '(list* list
|
||||
%make-structure-instance
|
||||
%make-instance
|
||||
%make-instance/mixed
|
||||
%make-funcallable-instance
|
||||
copy-structure))
|
||||
(and (lvar-fun-is (combination-fun allocator) '(sb-vm::splat))
|
||||
(let ((allocator (principal-lvar-ref-use
|
||||
(principal-lvar (first (combination-args allocator))))))
|
||||
(and (combination-p allocator)
|
||||
(lvar-fun-is (combination-fun allocator) '(allocate-vector)))))
|
||||
(let* ((name (lvar-fun-name (combination-fun allocator) t)))
|
||||
(typep (info :function :source-transform name)
|
||||
'(cons * (eql :constructor))))))
|
||||
(born-before-p allocator))))
|
||||
;;; Doesn't work because if there's a GC between two
|
||||
;;; stores and the object doesn't get a sticky-mark
|
||||
;;; (because it was on the stack, or the gc is triggered
|
||||
;;; by the current thread) it won't preserve the mark.
|
||||
;; (when (and (lambda-var-p object-lambda-var)
|
||||
;; (not old-p)
|
||||
;; (not (lvar-fun-is (combination-fun node)
|
||||
;; '(sb-kernel:data-vector-set
|
||||
;; sb-kernel:data-vector-set-with-offset))))
|
||||
;; (let ((previous-sets (lambda-var-constraints object-lambda-var)))
|
||||
;; (cond ((consp previous-sets)
|
||||
;; (if (and uses
|
||||
;; (loop for set in previous-sets
|
||||
;; thereis (and (node-dominates-p set node)
|
||||
;; (born-before-p set))))
|
||||
;; (setf old-p t)
|
||||
;; (push node (lambda-var-constraints object-lambda-var))))
|
||||
;; (t
|
||||
;; ;; Reuse the slot
|
||||
;; (setf (lambda-var-constraints object-lambda-var) (list node))))))
|
||||
old-p))))))
|
||||
(flet ((pseudo-static-value-p (lvar)
|
||||
(block nil
|
||||
(map-all-uses
|
||||
(lambda (use)
|
||||
(unless (and (ref-p use)
|
||||
(constant-p (ref-leaf use))
|
||||
#-sb-xc-host
|
||||
(let ((value (constant-value (ref-leaf use))))
|
||||
(or (typep value '(or character sb-xc:fixnum #+64-bit single-float boolean))
|
||||
(and (eql (generation-of value) sb-vm:+pseudo-static-generation+)
|
||||
(or (not (sb-c::producing-fasl-file))
|
||||
(and (symbolp value)
|
||||
(logtest sb-vm::+symbol-initial-core+ (get-header-data value))))))))
|
||||
(return)))
|
||||
lvar)
|
||||
t)))
|
||||
(cond ((set-p node)
|
||||
(pseudo-static-value-p (set-value node)))
|
||||
((combination-p node)
|
||||
(when (lvar-fun-is (combination-fun node) '(initialize-vector))
|
||||
(return-from set-slot-old-p t))
|
||||
(let ((args (combination-args node)))
|
||||
(when (lvar-fun-is (combination-fun node) '(%%primitive))
|
||||
(pop args))
|
||||
(let* ((object-lvar (first args))
|
||||
(value-lvar (nth nth-value args))
|
||||
;; (object-ref (principal-lvar-ref object-lvar t))
|
||||
;; (object-lambda-var (and (ref-p object-ref)
|
||||
;; (ref-leaf object-ref)))
|
||||
;; (uses (lvar-uses value-lvar))
|
||||
(allocator (principal-lvar-ref-use object-lvar t)))
|
||||
(labels ((born-before-p (node)
|
||||
(block nil
|
||||
(map-all-uses
|
||||
(lambda (use)
|
||||
(cond ((and (ref-p use)
|
||||
(let ((var (ref-leaf use)))
|
||||
(or (constant-p var)
|
||||
(when (and (lambda-var-p var)
|
||||
(not (lambda-var-sets var)))
|
||||
(let ((home (lambda-var-home var)))
|
||||
(and (member (functional-kind home) '(:external :optional))
|
||||
(or (eq (node-environment node)
|
||||
(lambda-environment (if (eq (functional-kind home) :external)
|
||||
(main-entry (functional-entry-fun home))
|
||||
home)))
|
||||
(return)))))))))
|
||||
((not (node-dominates-p use node))
|
||||
(return))))
|
||||
value-lvar)
|
||||
t)))
|
||||
(let ((old-p (when (and (combination-p allocator)
|
||||
(or
|
||||
(lvar-fun-is (combination-fun allocator) '(list* list
|
||||
%make-structure-instance
|
||||
%make-instance
|
||||
%make-instance/mixed
|
||||
%make-funcallable-instance
|
||||
copy-structure))
|
||||
(and (lvar-fun-is (combination-fun allocator) '(sb-vm::splat))
|
||||
(let ((allocator (principal-lvar-ref-use
|
||||
(principal-lvar (first (combination-args allocator))))))
|
||||
(and (combination-p allocator)
|
||||
(lvar-fun-is (combination-fun allocator) '(allocate-vector)))))
|
||||
(let* ((name (lvar-fun-name (combination-fun allocator) t)))
|
||||
(typep (info :function :source-transform name)
|
||||
'(cons * (eql :constructor))))))
|
||||
(born-before-p allocator))))
|
||||
;; Doesn't work because if there's a GC between two
|
||||
;; stores and the object doesn't get a sticky-mark
|
||||
;; (because it was on the stack, or the gc is triggered
|
||||
;; by the current thread) it won't preserve the mark.
|
||||
;; (when (and (lambda-var-p object-lambda-var)
|
||||
;; (not old-p)
|
||||
;; (not (lvar-fun-is (combination-fun node)
|
||||
;; '(sb-kernel:data-vector-set
|
||||
;; sb-kernel:data-vector-set-with-offset))))
|
||||
;; (let ((previous-sets (lambda-var-constraints object-lambda-var)))
|
||||
;; (cond ((consp previous-sets)
|
||||
;; (if (and uses
|
||||
;; (loop for set in previous-sets
|
||||
;; thereis (and (node-dominates-p set node)
|
||||
;; (born-before-p set))))
|
||||
;; (setf old-p t)
|
||||
;; (push node (lambda-var-constraints object-lambda-var))))
|
||||
;; (t
|
||||
;; ;; Reuse the slot
|
||||
;; (setf (lambda-var-constraints object-lambda-var) (list node))))))
|
||||
(or old-p
|
||||
(pseudo-static-value-p value-lvar))))))))))
|
||||
|
||||
;;;; block starting/creation
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue