1 ;;;; target-only code that knows how to load compiled code directly
4 ;;;; FIXME: The filename here is confusing because "core" here means
5 ;;;; "main memory", while elsewhere in the system it connotes a
6 ;;;; ".core" file dumping the contents of main memory.
8 ;;;; This software is part of the SBCL system. See the README file for
11 ;;;; This software is derived from the CMU CL system, which was
12 ;;;; written at Carnegie Mellon University and released into the
13 ;;;; public domain. The software is in the public domain and is
14 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
15 ;;;; files for more information.
19 (declaim (ftype (function (fixnum fixnum
) (values code-component
&optional
))
20 allocate-code-object
))
21 (defun allocate-code-object (boxed unboxed
)
25 (alien-funcall (extern-alien "alloc_code_object" (function unsigned unsigned unsigned
))
28 (%primitive allocate-code-object boxed unboxed
))
30 ;;; Make a function entry, filling in slots from the ENTRY-INFO.
31 (defun make-fun-entry (entry-info code-obj object
)
32 (declare (type entry-info entry-info
) (type core-object object
))
33 (let ((offset (label-position (entry-info-offset entry-info
))))
34 (declare (type index offset
))
35 (unless (zerop (logand offset sb
!vm
:lowtag-mask
))
36 (error "Unaligned function object, offset = #X~X." offset
))
37 (let ((res (%primitive compute-fun code-obj offset
)))
38 (setf (%simple-fun-self res
) res
)
39 (setf (%simple-fun-next res
) (%code-entry-points code-obj
))
40 (setf (%code-entry-points code-obj
) res
)
41 (setf (%simple-fun-name res
) (entry-info-name entry-info
))
42 (setf (%simple-fun-arglist res
) (entry-info-arguments entry-info
))
43 (setf (%simple-fun-type res
) (entry-info-type entry-info
))
44 (setf (%simple-fun-info res
) (entry-info-info entry-info
))
46 (note-fun entry-info res object
))))
48 ;;; Dump a component to core. We pass in the assembler fixups, code
49 ;;; vector and node info.
50 (defun make-core-component (component segment length fixup-notes object
)
51 (declare (type component component
)
52 (type sb
!assem
:segment segment
)
55 (type core-object object
))
57 (let* ((2comp (component-info component
))
58 (constants (ir2-component-constants 2comp
))
59 (box-num (- (length constants
) sb
!vm
:code-constants-offset
))
60 (code-obj (allocate-code-object box-num length
))
61 (fill-ptr (code-instructions code-obj
)))
62 (declare (type index box-num length
))
64 (let ((v (sb!assem
:segment-contents-as-vector segment
)))
65 (declare (type (simple-array sb
!assem
:assembly-unit
1) v
))
66 (copy-byte-vector-to-system-area v fill-ptr
)
67 (setf fill-ptr
(sap+ fill-ptr
(length v
))))
69 (do-core-fixups code-obj fixup-notes
)
71 (dolist (entry (ir2-component-entries 2comp
))
72 (make-fun-entry entry code-obj object
))
75 (sb!vm
:sanctify-for-execution code-obj
)
77 (let ((info (debug-info-for-component component
)))
78 (push info
(core-object-debug-info object
))
79 (setf (%code-debug-info code-obj
) info
))
81 (do ((index sb
!vm
:code-constants-offset
(1+ index
)))
82 ((>= index
(length constants
)))
83 (let ((const (aref constants index
)))
87 (setf (code-header-ref code-obj index
)
88 (constant-value const
)))
92 (reference-core-fun code-obj index
(cdr const
) object
))
94 (setf (code-header-ref code-obj index
)
95 (find-or-create-fdefn (cdr const
))))
97 (setf (code-header-ref code-obj index
)
98 (%coerce-name-to-fun
(cdr const
)))))))))))