1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
;;; Set up the cross-compiler.
(setf *print-level* 5 *print-length* 5)
(load "src/cold/shared.lisp")
(in-package "SB-COLD")
;;; FIXME: these prefixes look like non-pathnamy ways of defining a
;;; relative pathname. Investigate whether they can be made relative
;;; pathnames.
(setf *host-obj-prefix* "obj/from-host/"
*target-obj-prefix* "obj/from-xc/")
(load "src/cold/set-up-cold-packages.lisp")
(load "src/cold/defun-load-or-cload-xcompiler.lisp")
(load-or-cload-xcompiler #'host-load-stem)
;;; Set up the perfect hash generator for the target's value of N-FIXNUM-BITS.
(preload-perfect-hash-generator (perfect-hash-generator-journal :input))
;; Supress function/macro redefinition warnings under clisp.
#+clisp (setf custom:*suppress-check-redefinition* t)
;; Avoid natively compiling new code under ecl
#+ecl (ext:install-bytecodes-compiler)
(defun copy-file-from-file (new old)
(with-open-file (output new :direction :output :if-exists :supersede
:if-does-not-exist :create)
(with-open-file (input old)
(loop (let ((line (read-line input nil)))
(if line (write-line line output) (return new)))))))
;;; Run the cross-compiler to produce cold fasl files.
(setq sb-c::*track-full-called-fnames* :minimal) ; Change this as desired
(setq sb-c::*static-vop-usage-counts* (make-hash-table))
(defvar *emitted-full-calls*)
(let (fail
variables
functions
types
warnp
style-warnp)
;; Even the host may get STYLE-WARNINGS from e.g. cross-compiling
;; macro definitions. FIXME: This is duplicate code from make-host-1
(handler-bind ((style-warning
(lambda (c)
(signal c)
(setq style-warnp 'style-warning)))
(simple-warning
(lambda (c)
(declare (ignore c))
(setq warnp 'warning))))
(sb-xc:with-compilation-unit ()
(load "src/cold/compile-cold-sbcl.lisp")
(setf *emitted-full-calls*
(sb-c::cu-emitted-full-calls sb-c::*compilation-unit*))
(let ((cache (math-journal-pathname :output)))
(when (probe-file cache)
(copy-file-from-file "output/xfloat-math.lisp-expr" cache)
(format t "~&Math journal: replaced from ~S~%" cache)))
;; Enforce absence of unexpected forward-references to warm loaded code.
;; Looking into a hidden detail of this compiler seems fair game.
(when sb-c::*undefined-warnings*
(setf fail t)
(dolist (warning sb-c::*undefined-warnings*)
(case (sb-c::undefined-warning-kind warning)
(:variable (setf variables t))
(:type (setf types t))
(:function (setf functions t)))))))
;; Exit the compilation unit so that the summary is printed. Then complain.
(when fail
(cerror "Proceed anyway"
"Undefined ~:[~;variables~] ~:[~;types~]~
~:[~;functions (incomplete SB-COLD::*UNDEFINED-FUN-ALLOWLIST*?)~]"
variables types functions))
(when (and (or warnp style-warnp) *fail-on-warnings*)
(cerror "Proceed anyway"
"make-host-2 stopped due to unexpected ~A raised from the host." (or warnp style-warnp))))
#-clisp ; DO-ALL-SYMBOLS seems to kill CLISP at random
(do-all-symbols (s)
(when (and (sb-int:info :function :inlinep s)
(eq (sb-int:info :function :where-from s) :assumed))
(error "INLINE declaration for an undefined function: ~S?" s)))
(with-open-file (output "output/cold-vop-usage.txt"
:direction :output :if-exists :supersede)
(sb-int:dohash ((name vop) sb-c::*backend-parsed-vops*)
(declare (ignore vop))
(format output "~7d ~s~%"
(gethash name sb-c::*static-vop-usage-counts* 0)
;; change SB-XC symbols back to their normal counterpart
(if (string= (cl:package-name (cl:symbol-package name)) "SB-XC")
(find-symbol (string name) "COMMON-LISP")
name))))
(when sb-c::*track-full-called-fnames*
(let (possibly-suspicious likely-suspicious)
(sb-int:dohash ((name cell) *emitted-full-calls*)
(let* ((inlinep (eq (sb-int:info :function :inlinep name) 'inline))
(source-xform (sb-int:info :function :source-transform name))
(info (sb-int:info :function :info name)))
(when (and cell
(or inlinep
source-xform
(and info (sb-c::fun-info-templates info))
(sb-int:info :function :compiler-macro-function name)))
(cond (inlinep
;; A full call to an inline function almost always indicates
;; an out-of-order definition. If not an inline function,
;; the call could be due to an inapplicable transformation.
(push (list name cell) likely-suspicious))
;; structure constructors aren't inlined by default,
;; though we have a source-xform.
((and (listp source-xform) (eq :constructor (cdr source-xform))))
(t
(push (list name cell) possibly-suspicious))))))
(flet ((show (label list)
(when list
(format t "~%~A suspicious calls:~:{~%~4d ~S~@{~% ~S~}~}~%"
label
(mapcar (lambda (x) (list* (ash (cadr x) -2) (car x) (cddr x)))
(sort list #'> :key #'cadr))))))
;; Called inlines not in the presence of a declaration to the contrary
;; indicate that perhaps the function definition appeared too late.
(show "Likely" likely-suspicious) ; "quite likely" an error
;; Failed transforms are considered not quite as suspicious
;; because it could either be too late, or that the transform failed.
(show "Possibly" possibly-suspicious)) ; _potentially_ an error
;; As each platform's build becomes warning-free,
;; it should be added to the list here to prevent regresssions.
;; But oops! apparently this check started failing a long time ago
;; but because it was done in the wrong place, the check failed to fail.
#+nil
(when (and likely-suspicious
(target-featurep '(:and (:or :x86 :x86-64) (:or :linux :darwin))))
(warn "Expected zero inlinining failures"))))
;; After cross-compiling, show me a list of types that checkgen
;; would have liked to use primitive traps for but couldn't.
#+nil
(let ((l (sb-impl::%hash-table-alist sb-c::*checkgen-used-types*)))
(format t "~&Types needed by checkgen: ('+' = has internal error number)~%")
(setq l (sort l #'> :key #'cadr))
(loop for (type-spec . (count . interr-p)) in l
do (format t "~:[ ~;+~] ~5D ~S~%" interr-p count type-spec))
(format t "~&Error numbers not used by checkgen:~%")
(loop for (spec symbol) across sb-c:+backend-internal-errors+
when (and (not (stringp spec))
(not (gethash spec sb-c::*checkgen-used-types*)))
do (format t " ~S~%" spec)))
;; Print some information about how well the type operator caches performed
(when sb-impl::*profile-hash-cache*
(sb-impl::show-hash-cache-statistics))
#|
Sample output
-------------
Seek Hit (%) Evict (%) Size full
23698219 18382256 ( 77.6%) 5313915 ( 22.4%) 2048 100.0% TYPE=-CACHE
23528751 23416735 ( 99.5%) 46242 ( 0.2%) 1024 20.1% VALUES-SPECIFIER-TYPE-CACHE
16755212 13072420 ( 78.0%) 3681768 ( 22.0%) 1024 100.0% CSUBTYPEP-CACHE
9913114 8374965 ( 84.5%) 1537893 ( 15.5%) 256 100.0% MAKE-VALUES-TYPE-CACHED-CACHE
7718160 4702069 ( 60.9%) 3675019 ( 47.6%) 512 100.0% TYPE-INTERSECTION2-CACHE
5184706 1626512 ( 31.4%) 3557973 ( 68.6%) 256 86.3% %TYPE-INTERSECTION-CACHE
5156044 3986450 ( 77.3%) 1169338 ( 22.7%) 256 100.0% VALUES-SUBTYPEP-CACHE
4550163 2969409 ( 65.3%) 1580498 ( 34.7%) 256 100.0% VALUES-TYPE-INTERSECTION-CACHE
3544211 2607658 ( 73.6%) 936300 ( 26.4%) 256 98.8% %TYPE-UNION-CACHE
2545070 2110741 ( 82.9%) 433817 ( 17.0%) 512 100.0% PRIMITIVE-TYPE-AUX-CACHE
2164841 1112785 ( 51.4%) 1706097 ( 78.8%) 256 100.0% TYPE-UNION2-CACHE
1568022 1467575 ( 93.6%) 100191 ( 6.4%) 256 100.0% TYPE-SINGLETON-P-CACHE
779941 703208 ( 90.2%) 76477 ( 9.8%) 256 100.0% %COERCE-TO-VALUES-CACHE
618605 448427 ( 72.5%) 169922 ( 27.5%) 256 100.0% VALUES-TYPE-UNION-CACHE
145805 29403 ( 20.2%) 116206 ( 79.7%) 256 76.6% %%MAKE-UNION-TYPE-CACHED-CACHE
118634 76203 ( 64.2%) 42188 ( 35.6%) 256 94.9% %%MAKE-ARRAY-TYPE-CACHED-CACHE
12319 12167 ( 98.8%) 47 ( 0.4%) 128 82.0% WEAKEN-TYPE-CACHE
10416 9492 ( 91.1%) 668 ( 6.4%) 256 100.0% TYPE-NEGATION-CACHE
|#
;;; Let's check that the type system was reasonably sane. (It's easy
;;; to spend a long time wandering around confused trying to debug
;;; cold init if it wasn't.)
(load "tests/type.after-xc.lisp")
;;; If you're experimenting with the system under a cross-compilation
;;; host which supports CMU-CL-style SAVE-LISP, this can be a good
;;; time to run it. The resulting core isn't used in the normal build,
;;; but can be handy for experimenting with the system. (See slam.sh
;;; for an example.)
;;; FIXME: can we just always do this for supported hosts, and remove the choice?
(cond #+sbcl (t (host-sb-ext:save-lisp-and-die "output/after-xc.core"))
((member :sb-after-xc-core sb-xc:*features*)
#+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil)
#+openmcl (ccl::save-application "output/after-xc.core")
#+clisp (ext:saveinitmem "output/after-xc.core")))
|
