source: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp @ 15398

Last change on this file since 15398 was 15398, checked in by Mark Evenson, 2 years ago

Fixes for working under Windows 10

Remove intermediate compiler artifacts from the ZipCache?.

Fix URI for previous release.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 46.3 KB
Line 
1;;; compile-file.lisp
2;;;
3;;; Copyright (C) 2004-2006 Peter Graves
4;;; $Id: compile-file.lisp 15398 2020-10-10 21:43:33Z mevenson $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package #:system)
33
34(require "COMPILER-PASS2")
35
36
37(export 'compile-file-if-needed)
38
39(defvar *fbound-names*)
40
41(defvar *class-number*)
42
43(defvar *output-file-pathname*)
44
45(defvar *toplevel-functions*)
46(defvar *toplevel-macros*)
47(defvar *toplevel-exports*)
48(defvar *toplevel-setf-expanders*)
49(defvar *toplevel-setf-functions*)
50
51
52(defun base-classname (&optional (output-file-pathname *output-file-pathname*))
53  (sanitize-class-name (pathname-name output-file-pathname)))
54
55(defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*))
56  (%format nil "~A_0" (base-classname output-file-pathname)))
57
58(declaim (ftype (function (t) t) compute-classfile))
59(defun compute-classfile (n &optional (output-file-pathname
60                                            *output-file-pathname*))
61  "Computes the pathname of the class file associated with number `n'."
62  (let ((name
63         (sanitize-class-name
64    (%format nil "~A_~D" (pathname-name output-file-pathname) n))))
65    (merge-pathnames (make-pathname :name name :type *compile-file-class-extension*)
66                                 output-file-pathname)))
67
68(defun sanitize-class-name (name)
69  (let ((name (copy-seq name)))
70    (dotimes (i (length name))
71      (declare (type fixnum i))
72      (when (or (char= (char name i) #\-)
73    (char= (char name i) #\.)
74    (char= (char name i) #\Space))
75        (setf (char name i) #\_)))
76    name))
77 
78
79(declaim (ftype (function () t) next-classfile))
80(defun next-classfile ()
81  (compute-classfile (incf *class-number*)))
82
83(defmacro report-error (&rest forms)
84  `(handler-case (progn ,@forms)
85     (compiler-unsupported-feature-error (condition)
86       (fresh-line)
87       (%format t "; UNSUPPORTED-FEATURE: ~A~%" condition)
88       (values nil condition))))
89
90;; Dummy function. Should never be called.
91(defun dummy (&rest ignored)
92  (declare (ignore ignored))
93  (assert nil))
94
95;;; ??? rename to something shorter?
96(defparameter *compiler-diagnostic* nil
97  "The stream to emit compiler diagnostic messages to, or nil to muffle output.")
98(export '*compiler-diagnostic*)
99(defmacro diag (fmt &rest args)
100  `(format *compiler-diagnostic* "~&SYSTEM::*COMPILER-DIAGNOSTIC* ~A~&" (format nil ,fmt ,@args)))
101
102(declaim (ftype (function (t) t) verify-load))
103(defun verify-load (classfile &key (force nil))
104  "Return whether the file at the path denoted by CLASSFILE is a loadable JVM artifact."
105  (declare (ignore force))
106  (unless classfile
107    (diag "Nil classfile argument passed to verify-load.")
108    (return-from verify-load nil))
109  (with-open-file (cf classfile :direction :input)
110    (when 
111        (= 0 (file-length cf))
112;;; TODO hook into a real ABCL compiler condition hierarchy
113      (diag "Internal compiler error detected: Fasl contains ~
114zero-length jvm classfile corresponding to ~A." classfile)
115      (return-from verify-load nil)))
116  ;; ### FIXME
117  ;; The section below can't work, because we have
118  ;; circular references between classes of outer- and innerscoped
119  ;; functions. We need the class loader to resolve these circular
120  ;; references for us. Our FASL class loader does exactly that,
121  ;; so we need a class loader here which knows how to find
122  ;; all the .cls files related to the current scope being loaded.
123  #+nil
124  (when (or force (> *safety* *speed*))
125    (diag "Testing compiled bytecode by loading classfile into JVM.")
126    (let ((*load-truename* *output-file-pathname*))
127      ;; load-compiled-function used to be wrapped via report-error
128      (return-from verify-load (load-compiled-function classfile))))
129  t)
130
131(declaim (ftype (function (t) t) note-toplevel-form))
132(defun note-toplevel-form (form)
133  (when *compile-print*
134    (fresh-line)
135    (princ "; ")
136    (let ((*print-length* 2)
137          (*print-level* 2)
138          (*print-pretty* nil))
139      (prin1 form))
140    (terpri)))
141
142(defun output-form (form)
143  (if *binary-fasls*
144      (push form *forms-for-output*)
145      (progn
146        (dump-form form *fasl-stream*)
147        (%stream-terpri *fasl-stream*))))
148
149(defun finalize-fasl-output ()
150  (when *binary-fasls*
151    (let ((*package* (find-package :keyword))
152          (*double-colon-package-separators* T))
153      (dump-form (convert-toplevel-form (list* 'PROGN
154                                               (nreverse *forms-for-output*))
155                                        t)
156                 *fasl-stream*))
157    (%stream-terpri *fasl-stream*)))
158
159
160(declaim (ftype (function (t) t) simple-toplevel-form-p))
161(defun simple-toplevel-form-p (form)
162  "Returns NIL if the form is too complex to become an
163interpreted toplevel form, non-NIL if it is 'simple enough'."
164  (and (consp form)
165       (every #'(lambda (arg)
166                  (or (and (atom arg)
167                           (not (and (symbolp arg)
168                                     (symbol-macro-p arg))))
169                      (and (consp arg)
170                           (eq 'QUOTE (car arg)))))
171              (cdr form))))
172
173(declaim (ftype (function (t t) t) convert-toplevel-form))
174(defun convert-toplevel-form (form declare-inline)
175  (when (or (simple-toplevel-form-p form)
176            (and (eq (car form) 'SETQ)
177                 ;; for SETQ, look at the evaluated part
178                 (simple-toplevel-form-p (third form))))
179    ;; single form with simple or constant arguments
180    ;; Without this exception, toplevel function calls
181    ;; will be compiled into lambdas which get compiled to
182    ;; compiled-functions. Those need to be loaded.
183    ;; Conclusion: Top level interpreting the function call
184    ;;  and its arguments may be (and should be) more efficient.
185    (return-from convert-toplevel-form
186      (precompiler:precompile-form form nil *compile-file-environment*)))
187  (let* ((toplevel-form (third form))
188         (expr `(lambda () ,form))
189         (saved-class-number *class-number*)
190         (classfile (next-classfile))
191         (result
192          (with-open-file
193              (f classfile
194                 :direction :output
195                 :element-type '(unsigned-byte 8)
196                 :if-exists :supersede)
197            (report-error (jvm:compile-defun nil
198                                             expr *compile-file-environment*
199                                             classfile f
200                                             declare-inline))))
201         (compiled-function (verify-load classfile)))
202    (declare (ignore toplevel-form result))
203    (progn
204      #+nil
205      (when (> *debug* 0)
206;; TODO        (annotate form toplevel-form classfile compiled-function fasl-class-number)
207        ;;; ??? define an API by perhaps exporting these symbols?
208        (setf (getf form 'form-source) 
209              toplevel-form
210             
211              (getf form 'classfile) 
212              classfile
213                   
214              (getf form 'compiled-function) 
215              compiled-function
216                 
217              (getf form 'class-number) 
218              saved-class-number))
219      (setf form
220            (if compiled-function
221                `(funcall (sys::get-fasl-function *fasl-loader*
222                                                  ,saved-class-number))
223                (precompiler:precompile-form form nil
224                                             *compile-file-environment*))))))
225
226
227(declaim (ftype (function (t stream t) t) process-progn))
228(defun process-progn (forms stream compile-time-too)
229  (dolist (form forms)
230    (process-toplevel-form form stream compile-time-too))
231  nil)
232
233
234(declaim (ftype (function (t t t) t) process-toplevel-form))
235(defun precompile-toplevel-form (form stream compile-time-too)
236  (declare (ignore stream))
237  (let ((form (precompiler:precompile-form form nil
238                                           *compile-file-environment*)))
239    (when compile-time-too
240      (eval form))
241    form))
242
243
244
245(defun process-toplevel-macrolet (form stream compile-time-too)
246  (let ((*compile-file-environment*
247         (make-environment *compile-file-environment*)))
248    (dolist (definition (cadr form))
249      (environment-add-macro-definition *compile-file-environment*
250                                        (car definition)
251                                        (make-macro (car definition)
252                                                    (make-macro-expander definition))))
253    (dolist (body-form (cddr form))
254      (process-toplevel-form body-form stream compile-time-too)))
255  nil)
256
257(declaim (ftype (function (t t t) t) process-toplevel-defconstant))
258(defun process-toplevel-defconstant (form stream compile-time-too)
259  (declare (ignore stream compile-time-too))
260  ;; "If a DEFCONSTANT form appears as a top level form, the compiler
261  ;; must recognize that [the] name names a constant variable. An
262  ;; implementation may choose to evaluate the value-form at compile
263  ;; time, load time, or both. Therefore, users must ensure that the
264  ;; initial-value can be evaluated at compile time (regardless of
265  ;; whether or not references to name appear in the file) and that
266  ;; it always evaluates to the same value."
267  (note-toplevel-form form)
268  (eval form)
269      ;;; emit make-array  when initial-value is a specialized vector
270  (let ((initial-value (third form)))
271    (when (and (atom initial-value)
272               (arrayp initial-value)
273               (= (length (array-dimensions initial-value)) 1)
274               (not (eq (array-element-type initial-value) t)))
275      (setf (third form)
276            `(common-lisp:make-array
277              ',(array-dimensions initial-value)
278              :element-type ',(array-element-type initial-value)
279              :initial-contents ',(coerce initial-value 'list)))))
280  `(progn
281     (put ',(second form) 'sys::source (cons '(,(second form) ,(namestring *source*) ,*source-position*) (get ',(second form)  'sys::source nil)))
282     ,form))
283
284(declaim (ftype (function (t t t) t) process-toplevel-quote))
285(defun process-toplevel-quote (form stream compile-time-too)
286  (declare (ignore stream))
287  (when compile-time-too
288    (eval form))
289  nil)
290
291
292(declaim (ftype (function (t t t) t) process-toplevel-import))
293(defun process-toplevel-import (form stream compile-time-too)
294  (declare (ignore stream))
295  (let ((form (precompiler:precompile-form form nil
296                                           *compile-file-environment*)))
297    (let ((*package* +keyword-package+))
298      (output-form form))
299    (when compile-time-too
300      (eval form)))
301  nil)
302
303(declaim (ftype (function (t t t) t) process-toplevel-export))
304(defun process-toplevel-export (form stream compile-time-too)
305  (when (and (listp (second form))
306             (eq (car (second form)) 'QUOTE)) ;; constant export list
307    (let ((sym-or-syms (second (second form))))
308      (setf *toplevel-exports*
309            (append  *toplevel-exports* (if (listp sym-or-syms)
310                                            sym-or-syms
311                                            (list sym-or-syms))))))
312  (precompile-toplevel-form form stream compile-time-too))
313
314
315(declaim (ftype (function (t t t) t) process-record-source-information))
316
317(defun process-record-source-information (form stream compile-time-too)
318  (declare (ignore stream compile-time-too))
319  (let* ((name (second form))
320   (type (third form)))
321    (when (quoted-form-p name) (setq name (second name)))
322    (when (quoted-form-p type) (setq type (second type)))
323    (let ((sym (if (consp name) (second name) name)))
324      `(put ',sym 'sys::source (cons '(,type ,(namestring *source*) ,*source-position*)
325           (get ',sym  'sys::source nil))))))
326
327   
328(declaim (ftype (function (t t t) t) process-toplevel-mop.ensure-method))
329(defun process-toplevel-mop.ensure-method (form stream compile-time-too)
330  (declare (ignore stream))
331  (flet ((convert-ensure-method (form key)
332           (let* ((tail (cddr form))
333                  (function-form (getf tail key)))
334             (when (and function-form (consp function-form)
335               (eq (%car function-form) 'FUNCTION))
336               (let ((lambda-expression (cadr function-form)))
337                 (jvm::with-saved-compiler-policy
338                     (let* ((saved-class-number *class-number*)
339                            (classfile (next-classfile))
340                            (result
341                             (with-open-file
342                                 (f classfile
343                                    :direction :output
344                                    :element-type '(unsigned-byte 8)
345                                    :if-exists :supersede)
346                               (report-error
347                                (jvm:compile-defun nil lambda-expression
348                                                   *compile-file-environment*
349                                                   classfile f nil))))
350                            (compiled-function (verify-load classfile)))
351                       (declare (ignore result))
352                       (cond
353                         (compiled-function
354                          (setf (getf tail key)
355                                `(sys::get-fasl-function *fasl-loader*
356                                                         ,saved-class-number)))
357                         (t
358                          ;; FIXME This should be a warning or error of some sort...
359                          (format *error-output* "; Unable to compile method~%"))))))))))
360
361
362    (when compile-time-too
363      (let* ((copy-form (copy-tree form))
364             ;; ### Ideally, the precompiler would leave the forms alone
365             ;;  and copy them where required, instead of forcing us to
366             ;;  do a deep copy in advance
367             (precompiled-form (precompiler:precompile-form copy-form nil
368                                                            *compile-file-environment*)))
369        (eval precompiled-form)))
370    (convert-ensure-method form :function)
371    (convert-ensure-method form :fast-function))
372  (precompiler:precompile-form form nil *compile-file-environment*))
373
374(declaim (ftype (function (t t t) t) process-toplevel-defvar/defparameter))
375(defun process-toplevel-defvar/defparameter (form stream compile-time-too)
376  (declare (ignore stream))
377  (note-toplevel-form form)
378  (if compile-time-too
379      (eval form)
380      ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form,
381      ;; the compiler must recognize that the name has been proclaimed
382      ;; special. However, it must neither evaluate the initial-value
383      ;; form nor assign the dynamic variable named NAME at compile
384      ;; time."
385      (let ((name (second form)))
386        (%defvar name)))
387  (let ((name (second form))
388        (initial-value (third form)))
389    ;;; emit make-array  when initial-value is a specialized vector
390    (when (and (atom initial-value)
391               (arrayp initial-value)
392               (= (length (array-dimensions initial-value)) 1)
393               (not (eq (array-element-type initial-value) t)))
394      (setf (third form)
395            `(common-lisp:make-array
396              ',(array-dimensions initial-value)
397              :element-type ',(array-element-type initial-value)
398              :initial-contents ',(coerce initial-value 'list))))
399    `(progn 
400       (put ',name 'sys::source (cons (list :variable ,(namestring *source*) ,*source-position*) (get ',name  'sys::source nil)))
401       ,form)))
402
403
404(declaim (ftype (function (t t t) t) process-toplevel-defpackage/in-package))
405(defun process-toplevel-defpackage/in-package (form stream compile-time-too)
406  (declare (ignore stream compile-time-too))
407  (note-toplevel-form form)
408  (let ((defpackage-name (and (eq (car form) 'defpackage) (intern (string (second form)) :keyword))) )
409    (setf form
410    (precompiler:precompile-form form nil *compile-file-environment*))
411    (eval form)
412    ;; Force package prefix to be used when dumping form.
413    (let ((*package* +keyword-package+))
414      (output-form form))
415    ;; a bit ugly here. Since we precompile, and added record-source-information we need to know where it is.
416    ;; The defpackage is at top, so we know where the name is (though it is a string by now)
417    ;; (if it is a defpackage)
418    (if defpackage-name
419  `(put ,defpackage-name 'sys::source
420        (cons '(:package ,(namestring *source*) ,*source-position*)
421        (get ,defpackage-name 'sys::source nil)))
422  nil)))
423
424(declaim (ftype (function (t t t) t) process-toplevel-declare))
425(defun process-toplevel-declare (form stream compile-time-too)
426  (declare (ignore stream compile-time-too))
427  (compiler-style-warn "Misplaced declaration: ~S" form)
428  nil)
429
430(declaim (ftype (function (t t t) t) process-toplevel-progn))
431(defun process-toplevel-progn (form stream compile-time-too)
432  (process-progn (cdr form) stream compile-time-too)
433  nil)
434
435(declaim (ftype (function (t t t) t) process-toplevel-deftype))
436(defun process-toplevel-deftype (form stream compile-time-too)
437  (declare (ignore stream compile-time-too))
438  (note-toplevel-form form)
439  (eval form)
440  `(progn
441     (put ',(second form) 'sys::source (cons '(,(second form) ,(namestring *source*) ,*source-position*) (get ',(second form)  'sys::source nil)))
442     ,form))
443
444(declaim (ftype (function (t t t) t) process-toplevel-eval-when))
445(defun process-toplevel-eval-when (form stream compile-time-too)
446  (flet ((parse-eval-when-situations (situations)
447           "Parse an EVAL-WHEN situations list, returning three flags,
448            (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
449            the types of situations present in the list."
450            ; Adapted from SBCL.
451           (when (or (not (listp situations))
452                     (set-difference situations
453                                     '(:compile-toplevel
454                                       compile
455                                       :load-toplevel
456                                       load
457                                       :execute
458                                       eval)))
459             (error "Bad EVAL-WHEN situation list: ~S." situations))
460           (values (intersection '(:compile-toplevel compile) situations)
461                   (intersection '(:load-toplevel load) situations)
462                   (intersection '(:execute eval) situations))))
463    (multiple-value-bind (ct lt e)
464        (parse-eval-when-situations (cadr form))
465      (let ((new-compile-time-too (or ct (and compile-time-too e)))
466            (body (cddr form)))
467        (if lt
468            (process-progn body stream new-compile-time-too)
469            (when new-compile-time-too
470              (eval `(progn ,@body)))))))
471  nil)
472
473
474(declaim (ftype (function (t t t) t) process-toplevel-defmethod/defgeneric))
475(defun process-toplevel-defmethod/defgeneric (form stream compile-time-too)
476  (note-toplevel-form form)
477  (note-name-defined (second form))
478  (push (second form) *toplevel-functions*)
479  (when (and (consp (second form))
480             (eq 'setf (first (second form))))
481    (push (second (second form))
482          *toplevel-setf-functions*))
483  (let ((*compile-print* nil))
484    (process-toplevel-form (macroexpand-1 form *compile-file-environment*)
485           stream compile-time-too))
486  (let* ((sym (if (consp (second form)) (second (second form)) (second form))))
487    (when (eq (car form) 'defgeneric)
488      `(progn
489   (put ',sym 'sys::source
490        (cons  '((:generic-function ,(second form)) ,(namestring *source*) ,*source-position*) (get ',sym  'sys::source nil)))
491   ,@(loop for method-form in (cdddr form)
492     when (eq (car method-form) :method)
493       collect
494       (multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body) 
495           (mop::parse-defmethod `(,(second form) ,@(rest method-form)))
496                     ;;; FIXME: style points for refactoring double backquote to "normal" form
497         `(put ',sym 'sys::source
498         (cons `((:method ,',sym ,',qualifiers ,',specializers) ,,(namestring *source*) ,,*source-position*)
499         (get ',sym  'sys::source nil)))))))))
500
501
502(declaim (ftype (function (t t t) t) process-toplevel-locally))
503(defun process-toplevel-locally (form stream compile-time-too)
504  (jvm::with-saved-compiler-policy
505      (multiple-value-bind (forms decls)
506          (parse-body (cdr form) nil)
507        (process-optimization-declarations decls)
508        (let* ((jvm::*visible-variables* jvm::*visible-variables*)
509               (specials (jvm::process-declarations-for-vars (cdr form)
510                                                             nil nil)))
511          (dolist (special specials)
512            (push special jvm::*visible-variables*))
513          (process-progn forms stream compile-time-too))))
514  nil)
515
516(declaim (ftype (function (t t t) t) process-toplevel-defmacro))
517(defun process-toplevel-defmacro (form stream compile-time-too)
518  (declare (ignore stream compile-time-too))
519  (note-toplevel-form form)
520  (let ((name (second form)))
521    (eval form)
522    (push name *toplevel-macros*)
523    (let* ((expr (function-lambda-expression (macro-function name)))
524           (saved-class-number *class-number*)
525           (classfile (next-classfile)))
526      (with-open-file
527          (f classfile
528             :direction :output
529             :element-type '(unsigned-byte 8)
530             :if-exists :supersede)
531        (ignore-errors
532          (jvm:compile-defun nil expr *compile-file-environment*
533                             classfile f nil)))
534      (when (null (verify-load classfile))
535        ;; FIXME error or warning
536        (format *error-output* "; Unable to compile macro ~A~%" name)
537        (return-from process-toplevel-defmacro form))
538
539      (if (special-operator-p name)
540          `(put ',name 'macroexpand-macro
541                (make-macro ',name
542                            (sys::get-fasl-function *fasl-loader*
543                                                    ,saved-class-number)))
544    `(progn
545       (put ',name 'sys::source
546      (cons '(:macro  ,(namestring *source*) ,*source-position*) (get ',name  'sys::source nil)))
547       (fset ',name
548       (make-macro ',name
549             (sys::get-fasl-function *fasl-loader*
550                   ,saved-class-number))
551       ,*source-position*
552       ',(third form)
553       ,(%documentation name 'cl:function)))))))
554
555(declaim (ftype (function (t t t) t) process-toplevel-defun))
556(defun process-toplevel-defun (form stream compile-time-too)
557  (declare (ignore stream))
558  (note-toplevel-form form)
559  (let* ((name (second form))
560         (block-name (fdefinition-block-name name))
561         (lambda-list (third form))
562         (body (nthcdr 3 form)))
563    (jvm::with-saved-compiler-policy
564        (multiple-value-bind (body decls doc)
565            (parse-body body)
566          (let* ((expr `(lambda ,lambda-list
567                          ,@decls (block ,block-name ,@body)))
568                 (saved-class-number *class-number*)
569                 (classfile (next-classfile))
570                 (internal-compiler-errors nil)
571                 (result (with-open-file
572                             (f classfile
573                                :direction :output
574                                :element-type '(unsigned-byte 8)
575                                :if-exists :supersede)
576                           (handler-bind
577                               ((internal-compiler-error
578                                 #'(lambda (e)
579                                     (push e internal-compiler-errors)
580                                     (continue))))
581                             (report-error
582                              (jvm:compile-defun name expr *compile-file-environment*
583                                                 classfile f nil)))))
584                 (compiled-function (if (not internal-compiler-errors)
585                                        (verify-load classfile)
586                                        nil)))
587            (declare (ignore result))
588            (cond
589              ((and (not internal-compiler-errors)
590                    compiled-function)
591               (when compile-time-too
592                 (eval form))
593         (let ((sym (if (consp name) (second name) name)))
594     (setf form
595           `(progn
596       (put ',sym 'sys::source (cons '((:function ,name)  ,(namestring *source*) ,*source-position*) (get ',sym  'sys::source nil)))           
597       (fset ',name
598                            (sys::get-fasl-function *fasl-loader*
599                                                    ,saved-class-number)
600                            ,*source-position*
601                            ',lambda-list
602                            ,doc)))))
603              (t
604               (compiler-warn "Unable to compile function ~A.  Using interpreted form instead.~%" name)
605               (when internal-compiler-errors
606                 (dolist (e internal-compiler-errors)
607                   (format *error-output*
608                           "; ~A~%" e)))
609               (let ((precompiled-function
610                      (precompiler:precompile-form expr nil
611                                                   *compile-file-environment*)))
612                 (setf form
613                       `(fset ',name
614                              ,precompiled-function
615                              ,*source-position*
616                              ',lambda-list
617                              ,doc)))
618               (when compile-time-too
619                 (eval form)))))
620          (when (and (symbolp name) (eq (get name '%inline) 'INLINE))
621            ;; FIXME Need to support SETF functions too!
622            (setf (inline-expansion name)
623                  (jvm::generate-inline-expansion block-name
624                                                  lambda-list
625                                                  (append decls body)))
626            (output-form `(setf (inline-expansion ',name)
627                                ',(inline-expansion name))))))
628    (push name jvm::*functions-defined-in-current-file*)
629    (note-name-defined name)
630    (push name *toplevel-functions*)
631    (when (and (consp name)
632               (eq 'setf (first name)))
633      (push (second name) *toplevel-setf-functions*))
634    ;; If NAME is not fbound, provide a dummy definition so that
635    ;; getSymbolFunctionOrDie() will succeed when we try to verify that
636    ;; functions defined later in the same file can be loaded correctly.
637    (unless (fboundp name)
638      (setf (fdefinition name) #'dummy)
639      (push name *fbound-names*)))
640  form)
641
642
643;; toplevel handlers
644;;   each toplevel handler takes a form and stream as input
645
646(defun install-toplevel-handler (symbol handler)
647  (setf (get symbol 'toplevel-handler) handler))
648
649(dolist (pair '((COMPILER-DEFSTRUCT precompile-toplevel-form)
650                (DECLARE process-toplevel-declare)
651                (DEFCONSTANT process-toplevel-defconstant)
652                (DEFGENERIC process-toplevel-defmethod/defgeneric)
653                (DEFMACRO process-toplevel-defmacro)
654                (DEFMETHOD process-toplevel-defmethod/defgeneric)
655                (DEFPACKAGE process-toplevel-defpackage/in-package)
656                (DEFPARAMETER process-toplevel-defvar/defparameter)
657                (DEFTYPE process-toplevel-deftype)
658                (DEFUN process-toplevel-defun)
659                (DEFVAR process-toplevel-defvar/defparameter)
660                (EVAL-WHEN process-toplevel-eval-when)
661                (EXPORT process-toplevel-export)
662                (IMPORT process-toplevel-import)
663                (IN-PACKAGE process-toplevel-defpackage/in-package)
664                (LOCALLY process-toplevel-locally)
665                (MACROLET process-toplevel-macrolet)
666                (PROCLAIM precompile-toplevel-form)
667                (PROGN process-toplevel-progn)
668                (PROVIDE precompile-toplevel-form)
669                (PUT precompile-toplevel-form)
670                (QUOTE process-toplevel-quote)
671                (REQUIRE precompile-toplevel-form)
672                (SHADOW precompile-toplevel-form)
673                (%SET-FDEFINITION precompile-toplevel-form)
674                (MOP::ENSURE-METHOD process-toplevel-mop.ensure-method)
675    (record-source-information-for-type process-record-source-information)))
676  (install-toplevel-handler (car pair) (cadr pair)))
677
678(declaim (ftype (function (t stream t) t) process-toplevel-form))
679(defun process-toplevel-form (form stream compile-time-too)
680  (unless (atom form)
681    (let* ((operator (%car form))
682           (handler (get operator 'toplevel-handler)))
683      (when handler
684        (let ((out-form (funcall handler form stream compile-time-too)))
685          (when out-form
686            (output-form out-form)))
687        (return-from process-toplevel-form))
688      (when (and (symbolp operator)
689                 (macro-function operator *compile-file-environment*))
690        (when (eq operator 'define-setf-expander) ;; ??? what if the symbol is package qualified?
691          (push (second form) *toplevel-setf-expanders*))
692        (when (and (eq operator 'defsetf) ;; ??? what if the symbol is package qualified?
693                   (consp (third form))) ;; long form of DEFSETF
694          (push (second form) *toplevel-setf-expanders*))
695        (note-toplevel-form form)
696        ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in
697        ;; case the form being expanded expands into something that needs
698        ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO).
699        (let ((*compile-print* nil))
700          (process-toplevel-form (macroexpand-1 form *compile-file-environment*)
701                                 stream compile-time-too))
702        (return-from process-toplevel-form))
703      (cond
704        ((and (symbolp operator)
705              (not (special-operator-p operator))
706              (null (cdr form)))
707         (setf form (precompiler:precompile-form form nil
708                                                 *compile-file-environment*)))
709        (t
710         (note-toplevel-form form)
711         (setf form (convert-toplevel-form form nil)))))
712    (when (consp form)
713      (output-form form)))
714  ;; Make sure the compiled-function loader knows where
715  ;; to load the compiled functions. Note that this trickery
716  ;; was already used in verify-load before I used it,
717  ;; however, binding *load-truename* isn't fully compliant, I think.
718  (when compile-time-too
719    (let ((*load-truename* *output-file-pathname*)
720          (*fasl-loader* (make-fasl-class-loader
721                          (concatenate 'string
722                                       "org.armedbear.lisp." (base-classname)))))
723      (eval form))))
724
725(defun populate-zip-fasl (output-file)
726  (let* ((type ;; Don't use ".zip", it'll result in an extension with
727               ;; a dot, which is rejected by NAMESTRING
728          (%format nil "~A~A" (pathname-type output-file) "-zip"))
729         (output-file (if (logical-pathname-p output-file)
730                          (translate-logical-pathname output-file)
731                          output-file))
732         (zipfile 
733          (if (find :windows *features*)
734              (make-pathname :defaults output-file :type type)
735              (make-pathname :defaults output-file :type type
736                             :device :unspecific)))
737         (pathnames nil)
738         (fasl-loader (make-pathname :defaults output-file
739                                     :name (fasl-loader-classname)
740                                     :type *compile-file-class-extension*)))
741    (when (probe-file fasl-loader)
742      (push fasl-loader pathnames))
743    (dotimes (i *class-number*)
744      (let ((truename (probe-file (compute-classfile (1+ i)))))
745        (when truename
746          (push truename pathnames)
747          ;;; XXX it would be better to just use the recorded number
748          ;;; of class constants, but probing for the first at least
749          ;;; makes this subjectively bearable.
750          (when (probe-file
751                 (make-pathname :name (format nil "~A_0"
752                                              (pathname-name truename))
753                                :type "clc"
754                                :defaults truename))
755            (dolist (resource (directory
756                               (make-pathname :name (format nil "~A_*"
757                                                            (pathname-name truename))
758                                              :type "clc"
759                                              :defaults truename)))
760              (push resource pathnames))))))
761    (setf pathnames (nreverse (remove nil pathnames)))
762    (let ((load-file (make-pathname :defaults output-file
763                                    :name "__loader__"
764                                    :type "_")))
765      (rename-file output-file load-file)
766      (push load-file pathnames))
767    (zip zipfile pathnames)
768    (dolist (pathname pathnames)
769      (ignore-errors (delete-file pathname)))
770    (rename-file zipfile output-file)))
771
772(defun write-fasl-prologue (stream)
773  (let ((out stream))
774    ;; write header
775    (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
776    (%stream-terpri out)
777    (write (list 'init-fasl :version *fasl-version*) :stream out)
778    (%stream-terpri out)
779    (write (list 'setq '*source* *compile-file-truename*) :stream out)
780    (%stream-terpri out)
781
782    ;; Note: Beyond this point, you can't use DUMP-FORM,
783    ;; because the list of uninterned symbols has been fixed now.
784    (when *fasl-uninterned-symbols*
785      (write (list 'setq '*fasl-uninterned-symbols*
786                   (coerce (mapcar #'car (nreverse *fasl-uninterned-symbols*))
787                           'vector))
788             :stream out :length nil))
789    (%stream-terpri out)
790
791    (when (> *class-number* 0)
792      (write (list 'setq '*fasl-loader*
793                   `(sys::make-fasl-class-loader
794                     ,(concatenate 'string "org.armedbear.lisp."
795                                   (base-classname))))
796             :stream out))
797    (%stream-terpri out)))
798
799
800
801(defvar *binary-fasls* nil)
802(defvar *forms-for-output* nil)
803(defvar *fasl-stream* nil)
804
805(defun compile-from-stream (in output-file temp-file temp-file2
806                            extract-toplevel-funcs-and-macros
807                            functions-file macros-file exports-file 
808                            setf-functions-file setf-expanders-file)
809  (let* ((*compile-file-pathname* (make-pathname :defaults (pathname in)
810                                                 :version nil))
811         (*compile-file-truename* (make-pathname :defaults (truename in)
812                                                 :version nil))
813         (*source* *compile-file-truename*)
814         (*class-number* 0)
815         (namestring (namestring *compile-file-truename*))
816         (start (get-internal-real-time))
817         *fasl-uninterned-symbols*
818         (warnings-p nil)
819         (failure-p nil))
820    (when *compile-verbose*
821      (format t "; Compiling ~A ...~%" namestring))
822    (with-compilation-unit ()
823      (with-open-file (out temp-file
824                           :direction :output :if-exists :supersede
825                           :external-format *fasl-external-format*)
826        (let ((*readtable* *readtable*)
827              (*read-default-float-format* *read-default-float-format*)
828              (*read-base* *read-base*)
829              (*package* *package*)
830              (jvm::*functions-defined-in-current-file* '())
831              (*fbound-names* '())
832              (*fasl-stream* out)
833              *forms-for-output*)
834          (jvm::with-saved-compiler-policy
835            (jvm::with-file-compilation
836              (handler-bind
837                  ((style-warning 
838                    #'(lambda (c)
839                        (setf warnings-p t)
840                        ;; let outer handlers do their thing
841                        (signal c)
842                        ;; prevent the next handler
843                        ;; from running: we're a
844                        ;; WARNING subclass
845                        (continue)))
846                   ((or warning compiler-error)
847                    #'(lambda (c)
848                        (declare (ignore c))
849                        (setf warnings-p t
850                              failure-p t))))
851                (loop
852                   (let* ((*source-position* (file-position in))
853                          (jvm::*source-line-number* (stream-line-number in))
854                          (form (read in nil in))
855                          (*compiler-error-context* form))
856                     (when (eq form in)
857                       (return))
858                     (process-toplevel-form form out nil))))
859                    (finalize-fasl-output)
860                    (dolist (name *fbound-names*)
861                      (fmakunbound name)))))))
862        (when extract-toplevel-funcs-and-macros
863          (setf *toplevel-functions*
864                (remove-if-not (lambda (func-name)
865                                 (if (symbolp func-name)
866                                     (symbol-package func-name)
867                                     T))
868                               (remove-duplicates
869                            *toplevel-functions*)))
870          (when *toplevel-functions*
871            (with-open-file (f-out functions-file
872                                   :direction :output
873                                   :if-does-not-exist :create
874                                   :if-exists :supersede)
875
876              (let ((*package* (find-package :keyword)))
877                (write *toplevel-functions* :stream f-out))))
878          (setf *toplevel-macros*
879                (remove-if-not (lambda (mac-name)
880                                 (if (symbolp mac-name)
881                                     (symbol-package mac-name)
882                                     T))
883                               (remove-duplicates *toplevel-macros*)))
884          (when *toplevel-macros*
885            (with-open-file (m-out macros-file
886                                   :direction :output
887                                   :if-does-not-exist :create
888                                   :if-exists :supersede)
889              (let ((*package* (find-package :keyword)))
890                (write *toplevel-macros* :stream m-out))))
891          (setf *toplevel-exports*
892                (remove-if-not (lambda (sym)
893                                 (if (symbolp sym)
894                                     (symbol-package sym)
895                                     T))
896                               (remove-duplicates *toplevel-exports*)))
897          (when *toplevel-exports*
898            (with-open-file (e-out exports-file
899                                   :direction :output
900                                   :if-does-not-exist :create
901                                   :if-exists :supersede)
902              (let ((*package* (find-package :keyword)))
903                (write *toplevel-exports* :stream e-out))))
904          (setf *toplevel-setf-functions*
905                (remove-if-not (lambda (sym)
906                                 (if (symbolp sym)
907                                     (symbol-package sym)
908                                     T))
909                               (remove-duplicates *toplevel-setf-functions*)))
910          (when *toplevel-setf-functions*
911            (with-open-file (e-out setf-functions-file
912                                   :direction :output
913                                   :if-does-not-exist :create
914                                   :if-exists :supersede)
915              (let ((*package* (find-package :keyword)))
916                (write *toplevel-setf-functions* :stream e-out))))
917          (setf *toplevel-setf-expanders*
918                (remove-if-not (lambda (sym)
919                                 (if (symbolp sym)
920                                     (symbol-package sym)
921                                     T))
922                               (remove-duplicates *toplevel-setf-expanders*)))
923          (when *toplevel-setf-expanders*
924            (with-open-file (e-out setf-expanders-file
925                                   :direction :output
926                                   :if-does-not-exist :create
927                                   :if-exists :supersede)
928              (let ((*package* (find-package :keyword)))
929                (write *toplevel-setf-expanders* :stream e-out)))))
930        (with-open-file (in temp-file :direction :input :external-format *fasl-external-format*)
931          (with-open-file (out temp-file2 :direction :output
932                               :if-does-not-exist :create
933                               :if-exists :supersede
934                               :external-format *fasl-external-format*)
935            (let ((*package* (find-package '#:cl))
936                  (*print-fasl* t)
937                  (*print-array* t)
938                  (*print-base* 10)
939                  (*print-case* :upcase)
940                  (*print-circle* nil)
941                  (*print-escape* t)
942                  (*print-gensym* t)
943                  (*print-length* nil)
944                  (*print-level* nil)
945                  (*print-lines* nil)
946                  (*print-pretty* nil)
947                  (*print-radix* nil)
948                  (*print-readably* t)
949                  (*print-right-margin* nil)
950                  (*print-structure* t)
951
952                  ;; make sure to write all floats with their exponent marker:
953                  ;; the dump-time default may not be the same at load-time
954
955                  (*read-default-float-format* nil))
956
957              ;; these values are also bound by WITH-STANDARD-IO-SYNTAX,
958              ;; but not used by our reader/printer, so don't bind them,
959              ;; for efficiency reasons.
960              ;;        (*read-eval* t)
961              ;;        (*read-suppress* nil)
962              ;;        (*print-miser-width* nil)
963              ;;        (*print-pprint-dispatch* (copy-pprint-dispatch nil))
964              ;;        (*read-base* 10)
965              ;;        (*read-default-float-format* 'single-float)
966              ;;        (*readtable* (copy-readtable nil))
967
968              (write-fasl-prologue out)
969              ;; copy remaining content
970              (loop for line = (read-line in nil :eof)
971                 while (not (eq line :eof))
972        do (write-line line out)))))
973        (delete-file temp-file)
974        (when (subtypep (type-of output-file) 'jar-pathname)
975          (remove-zip-cache-entry output-file))
976        (rename-file temp-file2 output-file)
977
978        (when *compile-file-zip*
979          (populate-zip-fasl output-file))
980
981        (when *compile-verbose*
982          (format t "~&; Wrote ~A (~A seconds)~%"
983                  (namestring output-file)
984                  (/ (- (get-internal-real-time) start) 1000.0)))
985        (values (truename output-file) warnings-p failure-p)))
986
987(defun compile-file (input-file
988                     &key
989                     output-file
990                     ((:verbose *compile-verbose*) *compile-verbose*)
991                     ((:print *compile-print*) *compile-print*)
992                     (extract-toplevel-funcs-and-macros nil)
993                     (external-format :utf-8))
994  (flet ((pathname-with-type (pathname type &optional suffix)
995           (when suffix
996             (setq type (concatenate 'string type suffix)))
997           (make-pathname :type type :defaults pathname)))
998    (unless (or (and (probe-file input-file)
999                     (not (file-directory-p input-file)))
1000                (pathname-type input-file))
1001      (let ((pathname (pathname-with-type input-file "lisp")))
1002        (when (probe-file pathname)
1003          (setf input-file pathname))))
1004    (setf output-file
1005          (make-pathname :defaults
1006                         (if output-file
1007                             (merge-pathnames output-file
1008                                              *default-pathname-defaults*)
1009                             (compile-file-pathname input-file))
1010                         :version nil))
1011    (let* ((*output-file-pathname* output-file)
1012           (type (pathname-type output-file))
1013           (temp-file (pathname-with-type output-file type "-tmp"))
1014           (temp-file2 (pathname-with-type output-file type "-tmp2"))
1015           (functions-file (pathname-with-type output-file "funcs"))
1016           (macros-file (pathname-with-type output-file "macs"))
1017           (exports-file (pathname-with-type output-file "exps"))
1018           (setf-functions-file (pathname-with-type output-file "setf-functions"))
1019           (setf-expanders-file (pathname-with-type output-file "setf-expanders"))
1020           *toplevel-functions*
1021           *toplevel-macros*
1022           *toplevel-exports*
1023           *toplevel-setf-functions*
1024           *toplevel-setf-expanders*)
1025      (with-open-file (in input-file :direction :input :external-format external-format)
1026        (multiple-value-bind (output-file-truename warnings-p failure-p)
1027            (compile-from-stream in output-file temp-file temp-file2
1028                                 extract-toplevel-funcs-and-macros
1029                                 functions-file macros-file exports-file 
1030                                 setf-functions-file setf-expanders-file)
1031          (values (truename output-file) warnings-p failure-p))))))
1032
1033(defun compile-file-if-needed (input-file &rest allargs &key force-compile
1034                               &allow-other-keys)
1035  (setf input-file (truename input-file))
1036  (cond (force-compile
1037         (remf allargs :force-compile)
1038         (apply 'compile-file input-file allargs))
1039        (t
1040         (let* ((source-write-time (file-write-date input-file))
1041                (output-file       (or (getf allargs :output-file)
1042                                       (compile-file-pathname input-file)))
1043                (target-write-time (and (probe-file output-file)
1044                                        (file-write-date output-file))))
1045           (if (or (null target-write-time)
1046                   (<= target-write-time source-write-time))
1047               (apply #'compile-file input-file allargs)
1048               output-file)))))
1049
1050(provide 'compile-file)
Note: See TracBrowser for help on using the repository browser.