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
) (symbolp name2
))
48 (let ((p1 (package-name (symbol-package name1
)))
49 (p2 (package-name (symbol-package name2
))))
50 (cond ((string< p1 p2
) t
)
52 ((string< name1 name2
))))
53 (< (get-lisp-obj-address (car a
))
54 (get-lisp-obj-address (car b
))))))))))))
55 (sb-vm::map-allocated-objects
56 (lambda (obj type size
)
58 (when (= type sb-vm
:code-header-widetag
)
59 (loop for i from sb-vm
:code-constants-offset
60 below
(code-header-words obj
)
61 do
(let ((ref (code-header-ref obj i
)))
62 (when (and (fdefn-p ref
)
63 (simple-fun-p (fdefn-fun ref
)))
64 (let ((code (fun-code-header (fdefn-fun ref
))))
65 (when (immobile-space-p code
)
68 (%code-entry-point code
0)))))
69 (incf (gethash code ht
0))))))))))
71 (append (hashtable-keys-sorted other-stuff
)
72 (hashtable-keys-sorted compiler-stuff
)))))
74 ;;; Passing your own toplevel functions as the root set
75 ;;; will encourage the defrag procedure to place them early
76 ;;; in the space, which should be better than leaving the
77 ;;; organization to random chance.
78 ;;; Note that these aren't roots in the GC sense, just a locality sense.
79 (defun choose-code-component-order (&optional roots
)
80 (let ((ordering (make-array 10000 :adjustable t
:fill-pointer
0))
81 (hashset (make-hash-table :test
'eq
)))
83 ;; Place static funs first so that their addresses are really permanent.
84 ;; This simplifies saving an image when dynamic space functions point to
85 ;; immobile space functions - the x86 call sequence requires two
86 ;; instructions, and the fixupper does not understand that.
87 ;; (It's not too hard to enhance it, but not worth the trouble)
88 (dolist (fun-name sb-vm
:*static-funs
*)
89 (let ((code (fun-code-header (symbol-function fun-name
))))
90 (setf (gethash code hashset
) t
)
91 (vector-push-extend code ordering
)))
93 (labels ((visit (thing)
95 (code-component (visit-code thing
))
96 (simple-fun (visit-code (fun-code-header thing
)))
97 (closure (visit (%closure-fun thing
)))
98 (symbol (when (and (fboundp thing
)
99 (not (special-operator-p thing
))
100 (not (macro-function thing
)))
101 (visit (symbol-function thing
))))))
102 (visit-code (code-component)
103 (when (or (not (immobile-space-p code-component
))
104 (gethash code-component hashset
))
105 (return-from visit-code
))
106 (setf (gethash code-component hashset
) t
)
107 (vector-push-extend code-component ordering
)
108 (loop for i from sb-vm
:code-constants-offset
109 below
(code-header-words code-component
)
110 do
(let ((obj (code-header-ref code-component i
)))
112 (fdefn (awhen (fdefn-fun obj
) (visit it
)))
114 (vector (map nil
#'visit obj
)))))))
117 (let ((f (coerce x
'function
)))
118 (when (simple-fun-p f
)
119 (list (fun-code-header f
)))))
120 (or roots
'(read eval print compile
)))))
122 (dolist (code (order-by-in-degree))
123 (unless (gethash code hashset
)
124 (setf (gethash code hashset
) t
)
125 (vector-push-extend code ordering
)))
127 (sb-vm::map-allocated-objects
128 (lambda (obj type size
)
129 (declare (ignore size
))
130 (when (and (= type sb-vm
:code-header-widetag
)
131 (not (gethash obj hashset
)))
132 (setf (gethash obj hashset
) t
)
133 (vector-push-extend obj ordering
)))
136 (let* ((n (length ordering
))
137 (array (make-alien int
(1+ (* n
2)))))
139 do
(setf (deref array
(* i
2))
140 (get-lisp-obj-address (aref ordering i
))))
141 (setf (deref array
(* n
2)) 0) ; null-terminate the array
142 (setf (extern-alien "code_component_order" unsigned
)
143 (sap-int (alien-value-sap array
)))))
145 (multiple-value-bind (index relocs
) (sb-vm::collect-immobile-code-relocs
)
146 (let* ((n (length index
))
147 (array (make-alien int n
)))
148 (dotimes (i n
) (setf (deref array i
) (aref index i
)))
149 (setf (extern-alien "immobile_space_reloc_index" unsigned
)
150 (sap-int (alien-value-sap array
))))
151 (let* ((n (length relocs
))
152 (array (make-alien int n
)))
153 (dotimes (i n
) (setf (deref array i
) (aref relocs i
)))
154 (setf (extern-alien "immobile_space_relocs" unsigned
)
155 (sap-int (alien-value-sap array
))))))
