lisp-build.lisp 17.9 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; Support to build (compile and load) Lisp files

4
(asdf/package:define-package :asdf/lisp-build
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
5
  (:recycle :asdf/interface :asdf :asdf/lisp-build)
6 7
  (:use :common-lisp :asdf/package :asdf/compatibility :asdf/utility
        :asdf/pathname :asdf/stream :asdf/os :asdf/image)
8
  (:export
9
   ;; Variables
10
   #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
11
   #:*output-translation-function*
12 13 14 15 16
   #:*optimization-settings* #:*previous-optimization-settings*
   #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
   #:*deferred-warnings*
   ;; Functions & Macros
   #:get-optimization-settings #:proclaim-optimization-settings
17 18
   #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
   #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
19 20 21 22
   #:reify-simple-sexp #:unreify-simple-sexp
   #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings
   #:reset-deferred-warnings #:save-deferred-warnings
   #:with-saved-deferred-warnings
23
   #:call-with-asdf-compilation-unit #:with-asdf-compilation-unit
24 25
   #:current-lisp-file-pathname #:load-pathname
   #:lispize-pathname #:compile-file-type #:call-around-hook
26
   #:compile-file* #:compile-file-pathname*
27
   #:load* #:load-from-string #:combine-fasls)
28
  (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
29 30 31 32 33 34 35 36 37 38 39 40 41
(in-package :asdf/lisp-build)

(defvar *compile-file-warnings-behaviour*
  (or #+clisp :ignore :warn)
  "How should ASDF react if it encounters a warning when compiling a file?
Valid values are :error, :warn, and :ignore.")

(defvar *compile-file-failure-behaviour*
  (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
  "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
when compiling a file?  Valid values are :error, :warn, and :ignore.
Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")

42 43 44 45 46

;;; Optimization settings

(defvar *optimization-settings* nil)
(defvar *previous-optimization-settings* nil)
47
(defun* get-optimization-settings ()
48 49 50 51 52 53 54 55 56 57 58 59 60
  "Get current compiler optimization settings, ready to PROCLAIM again"
  (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
    #-(or clisp clozure cmu ecl sbcl scl)
    (warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.")
    #.`(loop :for x :in settings
         ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*))
               #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
               #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
         :for y = (or #+clisp (gethash x system::*optimize*)
                      #+(or clozure ecl) (symbol-value v)
                      #+(or cmu scl) (funcall f c::*default-cookie*)
                      #+sbcl (cdr (assoc x sb-c::*policy*)))
         :when y :collect (list x y))))
61
(defun* proclaim-optimization-settings ()
62 63 64 65 66 67 68 69 70
  "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
  (proclaim `(optimize ,@*optimization-settings*))
  (let ((settings (get-optimization-settings)))
    (unless (equal *previous-optimization-settings* settings)
      (setf *previous-optimization-settings* settings))))


;;; Condition control

71
(defvar *uninteresting-compiler-conditions*
72 73 74 75 76 77 78 79 80
  (append
   #+sbcl
   '(sb-c::simple-compiler-note
     "&OPTIONAL and &KEY found in the same lambda list: ~S"
     sb-int:package-at-variance
     sb-kernel:uninteresting-redefinition
     sb-kernel:undefined-alien-style-warning
     sb-ext:implicit-generic-function-warning
     sb-kernel:lexical-environment-too-complex
81 82 83 84 85 86
     "Couldn't grovel for ~A (unknown to the C compiler)."
     ;; BEWARE: the below four are controversial to include here.
     sb-kernel:redefinition-with-defun
     sb-kernel:redefinition-with-defgeneric
     sb-kernel:redefinition-with-defmethod
     sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
87
   ;;#+clozure '(ccl:compiler-warning)
88 89
   '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
  "Conditions that may be skipped while compiling")
90

91
(defvar *uninteresting-loader-conditions*
92 93 94 95
  (append
   '("Overwriting already existing readtable ~S." ;; from named-readtables
     #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
   #+clisp '(clos::simple-gf-replacing-method-warning))
96
  "Additional conditions that may be skipped while loading")
97 98 99 100 101 102

(defvar *deferred-warnings* ()
  "Warnings the handling of which is deferred until the end of the compilation unit")

;;;; ----- Filtering conditions while building -----

103 104
(defun* call-with-muffled-compiler-conditions (thunk)
  (call-with-muffled-conditions
105
    thunk *uninteresting-compiler-conditions*))
106
(defmacro with-muffled-compiler-conditions ((&optional) &body body)
107
  "Run BODY where uninteresting compiler conditions are muffled"
108 109 110
  `(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
(defun* call-with-muffled-loader-conditions (thunk)
  (call-with-muffled-conditions
111
   thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-conditions*)))
112
(defmacro with-muffled-loader-conditions ((&optional) &body body)
113
  "Run BODY where uninteresting compiler and additional loader conditions are muffled"
114
  `(call-with-muffled-loader-conditions #'(lambda () ,@body)))
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

;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.

(defun reify-simple-sexp (sexp)
  (etypecase sexp
    (symbol (reify-symbol sexp))
    ((or number character simple-string pathname) sexp)
    (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))))
(defun unreify-simple-sexp (sexp)
  (etypecase sexp
    ((or symbol number character simple-string pathname) sexp)
    (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
    ((simple-vector 2) (unreify-symbol sexp))))

(defun reify-undefined-warning (warning)
  ;; Extracting undefined-warnings from the compilation-unit
  ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
  #-sbcl (declare (ignore warning))
  #+sbcl
  (list*
   (sb-c::undefined-warning-kind warning)
   (sb-c::undefined-warning-name warning)
   (sb-c::undefined-warning-count warning)
   (mapcar
    #'(lambda (frob)
        ;; the lexenv slot can be ignored for reporting purposes
        `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob)
          :source ,(sb-c::compiler-error-context-source frob)
          :original-source ,(sb-c::compiler-error-context-original-source frob)
          :context ,(sb-c::compiler-error-context-context frob)
          :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname
          :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer
          :original-source-path ,(sb-c::compiler-error-context-original-source-path frob)))
    (sb-c::undefined-warning-warnings warning))))

(defun reify-deferred-warnings ()
  #-sbcl nil
  #+sbcl
  (when sb-c::*in-compilation-unit*
    ;; Try to send nothing through the pipe if nothing needs to be accumulated
    `(,@(when sb-c::*undefined-warnings*
          `((sb-c::*undefined-warnings*
             ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*))))
      ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count*
                              sb-c::*compiler-error-count*
                              sb-c::*compiler-warning-count*
                              sb-c::*compiler-style-warning-count*
                              sb-c::*compiler-note-count*)
              :for value = (symbol-value what)
              :when (plusp value)
                :collect `(,what . ,value)))))

(defun unreify-deferred-warnings (constructor-list)
  #-sbcl (declare (ignore constructor-list))
  #+sbcl
  (dolist (item constructor-list)
    ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
    ;; For *undefined-warnings*, the adjustment is a list of initargs.
    ;; For everything else, it's an integer.
    (destructuring-bind (symbol . adjustment) item
      (case symbol
        ((sb-c::*undefined-warnings*)
         (setf sb-c::*undefined-warnings*
               (nconc (mapcan
                       #'(lambda (stuff)
                           (destructuring-bind (kind name count . rest) stuff
                             (if (and (eq kind :function) (fboundp name))
                                 nil
                                 (list
                                  (sb-c::make-undefined-warning
                                   :name name
                                   :kind kind
                                   :count count
                                   :warnings
                                   (mapcar #'(lambda (x)
                                               (apply #'sb-c::make-compiler-error-context x))
                                           rest))))))
                       adjustment)
                      sb-c::*undefined-warnings*)))
        (otherwise
         (set symbol (+ (symbol-value symbol) adjustment)))))))

(defun reset-deferred-warnings ()
  #+sbcl
  (when sb-c::*in-compilation-unit*
    (setf sb-c::*undefined-warnings* nil
          sb-c::*aborted-compilation-unit-count* 0
          sb-c::*compiler-error-count* 0
          sb-c::*compiler-warning-count* 0
          sb-c::*compiler-style-warning-count* 0
          sb-c::*compiler-note-count* 0)))

(defun* save-deferred-warnings (warnings-file)
209 210
  "Save forward reference conditions so they may be issued at a latter time,
possibly in a different process."
211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233
  (with-open-file (s warnings-file :direction :output :if-exists :supersede)
    (if-let ((deferred-warnings (reify-deferred-warnings)))
      (with-safe-io-syntax ()
        (write deferred-warnings :stream s :pretty t :readably t)
        (terpri s))))
  (reset-deferred-warnings))

(defun* call-with-saved-deferred-warnings (thunk warnings-file)
  (if warnings-file
      (with-compilation-unit (:override t)
        (let ((*deferred-warnings* ())
              #+sbcl (sb-c::*undefined-warnings* nil))
          (multiple-value-prog1
              (with-muffled-compiler-conditions ()
                (funcall thunk))
            (save-deferred-warnings warnings-file))))
      (funcall thunk)))

(defmacro with-saved-deferred-warnings ((warnings-file) &body body)
  "If WARNINGS-FILE is not nil, records the deferred-warnings around the BODY
and saves those warnings to the given file for latter use,
possibly in a different process. Otherwise just run the BODY."
  `(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file))
234 235 236 237


;;; from ASDF

238 239 240
(defun* current-lisp-file-pathname ()
  (or *compile-file-pathname* *load-pathname*))

241 242 243
(defun* load-pathname ()
  *load-pathname*)

244 245 246
(defun* lispize-pathname (input-file)
  (make-pathname :type "lisp" :defaults input-file))

247
(defun* compile-file-type (&rest keys)
248 249
  "pathname TYPE for lisp FASt Loading files"
  (declare (ignorable keys))
250
  #-(or ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
251
  #+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
252

253
(defun* call-around-hook (hook function)
254
  (call-function (or hook 'funcall) function))
255

256
(defun* compile-file* (input-file &rest keys
257 258
                                  &key compile-check output-file warnings-file
                                  #+(or ecl mkcl) object-file
259 260 261 262 263 264 265 266 267 268 269 270 271 272 273
                                  &allow-other-keys)
  "This function provides a portable wrapper around COMPILE-FILE.
It ensures that the OUTPUT-FILE value is only returned and
the file only actually created if the compilation was successful,
even though your implementation may not do that, and including
an optional call to an user-provided consistency check function COMPILE-CHECK;
it will call this function if not NIL at the end of the compilation
with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE
where TMP-FILE is the name of a temporary output-file.
It also checks two flags (with legacy british spelling from ASDF1),
*COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR*
with appropriate implementation-dependent defaults,
and if a failure (respectively warnings) are reported by COMPILE-FILE
with consider it an error unless the respective behaviour flag
is one of :SUCCESS :WARN :IGNORE.
274
If WARNINGS-FILE is defined, deferred warnings are saved to that file.
275 276 277
On ECL or MKCL, it creates both the linkable object and loadable fasl files.
On implementations that erroneously do not recognize standard keyword arguments,
it will filter them appropriately."
278
  (let* ((keywords (remove-keys
279
                    `(:compile-check :warnings-file
280
                      #+gcl<2.7 ,@'(:external-format :print :verbose)) keys))
281
         (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))
282 283
         #+ecl
         (object-file
284
           (unless (use-ecl-byte-compiler-p)
285 286 287 288 289
             (or object-file
                 (compile-file-pathname output-file :type :object))))
         #+mkcl
         (object-file
           (or object-file
290 291
               (compile-file-pathname output-file :fasl-p nil)))
         (tmp-file (tmpize-pathname output-file)))
292
    (multiple-value-bind (output-truename warnings-p failure-p)
293 294 295 296 297 298 299 300
        (with-saved-deferred-warnings (warnings-file)
          (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords)
              #+ecl (apply 'compile-file input-file :output-file
                           (if object-file
                               (list* object-file :system-p t keywords)
                               (list* output-file keywords)))
              #+mkcl (apply 'compile-file input-file
                            :output-file object-file :fasl-p nil keywords)))
301
      (cond
302 303 304 305 306 307 308
        ((and output-truename
              (flet ((check-flag (flag behaviour)
                       (or (not flag) (member behaviour '(:success :warn :ignore)))))
                (and (check-flag failure-p *compile-file-failure-behaviour*)
                     (check-flag warnings-p *compile-file-warnings-behaviour*)))
              (progn
                #+(or ecl mkcl)
309
                (when (and #+ecl object-file)
310 311 312 313 314 315
                  (setf output-truename
                        (compiler::build-fasl
                         tmp-file #+ecl :lisp-files #+mkcl :lisp-object-files
                                  (list object-file))))
                (or (not compile-check)
                    (apply compile-check input-file :output-file tmp-file keywords))))
316 317 318
         (delete-file-if-exists output-file)
         (when output-truename
           (rename-file-overwriting-target output-truename output-file)
319
           (setf output-truename (truename output-file))))
320 321
        (t ;; error or failed check
         (delete-file-if-exists output-truename)
322
         (setf output-truename nil)))
323 324 325
      (values output-truename warnings-p failure-p))))

(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
326 327 328 329 330
  (let* ((keys
           (remove-keys `(#+(and allegro (not (version>= 8 2))) :external-format
                            ,@(unless output-file '(:output-file))) keys)))
    (if (absolute-pathname-p output-file)
        ;; what cfp should be doing, w/ mp* instead of mp
331
        (let* ((type (pathname-type (apply 'compile-file-type keys)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
332 333 334
               (defaults (make-pathname
                          :type type :defaults (merge-pathnames* input-file))))
          (merge-pathnames* output-file defaults))
335
        (funcall *output-translation-function*
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
336
                 (apply 'compile-file-pathname input-file keys)))))
337

338
(defun* load* (x &rest keys &key &allow-other-keys)
339
  (etypecase x
340
    ((or pathname string #-(or gcl<2.7 clozure allegro) stream)
341
     (apply 'load x
342
            #-gcl<2.7 keys #+gcl<2.7 (remove-key :external-format keys)))
343 344 345 346 347
    #-(or gcl<2.7 clozure allegro)
    ;; GCL 2.6 can't load from a string-input-stream
    ;; ClozureCL 1.6 can only load from file input stream
    ;; Allegro 5, I don't remember but it must have been broken when I tested.
    (stream ;; make do this way
348 349 350 351
     (let ((*package* *package*)
           (*readtable* *readtable*)
           (*load-pathname* nil)
           (*load-truename* nil))
352 353 354 355 356 357 358
       (eval-input x)))))

(defun* load-from-string (string)
  "Portably read and evaluate forms from a STRING."
  (with-input-from-string (s string) (load* s)))

;;; Links FASLs together
359 360
(defun* combine-fasls (inputs output)
  #-(or allegro clisp clozure cmu lispworks sbcl scl xcl)
361 362
  (error "~A does not support ~S~%inputs ~S~%output  ~S"
         (implementation-type) 'combine-fasls inputs output)
363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384
  #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
  #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output)
  #+lispworks
  (let (fasls)
    (unwind-protect
         (progn
           (loop :for i :in inputs
                 :for n :from 1
                 :for f = (add-pathname-suffix
                           output (format nil "-FASL~D" n))
                 :do #-lispworks-personal-edition (lispworks:copy-file i f)
                     #+lispworks-personal-edition (concatenate-files (list i) f)
                     (push f fasls))
           (ignore-errors (lispworks:delete-system :fasls-to-concatenate))
           (eval `(scm:defsystem :fasls-to-concatenate
                    (:default-pathname ,(pathname-directory-pathname output))
                    :members
                    ,(loop :for f :in (reverse fasls)
                           :collect `(,(namestring f) :load-only t))))
           (scm:concatenate-system output :fasls-to-concatenate))
      (loop :for f :in fasls :do (ignore-errors (delete-file f)))
      (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))
385