From 577487adfc43408ef5fba0ce118b961407e33494 Mon Sep 17 00:00:00 2001 From: Alastair Bridgewater Date: Tue, 5 May 2009 17:10:29 +0000 Subject: [PATCH] 1.0.28.14: Build system refactoring Moved flag processing as far "inward" as possible when dealing with compile-stem, reducing the amount of redundant code for parsing out and passing along boolean keywords based on the presence or absence of a flag and eliminating some of the keyword arguments to compile-stem. Added a "mode" parameter to compile-stem to enable determining the correct compile-file function based on the combination of mode and flags, further simplifying the interface. Added new functions for determining the source and object pathnames for a stem, fixing a longstanding KLUDGE in host-load-stem, consolidating the three instances of code to compute an object pathname and the two instances of code to compute a source pathname and eliminating the rest of the keyword arguments to compile-stem. --- make-genesis-2.lisp | 2 +- make-host-1.lisp | 2 +- src/cold/compile-cold-sbcl.lisp | 6 +- src/cold/defun-load-or-cload-xcompiler.lisp | 4 +- src/cold/shared.lisp | 290 +++++++++++++-------------- src/cold/slam.lisp | 11 +- version.lisp-expr | 2 +- 7 files changed, 146 insertions(+), 171 deletions(-) diff --git a/make-genesis-2.lisp b/make-genesis-2.lisp index 9bc9e21..ae3a24a 100644 --- a/make-genesis-2.lisp +++ b/make-genesis-2.lisp @@ -10,7 +10,7 @@ (with-open-file (s "output/object-filenames-for-genesis.lisp-expr" :direction :input) (read s))) -(host-load-stem "src/compiler/generic/genesis") +(host-load-stem "src/compiler/generic/genesis" nil) (sb!vm:genesis :object-file-names *target-object-file-names* :c-header-dir-name "output/genesis-2" :symbol-table-file-name "src/runtime/sbcl.nm" diff --git a/make-host-1.lisp b/make-host-1.lisp index 6e67ee9..549c50d 100644 --- a/make-host-1.lisp +++ b/make-host-1.lisp @@ -32,7 +32,7 @@ ;;; propagate structure offset and other information to the C runtime ;;; support code. -(host-cload-stem "src/compiler/generic/genesis") +(host-cload-stem "src/compiler/generic/genesis" nil) (sb!vm:genesis :c-header-dir-name "src/runtime/genesis") #+cmu (ext:quit) #+clisp (ext:quit) diff --git a/src/cold/compile-cold-sbcl.lisp b/src/cold/compile-cold-sbcl.lisp index c2017d3..6c0f058 100644 --- a/src/cold/compile-cold-sbcl.lisp +++ b/src/cold/compile-cold-sbcl.lisp @@ -19,11 +19,7 @@ (let ((reversed-target-object-file-names nil)) (do-stems-and-flags (stem flags) (unless (position :not-target flags) - (push (target-compile-stem stem - :trace-file (find :trace-file flags) - :assem-p (find :assem flags) - :ignore-failure-p (find :ignore-failure-p - flags)) + (push (target-compile-stem stem flags) reversed-target-object-file-names) #!+sb-show (warn-when-cl-snapshot-diff *cl-snapshot*))) (setf *target-object-file-names* diff --git a/src/cold/defun-load-or-cload-xcompiler.lisp b/src/cold/defun-load-or-cload-xcompiler.lisp index a83e063..9bd0b1e 100644 --- a/src/cold/defun-load-or-cload-xcompiler.lisp +++ b/src/cold/defun-load-or-cload-xcompiler.lisp @@ -162,9 +162,7 @@ ;; routines. (do-stems-and-flags (stem flags) (unless (find :not-host flags) - (funcall load-or-cload-stem - stem - :ignore-failure-p (find :ignore-failure-p flags)) + (funcall load-or-cload-stem stem flags) #!+sb-show (warn-when-cl-snapshot-diff *cl-snapshot*))) ;; If the cross-compilation host is SBCL itself, we can use the diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 7a77c6d..ee3d1df 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -101,135 +101,6 @@ (rename-file x path))) (compile 'rename-file-a-la-unix) -;;; 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. Several &KEY arguments are accepted: -;;; :SRC-PREFIX, :SRC-SUFFIX = -;;; strings to be concatenated to STEM to produce source filename -;;; :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 -;;; the name of a temporary object file -;;; :COMPILE-FILE, :IGNORE-FAILURE-P = -;;; :COMPILE-FILE is a function to use for compiling the file -;;; (with the same calling conventions as ANSI CL:COMPILE-FILE). -;;; If the third return value (FAILURE-P) of this function is -;;; true, a continuable error will be signalled, unless -;;; :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) - 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))) - - (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) - (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) - ;;; other miscellaneous tools (load "src/cold/read-from-file.lisp") (load "src/cold/rename-package-carefully.lisp") @@ -334,6 +205,21 @@ (,flags (rest ,stem-and-flags))) ,@body)))) +;;; Determine the source path for a stem. +(defun stem-source-path (stem) + (concatenate 'string "" stem ".lisp")) +(compile 'stem-source-path) + +;;; Determine the object path for a stem/mode combination. +(defun stem-object-path (stem mode) + (multiple-value-bind + (obj-prefix obj-suffix) + (ecase mode + (:host-compile (values *host-obj-prefix* *host-obj-suffix*)) + (:target-compile (values *target-obj-prefix* *target-obj-suffix*))) + (concatenate 'string obj-prefix 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) @@ -347,6 +233,122 @@ ;;;; 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 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) + (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) @@ -364,26 +366,17 @@ ;;; 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 &key ignore-failure-p) +(defun host-cload-stem (stem flags) (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))))) + (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 &key ignore-failure-p) - (declare (ignore ignore-failure-p)) ; (It's only relevant when - ;; compiling.) KLUDGE: It's untidy to have the knowledge of how to - ;; construct complete filenames from stems in here as well as in - ;; COMPILE-STEM. It should probably be factored out somehow. -- WHN - ;; 19990815 - (load (concatenate 'simple-string *host-obj-prefix* stem *host-obj-suffix*))) +(defun host-load-stem (stem flags) + (declare (ignore flags)) ; (It's only relevant when compiling.) + (load (stem-object-path stem :host-compile))) (compile 'host-load-stem) ;;;; tools to compile SBCL sources to create object files which will @@ -391,17 +384,10 @@ ;;; 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 trace-file) +(defun target-compile-stem (stem flags) (funcall *in-target-compilation-mode-fn* (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-stem stem flags :target-compile)))) (compile 'target-compile-stem) ;;; (This function is not used by the build process, but is intended diff --git a/src/cold/slam.lisp b/src/cold/slam.lisp index e9dc76f..57e4a4f 100644 --- a/src/cold/slam.lisp +++ b/src/cold/slam.lisp @@ -33,12 +33,7 @@ (do-stems-and-flags (stem flags) (unless (position :not-target flags) - (let ((srcname (concatenate 'string stem ".lisp")) - (objname (concatenate 'string - *target-obj-prefix* - stem - *target-obj-suffix*))) + (let ((srcname (stem-source-path stem)) + (objname (stem-object-path stem :target-compile))) (unless (output-up-to-date-wrt-input-p objname srcname) - (target-compile-stem stem - :assem-p (find :assem flags) - :ignore-failure-p (find :ignore-failure-p flags)))))) + (target-compile-stem stem flags))))) diff --git a/version.lisp-expr b/version.lisp-expr index 5e6d68f..b852a29 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.28.13" +"1.0.28.14" -- 1.7.10.4