forked from dmitryvk/sbcl-win32-threads
-
Notifications
You must be signed in to change notification settings - Fork 4
/
shared.lisp
463 lines (419 loc) · 20.8 KB
/
shared.lisp
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
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
;;;; stuff which is not specific to any particular build phase, but
;;;; used by most of them
;;;;
;;;; Note: It's specifically not used when bootstrapping PCL, because
;;;; we do SAVE-LISP after that, and we don't want to save extraneous
;;;; bootstrapping machinery into the frozen image which will
;;;; subsequently be used as the mother of all Lisp sessions.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
;;; SB-COLD holds stuff used to build the initial SBCL core file
;;; (including not only the final construction of the core file, but
;;; also the preliminary steps like e.g. building the cross-compiler
;;; and running the cross-compiler to produce target FASL files).
(defpackage "SB-COLD" (:use "CL"))
(in-package "SB-COLD")
;;; prefixes for filename stems when cross-compiling. These are quite arbitrary
;;; (although of course they shouldn't collide with anything we don't want to
;;; write over). In particular, they can be either relative path names (e.g.
;;; "host-objects/" or absolute pathnames (e.g. "/tmp/sbcl-xc-host-objects/").
;;;
;;; The cross-compilation process will force the creation of these directories
;;; by executing CL:ENSURE-DIRECTORIES-EXIST (on the xc host Common Lisp).
(defvar *host-obj-prefix*)
(defvar *target-obj-prefix*)
(defvar *target-obj-suffix*
;; Target fasl files are LOADed (actually only quasi-LOADed, in
;; GENESIS) only by SBCL code, and it doesn't care about particular
;; extensions, so we can use something arbitrary.
".lisp-obj")
(defvar *target-assem-obj-suffix*
;; Target fasl files from SB!C:ASSEMBLE-FILE are LOADed via GENESIS.
;; The source files are compiled once as assembly files and once as
;; normal lisp files. In the past, they were kept separate by
;; clever symlinking in the source tree, but that became less clean
;; as ports to host environments without symlinks started appearing.
;; In order to keep them separate, we have the assembled versions
;; with a separate suffix.
".assem-obj")
;;; a function of one functional argument, which calls its functional argument
;;; in an environment suitable for compiling the target. (This environment
;;; includes e.g. a suitable *FEATURES* value.)
(declaim (type function *in-target-compilation-mode-fn*))
(defvar *in-target-compilation-mode-fn*)
;;; a function with the same calling convention as CL:COMPILE-FILE, to be
;;; used to translate ordinary Lisp source files into target object files
(declaim (type function *target-compile-file*))
(defvar *target-compile-file*)
;;; designator for a function with the same calling convention as
;;; SB-C:ASSEMBLE-FILE, to be used to translate assembly files into target
;;; object files
(defvar *target-assemble-file*)
;;;; some tools
;;; Take the file named X and make it into a file named Y. Sorta like
;;; UNIX, and unlike Common Lisp's bare RENAME-FILE, we don't allow
;;; information from the original filename to influence the final
;;; filename. (The reason that it's only sorta like UNIX is that in
;;; UNIX "mv foo bar/" will work, but the analogous
;;; (RENAME-FILE-A-LA-UNIX "foo" "bar/") should fail.)
;;;
;;; (This is a workaround for the weird behavior of Debian CMU CL
;;; 2.4.6, where (RENAME-FILE "dir/x" "dir/y") tries to create a file
;;; called "dir/dir/y". If that behavior goes away, then we should be
;;; able to get rid of this function and use plain RENAME-FILE in the
;;; COMPILE-STEM function above. -- WHN 19990321
(defun rename-file-a-la-unix (x y)
(let ((path ;; (Note that the TRUENAME expression here is lifted from an
;; example in the ANSI spec for TRUENAME.)
(with-open-file (stream y :direction :output)
(close stream)
;; From the ANSI spec: "In this case, the file is closed
;; when the truename is tried, so the truename
;; information is reliable."
(truename stream))))
(delete-file path)
(rename-file x path)))
(compile 'rename-file-a-la-unix)
;;; other miscellaneous tools
(load "src/cold/read-from-file.lisp")
(load "src/cold/rename-package-carefully.lisp")
(load "src/cold/with-stuff.lisp")
;;; Try to minimize/conceal any non-standardness of the host Common Lisp.
(load "src/cold/ansify.lisp")
;;;; special read-macros for building the cold system (and even for
;;;; building some of our tools for building the cold system)
(load "src/cold/shebang.lisp")
;;; When cross-compiling, the *FEATURES* set for the target Lisp is
;;; not in general the same as the *FEATURES* set for the host Lisp.
;;; In order to refer to target features specifically, we refer to
;;; *SHEBANG-FEATURES* instead of *FEATURES*, and use the #!+ and #!-
;;; readmacros instead of the ordinary #+ and #- readmacros.
(setf *shebang-features*
(let* ((default-features
(append (read-from-file "base-target-features.lisp-expr")
(eval (read-from-file "local-target-features.lisp-expr"))))
(customizer-file-name "customize-target-features.lisp")
(customizer (if (probe-file customizer-file-name)
(compile nil
(read-from-file customizer-file-name))
#'identity)))
(funcall customizer default-features)))
(let ((*print-length* nil)
(*print-level* nil))
(format t
"target features *SHEBANG-FEATURES*=~@<~S~:>~%"
*shebang-features*))
(defvar *shebang-backend-subfeatures*
(let* ((default-subfeatures nil)
(customizer-file-name "customize-backend-subfeatures.lisp")
(customizer (if (probe-file customizer-file-name)
(compile nil
(read-from-file customizer-file-name))
#'identity)))
(funcall customizer default-subfeatures)))
(let ((*print-length* nil)
(*print-level* nil))
(format t
"target backend-subfeatures *SHEBANG-BACKEND-FEATURES*=~@<~S~:>~%"
*shebang-backend-subfeatures*))
;;; Some feature combinations simply don't work, and sometimes don't
;;; fail until quite a ways into the build. Pick off the more obvious
;;; combinations now, and provide a description of what the actual
;;; failure is (not always obvious from when the build fails).
(let ((feature-compatability-tests
'(("(and sb-thread (not gencgc))"
":SB-THREAD requires :GENCGC")
("(and sb-thread (not (or ppc x86 x86-64)))"
":SB-THREAD not supported on selected architecture")
("(and gencgc cheneygc)"
":GENCGC and :CHENEYGC are incompatible")
("(and cheneygc (not (or alpha hppa mips ppc sparc)))"
":CHENEYGC not supported on selected architecture")
("(and gencgc (not (or sparc ppc x86 x86-64)))"
":GENCGC not supported on selected architecture")
("(not (or gencgc cheneygc))"
"One of :GENCGC or :CHENEYGC must be enabled")
("(or (and alpha (or hppa mips ppc sparc x86 x86-64))
(and hppa (or mips ppc sparc x86 x86-64))
(and mips (or ppc sparc x86 x86-64))
(and ppc (or sparc x86 x86-64))
(and sparc (or x86 x86-64))
(and x86 x86-64))"
"More than one architecture selected")))
(failed-test-descriptions nil))
(dolist (test feature-compatability-tests)
(let ((*features* *shebang-features*))
(when (read-from-string (concatenate 'string "#+" (first test) "T NIL"))
(push (second test) failed-test-descriptions))))
(when failed-test-descriptions
(error "Feature compatability check failed, ~S"
failed-test-descriptions)))
;;;; cold-init-related PACKAGE and SYMBOL tools
;;; Once we're done with possibly ANSIfying the COMMON-LISP package,
;;; it's probably a mistake if we change it (beyond changing the
;;; values of special variables such as *** and +, anyway). Set up
;;; machinery to warn us when/if we change it.
;;;
;;; All code depending on this is itself dependent on #!+SB-SHOW.
#!+sb-show
(progn
(load "src/cold/snapshot.lisp")
(defvar *cl-snapshot* (take-snapshot "COMMON-LISP")))
;;;; master list of source files and their properties
;;; flags which can be used to describe properties of source files
(defparameter
*expected-stem-flags*
'(;; meaning: This file is not to be compiled when building the
;; cross-compiler which runs on the host ANSI Lisp. ("not host
;; code", i.e. does not execute on host -- but may still be
;; cross-compiled by the host, so that it executes on the target)
:not-host
;; meaning: This file is not to be compiled as part of the target
;; SBCL. ("not target code" -- but still presumably host code,
;; used to support the cross-compilation process)
:not-target
;; meaning: The #'COMPILE-STEM argument :TRACE-FILE should be T.
;; When the compiler is SBCL's COMPILE-FILE or something like it,
;; compiling "foo.lisp" will generate "foo.trace" which contains lots
;; of exciting low-level information about representation selection,
;; VOPs used by the compiler, and bits of assembly.
:trace-file
;; meaning: This file is to be processed with the SBCL assembler,
;; not COMPILE-FILE. (Note that this doesn't make sense unless
;; :NOT-HOST is also set, since the SBCL assembler doesn't exist
;; while the cross-compiler is being built in the host ANSI Lisp.)
:assem
;; meaning: The #'COMPILE-STEM argument called :IGNORE-FAILURE-P
;; should be true. (This is a KLUDGE: I'd like to get rid of it.
;; For now, it exists so that compilation can proceed through the
;; legacy warnings in src/compiler/x86/array.lisp, which I've
;; never figured out but which were apparently acceptable in CMU
;; CL. Eventually, it would be great to just get rid of all
;; warnings and remove support for this flag. -- WHN 19990323)
:ignore-failure-p))
(defparameter *stems-and-flags* (read-from-file "build-order.lisp-expr"))
(defmacro do-stems-and-flags ((stem flags) &body body)
(let ((stem-and-flags (gensym "STEM-AND-FLAGS")))
`(dolist (,stem-and-flags *stems-and-flags*)
(let ((,stem (first ,stem-and-flags))
(,flags (rest ,stem-and-flags)))
,@body))))
;;; Given a STEM, remap the path component "/target/" to a suitable
;;; target directory.
(defun stem-remap-target (stem)
(let ((position (search "/target/" stem)))
(if position
(concatenate 'string
(subseq stem 0 (1+ position))
#!+x86 "x86"
#!+x86-64 "x86-64"
#!+sparc "sparc"
#!+ppc "ppc"
#!+mips "mips"
#!+alpha "alpha"
#!+hppa "hppa"
(subseq stem (+ position 7)))
stem)))
(compile 'stem-remap-target)
;;; Determine the source path for a stem.
(defun stem-source-path (stem)
(concatenate 'string "" (stem-remap-target stem) ".lisp"))
(compile 'stem-source-path)
;;; Determine the object path for a stem/flags/mode combination.
(defun stem-object-path (stem flags mode)
(multiple-value-bind
(obj-prefix obj-suffix)
(ecase mode
(:host-compile
;; On some xc hosts, it's impossible to LOAD a fasl file unless it
;; has the same extension that the host uses for COMPILE-FILE
;; output, so we have to be careful to use the xc host's preferred
;; extension.
(values *host-obj-prefix*
(concatenate 'string "."
(pathname-type (compile-file-pathname stem)))))
(:target-compile (values *target-obj-prefix*
(if (find :assem flags)
*target-assem-obj-suffix*
*target-obj-suffix*))))
(concatenate 'string obj-prefix (stem-remap-target stem) obj-suffix)))
(compile 'stem-object-path)
;;; Check for stupid typos in FLAGS list keywords.
(let ((stems (make-hash-table :test 'equal)))
(do-stems-and-flags (stem flags)
;; We do duplicate stem comparison based on the object path in
;; order to cover the case of stems with an :assem flag, which
;; have two entries but separate object paths for each. KLUDGE:
;; We have to bind *target-obj-prefix* here because it's normally
;; set up later in the build process and we don't actually care
;; what it is so long as it doesn't change while we're checking
;; for duplicate stems.
(let* ((*target-obj-prefix* "")
(object-path (stem-object-path stem flags :target-compile)))
(if (gethash object-path stems)
(error "duplicate stem ~S in *STEMS-AND-FLAGS*" stem)
(setf (gethash object-path stems) t)))
;; FIXME: We should make sure that the :assem flag is only used
;; when paired with :not-host.
(let ((set-difference (set-difference flags *expected-stem-flags*)))
(when set-difference
(error "found unexpected flag(s) in *STEMS-AND-FLAGS*: ~S"
set-difference)))))
;;;; tools to compile SBCL sources to create the cross-compiler
;;; a wrapper for compilation/assembly, used mostly to centralize
;;; the procedure for finding full filenames from "stems"
;;;
;;; Compile the source file whose basic name is STEM, using some
;;; standard-for-the-SBCL-build-process procedures to generate the
;;; full pathnames of source file and object file. Return the pathname
;;; of the object file for STEM.
;;;
;;; STEM and FLAGS are as per DO-STEMS-AND-FLAGS. MODE is one of
;;; :HOST-COMPILE and :TARGET-COMPILE.
(defun compile-stem (stem flags mode)
(let* (;; KLUDGE: Note that this CONCATENATE 'STRING stuff is not The Common
;; Lisp Way, although it works just fine for common UNIX environments.
;; Should it come to pass that the system is ported to environments
;; where version numbers and so forth become an issue, it might become
;; urgent to rewrite this using the fancy Common Lisp PATHNAME
;; machinery instead of just using strings. In the absence of such a
;; port, it might or might be a good idea to do the rewrite.
;; -- WHN 19990815
(src (stem-source-path stem))
(obj (stem-object-path stem flags mode))
(tmp-obj (concatenate 'string obj "-tmp"))
(compile-file (ecase mode
(:host-compile #'compile-file)
(:target-compile (if (find :assem flags)
*target-assemble-file*
*target-compile-file*))))
(trace-file (find :trace-file flags))
(ignore-failure-p (find :ignore-failure-p flags)))
(declare (type function compile-file))
(ensure-directories-exist obj :verbose t)
;; We're about to set about building a new object file. First, we
;; delete any preexisting object file in order to avoid confusing
;; ourselves later should we happen to bail out of compilation
;; with an error.
(when (probe-file obj)
(delete-file obj))
;; Original comment:
;;
;; Work around a bug in CLISP 1999-01-08 #'COMPILE-FILE: CLISP
;; mangles relative pathnames passed as :OUTPUT-FILE arguments,
;; but works OK with absolute pathnames.
;;
;; following discussion on cmucl-imp 2002-07
;; "COMPILE-FILE-PATHNAME", it would seem safer to deal with
;; absolute pathnames all the time; it is no longer clear that the
;; original behaviour in CLISP was wrong or that the current
;; behaviour is right; and in any case absolutifying the pathname
;; insulates us against changes of behaviour. -- CSR, 2002-08-09
(setf tmp-obj
;; (Note that this idiom is taken from the ANSI
;; documentation for TRUENAME.)
(with-open-file (stream tmp-obj
:direction :output
;; Compilation would overwrite the
;; temporary object anyway and overly
;; strict implementations default
;; to :ERROR.
:if-exists :supersede)
(close stream)
(truename stream)))
;; and some compilers (e.g. OpenMCL) will complain if they're
;; asked to write over a file that exists already (and isn't
;; recognizeably a fasl file), so
(when (probe-file tmp-obj)
(delete-file tmp-obj))
;; Try to use the compiler to generate a new temporary object file.
(flet ((report-recompile-restart (stream)
(format stream "Recompile file ~S" src))
(report-continue-restart (stream)
(format stream "Continue, using possibly bogus file ~S" obj)))
(tagbody
retry-compile-file
(multiple-value-bind (output-truename warnings-p failure-p)
(if trace-file
(funcall compile-file src :output-file tmp-obj
:trace-file t :allow-other-keys t)
(funcall compile-file src :output-file tmp-obj))
(declare (ignore warnings-p))
(cond ((not output-truename)
(error "couldn't compile ~S" src))
(failure-p
(if ignore-failure-p
(warn "ignoring FAILURE-P return value from compilation of ~S"
src)
(unwind-protect
(restart-case
(error "FAILURE-P was set when creating ~S."
obj)
(recompile ()
:report report-recompile-restart
(go retry-compile-file))
(continue ()
:report report-continue-restart
(setf failure-p nil)))
;; Don't leave failed object files lying around.
(when (and failure-p (probe-file tmp-obj))
(delete-file tmp-obj)
(format t "~&deleted ~S~%" tmp-obj)))))
;; Otherwise: success, just fall through.
(t nil)))))
;; If we get to here, compilation succeeded, so it's OK to rename
;; the temporary output file to the permanent object file.
(rename-file-a-la-unix tmp-obj obj)
;; nice friendly traditional return value
(pathname obj)))
(compile 'compile-stem)
;;; Execute function FN in an environment appropriate for compiling the
;;; cross-compiler's source code in the cross-compilation host.
(defun in-host-compilation-mode (fn)
(declare (type function fn))
(let ((*features* (cons :sb-xc-host *features*))
;; the CROSS-FLOAT-INFINITY-KLUDGE, as documented in
;; base-target-features.lisp-expr:
(*shebang-features* (set-difference *shebang-features*
'(:sb-propagate-float-type
:sb-propagate-fun-type))))
(with-additional-nickname ("SB-XC" "SB!XC")
(funcall fn))))
(compile 'in-host-compilation-mode)
;;; Process a file as source code for the cross-compiler, compiling it
;;; (if necessary) in the appropriate environment, then loading it
;;; into the cross-compilation host Common lisp.
(defun host-cload-stem (stem flags)
(let ((compiled-filename (in-host-compilation-mode
(lambda ()
(compile-stem stem flags :host-compile)))))
(load compiled-filename)))
(compile 'host-cload-stem)
;;; like HOST-CLOAD-STEM, except that we don't bother to compile
(defun host-load-stem (stem flags)
(load (stem-object-path stem flags :host-compile)))
(compile 'host-load-stem)
;;;; tools to compile SBCL sources to create object files which will
;;;; be used to create the target SBCL .core file
;;; Run the cross-compiler on a file in the source directory tree to
;;; produce a corresponding file in the target object directory tree.
(defun target-compile-stem (stem flags)
(funcall *in-target-compilation-mode-fn*
(lambda ()
(compile-stem stem flags :target-compile))))
(compile 'target-compile-stem)
;;; (This function is not used by the build process, but is intended
;;; for interactive use when experimenting with the system. It runs
;;; the cross-compiler on test files with arbitrary filenames, not
;;; necessarily in the source tree, e.g. in "/tmp".)
(defun target-compile-file (filename)
(funcall *in-target-compilation-mode-fn*
(lambda ()
(funcall *target-compile-file* filename))))
(compile 'target-compile-file)