1 ;;;; Compile the fundamental system sources (not CLOS, and possibly
2 ;;;; not some other warm-load-only stuff like DESCRIBE) to produce
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
14 (in-package "SB-COLD")
16 ;;; FIXME: I think it's a mistake that we load muffler twice in
17 ;;; make-host-2 (once for the host, once for XC), because the host
18 ;;; should produce no new warnings, and because it's really hard
19 ;;; to think straight when you figure that we're using the host's
20 ;;; SIGNAL and type system but mixing it with our types.
21 ;;; We can just bake in some behavior to the cross-compiler never to warn
22 ;;; about sh*t that we think isn't warning-worthy.
23 ;;; (i.e. do it in source code using #[-+]sb-xc-host).
24 ;;; The target compiler will still get everything as usual.
25 (let ((*features
* (cons :sb-xc
*features
*)))
26 (load (sb-cold:find-bootstrap-file
"^muffler")))
28 ;;; Ordinarily the types carried around as "handled conditions" while compiling
29 ;;; have been parsed into internal CTYPE objects. However, using parsed objects
30 ;;; in the cross-compiler was confusing as hell.
31 ;;; Consider any toplevel form in make-host-2 - it will have constants in it,
32 ;;; and we need to know if each constant is dumpable. So we call DUMPABLE-LEAFLIKE-P
33 ;;; which invokes SB-XC:TYPEP. But SB-XC:TYPEP may know nothing of a particular struct type
34 ;;; until that DEFSTRUCT is seen. So how did it ever work? Well, for starters,
35 ;;; if it's an unknown type, we need to signal a PARSE-UNKNOWN-TYPE condition.
36 ;;; To signal that, we check whether that condition is in *HANDLED-CONDITIONS*.
37 ;;; The way we tested that is to unparse the entry and then use CL:TYPEP on the
38 ;;; specifier. (rev 2bad5ce54d5692a0 "Represent LEXENV-HANDLED-CONDITIONS as CTYPEs")
40 ;;; (HANDLE-CONDITION-P #<PARSE-UNKNOWN-TYPE {1003172603}>)
41 ;;; -> (UNION-UNPARSE-TYPE-METHOD #<UNION-TYPE (OR (SATISFIES UNABLE-TO-OPTIMIZE-NOTE-P) ...)>)
42 ;;; -> (TYPE= #<UNION-TYPE (OR (SATISFIES UNABLE-TO-OPTIMIZE-NOTE-P) ...)> #<UNION-TYPE LIST>)
43 ;;; -> ... lots more frames ...
44 ;;; -> (CTYPEP NIL #<HAIRY-TYPE (SATISFIES UNABLE-TO-OPTIMIZE-NOTE-P)>)
45 ;;; While means while merely unparsing, we have to reason about UNION-TYPE
46 ;;; and UNKNOWN-TYPE, which might entail invoking (CROSS-TYPEP 'NIL #<an-unknown-type>)
47 ;;; i.e. we can't even unparse a parsed type without reasoning about whether
48 ;;; we should signal a condition about the condition we're trying to signal.
49 ;;; That could only be described as an unmitigated disaster.
50 ;;; So now, as a special case within the cross-compiler, *HANDLED-CONDITIONS*
51 ;;; uses type designators instead of parsed types.
52 (setq sb-c
::*handled-conditions
*
53 `(((or (satisfies unable-to-optimize-note-p
)
54 sb-ext
:code-deletion-note
)
57 (defun proclaim-target-optimization ()
58 ;; The difference between init'ing the XC policy vs just proclaiming
59 ;; is that INIT makes the settings stick in the baseline policy,
60 ;; which affects POLICY-COLD-INIT-OR-RESANIFY.
61 (sb-c::init-xc-policy
(if (member :cons-profiling sb-xc
:*features
*)
62 '((sb-c::instrument-consing
2))
67 (debug ,(if (find :sb-show sb-xc
:*features
*) 2 1))
68 (sb-ext:inhibit-warnings
2)
69 ;; SAFETY = SPEED (and < 3) should provide reasonable safety,
70 ;; but might skip some unreasonably expensive stuff
71 (safety 2) (space 1) (speed 2)
72 ;; sbcl-internal optimization declarations:
74 ;; never insert stepper conditions
75 (sb-c:insert-step-conditions
0)
76 ;; save FP and PC for alien calls -- or not
77 (sb-c:alien-funcall-saves-fp-and-pc
78 ,(if (find :x86 sb-xc
:*features
*) 3 0)))))
80 (defun in-target-cross-compilation-mode (fun)
81 "Call FUN with everything set up appropriately for cross-compiling
83 (let (;; In order to increase microefficiency of the target Lisp,
84 ;; enable old CMU CL defined-function-types-never-change
85 ;; optimizations. (ANSI says users aren't supposed to
86 ;; redefine our functions anyway; and developers can
87 ;; fend for themselves.)
88 (sb-ext:*derive-function-types
* t
)
89 ;; Let the target know that we're the cross-compiler.
90 (sb-xc:*features
* (cons :sb-xc sb-xc
:*features
*))
91 (*readtable
* sb-cold
:*xc-readtable
*))
92 ;; Control optimization policy.
93 (proclaim-target-optimization)
96 (setf *target-compile-file
* #'sb-xc
:compile-file
)
97 (setf *target-assemble-file
* #'sb-c
:assemble-file
)
98 (setf *in-target-compilation-mode-fn
* #'in-target-cross-compilation-mode
)
100 ;; Update the xc-readtable
101 (set-macro-character #\
` #'sb-impl
::backquote-charmacro nil
*xc-readtable
*)
102 (set-macro-character #\
, #'sb-impl
::comma-charmacro nil
*xc-readtable
*)
103 (set-dispatch-macro-character #\
# #\a 'sb-kernel
::our-sharp-a-reader
*xc-readtable
*)
104 ;; ... and since the cross-compiler hasn't seen a DEFMACRO for QUASIQUOTE,
105 ;; make it think it has, otherwise it fails more-or-less immediately.
106 (setf (sb-xc:macro-function
'sb-int
:quasiquote
)
108 (the sb-kernel
:lexenv-designator env
)
109 (sb-impl::expand-quasiquote
(second form
) t
)))
111 (setq sb-c
::*track-full-called-fnames
* :minimal
) ; Change this as desired
113 ;;; Need to get access these sb-sys symbols unqualified from sb-assem
114 ;;; during make-host-2. Make-host-1 would have already converted its
115 ;;; code via DEFSETF so it should be insensitive to this substitution.
116 (unintern 'sb-assem
::sap-ref-16
'sb-assem
)
117 (unintern 'sb-assem
::sap-ref-32
'sb-assem
)
118 (import '(sb-sys:sap-ref-16 sb-sys
:sap-ref-32
) 'sb-assem
)
120 (read-undefined-fun-allowlist)
121 (defun parallel-make-host-2 (max-jobs)
122 (let ((subprocess-count 0)
123 (subprocess-list nil
)
126 (multiple-value-bind (pid status
) (sb-cold::posix-wait
)
127 (format t
"~&; Subprocess ~D exit status ~D~%" pid status
)
128 (unless (zerop status
)
129 (let ((stem (cdr (assoc pid subprocess-list
))))
130 (format t
"; File: ~a~%" stem
)
131 (show-log pid
"out" "; Standard output:")
132 (show-log pid
"err" "; Error output:"))
134 (setq subprocess-list
(delete pid subprocess-list
:key
#'car
)))
135 (decf subprocess-count
))
136 (show-log (pid logsuffix label
)
137 (format t
"~a~%" label
)
138 (with-open-file (f (format nil
"output/~d.~a" pid logsuffix
))
139 (loop (let ((line (read-line f nil
)))
140 (unless line
(return))
144 #+sbcl
(host-sb-ext:disable-debugger
)
145 (sb-cold::with-subprocesses
147 (do-stems-and-flags (stem flags
2)
148 (unless (position :not-target flags
)
149 (when (>= subprocess-count max-jobs
)
153 (let ((pid (sb-cold::posix-fork
)))
155 (let ((pid (sb-cold::getpid
)))
156 (let ((*standard-output
*
157 (open (format nil
"output/~d.out" pid
)
158 :direction
:output
:if-exists
:supersede
))
160 (open (format nil
"output/~d.err" pid
)
161 :direction
:output
:if-exists
:supersede
)))
162 (handler-case (target-compile-stem stem flags
)
164 (format *error-output
* "~a~%" e
)
165 (close *standard-output
*)
166 (close *error-output
*)
167 (sb-cold::exit-subprocess
1))
169 (declare (ignore res
))
170 (delete-file *standard-output
*)
171 (delete-file *error-output
*)
172 (sb-cold::exit-subprocess
0))))))
173 (push (cons pid stem
) subprocess-list
))
174 (incf subprocess-count
)
175 ;; Cause the compile-time effects from this file
176 ;; to appear in subsequently forked children.
177 (let ((*compile-for-effect-only
* t
))
178 (target-compile-stem stem flags
))))
179 (loop (if (plusp subprocess-count
) (wait) (return)))
181 (sb-cold::exit-process
1))))
184 (sb-kernel::show-ctype-ctor-cache-metrics
)
186 (defun write-sxhash-xcheck-data (pathname)
187 (with-open-file (stream pathname
:direction
:output
188 :if-exists
:supersede
:if-does-not-exist
:create
)
189 (format stream
";;; SXHASH test data~%(~%")
190 (let ((seen (make-hash-table)))
191 (dolist (pair sb-c
::*sxhash-crosscheck
*)
192 (let ((prev (gethash (car pair
) seen
)))
194 (assert (= prev
(cdr pair
))) ; be self-consistent at least
195 (format stream
"(~S #x~X)~%" (car pair
) (cdr pair
))))
196 (setf (gethash (car pair
) seen
) (cdr pair
))))
197 (format stream
")~%")))
199 ;;; See whether we're in individual file mode
201 ((boundp 'cl-user
::*compile-files
*)
203 (mapcar (lambda (x) (concatenate 'string
"src/" x
))
204 (symbol-value 'cl-user
::*compile-files
*))))
205 (with-compilation-unit ()
206 (do-stems-and-flags (stem flags
2)
207 (unless (position :not-target flags
)
208 (let* ((*compile-for-effect-only
* (not (member stem files
:test
#'string
=)))
209 (sb-xc:*compile-print
* (not *compile-for-effect-only
*)))
210 (target-compile-stem stem flags
)))))))
213 (let ((sb-xc:*compile-print
* nil
))
214 (if (make-host-2-parallelism)
215 (funcall 'parallel-make-host-2
(make-host-2-parallelism))
217 (count-if (lambda (x) (not (find :not-target
(cdr x
))))
218 (get-stems-and-flags 2)))
221 (sb-xc:*compile-verbose
* nil
))
222 ;; Workaround memory exhaustion in SB-FASTEVAL.
223 ;; In SB-EVAL the default evaluator-mode is :compile,
224 ;; but it also would exhaust memory if interpreting.
225 #+sbcl
(setq host-sb-ext
:*evaluator-mode
* :compile
)
227 (do-stems-and-flags (stem flags
2)
228 (unless (position :not-target flags
)
229 (format t
"~&[~3D/~3D] ~40A" (incf n
) total-files
(stem-remap-target stem
))
230 (let ((start (get-internal-real-time)))
231 (target-compile-stem stem flags
)
232 (let ((elapsed (/ (- (get-internal-real-time) start
)
233 internal-time-units-per-second
)))
234 (format t
" (~5,3f sec)~%" elapsed
)
235 (incf total-time elapsed
)))
236 ;(sb-kernel::show-ctype-ctor-cache-metrics)
237 (when sb-impl
::*profile-hash-cache
*
238 ;; avoid "make-host-2 stopped due to unexpected STYLE-WARNING raised from the host."
239 (funcall (intern "SHOW-HASH-CACHE-STATISTICS" "SB-IMPL")))
240 ;; The specialized array registry has file-wide scope. Hacking that aspect
241 ;; into the xc build scaffold seemed slightly easier than hacking the
242 ;; compiler (i.e. making the registry a slot of the fasl-output struct)
243 (clear-specialized-array-registry)))
244 (format t
"~&~50t ~f~%" total-time
))
245 (sb-cold::maybe-save-perfect-hashfuns-for-playback
)
246 (sb-c::dump
/restore-interesting-types
'write
)))
247 (write-sxhash-xcheck-data
248 (sb-cold:find-bootstrap-file
"output/sxhash-calls.lisp-expr" t
))
249 (sb-kernel::write-structure-definitions-as-text
250 (sb-cold:find-bootstrap-file
"output/defstructs.lisp-expr" t
)))))
251 (sb-kernel::show-ctype-ctor-cache-metrics
)
253 (defun dump-some-ctype-hashsets ()
254 (flet ((cells (hs) (sb-impl::hss-cells
(sb-impl::hashset-storage hs
))))
255 ;; It might warrant looking into that we print a lot of unknown types.
256 ;; Some of those might have resulted in suboptimal code.
257 (format t
"~2&UNKNOWN~%=======")
258 (sb-int:dovector
(x (cells sb-kernel
::*unknown-type-hashset
*) (terpri))
259 (when (sb-kernel:ctype-p x
)
260 (print (sb-kernel::hairy-type-specifier x
))))
261 (format t
"~2&HAIRY~%=====")
262 (sb-int:dovector
(x (cells sb-kernel
::*hairy-type-hashset
*) (terpri))
263 (when (sb-kernel:ctype-p x
)
264 (print (sb-kernel::hairy-type-specifier x
))))
265 ;; Out of curiosity, why are there 35 character-set-type instances?
266 ;; I suppose it's because the unicode processing logic contains all different
267 ;; manner of tests about the range of code points.
269 (sb-int:dovector
(x (cells sb-kernel
::*character-set-type-hashset
*) (terpri))
270 (when (sb-kernel:ctype-p x
)
271 (print (sb-kernel::character-set-type-pairs x
))))
272 #+nil
; we see > 350 distinct simd-pack types. wow!
274 (sb-int:dovector
(x (cells sb-kernel
::*simd-pack-type-hashset
*))
275 (when (sb-kernel:ctype-p x
)
276 (push (sb-kernel::simd-pack-type-element-type x
) list
)))
277 (flet ((int (x) (logand (host-sb-kernel:%vector-raw-bits
(reverse x
) 0) #b1111111111
)))
278 (dolist (bv (sort list
(lambda (a b
) (< (int a
) (int b
)))) (terpri))
280 ;; There are an astoundingly high number of MEMBER types.
281 ;; Most contain symbols. A few contain conses and proxy floating-point values.
282 ;; So we must operate on sets that contain unpaired signed zeros.
283 (format t
"~2&MEMBER~%======")
284 (sb-int:dovector
(x (cells sb-kernel
::*member-type-hashset
*) (terpri))
285 (when (sb-kernel:ctype-p x
)
286 (unless (every #'symbolp
(sb-kernel:member-type-members x
))
287 (print (sb-kernel:member-type-members x
)))))))