1 ;;;; Reorganization of immobile code space.
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB-KERNEL")
14 (defun immobile-space-p (obj)
15 (<= sb-vm
:immobile-space-start
(get-lisp-obj-address obj
) sb-vm
:immobile-space-end
))
17 (defun order-by-in-degree ()
18 (let ((compiler-stuff (make-hash-table :test
'eq
))
19 (other-stuff (make-hash-table :test
'eq
)))
20 (flet ((pick-table (fun-name)
21 (if (symbolp fun-name
)
22 (let ((package (symbol-package fun-name
)))
25 (cons sb-assem
::*backend-instruction-set-package
*
27 '("SB-C" "SB-VM" "SB-FASL"
28 "SB-ASSEM" "SB-DISASSEM"
34 (hashtable-keys-sorted (table)
36 (sort (%hash-table-alist table
)
38 (cond ((> (cdr a
) (cdr b
)) t
) ; higher in-degree
39 ((< (cdr a
) (cdr b
)) nil
) ; lower in-degree
40 ;; break ties by name, and failing that,
41 ;; by address (which = random)
44 (%simple-fun-name
(%code-entry-point
(car a
) 0)))
46 (%simple-fun-name
(%code-entry-point
(car b
) 0))))
47 (if (and (symbolp name1
) (symbol-package name1
)
48 (symbolp name2
) (symbol-package name2
))
49 (let ((p1 (package-name (symbol-package name1
)))
50 (p2 (package-name (symbol-package name2
))))
51 (cond ((string< p1 p2
) t
)
53 ((string< name1 name2
))))
54 (< (get-lisp-obj-address (car a
))
55 (get-lisp-obj-address (car b
))))))))))))
56 (sb-vm::map-allocated-objects
57 (lambda (obj type size
)
59 (when (= type sb-vm
:code-header-widetag
)
60 (loop for i from sb-vm
:code-constants-offset
61 below
(code-header-words obj
)
62 do
(let ((ref (code-header-ref obj i
)))
63 (when (and (fdefn-p ref
)
64 (simple-fun-p (fdefn-fun ref
)))
65 (let ((code (fun-code-header (fdefn-fun ref
))))
66 (when (immobile-space-p code
)
69 (%code-entry-point code
0)))))
70 (incf (gethash code ht
0))))))))))
72 (append (hashtable-keys-sorted other-stuff
)
73 (hashtable-keys-sorted compiler-stuff
)))))
75 ;;; Passing your own toplevel functions as the root set
76 ;;; will encourage the defrag procedure to place them early
77 ;;; in the space, which should be better than leaving the
78 ;;; organization to random chance.
79 ;;; Note that these aren't roots in the GC sense, just a locality sense.
80 (defun choose-code-component-order (&optional roots
)
81 (let ((ordering (make-array 10000 :adjustable t
:fill-pointer
0))
82 (hashset (make-hash-table :test
'eq
)))
84 ;; Place static funs first so that their addresses are really permanent.
85 ;; This simplifies saving an image when dynamic space functions point to
86 ;; immobile space functions - the x86 call sequence requires two
87 ;; instructions, and the fixupper does not understand that.
88 ;; (It's not too hard to enhance it, but not worth the trouble)
89 (dolist (fun-name sb-vm
:*static-funs
*)
90 (let ((code (fun-code-header (symbol-function fun-name
))))
91 (setf (gethash code hashset
) t
)
92 (vector-push-extend code ordering
)))
94 (labels ((visit (thing)
96 (code-component (visit-code thing
))
97 (simple-fun (visit-code (fun-code-header thing
)))
98 (closure (visit (%closure-fun thing
)))
99 (symbol (when (and (fboundp thing
)
100 (not (special-operator-p thing
))
101 (not (macro-function thing
)))
102 (visit (symbol-function thing
))))))
103 (visit-code (code-component)
104 (when (or (not (immobile-space-p code-component
))
105 (gethash code-component hashset
))
106 (return-from visit-code
))
107 (setf (gethash code-component hashset
) t
)
108 (vector-push-extend code-component ordering
)
109 (loop for i from sb-vm
:code-constants-offset
110 below
(code-header-words code-component
)
111 do
(let ((obj (code-header-ref code-component i
)))
113 (fdefn (awhen (fdefn-fun obj
) (visit it
)))
115 (vector (map nil
#'visit obj
)))))))
118 (let ((f (coerce x
'function
)))
119 (when (simple-fun-p f
)
120 (list (fun-code-header f
)))))
121 (or roots
'(read eval print compile
)))))
123 (dolist (code (order-by-in-degree))
124 (unless (gethash code hashset
)
125 (setf (gethash code hashset
) t
)
126 (vector-push-extend code ordering
)))
128 (sb-vm::map-allocated-objects
129 (lambda (obj type size
)
130 (declare (ignore size
))
131 (when (and (= type sb-vm
:code-header-widetag
)
132 (not (gethash obj hashset
)))
133 (setf (gethash obj hashset
) t
)
134 (vector-push-extend obj ordering
)))
137 (let* ((n (length ordering
))
138 (array (make-alien int
(1+ (* n
2)))))
140 do
(setf (deref array
(* i
2))
141 (get-lisp-obj-address (aref ordering i
))))
142 (setf (deref array
(* n
2)) 0) ; null-terminate the array
143 (setf (extern-alien "code_component_order" unsigned
)
144 (sap-int (alien-value-sap array
)))))
146 (multiple-value-bind (index relocs
) (sb-vm::collect-immobile-code-relocs
)
147 (let* ((n (length index
))
148 (array (make-alien int n
)))
149 (dotimes (i n
) (setf (deref array i
) (aref index i
)))
150 (setf (extern-alien "immobile_space_reloc_index" unsigned
)
151 (sap-int (alien-value-sap array
))))
152 (let* ((n (length relocs
))
153 (array (make-alien int n
)))
154 (dotimes (i n
) (setf (deref array i
) (aref relocs i
)))
155 (setf (extern-alien "immobile_space_relocs" unsigned
)
156 (sap-int (alien-value-sap array
))))))