X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcold%2Fshared.lisp;h=86dcd58a93883e8f49719399beea0cdebd183f0c;hb=670010e3f3dcd62efaf23f61abdc73950edb88c6;hp=7fcb851e448b09302110c068c015e3aa169a9cc9;hpb=6e7e59adb6f6c30f84b31695b48cb51e2c519d75;p=sbcl.git diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 7fcb851..86dcd58 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -15,27 +15,6 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -;;; GC tuning has little effect on the x86 due to the generational -;;; collector. For the older stop & copy collector, it assuredly -;;; does. GC time is proportional to the amount of non-garbage -;;; needing collection and copying; when the application involved is -;;; the SBCL compiler, it doesn't take any longer to collect 20 Mb than -;;; to collect 2 Mb. -dan, 20000819 -;;; -;;; Actually, tweaking *BYTES-CONSED-BETWEEN-GCS* to 20Mb instead of -;;; the default 2 seemed to make SBCL rebuild O(25%) faster on my 256 -;;; Mb K6/3, so I think it does have some effect on X86/GENCGC. I -;;; haven't looked into why this would be, though. Also, I'm afraid -;;; that using 20Mb here might be unfriendly to people using more-reasonable -;;; machines (like old laptops with 48Mb of memory..) so I've -;;; suppressed this tweak except for Alpha. -- WHN 2001-05-11 -#+(and sbcl alpha) ; SBCL/Alpha uses stop-and-copy, and Alphas have lotso RAM. -(progn - (sb-ext:gc-off) - (setf (sb-ext:bytes-consed-between-gcs) (* 20 (expt 10 6))) - (sb-ext:gc-on) - (sb-ext:gc)) - ;;; 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 @@ -67,6 +46,7 @@ ;; that we never explicitly refer to host object file suffixes, ;; only to the result of CL:COMPILE-FILE-PATHNAME. #+lispworks ".ufsl" ; as per Lieven Marchand sbcl-devel 2002-02-01 + #+openmcl ".pfsl" ;; On most xc hosts, any old extension works, so we use an ;; arbitrary one. ".lisp-obj")) @@ -79,11 +59,12 @@ ;;; 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*) -;;; designator for a function with the same calling convention as -;;; CL:COMPILE-FILE, to be used to translate ordinary Lisp source files into -;;; target object files +;;; 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 @@ -107,20 +88,16 @@ ;;; COMPILE-STEM function above. -- WHN 19990321 (defun rename-file-a-la-unix (x y) - ;; CLISP signals an error when the target file exists, which - ;; seems unjustified by the ANSI definition of RENAME-FILE. - ;; Work around it. - #+clisp (ignore-errors (delete-file y)) - - (rename-file x - ;; (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)))) + (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) ;;; a wrapper for compilation/assembly, used mostly to centralize @@ -154,6 +131,8 @@ (compile-file #'compile-file) ignore-failure-p) + (declare (type function compile-file)) + (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 @@ -175,41 +154,62 @@ (when (probe-file obj) (delete-file obj)) - ;; 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. - #+clisp + ;; 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) (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. - (multiple-value-bind (output-truename warnings-p failure-p) - (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 - (progn - ;; FIXME: This should have another option, - ;; redoing compilation. - (cerror "Continue, using possibly-bogus ~S." - "FAILURE-P was set when creating ~S." - obj) - (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))) + (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) + (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. @@ -252,6 +252,20 @@ (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*)) ;;;; cold-init-related PACKAGE and SYMBOL tools @@ -260,11 +274,11 @@ ;;; values of special variables such as *** and +, anyway). Set up ;;; machinery to warn us when/if we change it. ;;; -;;; FIXME: All this machinery should probably be conditional on -;;; #!+SB-SHOW, i.e. we should be able to wrap #!+SB-SHOW around both -;;; the LOAD and the DEFVAR here. -(load "src/cold/snapshot.lisp") -(defvar *cl-snapshot* (take-snapshot "COMMON-LISP")) +;;; 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 @@ -272,10 +286,13 @@ (defparameter *expected-stem-flags* '(;; meaning: This file is not to be compiled when building the - ;; cross-compiler which runs on the host ANSI Lisp. + ;; 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. + ;; SBCL. ("not target code" -- but still presumably host code, + ;; used to support the cross-compilation process) :not-target ;; meaning: This file is to be processed with the SBCL assembler, ;; not COMPILE-FILE. (Note that this doesn't make sense unless @@ -294,7 +311,7 @@ (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-"))) + (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))) @@ -316,6 +333,7 @@ ;;; 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: