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

Last change on this file since 14914 was 14914, checked in by Mark Evenson, 5 years ago

Dramatically improve source recording on SYS::SOURCE plist for a symbol (Alan Ruttenberg)

The interface to recording information on the SYS:%SOURCE plist for a
symbol is now deprecated and will be removed with abcl-1.7.

Implementation


Source information for ABCL is now recorded on the SYS::SOURCE
property. The appropiate information for type is recorded by the
SYS::RECORD-SOURCE-INFORMATION-BY-TYPE function:

record-source-information-by-type (name type &optional source-pathname source-position)

TYPE is either a symbol or list.

Source information for functions, methods, and generic functions are
represented as lists of the following form:

(:generic-function function-name)
(:function function-name)
(:method method-name qualifiers specializers)

Where FUNCTION-NAME or METHOD-NAME can be a either be of the form
'symbol or '(setf symbol).

Source information for all other forms have a symbol for TYPE which is
one of the following:

:class, :variable, :condition, :constant, :compiler-macro, :macro
:package, :structure, :type, :setf-expander, :source-transform

These values follow SBCL'S implemenation in SLIME
c.f. <https://github.com/slime/slime/blob/bad2acf672c33b913aabc1a7facb9c3c16a4afe9/swank/sbcl.lisp#L748>

Modifications are in two places, one at the definitions, calling
record-source-information-by-type and then again in the file-compiler,
which writes forms like

(put 'source name (cons (list type pathname position) (get 'source name)))

In theory this can lead to redundancy if a fasl is loaded again and
again. I'm not sure how to fix this yet. Forms in the loader get
called early in build when many of the sequence functions aren't
present. Will probably just filter when presenting in slime.

<> :closes <http://abcl.org/trac/ticket/421> .
<> :merges <https://github.com/armedbear/abcl/pull/5> .

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