Disallow inlining failures in self-build.
[sbcl.git] / make-host-2.lisp
bloba1858d07f1269757e022e9c92b746e4288f6d4a2
1 ;;; Set up the cross-compiler.
2 (setf *print-level* 5 *print-length* 5)
3 (load "src/cold/shared.lisp")
4 (in-package "SB-COLD")
5 ;;; FIXME: these prefixes look like non-pathnamy ways of defining a
6 ;;; relative pathname. Investigate whether they can be made relative
7 ;;; pathnames.
8 (setf *host-obj-prefix* "obj/from-host/"
9 *target-obj-prefix* "obj/from-xc/")
10 (load "src/cold/set-up-cold-packages.lisp")
11 (load "src/cold/defun-load-or-cload-xcompiler.lisp")
12 (load-or-cload-xcompiler #'host-load-stem)
14 (let ((*features* (cons :sb-xc *features*)))
15 (load "src/cold/muffler.lisp"))
17 ;; Avoid forward-reference to an as-yet unknown type.
18 ;; NB: This is not how you would write this function, if you required
19 ;; such a thing. It should be (TYPEP X 'CODE-DELETION-NOTE).
20 ;; Do as I say, not as I do.
21 (defun code-deletion-note-p (x)
22 (eq (type-of x) 'sb!ext:code-deletion-note))
23 (setq sb!c::*handled-conditions*
24 `((,(sb!kernel:specifier-type
25 '(or (satisfies unable-to-optimize-note-p)
26 (satisfies code-deletion-note-p)))
27 . muffle-warning)))
29 (defun proclaim-target-optimization ()
30 (let ((debug (if (position :sb-show *shebang-features*) 2 1)))
31 (sb-xc:proclaim
32 `(optimize
33 (compilation-speed 1) (debug ,debug)
34 ;; CLISP's pretty-printer is fragile and tends to cause stack
35 ;; corruption or fail internal assertions, as of 2003-04-20; we
36 ;; therefore turn off as many notes as possible.
37 (sb!ext:inhibit-warnings #-clisp 2 #+clisp 3)
38 ;; SAFETY = SPEED (and < 3) should provide reasonable safety,
39 ;; but might skip some unreasonably expensive stuff
40 ;; (e.g. %DETECT-STACK-EXHAUSTION in sbcl-0.7.2).
41 (safety 2) (space 1) (speed 2)
42 ;; sbcl-internal optimization declarations:
44 ;; never insert stepper conditions
45 (sb!c:insert-step-conditions 0)
46 ;; save FP and PC for alien calls -- or not
47 (sb!c:alien-funcall-saves-fp-and-pc #!+x86 3 #!-x86 0)))))
48 (compile 'proclaim-target-optimization)
50 (defun in-target-cross-compilation-mode (fun)
51 "Call FUN with everything set up appropriately for cross-compiling
52 a target file."
53 (let (;; In order to increase microefficiency of the target Lisp,
54 ;; enable old CMU CL defined-function-types-never-change
55 ;; optimizations. (ANSI says users aren't supposed to
56 ;; redefine our functions anyway; and developers can
57 ;; fend for themselves.)
58 #!-sb-fluid
59 (sb!ext:*derive-function-types* t)
60 ;; Let the target know that we're the cross-compiler.
61 (*features* (cons :sb-xc *features*))
62 ;; We need to tweak the readtable..
63 (*readtable* (copy-readtable)))
64 ;; ..in order to make backquotes expand into target code
65 ;; instead of host code.
66 ;; FIXME: Isn't this now taken care of automatically by
67 ;; toplevel forms in the xcompiler backq.lisp file?
68 (set-macro-character #\` #'sb!impl::backquote-charmacro)
69 (set-macro-character #\, #'sb!impl::comma-charmacro)
71 (set-dispatch-macro-character #\# #\+ #'she-reader)
72 (set-dispatch-macro-character #\# #\- #'she-reader)
73 ;; Control optimization policy.
74 (proclaim-target-optimization)
75 ;; Specify where target machinery lives.
76 (with-additional-nickname ("SB-XC" "SB!XC")
77 (funcall fun))))
78 (compile 'in-target-cross-compilation-mode)
81 ;; Supress function/macro redefinition warnings under clisp.
82 #+clisp (setf custom:*suppress-check-redefinition* t)
84 (setf *target-compile-file* #'sb-xc:compile-file)
85 (setf *target-assemble-file* #'sb!c:assemble-file)
86 (setf *in-target-compilation-mode-fn* #'in-target-cross-compilation-mode)
88 ;;; Run the cross-compiler to produce cold fasl files.
89 ;; ... and since the cross-compiler hasn't seen a DEFMACRO for QUASIQUOTE,
90 ;; make it think it has, otherwise it fails more-or-less immediately.
91 (setf (sb-xc:macro-function 'sb!int:quasiquote)
92 (lambda (form env)
93 (the sb!kernel:lexenv-designator env)
94 (sb!impl::expand-quasiquote (second form) t)))
95 (setq sb!c::*track-full-called-fnames* :minimal) ; Change this as desired
96 (let (fail)
97 (sb-xc:with-compilation-unit ()
98 (load "src/cold/compile-cold-sbcl.lisp")
99 ;; Enforce absence of unexpected forward-references to warm loaded code.
100 ;; Looking into a hidden detail of this compiler seems fair game.
101 #!+(or x86 x86-64) ; until all the rest are clean
102 (when sb!c::*undefined-warnings* (setq fail t)))
103 ;; Exit the compilation unit so that the summary is printed. Then complain.
104 (when fail
105 (cerror "Proceed anyway"
106 "SB-COLD::*UNDEFINED-FUN-WHITELIST* is incomplete")))
108 (when sb!c::*track-full-called-fnames*
109 (let (possibly-suspicious likely-suspicious)
110 (sb!c::call-with-each-globaldb-name
111 (lambda (name)
112 (let* ((cell (sb!int:info :function :emitted-full-calls name))
113 (inlinep (eq (sb!int:info :function :inlinep name) :inline))
114 (info (sb!int:info :function :info name)))
115 (if (and cell
116 (or inlinep
117 (and info (sb!c::fun-info-templates info))
118 (sb!int:info :function :compiler-macro-function name)
119 (sb!int:info :function :source-transform name)))
120 (if inlinep
121 ;; A full call to an inline function almost always indicates
122 ;; an out-of-order definition. If not an inline function,
123 ;; the call could be due to an inapplicable transformation.
124 (push (cons name cell) likely-suspicious)
125 (push (cons name cell) possibly-suspicious))))))
126 (flet ((show (label list)
127 (when list
128 (format t "~%~A suspicious calls:~:{~%~4d ~S~@{~% ~S~}~}~%"
129 label
130 (mapcar (lambda (x) (list* (ash (cadr x) -2) (car x) (cddr x)))
131 (sort list #'> :key #'cadr))))))
132 ;; Called inlines not in the presence of a declaration to the contrary
133 ;; indicate that perhaps the function definition appeared too late.
134 (show "Likely" likely-suspicious)
135 ;; Failed transforms are considered not quite as suspicious
136 ;; because it could either be too late, or that the transform failed.
137 (show "Possibly" possibly-suspicious))
138 ;; As each platform's build becomes warning-free,
139 ;; it should be added to the list here to prevent regresssions.
140 #!+(and (or x86 x86-64) (or linux darwin))
141 (when likely-suspicious
142 (warn "Expected zero inlinining failures"))))
144 ;; After cross-compiling, show me a list of types that checkgen
145 ;; would have liked to use primitive traps for but couldn't.
146 #+nil
147 (let ((l (sb-impl::%hash-table-alist sb!c::*checkgen-used-types*)))
148 (format t "~&Types needed by checkgen: ('+' = has internal error number)~%")
149 (setq l (sort l #'> :key #'cadr))
150 (loop for (type-spec . (count . interr-p)) in l
151 do (format t "~:[ ~;+~] ~5D ~S~%" interr-p count type-spec))
152 (format t "~&Error numbers not used by checkgen:~%")
153 (loop for (spec . symbol) across sb!c:+backend-internal-errors+
154 when (and (not (stringp spec))
155 (not (gethash spec sb!c::*checkgen-used-types*)))
156 do (format t " ~S~%" spec)))
158 ;; Print some information about how well the function caches performed
159 (when sb!impl::*profile-hash-cache*
160 (sb!impl::show-hash-cache-statistics))
162 Sample output
163 -------------
164 Seek Hit (%) Evict (%) Size full
165 23698219 18382256 ( 77.6%) 5313915 ( 22.4%) 2048 100.0% TYPE=-CACHE
166 23528751 23416735 ( 99.5%) 46242 ( 0.2%) 1024 20.1% VALUES-SPECIFIER-TYPE-CACHE
167 16755212 13072420 ( 78.0%) 3681768 ( 22.0%) 1024 100.0% CSUBTYPEP-CACHE
168 9913114 8374965 ( 84.5%) 1537893 ( 15.5%) 256 100.0% MAKE-VALUES-TYPE-CACHED-CACHE
169 7718160 4702069 ( 60.9%) 3675019 ( 47.6%) 512 100.0% TYPE-INTERSECTION2-CACHE
170 5184706 1626512 ( 31.4%) 3557973 ( 68.6%) 256 86.3% %TYPE-INTERSECTION-CACHE
171 5156044 3986450 ( 77.3%) 1169338 ( 22.7%) 256 100.0% VALUES-SUBTYPEP-CACHE
172 4550163 2969409 ( 65.3%) 1580498 ( 34.7%) 256 100.0% VALUES-TYPE-INTERSECTION-CACHE
173 3544211 2607658 ( 73.6%) 936300 ( 26.4%) 256 98.8% %TYPE-UNION-CACHE
174 2545070 2110741 ( 82.9%) 433817 ( 17.0%) 512 100.0% PRIMITIVE-TYPE-AUX-CACHE
175 2164841 1112785 ( 51.4%) 1706097 ( 78.8%) 256 100.0% TYPE-UNION2-CACHE
176 1568022 1467575 ( 93.6%) 100191 ( 6.4%) 256 100.0% TYPE-SINGLETON-P-CACHE
177 779941 703208 ( 90.2%) 76477 ( 9.8%) 256 100.0% %COERCE-TO-VALUES-CACHE
178 618605 448427 ( 72.5%) 169922 ( 27.5%) 256 100.0% VALUES-TYPE-UNION-CACHE
179 145805 29403 ( 20.2%) 116206 ( 79.7%) 256 76.6% %%MAKE-UNION-TYPE-CACHED-CACHE
180 118634 76203 ( 64.2%) 42188 ( 35.6%) 256 94.9% %%MAKE-ARRAY-TYPE-CACHED-CACHE
181 12319 12167 ( 98.8%) 47 ( 0.4%) 128 82.0% WEAKEN-TYPE-CACHE
182 10416 9492 ( 91.1%) 668 ( 6.4%) 256 100.0% TYPE-NEGATION-CACHE
185 ;;; miscellaneous tidying up and saving results
186 (let ((filename "output/object-filenames-for-genesis.lisp-expr"))
187 (ensure-directories-exist filename :verbose t)
188 ;; save the initial-symbol-values before writing the object filenames.
189 (save-initial-symbol-values)
190 (with-open-file (s filename :direction :output :if-exists :supersede)
191 (write *target-object-file-names* :stream s :readably t)))
193 ;;; Let's check that the type system was reasonably sane. (It's easy
194 ;;; to spend a long time wandering around confused trying to debug
195 ;;; cold init if it wasn't.)
196 (when (position :sb-test *shebang-features*)
197 (load "tests/type.after-xc.lisp"))
199 ;;; If you're experimenting with the system under a cross-compilation
200 ;;; host which supports CMU-CL-style SAVE-LISP, this can be a good
201 ;;; time to run it. The resulting core isn't used in the normal build,
202 ;;; but can be handy for experimenting with the system. (See slam.sh
203 ;;; for an example.)
204 (when (position :sb-after-xc-core *shebang-features*)
205 #+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil)
206 #+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core")
207 #+openmcl (ccl::save-application "output/after-xc.core")
208 #+clisp (ext:saveinitmem "output/after-xc.core"))
209 #+cmu (ext:quit)
210 #+clisp (ext:quit)
211 #+abcl (ext:quit)