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

Last change on this file was 15630, checked in by Mark Evenson, 3 years ago

compiler: fix top-level lambda in function position

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