Add abstraction for getting simple-fun instruction byte count

- New function %SIMPLE-FUN-TEXT-LEN

- Use %FUN-CODE-OFFSET instead of GET-CLOSURE-LENGTH for
  coputing backward displacement to containing code

package-data-list.lisp-expr

@@ -1747,7 +1747,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
  "FLOAT-FORMAT-MAX" "FLOAT-INT-EXPONENT"
  "FLOATING-POINT-EXCEPTION" "FORM" "FORMAT-CONTROL"
  "*FREE-INTERRUPT-CONTEXT-INDEX*" "FUNCALLABLE-INSTANCE-P"
- "FUN-CODE-HEADER"
+ "%FUN-CODE-OFFSET" "FUN-CODE-HEADER"
  "FUN-DESIGNATOR-TYPE" "FUN-DESIGNATOR-TYPE-P"
  "FUN-TYPE" "FUN-TYPE-ALLOWP"
  "FUN-TYPE-KEYP" "FUN-TYPE-KEYWORDS" "FUN-TYPE-NARGS"
@@ -2088,6 +2088,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
  "%SIMPLE-FUN-NAME"
  "%SIMPLE-FUN-NEXT" ; FIXME: remove
  "%SIMPLE-FUN-SELF" ; FIXME: don't export
+ "%SIMPLE-FUN-TEXT-LEN"
  "%SIMPLE-FUN-TYPE"
  "%SIMPLE-FUN-XREFS"
 

src/code/immobile-space.lisp

@@ -33,13 +33,7 @@
  (- n-word-bytes other-pointer-lowtag))
  ,addr-var))
  (setf (seg-virtual-location seg) ,addr-var
- (seg-length seg)
- (- (let ((next (%code-entry-point ,code-var (1+ fun-index))))
- (if next
- (- (get-lisp-obj-address next) fun-pointer-lowtag)
- (+ (sap-int (code-instructions ,code-var))
- (%code-code-size ,code-var))))
- ,addr-var))
+ (seg-length seg) (%simple-fun-text-len ,fun-var fun-index))
  ,@body))))
  ;; Slowness here is bothersome, especially for SB-VM::REMOVE-STATIC-LINKS,
  ;; so skip right over all fixedobj pages.
@@ -121,14 +115,12 @@
  (text-end (+ text-origin (%code-code-size code)))
  (relocs-index (fill-pointer relocs)))
  (dotimes (i (code-n-entries code) (finish-component code relocs-index))
- (let ((fun (%code-entry-point code i)))
+ (let* ((fun (%code-entry-point code i))
+ (fun-text (+ (get-lisp-obj-address fun)
+ (- fun-pointer-lowtag)
+ (ash simple-fun-code-offset word-shift))))
  (scan-function
- (+ (get-lisp-obj-address fun) (- fun-pointer-lowtag)
- (ash simple-fun-code-offset word-shift))
- (if (< (1+ i) (code-n-entries code))
- (- (get-lisp-obj-address (%code-entry-point code (1+ i)))
- fun-pointer-lowtag)
- text-end)
+ fun-text (+ fun-text (%simple-fun-text-len fun i))
  ;; Exclude transfers within this code component
  (lambda (jmp-targ-addr)
  (not (<= text-origin jmp-targ-addr text-end)))))))))

src/code/simple-fun.lisp

@@ -324,10 +324,21 @@
  new-value)
 
 (defun %simple-fun-next (simple-fun) ; DO NOT USE IN NEW CODE
- (let ((code-obj (fun-code-header simple-fun)))
- (dotimes (i (code-n-entries code-obj))
- (when (eq simple-fun (%code-entry-point code-obj i))
- (return (%code-entry-point code-obj (1+ i)))))))
+ (%code-entry-point (fun-code-header simple-fun)
+ (1+ (%simple-fun-index simple-fun))))
+
+;;; Return the number of bytes to subtract from the untagged address of SIMPLE-FUN
+;;; to obtain the untagged address of its code component.
+;;; Not to be confused with SIMPLE-FUN-CODE-OFFSET which is a constant.
+;;; See also CODE-FROM-FUNCTION.
+(declaim (inline %fun-code-offset))
+(defun %fun-code-offset (simple-fun)
+ (declare (type simple-fun simple-fun))
+ (ash (ash (with-pinned-objects (simple-fun)
+ (sap-ref-32 (int-sap (get-lisp-obj-address simple-fun))
+ (- sb!vm:fun-pointer-lowtag)))
+ (- sb!vm:n-widetag-bits))
+ sb!vm:word-shift))
 
 ;;;; CODE-COMPONENT
 
@@ -346,44 +357,86 @@
  ;; The header stores the count.
  #!+64-bit (ldb (byte 16 24) (get-header-data code-obj)))
 
+;;; Return the offset in bytes from (CODE-INSTRUCTIONS CODE-OBJ)
+;;; to its FUN-INDEXth function
+(declaim (inline %code-fun-offset))
+(defun %code-fun-offset (code-obj fun-index)
+ (declare ((unsigned-byte 16) fun-index))
+ (cond ((eql fun-index 0) ; special case for the first simple-fun
+ #!-64-bit (ldb (byte 16 14) (sb!vm::%code-n-entries code-obj))
+ #!+64-bit (ldb (byte 16 40) (get-header-data code-obj)))
+ (t
+ (let ((i (+ (- sb!vm:other-pointer-lowtag)
+ (ash (code-header-words code-obj)
+ sb!vm:word-shift)
+ (ash (1- fun-index) 2))))
+ (with-pinned-objects (code-obj)
+ (sap-ref-32 (int-sap (get-lisp-obj-address code-obj))
+ i))))))
+
 (defun %code-entry-point (code-obj fun-index)
  (declare (type (unsigned-byte 16) fun-index))
- (if (>= fun-index (code-n-entries code-obj))
- nil
- (%primitive sb!c:compute-fun
- code-obj
- (cond ((zerop fun-index) ; special case for the first simple-fun
- #!-64-bit (ldb (byte 16 14) (sb!vm::%code-n-entries code-obj))
- #!+64-bit (ldb (byte 16 40) (get-header-data code-obj)))
- (t
- (let ((i (+ (- sb!vm:other-pointer-lowtag)
- (ash (code-header-words code-obj)
- sb!vm:word-shift)
- (ash (1- fun-index) 2))))
- (with-pinned-objects (code-obj)
- (sap-ref-32 (int-sap (get-lisp-obj-address code-obj))
- i))))))))
+ (when (< fun-index (code-n-entries code-obj))
+ (truly-the function
+ (values (%primitive sb!c:compute-fun code-obj
+ (truly-the (unsigned-byte 32)
+ (%code-fun-offset code-obj fun-index)))))))
 
 (defun code-entry-points (code-obj) ; FIXME: obsolete
  (let ((a (make-array (code-n-entries code-obj))))
  (dotimes (i (length a) a)
  (setf (aref a i) (%code-entry-point code-obj i)))))
 
+;;; Return the 0-based index of SIMPLE-FUN within its code component.
+;;; Computed via binary search.
+(defun %simple-fun-index (simple-fun)
+ (let* ((code (fun-code-header simple-fun))
+ (n-entries (code-n-entries code)))
+ (if (eql n-entries 1)
+ 0
+ (let* ((offset (the (unsigned-byte 24)
+ (- (%fun-code-offset simple-fun)
+ (ash (code-header-words code) sb!vm:word-shift))))
+ (min 0)
+ (max (1- n-entries)))
+ (declare ((unsigned-byte 16) min max))
+ (loop
+ (let* ((index (floor (+ min max) 2))
+ (guess (%code-fun-offset code index)))
+ (cond ((< guess offset) (setq min (1+ index)))
+ ((> guess offset) (setq max (1- index)))
+ (t (return index)))
+ (aver (<= min max))))))))
+
+;;; Return the number of bytes of instructions in SIMPLE-FUN,
+;;; i.e. to the distance to the next simple-fun or end of code component.
+;;; If INDEX is specified, it is used to quickly find the next simple-fun.
+;;; Otherwise the code object is scanned to determine SIMPLE-FUN's index.
+(defun %simple-fun-text-len (simple-fun &optional index)
+ (let* ((code (fun-code-header simple-fun))
+ (max-index (1- (code-n-entries code))))
+ (- (cond ((eq simple-fun (%code-entry-point code max-index))
+ (if index
+ (aver (= index max-index))
+ (setq index max-index))
+ (%code-code-size code))
+ (t
+ (if index
+ (aver (eq (%code-entry-point code index) simple-fun))
+ (setq index (%simple-fun-index simple-fun)))
+ (%code-fun-offset code (1+ index))))
+ (%code-fun-offset code index)
+ (ash sb!vm:simple-fun-code-offset sb!vm:word-shift))))
+
 (defun code-n-unboxed-data-words (code-obj)
  ;; If the number of boxed words (from the header) is not the same as
  ;; the displacement backwards from the first simple-fun to the header,
  ;; then there are unboxed constants between the end of the boxed constants
  ;; and the first simple-fun.
  (let ((f (%code-entry-point code-obj 0)))
  (or (and f
- (let ((from (code-header-words code-obj))
- ;; Ignore the layout pointer (if present) in the upper bits
- ;; of the function header.
- (to (ldb (byte 24 sb!vm:n-widetag-bits)
- (with-pinned-objects (f)
- (sap-ref-word (int-sap (get-lisp-obj-address f))
- (- sb!vm:fun-pointer-lowtag))))))
- (and (< from to) (- to from))))
+ (- (ash (%fun-code-offset f) (- sb!vm:word-shift))
+ (code-header-words code-obj)))
  0)))
 
 ;;; Set (SYMBOL-FUNCTION SYMBOL) to a closure that signals an error,

src/compiler/target-disassem.lisp

@@ -321,14 +321,6 @@
  (- (get-lisp-obj-address simple-fun)
  sb!vm:fun-pointer-lowtag
  (sap-int (code-instructions (fun-code-header simple-fun)))))
-
-;;; the offset of FUNCTION from the start of its code-component
-(defun fun-offset (function)
- (declare (type simple-fun function))
- ;; FIXME: closure-length has fewer bits than the number of bits
- ;; specifying the offset from a function back to its code.
- ;; FUN_HEADER_NWORDS_MASK is 24 bits, closure-length is <= 15 bits
- (words-to-bytes (get-closure-length function)))
 
 ;;;; operations on code-components (which hold the instructions for
 ;;;; one or more functions)
@@ -1071,7 +1063,7 @@
  (dotimes (i (code-n-entries (seg-code segment)))
  (let* ((fun (%code-entry-point (seg-code segment) i))
  (length (seg-length segment))
- (offset (code-offs-to-segment-offs (fun-offset fun) segment)))
+ (offset (code-offs-to-segment-offs (%fun-code-offset fun) segment)))
  (when (<= 0 offset length)
  ;; Up to 2 words of zeros might be present to align the next
  ;; simple-fun. Limit on OFFSET is to avoid incorrect triggering
@@ -1203,9 +1195,9 @@
  do
  ;; There is function header fun-offset words from the
  ;; code header.
- (format t "Fun-header ~S at offset ~W (words):~% ~S ~A => ~S~%"
+ (format t "Fun-header ~S at offset #x~X (bytes):~% ~S ~A => ~S~%"
  fun
- (get-closure-length fun)
+ (%fun-code-offset fun)
  (%simple-fun-name fun)
  (%simple-fun-arglist fun)
  (%simple-fun-type fun)))))

tools-for-build/editcore.lisp

@@ -697,13 +697,10 @@
  (dotimes (j (code-n-entries code))
  (let* ((fun (%code-entry-point code j))
  (fun-addr (logandc2 (get-lisp-obj-address fun) lowtag-mask))
- (end (if (< (1+ j) (code-n-entries code))
- (logandc2 (get-lisp-obj-address (%code-entry-point code (1+ j)))
- lowtag-mask)
- (+ (translate-ptr code-addr spaces) objsize)))
  (entrypoint
  (+ fun-addr (* simple-fun-code-offset n-word-bytes)))
- (size (- end entrypoint))
+ (size (logandc2 (+ (%simple-fun-text-len fun j) sb-vm:lowtag-mask)
+ sb-vm:lowtag-mask))
  (lispname (fun-name-from-core fun spaces core-nil packages))
  (quotname (ldsym-quote (c-name lispname pp-state))))
  ;; Globalize the C symbol only if the name is a legal function designator