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 (sfunction (#!+immobile-code boolean fixnum fixnum
)
20 code-component
) allocate-code-object
))
21 (defun allocate-code-object (#!+immobile-code immobile-p boxed unboxed
)
24 (if (or #!+immobile-code immobile-p
)
25 #!+immobile-code
(sb!vm
::allocate-immobile-code boxed unboxed
)
28 (alien-funcall (extern-alien "alloc_code_object"
29 (function unsigned unsigned unsigned
))
32 (%primitive allocate-code-object boxed unboxed
))
34 ;; OFFSET is in bytes from the start of the code component's raw bytes
35 (defun new-simple-fun (code fun-index offset nfuns
)
36 (declare (type (unsigned-byte 27) fun-index
)
38 (type (unsigned-byte 14) nfuns
))
39 (unless (zerop (logand offset sb
!vm
:lowtag-mask
))
40 (bug "unaligned function object, offset = #X~X" offset
))
41 (let ((header-data (get-header-data code
)))
43 (let* ((n-header-words (logand header-data sb
!vm
:short-header-max-words
))
44 (index (+ (- sb
!vm
:other-pointer-lowtag
)
45 (ash n-header-words sb
!vm
:word-shift
)
46 (ash (1- fun-index
) 2))))
47 (aver (eql (sap-ref-32 (int-sap (get-lisp-obj-address code
)) index
) 0))
48 (setf (sap-ref-32 (int-sap (get-lisp-obj-address code
)) index
) offset
))
49 ;; Special case for the first simple-fun:
50 ;; The value range of 'offset' and 'nfuns' is the same
51 ;; regardless of word size.
52 ;; It's as if it's a positive 32-bit fixnum (29 significant bits).
53 ;; 16 bits is enough for the offset because it only needs to
54 ;; skip over the unboxed constants.
56 (let ((newval (logior (ash (the (mod #x8000
) offset
) 14) nfuns
)))
57 (aver (eql (sb!vm
::%code-n-entries code
) 0))
58 (setf (sb!vm
::%code-n-entries code
) newval
))
60 (let ((newval (logior (ash (the (mod #x8000
) offset
) 16) nfuns
)))
61 (aver (eql (ldb (byte 32 24) header-data
) 0))
62 (set-header-data code
(dpb newval
(byte 32 24) header-data
)))))
63 (let ((fun (%primitive sb
!c
:compute-fun code offset
)))
64 (setf (%simple-fun-self fun
) fun
)
67 ;;; Make a function entry, filling in slots from the ENTRY-INFO.
68 (defun make-fun-entry (fun-index entry-info code-obj object nfuns
)
69 (declare (type entry-info entry-info
) (type core-object object
))
70 (let ((res (new-simple-fun code-obj fun-index
71 (label-position (entry-info-offset entry-info
))
73 (setf (%simple-fun-name res
) (entry-info-name entry-info
))
74 (setf (%simple-fun-arglist res
) (entry-info-arguments entry-info
))
75 (setf (%simple-fun-type res
) (entry-info-type entry-info
))
76 (setf (%simple-fun-info res
) (entry-info-info entry-info
))
77 (note-fun entry-info res object
)))
79 ;;; Dump a component to core. We pass in the assembler fixups, code
80 ;;; vector and node info.
81 (defun make-core-component (component segment length fixup-notes object
)
82 (declare (type component component
)
83 (type segment segment
)
86 (type core-object object
))
87 (let ((debug-info (debug-info-for-component component
)))
88 ;; FIXME: use WITHOUT-GCING only for stuff that needs it.
89 ;; Most likely this could be WITH-PINNED-OBJECTS.
90 ;; See also the remark in LOAD-CODE about the order of installing
91 ;; simple-funs and setting the 'nfuns' value.
93 (let* ((2comp (component-info component
))
94 (constants (ir2-component-constants 2comp
))
95 (box-num (- (length constants
) sb
!vm
:code-constants-offset
))
96 (code-obj (allocate-code-object
97 #!+immobile-code
(eq *compile-to-memory-space
* :immobile
)
99 (declare (type index box-num length
))
101 (copy-byte-vector-to-system-area
102 (the (simple-array assembly-unit
1) (segment-contents-as-vector segment
))
103 (code-instructions code-obj
))
105 (do-core-fixups code-obj fixup-notes
)
107 (let* ((entries (ir2-component-entries 2comp
))
108 (nfuns (length entries
))
110 (dolist (entry entries
)
111 (make-fun-entry (decf fun-index
) entry code-obj object nfuns
)))
114 (sb!vm
:sanctify-for-execution code-obj
)
116 (push debug-info
(core-object-debug-info object
))
117 (setf (%code-debug-info code-obj
) debug-info
)
119 (do ((index sb
!vm
:code-constants-offset
(1+ index
)))
120 ((>= index
(length constants
)))
121 (let ((const (aref constants index
)))
125 (setf (code-header-ref code-obj index
)
126 (constant-value const
)))
130 (reference-core-fun code-obj index
(cdr const
) object
))
132 (setf (code-header-ref code-obj index
)
133 (find-or-create-fdefn (cdr const
))))
135 (setf (code-header-ref code-obj index
)
136 (%coerce-name-to-fun
(cdr const
))))))))))))