mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Simplify logic around untagged fdefns
Untagged fdefns only pertained to named call when first implemented, but then later to IR2-CONVERT-GLOBAL-VAR as well. Distinct kinds of fdefn references from the code header are no longer needed. Also change :NAMED-CALL fixups to :FDEFN-CALL because they were confusable for :NAMED-CALL code constants, though not so much any more.
This commit is contained in:
Douglas Katzman
parent
851cbd2b77
commit
9dae557697
|
|
@ -158,10 +158,8 @@
|
|||
(let ((fun-entry (sb-vm::fdefn-raw-addr fdefn))
|
||||
(fdefn-entry (sb-vm::fdefn-entry-address fdefn)))
|
||||
(flet ((code-statically-links-fdefn-p (code)
|
||||
(let ((fdefns-start (+ code-constants-offset
|
||||
(* code-slots-per-simple-fun
|
||||
(code-n-entries code)))))
|
||||
(dotimes (i (code-n-named-calls code))
|
||||
(multiple-value-bind (fdefns-start count) (sb-vm::code-header-fdefn-range code)
|
||||
(dotimes (i count)
|
||||
(let ((constant (code-header-ref code (+ fdefns-start i))))
|
||||
(when (or (eq constant fdefn)
|
||||
(and (consp constant) (eq (car constant) fdefn)))
|
||||
|
|
|
|||
|
|
@ -425,18 +425,13 @@
|
|||
(declare (type code-component code-obj))
|
||||
(ash (code-fun-table-count code-obj) -5))
|
||||
|
||||
;;; Index to start of named-call fdefns
|
||||
;;; FIXME: Naming symmetry between this and code-n-named-calls might be nice.
|
||||
(defun code-fdefns-start-index (code-obj)
|
||||
(+ sb-vm:code-constants-offset
|
||||
(* (code-n-entries code-obj) sb-vm:code-slots-per-simple-fun)))
|
||||
|
||||
;;; Number of "called" fdefns, which does not count fdefns in the boxed
|
||||
;;; constants that are used in #'FUN syntax without a funcall necessarily
|
||||
;;; occuring, though it may.
|
||||
(defun code-n-named-calls (code-obj)
|
||||
(ash (sb-vm::%code-boxed-size code-obj)
|
||||
(+ -32 sb-vm:n-fixnum-tag-bits)))
|
||||
;;; Start and count of fdefns used in #'F synax or normal named call
|
||||
;;; (i.e. at the head of an expression)
|
||||
(defun sb-vm::code-header-fdefn-range (code-obj)
|
||||
(values (+ sb-vm:code-constants-offset
|
||||
(* (code-n-entries code-obj) sb-vm:code-slots-per-simple-fun))
|
||||
(ash (sb-vm::%code-boxed-size code-obj)
|
||||
(+ -32 sb-vm:n-fixnum-tag-bits))))
|
||||
|
||||
;;; Return the offset in bytes from (CODE-INSTRUCTIONS CODE-OBJ)
|
||||
;;; to its FUN-INDEXth function.
|
||||
|
|
|
|||
|
|
@ -160,7 +160,6 @@
|
|||
(def stack-ref (s n))
|
||||
(def fun-code-header)
|
||||
(def symbol-hash)
|
||||
#+sb-thread (def symbol-tls-index)
|
||||
(def symbol-%info) ; primitive reader always needs a stub
|
||||
;; but the "wrapped" reader might not need a stub.
|
||||
;; If it's already a proper function, then it doesn't.
|
||||
|
|
|
|||
|
|
@ -597,3 +597,5 @@ distinct from the global value. Can also be SETF."
|
|||
:datum new-value
|
||||
:expected-type spec)))))))
|
||||
nil))
|
||||
|
||||
#+sb-thread (defun symbol-tls-index (x) (symbol-tls-index x)) ; necessary stub
|
||||
|
|
|
|||
|
|
@ -355,13 +355,11 @@
|
|||
(unless (immobile-space-obj-p code)
|
||||
(return-from statically-link-code-obj code))
|
||||
#+immobile-code
|
||||
(let* ((fdefns-start (+ code-constants-offset
|
||||
(* code-slots-per-simple-fun (code-n-entries code))))
|
||||
(fdefns-count (the index (code-n-named-calls code)))
|
||||
(replacements (make-array fdefns-count :initial-element nil))
|
||||
(ambiguous (make-array fdefns-count :initial-element 0 :element-type 'bit))
|
||||
(any-replacements)
|
||||
(any-ambiguous))
|
||||
(binding* (((fdefns-start fdefns-count) (code-header-fdefn-range code))
|
||||
(replacements (make-array fdefns-count :initial-element nil))
|
||||
(ambiguous (make-array fdefns-count :initial-element 0 :element-type 'bit))
|
||||
(any-replacements nil)
|
||||
(any-ambiguous nil))
|
||||
;; For each fdefn, decide two things:
|
||||
;; * whether the fdefn can be replaced by its function - possible only when
|
||||
;; that function is in immobile space and needs no trampoline.
|
||||
|
|
|
|||
|
|
@ -1036,7 +1036,7 @@
|
|||
#(:assembly-routine :assembly-routine* :asm-routine-nil-offset
|
||||
:gc-barrier :symbol-tls-index
|
||||
:foreign :foreign-dataref :code-object
|
||||
:layout :immobile-symbol :named-call :static-call
|
||||
:layout :immobile-symbol :fdefn-call :static-call
|
||||
:symbol-value
|
||||
:layout-id)
|
||||
#'equalp)
|
||||
|
|
@ -1119,7 +1119,7 @@
|
|||
:immobile-symbol :symbol-value)
|
||||
(the symbol name))
|
||||
((:foreign :foreign-dataref) (the string name))
|
||||
((:named-call :static-call) name))))
|
||||
((:fdefn-call :static-call) name))))
|
||||
(dump-object info fasl-output)
|
||||
(incf nelements (cond (named (dump-object operand fasl-output) 2)
|
||||
(t 1))))))
|
||||
|
|
@ -1143,7 +1143,7 @@
|
|||
(let* ((2comp (component-info component))
|
||||
(constants (sb-c:ir2-component-constants 2comp))
|
||||
(header-length (length constants))
|
||||
(n-named-calls 0))
|
||||
(n-fdefns 0))
|
||||
(collect ((patches)
|
||||
(named-constants))
|
||||
;; Dump the constants, noting any :ENTRY constants that have to
|
||||
|
|
@ -1175,8 +1175,12 @@
|
|||
(dump-fop 'fop-misc-trap fasl-output)))))
|
||||
(:load-time-value
|
||||
(dump-push (cadr entry) fasl-output))
|
||||
((:named-call :fdefinition)
|
||||
(when (eq (car entry) :named-call) (incf n-named-calls))
|
||||
(:fdefinition
|
||||
;; It's possible for other fdefns to be found in the header, but they can't
|
||||
;; have resulted from IR2 conversion. They would have had to come from
|
||||
;; something like (load-time-value (find-or-create-fdefn ...))
|
||||
;; which is fine, but they don't count for this purpose.
|
||||
(incf n-fdefns)
|
||||
(dump-object (cadr entry) fasl-output)
|
||||
(dump-fop 'fop-fdefn fasl-output))
|
||||
(:known-fun
|
||||
|
|
@ -1209,7 +1213,7 @@
|
|||
(dump-integer-as-n-bytes (length (sb-c::ir2-component-entries 2comp))
|
||||
4 ; output 4 bytes
|
||||
fasl-output)
|
||||
(dump-integer-as-n-bytes (the (unsigned-byte 22) n-named-calls)
|
||||
(dump-integer-as-n-bytes (the (unsigned-byte 22) n-fdefns)
|
||||
4 ; output 4 bytes
|
||||
fasl-output)
|
||||
(dump-segment code-segment code-length fasl-output)
|
||||
|
|
|
|||
|
|
@ -2944,9 +2944,11 @@ Legal values for OFFSET are -4, -8, -12, ..."
|
|||
;; but an uninterned symbol is a descriptor.
|
||||
(descriptor-bits (if (symbolp name) (cold-intern name) name)))
|
||||
(:symbol-value (descriptor-bits (cold-symbol-value name)))
|
||||
(:named-call
|
||||
(:fdefn-call ; x86-64 only
|
||||
(+ (descriptor-bits (ensure-cold-fdefn name))
|
||||
(- 2 sb-vm:other-pointer-lowtag)))) ; wtf?
|
||||
;; this jumps to the jump instruction embedded within an fdefn.
|
||||
;; (It's a terrible technique which I plan to remove.)
|
||||
(- 2 sb-vm:other-pointer-lowtag))))
|
||||
kind flavor))))
|
||||
code-obj)
|
||||
|
||||
|
|
|
|||
|
|
@ -100,7 +100,7 @@
|
|||
;; (whose address we don't want to wire in).
|
||||
(:symbol-value (get-lisp-obj-address (symbol-global-value name)))
|
||||
#+immobile-code
|
||||
(:named-call
|
||||
(:fdefn-call
|
||||
(prog1 (sb-vm::fdefn-entry-address name) ; creates if didn't exist
|
||||
(when statically-link-p
|
||||
(push (cons offset (find-fdefn name)) (elt preserved-lists 0)))))
|
||||
|
|
@ -180,7 +180,7 @@
|
|||
#+x86-64
|
||||
(aver (not (nth-value
|
||||
1 (sb-c:unpack-code-fixup-locs (sb-vm::%code-fixups code)))))
|
||||
(aver (zerop (code-n-named-calls code)))
|
||||
(aver (zerop (nth-value 1 (sb-vm::code-header-fdefn-range code))))
|
||||
(let* ((nbytes (code-object-size code))
|
||||
(boxed (code-header-words code)) ; word count
|
||||
(unboxed (- nbytes (ash boxed sb-vm:word-shift))) ; byte count
|
||||
|
|
@ -296,18 +296,17 @@
|
|||
(const-patch-start-index
|
||||
(+ sb-vm:code-constants-offset (* (length (ir2-component-entries 2comp))
|
||||
sb-vm:code-slots-per-simple-fun)))
|
||||
(n-named-calls
|
||||
;; Pre-scan for fdefinitions to ensure their existence.
|
||||
;; Doing so guarantees that storing them into the boxed header now
|
||||
;; can't create any old->young pointer, which is important since gencgc
|
||||
;; does not deal with untagged pointers when looking for old->young.
|
||||
;; Pre-scan for all fdefinitions to ensure their existence, which guarantees that
|
||||
;; storing them into the boxed words can't can't create an old->young pointer.
|
||||
;; This is essential since gencgc will miss them when scanning the code header
|
||||
;; for such tagged pointers.
|
||||
(n-fdefns
|
||||
(do ((count 0)
|
||||
(index const-patch-start-index (1+ index)))
|
||||
((>= index n-boxed-words) count)
|
||||
(let ((const (aref constants index)))
|
||||
(when (and (listp const) (case (car const)
|
||||
(:named-call (incf count))
|
||||
(:fdefinition t)))
|
||||
(when (typep const '(cons (eql :fdefinition)))
|
||||
(incf count)
|
||||
(setf (second const) (find-or-create-fdefn (second const)))))))
|
||||
(retained-fixups (pack-retained-fixups fixup-notes))
|
||||
((code-obj total-nwords)
|
||||
|
|
@ -321,7 +320,7 @@
|
|||
(real-code-obj code-obj))
|
||||
(declare (ignorable boxed-data))
|
||||
(sb-fasl::with-writable-code-instructions
|
||||
(code-obj total-nwords debug-info n-named-calls n-simple-funs)
|
||||
(code-obj total-nwords debug-info n-fdefns n-simple-funs)
|
||||
:copy (%byte-blt bytes 0 (code-instructions code-obj) 0 (length bytes))
|
||||
:fixup (setq named-call-fixups
|
||||
(apply-core-fixups code-obj fixup-notes retained-fixups real-code-obj)))
|
||||
|
|
@ -371,10 +370,10 @@
|
|||
((eql :entry)
|
||||
(the function (gethash (leaf-info (cadr const))
|
||||
(core-object-entry-table object))))
|
||||
((member :named-call :fdefinition) (cadr const))
|
||||
((eql :fdefinition) (cadr const))
|
||||
((eql :known-fun) (%coerce-name-to-fun (cadr const)))
|
||||
(constant (constant-value const)))
|
||||
(eq kind :named-call))))
|
||||
(eq kind :fdefinition))))
|
||||
|
||||
#+darwin-jit (assign-code-constants code-obj boxed-data))
|
||||
|
||||
|
|
|
|||
|
|
@ -125,6 +125,8 @@
|
|||
(vop fast-symbol-global-value node block name-tn res)
|
||||
(vop symbol-global-value node block name-tn res))))
|
||||
(:global-function
|
||||
;; A :GLOBAL-FUNCTION refers to #'NAME for some purpose _other_ _than_
|
||||
;; NAME being a symbol at the CAR of a form (and referenced in FUN-LVAR-TN).
|
||||
;; In cross-compilation, testing (INFO :function :definition) is not
|
||||
;; sensible (or possible) but we can assume that things with fun-info
|
||||
;; will eventually be defined. If that's untrue, e.g. if we referred
|
||||
|
|
@ -145,25 +147,27 @@
|
|||
(eq pkg *cl-package*))))
|
||||
(t t))))
|
||||
(internal-name-p name))
|
||||
#-sb-xc-host (find-fdefn name)
|
||||
(info :function :info name)
|
||||
;; Known functions can be dumped without going through fdefns.
|
||||
;; But if NOTINLINEd, don't early-bind to the functional value
|
||||
;; because that disallows redefinition, including but not limited
|
||||
;; to encapsulations, which in turn makes TRACE not work, which
|
||||
;; leads to extreme frustration when debugging.
|
||||
(let ((*lexenv* (node-lexenv node)))
|
||||
(not (fun-lexically-notinline-p name))))
|
||||
;; Known functions can be dumped without going through fdefns.
|
||||
;; But if NOTINLINEd, don't early-bind to the functional value
|
||||
;; because that disallows redefinition, including but not limited
|
||||
;; to encapsulations, which in turn makes TRACE not work, which
|
||||
;; leads to extreme frustration when debugging.
|
||||
(not (fun-lexically-notinline-p name)))
|
||||
;; If NOT compiling to a file, then the function had better exist now.
|
||||
;; If to a file, then it better exist at some point, but its existence
|
||||
;; in the compilation lisp doesn't really imply that it will.
|
||||
#-sb-xc-host (if (producing-fasl-file) t (find-fdefn name)))
|
||||
(emit-move node block (make-load-time-constant-tn :known-fun name)
|
||||
res))
|
||||
(t
|
||||
#+untagged-fdefns
|
||||
(let ((fdefn-tn (make-load-time-constant-tn :named-call name)))
|
||||
(let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
|
||||
#+untagged-fdefns
|
||||
(if unsafe
|
||||
(vop sb-vm::untagged-fdefn-fun node block fdefn-tn res)
|
||||
(vop sb-vm::safe-untagged-fdefn-fun node block fdefn-tn res)))
|
||||
#-untagged-fdefns
|
||||
(let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
|
||||
(vop sb-vm::safe-untagged-fdefn-fun node block fdefn-tn res))
|
||||
#-untagged-fdefns
|
||||
(if unsafe
|
||||
(vop fdefn-fun node block fdefn-tn res)
|
||||
(vop safe-fdefn-fun node block fdefn-tn res)))))))))
|
||||
|
|
@ -1057,11 +1061,11 @@
|
|||
;; and CL:GENSYM, in case a piece of code mentions both.
|
||||
(let ((name (uncross (lvar-fun-name lvar t))))
|
||||
;; Static fdefns never need a code header constant.
|
||||
;; Calls to immobile space fdefns won't use the constant,
|
||||
;; but it needs to exist for GC's pointer tracing.
|
||||
(values (if (sb-vm::static-fdefn-offset name)
|
||||
name
|
||||
;; Calls to immobile space fdefns won't use this constant,
|
||||
;; but it needs to exist for GC's pointer tracing.
|
||||
(make-load-time-constant-tn :named-call name))
|
||||
(make-load-time-constant-tn :fdefinition name))
|
||||
name)))
|
||||
(t
|
||||
(values (lvar-tn node block lvar) nil)))))
|
||||
|
|
|
|||
|
|
@ -540,13 +540,11 @@
|
|||
#-sb-xc-host
|
||||
(defun code-header-ref (code index)
|
||||
(declare (index index))
|
||||
(let ((fdefns-start (sb-impl::code-fdefns-start-index code))
|
||||
(count (code-n-named-calls code)))
|
||||
(declare ((unsigned-byte 16) fdefns-start count))
|
||||
(values
|
||||
(if (and (>= index fdefns-start) (< index (+ fdefns-start count)))
|
||||
(%primitive code-header-ref+tag code index other-pointer-lowtag)
|
||||
(%primitive code-header-ref+tag code index 0)))))
|
||||
(binding* (((start count) (sb-vm::code-header-fdefn-range code))
|
||||
(end (+ start count)))
|
||||
(values (if (and (>= index start) (< index end))
|
||||
(%primitive code-header-ref+tag code index other-pointer-lowtag)
|
||||
(%primitive code-header-ref+tag code index 0)))))
|
||||
|
||||
(define-vop (code-header-set)
|
||||
(:translate code-header-set)
|
||||
|
|
|
|||
|
|
@ -810,11 +810,11 @@
|
|||
(dovector (constant unsorted)
|
||||
(incf old-offset)
|
||||
(when (eql pass (cond ((constant-p constant) 2)
|
||||
((eq (car constant) :named-call) 1)
|
||||
((eq (car constant) :fdefinition) 1)
|
||||
(t 3)))
|
||||
(let ((new-offset (vector-push-extend constant sorted)))
|
||||
(push (cons old-offset new-offset) renumbering))))))
|
||||
(scan 1) ; first all the called fdefinitions
|
||||
(scan 1) ; first all the fdefinitions use for call or global function ref (as in #'FUN)
|
||||
(scan 2) ; then IR1 constants
|
||||
(scan 3)) ; then various flavors of load-time magic
|
||||
;; Update the TN-OFFSET slot.
|
||||
|
|
|
|||
|
|
@ -842,10 +842,10 @@
|
|||
;;; if possible (without loading RAX)
|
||||
(defun emit-direct-call (name instruction node step-instrumenting)
|
||||
;; a :STATIC-CALL fixup is the address of the entry point of
|
||||
;; the function itself, and a :NAMED-CALL fixup is the address
|
||||
;; the function itself, and a :FDEFN-CALL fixup is the address
|
||||
;; of the JMP instruction embedded in the header for the named FDEFN.
|
||||
(let* ((fixup (make-fixup name
|
||||
(if (static-fdefn-offset name) :static-call :named-call)))
|
||||
(if (static-fdefn-offset name) :static-call :fdefn-call)))
|
||||
(target
|
||||
(if (and (sb-c::code-immobile-p node)
|
||||
(not step-instrumenting))
|
||||
|
|
|
|||
|
|
@ -3376,7 +3376,7 @@
|
|||
(flavor (fixup-flavor fixup)))
|
||||
(cond ((eq flavor :gc-barrier) (push offset imm-fixups))
|
||||
((and (memq flavor
|
||||
'(:named-call :layout :immobile-symbol :symbol-value ; -> fixedobj subspace
|
||||
'(:fdefn-call :layout :immobile-symbol :symbol-value ; -> fixedobj subspace
|
||||
:assembly-routine :assembly-routine* :static-call)) ; -> text subspace
|
||||
(eq kind :abs32))
|
||||
#+immobile-space (push offset abs32-fixups))
|
||||
|
|
|
|||
|
|
@ -2634,13 +2634,10 @@
|
|||
(push name names)))))
|
||||
(assert (not dup-fdefns)))))
|
||||
(dolist (c (sb-vm::list-allocated-objects :all :type sb-vm:code-header-widetag))
|
||||
(let* ((start (+ sb-vm:code-constants-offset
|
||||
(* (sb-kernel:code-n-entries c)
|
||||
sb-vm:code-slots-per-simple-fun)))
|
||||
(end (+ start (sb-kernel:code-n-named-calls c))))
|
||||
(sb-int:binding* (((start count) (sb-vm::code-header-fdefn-range c))
|
||||
(end (+ start count)))
|
||||
;; Within each subset of FDEFNs there should be no duplicates
|
||||
;; by name. But there could be an fdefn that is in the union of
|
||||
;; the ranges twice, if used for named call and a global ref.
|
||||
;; by name. But there could be an fdefn that is in the union of the two sets.
|
||||
(scan-range c start end)
|
||||
(scan-range c end (sb-kernel:code-header-words c))))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue