X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcold%2Fshared.lisp;h=7a77c6d338cf02eb0995aadb896f1e8c11626bf7;hb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;hp=5f86752620730c51836e54beb9b4890e6bd86cc3;hpb=fea8ea02847ddc0864546a02480fb3e97d6fa318;p=sbcl.git diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 5f86752..7a77c6d 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -23,17 +23,6 @@ (in-package "SB-COLD") -;;; FIXME: This is embarassing -- SBCL violates SBCL style-package -;;; locks on the host lisp. Rather then find and fix all the cases -;;; right now, let's just remain self-hosting. The problems at least -;;; involve a few defvars and local macros with names in the CL -;;; package. -#+sbcl -(let ((plp (find-symbol PACKAGE-LOCKED-P :sb-ext))) - (when (and plp (fboundp plp)) - (dolist (p (list-all-packages)) - (sb-ext::unlock-package p)))) - ;;; 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. @@ -45,7 +34,7 @@ (defvar *target-obj-prefix*) ;;; suffixes for filename stems when cross-compiling -(defvar *host-obj-suffix* +(defvar *host-obj-suffix* (or ;; 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 @@ -100,14 +89,14 @@ ;;; 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)))) + (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) @@ -124,7 +113,7 @@ ;;; :OBJ-PREFIX, :OBJ-SUFFIX = ;;; strings to be concatenated to STEM to produce object filename ;;; :TMP-OBJ-SUFFIX-SUFFIX = -;;; string to be appended to the name of an object file to produce +;;; string to be appended to the name of an object file to produce ;;; the name of a temporary object file ;;; :COMPILE-FILE, :IGNORE-FAILURE-P = ;;; :COMPILE-FILE is a function to use for compiling the file @@ -134,28 +123,29 @@ ;;; :IGNORE-FAILURE-P is set, in which case only a warning will be ;;; signalled. (defun compile-stem (stem - &key - (obj-prefix "") - (obj-suffix (error "missing OBJ-SUFFIX")) - (tmp-obj-suffix-suffix "-tmp") - (src-prefix "") - (src-suffix ".lisp") - (compile-file #'compile-file) - ignore-failure-p) + &key + (obj-prefix "") + (obj-suffix (error "missing OBJ-SUFFIX")) + (tmp-obj-suffix-suffix "-tmp") + (src-prefix "") + (src-suffix ".lisp") + (compile-file #'compile-file) + trace-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 - ;; 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 (concatenate 'string src-prefix stem src-suffix)) - (obj (concatenate 'string obj-prefix stem obj-suffix)) - (tmp-obj (concatenate 'string obj tmp-obj-suffix-suffix))) + ;; 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 (concatenate 'string src-prefix stem src-suffix)) + (obj (concatenate 'string obj-prefix stem obj-suffix)) + (tmp-obj (concatenate 'string obj tmp-obj-suffix-suffix))) (ensure-directories-exist obj :verbose t) @@ -179,11 +169,17 @@ ;; 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))) + ;; (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 @@ -198,7 +194,10 @@ (tagbody retry-compile-file (multiple-value-bind (output-truename warnings-p failure-p) - (funcall compile-file src :output-file tmp-obj) + (if trace-file + (funcall compile-file src :output-file tmp-obj + :trace-file t) + (funcall compile-file src :output-file tmp-obj )) (declare (ignore warnings-p)) (cond ((not output-truename) (error "couldn't compile ~S" src)) @@ -251,33 +250,33 @@ ;;; readmacros instead of the ordinary #+ and #- readmacros. (setf *shebang-features* (let* ((default-features - (append (read-from-file "base-target-features.lisp-expr") - (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))) + (append (read-from-file "base-target-features.lisp-expr") + (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*)) + "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))) + (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*)) + "target backend-subfeatures *SHEBANG-BACKEND-FEATURES*=~@<~S~:>~%" + *shebang-backend-subfeatures*)) ;;;; cold-init-related PACKAGE and SYMBOL tools @@ -306,6 +305,12 @@ ;; 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 @@ -326,8 +331,8 @@ (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)))) + (,flags (rest ,stem-and-flags))) + ,@body)))) ;;; Check for stupid typos in FLAGS list keywords. (let ((stems (make-hash-table :test 'equal))) @@ -337,8 +342,8 @@ (setf (gethash stem stems) t)) (let ((set-difference (set-difference flags *expected-stem-flags*))) (when set-difference - (error "found unexpected flag(s) in *STEMS-AND-FLAGS*: ~S" - set-difference))))) + (error "found unexpected flag(s) in *STEMS-AND-FLAGS*: ~S" + set-difference))))) ;;;; tools to compile SBCL sources to create the cross-compiler @@ -347,11 +352,11 @@ (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)))) + ;; 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) @@ -361,13 +366,13 @@ ;;; into the cross-compilation host Common lisp. (defun host-cload-stem (stem &key ignore-failure-p) (let ((compiled-filename (in-host-compilation-mode - (lambda () - (compile-stem - stem - :obj-prefix *host-obj-prefix* - :obj-suffix *host-obj-suffix* - :compile-file #'cl:compile-file - :ignore-failure-p ignore-failure-p))))) + (lambda () + (compile-stem + stem + :obj-prefix *host-obj-prefix* + :obj-suffix *host-obj-suffix* + :compile-file #'cl:compile-file + :ignore-failure-p ignore-failure-p))))) (load compiled-filename))) (compile 'host-cload-stem) @@ -386,16 +391,17 @@ ;;; 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 &key assem-p ignore-failure-p) +(defun target-compile-stem (stem &key assem-p ignore-failure-p trace-file) (funcall *in-target-compilation-mode-fn* - (lambda () - (compile-stem stem - :obj-prefix *target-obj-prefix* - :obj-suffix *target-obj-suffix* - :ignore-failure-p ignore-failure-p - :compile-file (if assem-p - *target-assemble-file* - *target-compile-file*))))) + (lambda () + (compile-stem stem + :obj-prefix *target-obj-prefix* + :obj-suffix *target-obj-suffix* + :trace-file trace-file + :ignore-failure-p ignore-failure-p + :compile-file (if assem-p + *target-assemble-file* + *target-compile-file*))))) (compile 'target-compile-stem) ;;; (This function is not used by the build process, but is intended @@ -404,6 +410,6 @@ ;;; 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)))) + (lambda () + (funcall *target-compile-file* filename)))) (compile 'target-compile-file)