1 ;;;; Dump the current Lisp image into a core file. Also contains
2 ;;;; various high-level initialization stuff: loading init files and
3 ;;;; parsing environment variables.
5 ;;;; (All the real work is done by C.)
7 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; This software is derived from the CMU CL system, which was
11 ;;;; written at Carnegie Mellon University and released into the
12 ;;;; public domain. The software is in the public domain and is
13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
14 ;;;; files for more information.
16 (in-package "SB-IMPL")
18 ;;;; SAVE-LISP-AND-DIE itself
21 (define-alien-routine "save" (boolean)
23 (initial-fun (unsigned #.sb-vm
:n-word-bits
))
25 (save-runtime-options int
)
27 (compression-level int
)
28 (application-type int
))
30 (define-alien-routine "gc_and_save" void
34 (save-runtime-options int
)
36 (compression-level int
)
37 (application-type int
))
39 (define-alien-variable "lisp_init_function" (unsigned #.sb-vm
:n-machine-word-bits
))
41 (define-condition save-condition
(reference-condition)
44 :references
'((:sbcl
:node
"Saving a Core Image"))))
46 (define-condition save-error
(error save-condition
)
48 (:report
"Could not save core."))
50 (define-condition save-with-multiple-threads-error
(save-error)
51 ((interactive-thread :initarg
:interactive-threads
52 :reader save-with-multiple-threads-error-interactive-threads
)
53 (other-threads :initarg
:other-threads
54 :reader save-with-multiple-threads-error-other-threads
))
55 (:report
(lambda (condition stream
)
56 (let ((interactive (save-with-multiple-threads-error-interactive-threads condition
))
57 (other (save-with-multiple-threads-error-other-threads condition
)))
58 (format stream
"~@<Cannot save core with multiple threads running.~
59 ~@:_~@:_Interactive thread~P (of current session):~
60 ~@:_~2@T~<~{~A~^, ~}~:>~
61 ~@:_~@:_Other thread~P:~
62 ~@:_~2@T~<~{~A~^, ~}~:>~@:>"
63 (length interactive
) (list interactive
)
64 (length other
) (list other
))))))
66 ;;; This variable is accessed by C code when saving. Export it to survive tree-shaker.
67 ;;; The symbols in this set are clobbered just in time to avoid saving them to the core
68 ;;; but not so early that we kill the running image.
69 (export 'sb-kernel
::*save-lisp-clobbered-globals
* 'sb-kernel
)
70 (define-load-time-global sb-kernel
::*save-lisp-clobbered-globals
*
71 '#(sb-impl::*exit-lock
*
72 sb-vm
::*allocator-mutex
*
73 sb-thread
::*make-thread-lock
*
74 sb-thread
::*initial-thread
*
75 ;; Saving *JOINABLE-THREADS* could cause catastophic failure on restart.
76 ;; SAVE-LISP-AND-DIE should have cleaned up, but there's a timing problem
77 ;; with the finalizer thread, and I'm loathe to put in a SLEEP delay.
78 sb-thread
::*joinable-threads
*
79 sb-thread
::*all-threads
*
81 sb-kernel
::*gc-epoch
*))
83 (defun start-lisp (toplevel callable-exports
)
85 (named-lambda %start-lisp
()
87 (dolist (export callable-exports
)
88 (sb-alien::initialize-alien-callable-symbol export
)))
89 (named-lambda %start-lisp
()
90 (handling-end-of-the-world
92 (funcall toplevel
)))))
94 (defun save-lisp-and-die (core-file-name &key
95 (toplevel #'toplevel-init toplevel-supplied
)
97 (save-runtime-options nil
)
101 (environment-name "auxiliary")
104 (application-type :console
))
105 "Save a \"core image\", i.e. enough information to restart a Lisp
106 process later in the same state, in the file of the specified name.
107 Only global state is preserved: the stack is unwound in the process.
109 The following &KEY arguments are defined:
112 The function to run when the created core file is resumed. The
113 default function handles command line toplevel option processing
114 and runs the top level read-eval-print loop. This function returning
115 is equivalent to (SB-EXT:EXIT :CODE 0) being called.
117 TOPLEVEL functions should always provide an ABORT restart: otherwise
118 code they call will run without one.
121 If true, arrange to combine the SBCL runtime and the core image
122 to create a standalone executable. If false (the default), the
123 core image will not be executable on its own. Executable images
124 always behave as if they were passed the --noinform runtime option.
126 :SAVE-RUNTIME-OPTIONS
127 If true, values of runtime options --dynamic-space-size and
128 --control-stack-size that were used to start SBCL are stored in
129 the standalone executable, and restored when the executable is
130 run. This also inhibits normal runtime option processing, causing
131 all command line arguments to be passed to the toplevel.
132 Meaningless if :EXECUTABLE is NIL.
135 This should be a list of symbols to be initialized to the
136 appropriate alien callables on startup. All exported symbols should
137 be present as global symbols in the symbol table of the runtime
138 before the saved core is loaded. When this list is non-empty, the
139 :TOPLEVEL argument cannot be supplied.
142 If true (the default), then some objects in the restarted core will
143 be memory-mapped as read-only. Among those objects are numeric vectors
144 that were determined to be compile-time constants, and any immutable
145 values according to the language specification such as symbol names.
148 This should be a list of the main entry points in any newly loaded
149 systems. This need not be supplied, but locality and/or GC performance
150 may be better if they are. This has two different but related meanings:
151 If :PURIFY is true - and only for cheneygc - the root structures
152 are those which anchor the set of objects moved into static space.
153 On gencgc - and only on platforms supporting immobile code - these are
154 the functions and/or function-names which commence a depth-first scan
155 of code when reordering based on the statically observable call chain.
156 The complete set of reachable objects is not affected per se.
157 This argument is meaningless if neither enabling precondition holds.
160 This has no purpose; it is accepted only for legacy compatibility.
163 This is only meaningful if the runtime was built with the :SB-CORE-COMPRESSION
164 feature enabled. If NIL (the default), saves to uncompressed core files. If
165 :SB-CORE-COMPRESSION was enabled at build-time, the argument may also be
166 an integer from -7 to 22, corresponding to zstd compression levels, or T
167 (which is equivalent to the default compression level, 9).
170 Present only on Windows and is meaningful only with :EXECUTABLE T.
171 Specifies the subsystem of the executable, :CONSOLE or :GUI.
172 The notable difference is that :GUI doesn't automatically create a console
173 window. The default is :CONSOLE.
175 The save/load process changes the values of some global variables:
177 *STANDARD-OUTPUT*, *DEBUG-IO*, etc.
178 Everything related to open streams is necessarily changed, since
179 the OS won't let us preserve a stream across save and load.
181 *DEFAULT-PATHNAME-DEFAULTS*
182 This is reinitialized to reflect the working directory where the
183 saved core is loaded.
185 SAVE-LISP-AND-DIE interacts with SB-ALIEN:LOAD-SHARED-OBJECT: see its
186 documentation for details.
188 On threaded platforms only a single thread may remain running after
189 SB-EXT:*SAVE-HOOKS* have run. Applications using multiple threads can
190 be SAVE-LISP-AND-DIE friendly by registering a save-hook that quits
191 any additional threads, and an init-hook that restarts them.
193 This implementation is not as polished and painless as you might like:
194 * It corrupts the current Lisp image enough that the current process
195 needs to be killed afterwards. This can be worked around by forking
196 another process that saves the core.
197 * There is absolutely no binary compatibility of core images between
198 different runtime support programs. Even runtimes built from the same
199 sources at different times are treated as incompatible for this
201 This isn't because we like it this way, but just because there don't
202 seem to be good quick fixes for either limitation and no one has been
203 sufficiently motivated to do lengthy fixes."
204 (declare (ignore environment-name
))
205 (declare (ignorable root-structures
))
206 (when (and callable-exports toplevel-supplied
)
207 (error ":TOPLEVEL cannot be supplied when there are callable exports."))
208 ;; If the toplevel function is not defined, this will signal an
209 ;; error before saving, not at startup time.
210 (let ((toplevel (%coerce-callable-to-fun toplevel
))
211 *streams-closed-by-slad
*)
212 #+sb-core-compression
213 (check-type compression
(or boolean
(integer -
7 22)))
214 #-sb-core-compression
216 (error "Unable to save compressed core: this runtime was not built with zstd support"))
217 (when *dribble-stream
*
218 (restart-case (error "Dribbling to ~s is enabled." (pathname *dribble-stream
*))
220 :report
"Stop dribbling and save the core."
223 :report
"Abort saving the core."
224 (return-from save-lisp-and-die
))))
225 (when (eql t compression
)
226 (setf compression
9))
227 (flet ((foreign-bool (value)
229 (let ((name (native-namestring (physicalize-pathname core-file-name
)
231 (startfun (start-lisp toplevel callable-exports
)))
235 ;; Scan roots as close as possible to GC-AND-SAVE, in case anything
236 ;; prior causes compilation to occur into immobile space.
237 ;; Failing to see all immobile code would miss some relocs.
238 ;; FIXME: this could work on non-x86, but it doesn't right now.
239 #+(and x86-64 immobile-code
) (sb-vm::choose-code-component-order root-structures
)
240 ;; Must clear this cache if asm routines are movable.
241 (setq sb-disassem
::*assembler-routines-by-addr
* nil
242 ;; and save some space by deleting the instruction decoding table
243 ;; which can be rebuilt on demand. Must be done after DEINIT
244 ;; and CHOOSE-CODE-COMPONENT-ORDER both of which disassemble.
245 sb-disassem
::*disassem-inst-space
* nil
)
246 ;; Save the restart function. Logically a passed argument, but can't be,
247 ;; as it would require pinning around the whole save operation.
248 (with-pinned-objects (startfun)
249 (setf lisp-init-function
(get-lisp-obj-address startfun
)))
250 ;; Do a destructive non-conservative GC, and then save a core.
251 ;; A normal GC will leave huge amounts of storage unreclaimed
252 ;; (over 50% on x86). This needs to be done by a single function
253 ;; since the GC will invalidate the stack.
254 (sb-kernel::unsafe-clear-roots sb-vm
:+highest-normal-generation
+)
256 (foreign-bool executable
)
257 (foreign-bool purify
)
258 (foreign-bool save-runtime-options
)
259 (foreign-bool compression
)
261 #+win32
(ecase application-type
(:console
0) (:gui
1))
263 (setf lisp-init-function
0)) ; only reach here on save error
266 ;; Coalescing after GC will do no good - the un-needed dups
267 ;; of things won't actually go away. Do it before.
268 (alien-funcall (extern-alien "coalesce_similar_objects"
270 (if purify
(purify :root-structures root-structures
) (gc))
273 (get-lisp-obj-address startfun
)
274 (foreign-bool executable
)
275 (foreign-bool save-runtime-options
)
276 (foreign-bool compression
)
278 #+win32
(ecase application-type
(:console
0) (:gui
1))
281 ;; Something went very wrong -- reinitialize to have a prayer
282 ;; of being able to report the error.
285 (error 'save-error
)))
287 (defun tune-image-for-dump ()
288 ;; C code will GC again (nonconservatively if pertinent), but the coalescing
289 ;; steps done below will be more efficient if some junk is removed now.
292 ;; Share EQUALP FUN-INFOs
293 (let ((ht (make-hash-table :test
'equalp
)))
294 (sb-int:call-with-each-globaldb-name
296 (binding* ((info (info :function
:info name
) :exit-if-null
)
297 (shared-info (gethash info ht
)))
299 (setf (info :function
:info name
) shared-info
)
300 (setf (gethash info ht
) info
))))))
302 ;; Don't try to assign header slots of code objects. Any of them could be in
303 ;; readonly space. It's not worth the trouble to try to figure out which aren't.
304 #-cheneygc
(sb-c::coalesce-debug-info
) ; Share even more things
306 #+sb-fasteval
(sb-interpreter::flush-everything
)
307 (tune-hashset-sizes-of-all-packages))
310 (call-hooks "save" *save-hooks
*)
311 #+win32
(itimer-emulation-deinit)
314 (with-system-mutex (sb-thread::*make-thread-lock
*)
315 (finalizer-thread-stop)
316 (sb-thread::%dispose-thread-structs
)
317 (let ((threads (sb-thread:list-all-threads
))
319 (setq sb-thread
::*starting-threads
* ; ordinarily pruned in MAKE-THREAD
320 (delete 0 sb-thread
::*starting-threads
*)))
321 (joinable sb-thread
::*joinable-threads
*))
322 (when (or (cdr threads
) starting joinable
)
323 (let* ((interactive (sb-thread::interactive-threads
))
324 (other (union (set-difference threads interactive
)
325 (union starting joinable
))))
326 (setf error
(make-condition 'save-with-multiple-threads-error
327 :interactive-threads interactive
328 :other-threads other
))))))
329 (when error
(error error
))
330 #+allocator-metrics
(setq sb-thread
::*allocator-metrics
* nil
)
331 (setq sb-thread
::*sprof-data
* nil
))
332 (tune-image-for-dump)
336 (when (zerop (hash-table-count sb-kernel
::*forward-referenced-layouts
*))
337 ;; I think this table should always be empty but I'm not sure. If it is,
338 ;; recreate it so that we don't preserve an empty vector taking up 16KB
339 (setq sb-kernel
::*forward-referenced-layouts
* (make-hash-table :test
'equal
)))
340 ;; Clean up the simulated weak list of covered code components.
341 (rplacd *code-coverage-info
*
342 (delete-if-not #'weak-pointer-value
(cdr *code-coverage-info
*)))
343 (sb-kernel::rebuild-ctype-hashsets
)
344 (drop-all-hash-caches)
346 (clrhash sb-c
::*emitted-full-calls
*) ; Don't immortalize compiler's scratchpad
347 ;; Perform static linkage. Functions become un-statically-linked
348 ;; on demand, for TRACE, redefinition, etc.
349 #+(and immobile-code x86-64
) (sb-vm::statically-link-core
)
351 ;; Try to shrink the pathname cache. It might be largely nulls
352 (rebuild-pathname-cache)
353 (sb-vm::restore-cpu-specific-routines
)
354 ;; Do this last, to have some hope of printing if we need to.
356 (setf sb-c
::*compile-elapsed-time
* 0
357 sb-c
::*compile-file-elapsed-time
* 0)
358 (setf * nil
** nil
*** nil
359 - nil
+ nil
++ nil
+++ nil
360 /// nil
// nil
/ nil
))
364 (defun coalesce-debug-info ()
365 ;; Discard the uncompacted fun map cache.
366 (setq sb-di
::*uncompacted-fun-maps
* nil
)
367 ;; Discard the debugger's cached mapping of debug functions.
368 (setq sb-di
::*compiled-debug-funs
* nil
)
369 (flet ((debug-source= (a b
)
372 (equal (debug-source-plist a
) (debug-source-plist b
)))))
373 ;; Coalesce the following:
374 ;; DEBUG-INFO-SOURCE, SIMPLE-FUN-ARGLIST, SIMPLE-FUN-TYPE
375 ;; FUN-NAMES-EQUALISH considers any two string= gensyms as EQ.
376 (let ((source-ht (make-hash-table :test
'equal
))
377 (arglist-hash (make-hash-table :hash-function
'sb-impl
::equal-hash
378 :test
'sb-impl
::fun-names-equalish
))
379 (type-hash (make-hash-table :test
'equal
)))
380 (sb-vm:map-allocated-objects
381 (lambda (obj widetag size
)
382 (declare (ignore size
))
384 (#.sb-vm
:code-header-widetag
385 (dotimes (i (sb-kernel:code-n-entries obj
))
386 (let* ((fun (sb-kernel:%code-entry-point obj i
))
387 (arglist (%simple-fun-arglist fun
))
388 (info (%simple-fun-info fun
))
390 ((cons t simple-vector
) (car info
))
391 ((not simple-vector
) info
)))
392 (type (ensure-gethash type type-hash type
))
393 (xref (%simple-fun-xrefs fun
)))
394 (setf (%simple-fun-arglist fun
)
395 (ensure-gethash arglist arglist-hash arglist
))
396 (setf (sb-impl::%simple-fun-info fun
)
397 (if (and type xref
) (cons type xref
) (or type xref
))))))
398 (#.sb-vm
:instance-widetag
401 (let ((source (compiled-debug-info-source obj
)))
403 (core-debug-source) ; skip - uh, why?
405 (let* ((namestring (debug-source-namestring source
))
407 (find-if (lambda (x) (debug-source= x source
))
408 (gethash namestring source-ht
))))
409 (cond ((not canonical-repr
)
410 (push source
(gethash namestring source-ht
)))
411 ((neq source canonical-repr
)
412 (setf (compiled-debug-info-source obj
)
413 canonical-repr
))))))))
414 (sb-lockless::linked-list
415 ;; In the normal course of execution, incompletely deleted nodes
416 ;; exist only for a brief moment, as the next operation on the list by
417 ;; any thread that touches the logically deleted node can fully delete it.
418 ;; If somehow we get here and there are in fact pending deletions,
419 ;; they must be finished or else bad things can happen, since 'coreparse'
420 ;; can not deal with the untagged pointer convention.
421 (sb-lockless::finish-incomplete-deletions obj
))))))
426 ;;; Return the caller -> callee graph as an array grouped by caller.
427 ;;; i.e. each element is (CALLING-CODE-COMPONENT . CODE-COMPONENT*)).
428 ;;; A call is assumed only if we see a function or fdefn in the calling
429 ;;; component. This underestimates the call graph of course,
430 ;;; because it's impossible to predict whether calls occur through symbols,
431 ;;; arrays of functions, or anything else. But it's a good approximation.
432 (defun compute-direct-call-graph (&optional verbose
)
433 (let ((graph (make-array 10000 :adjustable t
:fill-pointer
0))
434 (gf-code-cache (make-hash-table :test
'eq
))
436 (labels ((get-gf-code (gf)
440 (dolist (method (sb-mop:generic-function-methods gf
) result
)
441 (let ((fun (sb-mop:method-function method
)))
442 (if (typep fun
'sb-pcl
::%method-function
)
444 (list* (code-from-fun (sb-pcl::%method-function-fast-function fun
))
445 (code-from-fun (%funcallable-instance-fun fun
))
447 (pushnew (code-from-fun fun
) result
)))))))
449 (ecase (%fun-pointer-widetag fun
)
450 (#.simple-fun-widetag
451 (fun-code-header fun
))
452 (#.funcallable-instance-widetag
453 (code-from-fun (%funcallable-instance-fun fun
)))
455 (fun-code-header (%closure-fun fun
))))))
456 (map-allocated-objects
457 (lambda (obj type size
)
459 (when (and (= type code-header-widetag
)
460 (plusp (code-n-entries obj
)))
463 (loop for j from code-constants-offset
464 below
(code-header-words obj
)
465 do
(let* ((const (code-header-ref obj j
))
467 (fdefn (fdefn-fun const
))
470 (if (typep fun
'generic-function
)
471 ;; Don't claim thousands of callees
472 (unless (and (typep const
'fdefn
)
473 (eq (fdefn-name const
) 'print-object
))
474 (setf list
(union (copy-list (get-gf-code fun
))
476 (pushnew (code-from-fun fun
) list
:test
'eq
)))))
478 (vector-push-extend (cons obj list
) graph
)))))
481 (format t
"~&Call graph: ~D nodes, ~D with out-edges, max-edges=~D~%"
484 (reduce (lambda (x y
) (max x
(length (cdr y
))))
485 graph
:initial-value
0)))
488 ;;; Return list of code components ordered in a quasi-predictable way,
489 ;;; provided that LOAD happened in a most 1 thread.
490 ;;; In general: user code sorts before system code, never-called code sorts
491 ;;; to the end, and ties are impossible due to uniqueness of serial#.
492 (defun deterministically-sort-immobile-code ()
493 (let ((forward-graph (compute-direct-call-graph))
494 (reverse-graph (make-hash-table :test
'eq
))
496 ;; Compute the inverted call graph as a hash-table
497 ;; for O(1) lookup of callers of any component.
498 (dovector (item forward-graph
)
499 (let ((caller (car item
))
500 (callees (cdr item
)))
501 (dolist (callee callees
)
502 (push caller
(gethash callee reverse-graph
)))))
503 ;; Compute popularity of each code component in text space
504 (map-allocated-objects
505 (lambda (obj type size
)
506 (declare (ignore size
))
507 (when (and (= type code-header-widetag
)
508 (plusp (code-n-entries obj
))
509 (immobile-space-addr-p (get-lisp-obj-address obj
)))
510 (push (cons (length (gethash obj reverse-graph
)) obj
) ranking
)))
512 ;; Sort by a 4-part key:
513 ;; - 1 bit : 0 = ever called, 1 = apparently un-called
514 ;; - 1 bit : system/non-system source file (system has lower precedence)
515 ;; - 8 bits : popularity (as computed above)
516 ;; - 32 bits : code component serial# (as stored on creation)
517 (flet ((calc-key (item &aux
(code (cdr item
)))
519 (or (let ((di (%code-debug-info code
)))
520 (and (typep di
'sb-c
::compiled-debug-info
)
521 (let ((src (sb-c::compiled-debug-info-source di
)))
522 (and (typep src
'sb-c
::debug-source
)
523 (let ((str (sb-c::debug-source-namestring src
)))
524 (if (= (mismatch str
"SYS:") 4) 1))))))
526 ;; cap the popularity index to 255 and negate so that higher
528 (popularity (- 255 (min (car item
) 255)))
529 (serialno (sb-impl::%code-serialno code
)))
530 (logior (ash (if (= (car item
) 0) 1 0) 41)
534 (mapcar #'cdr
(sort ranking
#'< :key
#'calc-key
)))))
537 (defun order-by-in-degree ()
538 (let ((compiler-stuff (make-hash-table :test
'eq
))
539 (other-stuff (make-hash-table :test
'eq
)))
540 (flet ((pick-table (fun-name)
541 (if (symbolp fun-name
)
542 (let ((package (symbol-package fun-name
)))
545 (cons sb-assem
::*backend-instruction-set-package
*
546 (mapcar 'find-package
547 '("SB-C" "SB-VM" "SB-FASL"
548 "SB-ASSEM" "SB-DISASSEM"
554 (hashtable-keys-sorted (table)
556 (sort (%hash-table-alist table
)
558 (cond ((> (cdr a
) (cdr b
)) t
) ; higher in-degree
559 ((< (cdr a
) (cdr b
)) nil
) ; lower in-degree
560 ;; break ties by name, and failing that,
561 ;; by address (which = random)
564 (%simple-fun-name
(%code-entry-point
(car a
) 0)))
566 (%simple-fun-name
(%code-entry-point
(car b
) 0))))
567 (if (and (symbolp name1
) (symbol-package name1
)
568 (symbolp name2
) (symbol-package name2
))
569 (let ((p1 (package-name (symbol-package name1
)))
570 (p2 (package-name (symbol-package name2
))))
571 (cond ((string< p1 p2
) t
)
572 ((string> p1 p2
) nil
)
573 ((string< name1 name2
))))
574 (< (get-lisp-obj-address (car a
))
575 (get-lisp-obj-address (car b
))))))))))))
576 (sb-vm:map-allocated-objects
577 (lambda (obj type size
)
579 (when (= type sb-vm
:code-header-widetag
)
580 (loop for i from sb-vm
:code-constants-offset
581 below
(code-header-words obj
)
582 do
(let ((ref (code-header-ref obj i
))
584 (when (and (fdefn-p ref
)
585 (simple-fun-p (setq fun
(fdefn-fun ref
)))
586 (immobile-space-obj-p fun
))
587 (let* ((code (fun-code-header fun
))
588 (ht (pick-table (%simple-fun-name
589 (%code-entry-point code
0)))))
590 (incf (gethash code ht
0))))))))
592 (append (hashtable-keys-sorted other-stuff
)
593 (hashtable-keys-sorted compiler-stuff
)))))
595 ;;; Passing your own toplevel functions as the root set
596 ;;; will encourage the defrag procedure to place them early
597 ;;; in the space, which should be better than leaving the
598 ;;; organization to random chance.
599 ;;; Note that these aren't roots in the GC sense, just a locality sense.
601 (defun choose-code-component-order (&optional roots
)
602 (declare (ignore roots
))
603 (let ((ordering (make-array 10000 :adjustable t
:fill-pointer
0))
604 (hashset (make-hash-table :test
'eq
)))
606 (labels ((emplace (code)
607 (unless (gethash code hashset
)
608 (setf (gethash code hashset
) t
)
609 (vector-push-extend code ordering
)))
612 (code-component (visit-code thing
))
613 (simple-fun (visit-code (fun-code-header thing
)))
614 (closure (visit (%closure-fun thing
)))
615 (symbol (when (and (fboundp thing
)
616 (not (special-operator-p thing
))
617 (not (macro-function thing
)))
618 (visit (symbol-function thing
))))))
619 (visit-code (code-component)
620 (when (or (not (immobile-space-obj-p code-component
))
621 (gethash code-component hashset
))
622 (return-from visit-code
))
623 (setf (gethash code-component hashset
) t
)
624 (vector-push-extend code-component ordering
)
625 (loop for i from sb-vm
:code-constants-offset
626 below
(code-header-words code-component
)
627 do
(let ((obj (code-header-ref code-component i
)))
629 (fdefn (awhen (fdefn-fun obj
) (visit it
)))
631 (vector (map nil
#'visit obj
)))))))
633 ;; Place assembler routines first.
634 (emplace sb-fasl
:*assembler-routines
*)
635 ;; Place functions called by assembler routines next.
636 (dovector (f +static-fdefns
+)
637 (emplace (fun-code-header (symbol-function f
))))
641 (let ((f (coerce x
'function
)))
642 (when (simple-fun-p f
)
643 (list (fun-code-header f
)))))
644 (or roots
'(read eval print compile
))))
646 (mapc #'emplace
(deterministically-sort-immobile-code))
648 (map-allocated-objects
649 (lambda (obj type size
)
650 (declare (ignore size
))
651 (when (and (= type code-header-widetag
)
652 (not (typep (%code-debug-info obj
) 'function
)))
656 (let* ((n (length ordering
))
657 (array (make-alien unsigned
(1+ (* n
2)))))
659 do
(setf (deref array
(* i
2)) (get-lisp-obj-address (aref ordering i
))))
660 (setf (deref array
(* n
2)) 0) ; null-terminate the array
661 (setf (extern-alien "code_component_order" unsigned
)
662 (sap-int (alien-value-sap array
)))))
664 (multiple-value-bind (index relocs
) (collect-immobile-code-relocs)
665 (let* ((n (length index
))
666 (array (make-alien unsigned n
)))
667 (dotimes (i n
) (setf (deref array i
) (aref index i
)))
668 (setf (extern-alien "immobile_space_reloc_index" unsigned
)
669 (sap-int (alien-value-sap array
))))
670 (let* ((n (length relocs
))
671 (array (make-alien unsigned n
)))
672 (dotimes (i n
) (setf (deref array i
) (aref relocs i
)))
673 (setf (extern-alien "immobile_space_relocs" unsigned
)
674 (sap-int (alien-value-sap array
))))))