source: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp @ 12326

Last change on this file since 12326 was 12326, checked in by ehuelsmann, 11 years ago

Performance improvement for ticket #76: slow swank fuzzy completion.

This commit pushes FORMAT back in the list of time-consumers,
according to our profiler's output.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 40.9 KB
Line 
1;;; precompiler.lisp
2;;;
3;;; Copyright (C) 2003-2008 Peter Graves <peter@armedbear.org>
4;;; $Id: precompiler.lisp 12326 2010-01-01 22:52:09Z ehuelsmann $
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., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, 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
35(export '(*inline-declarations*
36          process-optimization-declarations
37          inline-p notinline-p inline-expansion expand-inline
38          *defined-functions* *undefined-functions* note-name-defined))
39
40(defvar *inline-declarations* nil)
41
42(declaim (ftype (function (t) t) process-optimization-declarations))
43(defun process-optimization-declarations (forms)
44  (dolist (form forms)
45    (unless (and (consp form) (eq (%car form) 'DECLARE))
46      (return))
47    (dolist (decl (%cdr form))
48      (case (car decl)
49        (OPTIMIZE
50         (dolist (spec (%cdr decl))
51           (let ((val 3)
52                 (quality spec))
53             (when (consp spec)
54               (setf quality (%car spec)
55                     val (cadr spec)))
56             (when (and (fixnump val)
57                        (<= 0 val 3))
58               (case quality
59                 (speed
60                  (setf *speed* val))
61                 (safety
62                  (setf *safety* val))
63                 (debug
64                  (setf *debug* val))
65                 (space
66                  (setf *space* val))
67                 (compilation-speed) ;; Ignored.
68                 (t
69                  (compiler-warn "Ignoring unknown optimization quality ~S in ~S." quality decl)))))))
70        ((INLINE NOTINLINE)
71         (dolist (symbol (%cdr decl))
72           (push (cons symbol (%car decl)) *inline-declarations*)))
73        (:explain
74         (dolist (spec (%cdr decl))
75           (let ((val t)
76                 (quality spec))
77             (when (consp spec)
78               (setf quality (%car spec))
79               (when (= (length spec) 2)
80                 (setf val (%cadr spec))))
81             (if val
82                 (pushnew quality *explain*)
83                 (setf *explain* (remove quality *explain*)))))))))
84  t)
85
86(declaim (ftype (function (t) t) inline-p))
87(defun inline-p (name)
88  (declare (optimize speed))
89  (let ((entry (assoc name *inline-declarations*)))
90    (if entry
91        (eq (cdr entry) 'INLINE)
92        (and (symbolp name) (eq (get name '%inline) 'INLINE)))))
93
94(declaim (ftype (function (t) t) notinline-p))
95(defun notinline-p (name)
96  (declare (optimize speed))
97  (let ((entry (assoc name *inline-declarations*)))
98    (if entry
99        (eq (cdr entry) 'NOTINLINE)
100        (and (symbolp name) (eq (get name '%inline) 'NOTINLINE)))))
101
102(defun expand-inline (form expansion)
103;;   (format t "expand-inline form = ~S~%" form)
104;;   (format t "expand-inline expansion = ~S~%" expansion)
105  (let* ((op (car form))
106         (proclaimed-ftype (proclaimed-ftype op))
107         (args (cdr form))
108         (vars (cadr expansion))
109         (varlist ())
110         new-form)
111;;     (format t "op = ~S proclaimed-ftype = ~S~%" op (proclaimed-ftype op))
112    (do ((vars vars (cdr vars))
113         (args args (cdr args)))
114        ((null vars))
115      (push (list (car vars) (car args)) varlist))
116    (setf new-form (list* 'LET (nreverse varlist)
117                          (copy-tree (cddr expansion))))
118    (when proclaimed-ftype
119      (let ((result-type (ftype-result-type proclaimed-ftype)))
120        (when (and result-type
121                   (neq result-type t)
122                   (neq result-type '*))
123          (setf new-form (list 'TRULY-THE result-type new-form)))))
124;;     (format t "expand-inline new form = ~S~%" new-form)
125    new-form))
126
127(define-compiler-macro assoc (&whole form &rest args)
128  (cond ((and (= (length args) 4)
129              (eq (third args) :test)
130              (or (equal (fourth args) '(quote eq))
131                  (equal (fourth args) '(function eq))))
132         `(assq ,(first args) ,(second args)))
133        ((= (length args) 2)
134         `(assql ,(first args) ,(second args)))
135        (t form)))
136
137(define-compiler-macro member (&whole form &rest args)
138  (let ((arg1 (first args))
139        (arg2 (second args)))
140    (case (length args)
141      (2
142       `(memql ,arg1 ,arg2))
143      (4
144       (let ((arg3 (third args))
145             (arg4 (fourth args)))
146         (cond ((and (eq arg3 :test)
147                     (or (equal arg4 '(quote eq))
148                         (equal arg4 '(function eq))))
149                `(memq ,arg1 ,arg2))
150               ((and (eq arg3 :test)
151                     (or (equal arg4 '(quote eql))
152                         (equal arg4 '(function eql))
153                         (equal arg4 '(quote char=))
154                         (equal arg4 '(function char=))))
155                `(memql ,arg1 ,arg2))
156               (t
157                form))))
158      (t
159       form))))
160
161(define-compiler-macro search (&whole form &rest args)
162  (if (= (length args) 2)
163      `(simple-search ,@args)
164      form))
165
166(define-compiler-macro identity (&whole form &rest args)
167  (if (= (length args) 1)
168      `(progn ,(car args))
169      form))
170
171(defun quoted-form-p (form)
172  (and (consp form) (eq (%car form) 'QUOTE) (= (length form) 2)))
173
174(define-compiler-macro eql (&whole form &rest args)
175  (let ((first (car args))
176        (second (cadr args)))
177    (if (or (and (quoted-form-p first) (symbolp (cadr first)))
178            (and (quoted-form-p second) (symbolp (cadr second))))
179        `(eq ,first ,second)
180        form)))
181
182(define-compiler-macro not (&whole form arg)
183  (if (atom arg)
184      form
185      (let ((op (case (car arg)
186                  (>= '<)
187                  (<  '>=)
188                  (<= '>)
189                  (>  '<=)
190                  (t  nil))))
191        (if (and op (= (length arg) 3))
192            (cons op (cdr arg))
193            form))))
194
195(defun predicate-for-type (type)
196  (cdr (assq type '((ARRAY             . arrayp)
197                    (ATOM              . atom)
198                    (BIT-VECTOR        . bit-vector-p)
199                    (CHARACTER         . characterp)
200                    (COMPLEX           . complexp)
201                    (CONS              . consp)
202                    (FIXNUM            . fixnump)
203                    (FLOAT             . floatp)
204                    (FUNCTION          . functionp)
205                    (HASH-TABLE        . hash-table-p)
206                    (INTEGER           . integerp)
207                    (LIST              . listp)
208                    (NULL              . null)
209                    (NUMBER            . numberp)
210                    (NUMBER            . numberp)
211                    (PACKAGE           . packagep)
212                    (RATIONAL          . rationalp)
213                    (REAL              . realp)
214                    (SIMPLE-BIT-VECTOR . simple-bit-vector-p)
215                    (SIMPLE-STRING     . simple-string-p)
216                    (SIMPLE-VECTOR     . simple-vector-p)
217                    (STREAM            . streamp)
218                    (STRING            . stringp)
219                    (SYMBOL            . symbolp)))))
220
221(define-compiler-macro typep (&whole form &rest args)
222  (if (= (length args) 2) ; no environment arg
223      (let* ((object (%car args))
224             (type-specifier (%cadr args))
225             (type (and (consp type-specifier)
226                        (eq (%car type-specifier) 'QUOTE)
227                        (%cadr type-specifier)))
228             (predicate (and type (predicate-for-type type))))
229        (if predicate
230            `(,predicate ,object)
231            `(%typep ,@args)))
232      form))
233
234(define-compiler-macro subtypep (&whole form &rest args)
235  (if (= (length args) 2)
236      `(%subtypep ,@args)
237      form))
238
239(define-compiler-macro funcall (&whole form
240                                &environment env &rest args)
241  (let ((callee (car args)))
242    (if (and (>= *speed* *debug*)
243             (consp callee)
244             (eq (%car callee) 'function)
245             (symbolp (cadr callee))
246             (not (special-operator-p (cadr callee)))
247             (not (macro-function (cadr callee) env))
248             (memq (symbol-package (cadr callee))
249                   (list (find-package "CL") (find-package "SYS"))))
250        `(,(cadr callee) ,@(cdr args))
251        form)))
252
253(define-compiler-macro byte (size position)
254  `(cons ,size ,position))
255
256(define-compiler-macro byte-size (bytespec)
257  `(car ,bytespec))
258
259(define-compiler-macro byte-position (bytespec)
260  `(cdr ,bytespec))
261
262(define-source-transform concatenate (&whole form result-type &rest sequences)
263  (if (equal result-type '(quote STRING))
264      `(sys::concatenate-to-string (list ,@sequences))
265      form))
266
267(define-source-transform ldb (&whole form bytespec integer)
268  (if (and (consp bytespec)
269           (eq (%car bytespec) 'byte)
270           (= (length bytespec) 3))
271      (let ((size (%cadr bytespec))
272            (position (%caddr bytespec)))
273        `(%ldb ,size ,position ,integer))
274      form))
275
276(define-source-transform find (&whole form item sequence &key from-end test test-not start end key)
277  (cond ((and (>= (length form) 3) (null start) (null end))
278         (cond ((and (stringp sequence)
279                     (null from-end)
280                     (member test '(#'eql #'char=) :test #'equal)
281                     (null test-not)
282                     (null key))
283                `(string-find ,item ,sequence))
284               (t
285                (let ((item-var (gensym))
286                      (seq-var (gensym)))
287                  `(let ((,item-var ,item)
288                         (,seq-var ,sequence))
289                     (if (listp ,seq-var)
290                         (list-find* ,item-var ,seq-var ,from-end ,test ,test-not 0 (length ,seq-var) ,key)
291                         (vector-find* ,item-var ,seq-var ,from-end ,test ,test-not 0 (length ,seq-var) ,key)))))))
292        (t
293         form)))
294
295(define-source-transform adjoin (&whole form &rest args)
296  (if (= (length args) 2)
297      `(adjoin-eql ,(first args) ,(second args))
298      form))
299
300(define-source-transform format (&whole form &rest args)
301  (if (stringp (second args))
302      `(format ,(pop args) (formatter ,(pop args)) ,@args)
303      form))
304
305(define-compiler-macro catch (&whole form tag &rest args)
306  (declare (ignore tag))
307  (if (and (null (cdr args))
308           (constantp (car args)))
309      (car args)
310      form))
311
312(define-compiler-macro string= (&whole form &rest args)
313  (if (= (length args) 2)
314      `(sys::%%string= ,@args)
315      form))
316
317(define-compiler-macro <= (&whole form &rest args)
318  (cond ((and (= (length args) 3)
319              (numberp (first args))
320              (numberp (third args))
321              (= (first args) (third args)))
322         `(= ,(second args) ,(first args)))
323        (t
324         form)))
325
326
327(in-package "PRECOMPILER")
328
329;; No source-transforms and inlining in precompile-function-call
330;; No macro expansion in precompile-dolist and precompile-dotimes
331;; No macro expansion in precompile-do/do*
332;; No macro expansion in precompile-defun
333;; Special precompilation in precompile-case and precompile-cond
334;; Special precompilation in precompile-when and precompile-unless
335;; No precompilation in precompile-nth-value
336;; Special precompilation in precompile-return
337;; Special precompilation in expand-macro
338;;
339;; if *in-jvm-compile* is false
340
341(defvar *in-jvm-compile* nil)
342(defvar *precompile-env* nil)
343
344
345(declaim (ftype (function (t) t) precompile1))
346(defun precompile1 (form)
347  (cond ((symbolp form)
348         (multiple-value-bind
349               (expansion expanded)
350             (expand-macro form)
351           (if expanded
352               (precompile1 expansion)
353               form)))
354        ((atom form)
355         form)
356        (t
357         (let ((op (%car form))
358               handler)
359           (when (symbolp op)
360             (cond ((setf handler (get op 'precompile-handler))
361                    (return-from precompile1 (funcall handler form)))
362                   ((macro-function op *precompile-env*)
363                    (return-from precompile1 (precompile1 (expand-macro form))))
364                   ((special-operator-p op)
365                    (error "PRECOMPILE1: unsupported special operator ~S." op))))
366           (precompile-function-call form)))))
367
368(defun precompile-identity (form)
369  (declare (optimize speed))
370  form)
371
372(declaim (ftype (function (t) cons) precompile-cons))
373(defun precompile-cons (form)
374  (cons (car form) (mapcar #'precompile1 (cdr form))))
375
376(declaim (ftype (function (t t) t) precompile-function-call))
377(defun precompile-function-call (form)
378  (let ((op (car form)))
379    (when (and (consp op) (eq (%car op) 'LAMBDA))
380      (return-from precompile-function-call
381                   (cons (precompile-lambda op)
382                         (mapcar #'precompile1 (cdr form)))))
383    (when (or (not *in-jvm-compile*) (notinline-p op))
384      (return-from precompile-function-call (precompile-cons form)))
385    (when (source-transform op)
386      (let ((new-form (expand-source-transform form)))
387        (when (neq new-form form)
388          (return-from precompile-function-call (precompile1 new-form)))))
389    (when *enable-inline-expansion*
390      (let ((expansion (inline-expansion op)))
391        (when expansion
392          (let ((explain *explain*))
393            (when (and explain (memq :calls explain))
394              (format t ";   inlining call to ~S~%" op)))
395          (return-from precompile-function-call (precompile1 (expand-inline form expansion))))))
396    (cons op (mapcar #'precompile1 (cdr form)))))
397
398(defun precompile-locally (form)
399  (let ((*inline-declarations* *inline-declarations*))
400    (process-optimization-declarations (cdr form))
401  (cons 'LOCALLY (mapcar #'precompile1 (cdr form)))))
402
403(defun precompile-block (form)
404  (let ((args (cdr form)))
405    (if (null (cdr args))
406        nil
407        (list* 'BLOCK (car args) (mapcar #'precompile1 (cdr args))))))
408
409(defun precompile-dolist (form)
410  (if *in-jvm-compile*
411      (precompile1 (macroexpand form *precompile-env*))
412      (cons 'DOLIST (cons (mapcar #'precompile1 (cadr form))
413                          (mapcar #'precompile1 (cddr form))))))
414
415(defun precompile-dotimes (form)
416  (if *in-jvm-compile*
417      (precompile1 (macroexpand form *precompile-env*))
418      (cons 'DOTIMES (cons (mapcar #'precompile1 (cadr form))
419                           (mapcar #'precompile1 (cddr form))))))
420
421(defun precompile-do/do*-vars (varlist)
422  (let ((result nil))
423    (dolist (varspec varlist)
424      (if (atom varspec)
425          (push varspec result)
426          (case (length varspec)
427            (1
428             (push (%car varspec) result))
429            (2
430             (let* ((var (%car varspec))
431                    (init-form (%cadr varspec)))
432               (unless (symbolp var)
433                 (error 'type-error))
434               (push (list var (precompile1 init-form))
435                     result)))
436            (3
437             (let* ((var (%car varspec))
438                    (init-form (%cadr varspec))
439                    (step-form (%caddr varspec)))
440               (unless (symbolp var)
441                 (error 'type-error))
442               (push (list var (precompile1 init-form) (precompile1 step-form))
443                     result))))))
444    (nreverse result)))
445
446(defun precompile-do/do*-end-form (end-form)
447  (let ((end-test-form (car end-form))
448        (result-forms (cdr end-form)))
449    (list* end-test-form (mapcar #'precompile1 result-forms))))
450
451(defun precompile-do/do* (form)
452  (if *in-jvm-compile*
453      (precompile1 (macroexpand form *precompile-env*))
454      (list* (car form)
455             (precompile-do/do*-vars (cadr form))
456             (precompile-do/do*-end-form (caddr form))
457             (mapcar #'precompile1 (cdddr form)))))
458
459(defun precompile-do-symbols (form)
460  (list* (car form) (cadr form) (mapcar #'precompile1 (cddr form))))
461
462(defun precompile-load-time-value (form)
463  form)
464
465(defun precompile-progn (form)
466  (let ((body (cdr form)))
467    (if (eql (length body) 1)
468        (let ((res (precompile1 (%car body))))
469          ;; If the result turns out to be a bare symbol, leave it wrapped
470          ;; with PROGN so it won't be mistaken for a tag in an enclosing
471          ;; TAGBODY.
472          (if (symbolp res)
473              (list 'progn res)
474              res))
475        (cons 'PROGN (mapcar #'precompile1 body)))))
476
477(defun precompile-threads-synchronized-on (form)
478  (cons 'threads:synchronized-on (mapcar #'precompile1 (cdr form))))
479
480(defun precompile-progv (form)
481  (if (< (length form) 3)
482      (error "Not enough arguments for ~S." 'progv)
483      (list* 'PROGV (mapcar #'precompile1 (%cdr form)))))
484
485(defun precompile-setf (form)
486  (let ((place (second form)))
487    (cond ((and (consp place)
488                (eq (%car place) 'VALUES))
489     (setf form
490     (list* 'SETF
491      (list* 'VALUES
492             (mapcar #'precompile1 (%cdr place)))
493      (cddr form)))
494     (precompile1 (expand-macro form)))
495    ((symbolp place)
496           (multiple-value-bind
497                 (expansion expanded)
498               (expand-macro place)
499             (if expanded
500                 (precompile1 (list* 'SETF expansion
501                                     (cddr form)))
502                 (precompile1 (expand-macro form)))))
503          (t
504           (precompile1 (expand-macro form))))))
505
506(defun precompile-setq (form)
507  (let* ((args (cdr form))
508         (len (length args)))
509    (when (oddp len)
510      (error 'simple-program-error
511             :format-control "Odd number of arguments to SETQ."))
512    (if (= len 2)
513        (let* ((sym (%car args))
514               (val (%cadr args)))
515          (multiple-value-bind
516                (expansion expanded)
517              (expand-macro sym)
518            (if expanded
519                (precompile1 (list 'SETF expansion val))
520                (list 'SETQ sym (precompile1 val)))))
521        (let ((result ()))
522          (loop
523            (when (null args)
524              (return))
525            (push (precompile-setq (list 'SETQ (car args) (cadr args))) result)
526            (setq args (cddr args)))
527          (setq result (nreverse result))
528          (push 'PROGN result)
529          result))))
530
531(defun precompile-psetf (form)
532  (setf form
533        (list* 'PSETF
534               (mapcar #'precompile1 (cdr form))))
535  (precompile1 (expand-macro form)))
536
537(defun precompile-psetq (form)
538  ;; Make sure all the vars are symbols.
539  (do* ((rest (cdr form) (cddr rest))
540        (var (car rest)))
541       ((null rest))
542    (unless (symbolp var)
543      (error 'simple-error
544             :format-control "~S is not a symbol."
545             :format-arguments (list var))))
546  ;; Delegate to PRECOMPILE-PSETF so symbol macros are handled correctly.
547  (precompile-psetf form))
548
549
550(defun precompile-lambda-list (form)
551  (let (new aux-tail)
552    (dolist (arg form (nreverse new))
553       (if (or (atom arg) (> 2 (length arg)))
554           (progn
555             (when (eq arg '&aux)
556               (setf aux-tail t))
557             (push arg new))
558          ;; must be a cons of more than 1 cell
559          (let ((new-arg (copy-list arg)))
560            (unless (<= 1 (length arg) (if aux-tail 2 3))
561              ;; the aux-vars have a maximum length of 2 conses
562              ;; optional and key vars may have 3
563              (error 'program-error
564                     :format-control
565                     "The ~A binding specification ~S is invalid."
566                     :format-arguments (list (if aux-tail "&AUX"
567                                                 "&OPTIONAL/&KEY") arg)))
568             (setf (second new-arg)
569                   (precompile1 (second arg)))
570             (push new-arg new))))))
571
572(defun precompile-lambda (form)
573  (let ((body (cddr form))
574        (precompiled-lambda-list
575           (precompile-lambda-list (cadr form)))
576        (*inline-declarations* *inline-declarations*))
577    (process-optimization-declarations body)
578    (list* 'LAMBDA precompiled-lambda-list
579           (mapcar #'precompile1 body))))
580
581(defun precompile-named-lambda (form)
582  (let ((lambda-form (list* 'LAMBDA (caddr form) (cdddr form))))
583    (let ((body (cddr lambda-form))
584          (precompiled-lambda-list
585           (precompile-lambda-list (cadr lambda-form)))
586          (*inline-declarations* *inline-declarations*))
587      (process-optimization-declarations body)
588      (list* 'NAMED-LAMBDA (cadr form) precompiled-lambda-list
589             (mapcar #'precompile1 body)))))
590
591(defun precompile-defun (form)
592  (if *in-jvm-compile*
593      (precompile1 (expand-macro form))
594      form))
595
596(defun precompile-macrolet (form)
597  (let ((*precompile-env* (make-environment *precompile-env*)))
598    (dolist (definition (cadr form))
599      (environment-add-macro-definition
600       *precompile-env*
601       (car definition)
602       (make-macro (car definition)
603                   (make-closure
604                    (make-expander-for-macrolet definition)
605                    NIL))))
606    (multiple-value-bind (body decls)
607        (parse-body (cddr form) nil)
608      `(locally ,@decls ,@(mapcar #'precompile1 body)))))
609
610(defun precompile-symbol-macrolet (form)
611  (let ((*precompile-env* (make-environment *precompile-env*))
612        (defs (cadr form)))
613    (dolist (def defs)
614      (let ((sym (car def))
615            (expansion (cadr def)))
616        (when (special-variable-p sym)
617          (error 'program-error
618                 :format-control
619                 "Attempt to bind the special variable ~S with SYMBOL-MACROLET."
620                 :format-arguments (list sym)))
621        (environment-add-symbol-binding *precompile-env*
622                                        sym
623                                        (sys::make-symbol-macro expansion))))
624    (multiple-value-bind (body decls)
625        (parse-body (cddr form) nil)
626      (when decls
627        (let ((specials ()))
628          (dolist (decl decls)
629            (when (eq (car decl) 'DECLARE)
630              (dolist (declspec (cdr decl))
631                (when (eq (car declspec) 'SPECIAL)
632                  (setf specials (append specials (cdr declspec)))))))
633          (when specials
634            (let ((syms (mapcar #'car (cadr form))))
635              (dolist (special specials)
636                (when (memq special syms)
637                  (error 'program-error
638                         :format-control
639                         "~S is a symbol-macro and may not be declared special."
640                         :format-arguments (list special))))))))
641      `(locally ,@decls ,@(mapcar #'precompile1 body)))))
642
643(defun precompile-the (form)
644  (list 'THE
645        (second form)
646        (precompile1 (third form))))
647
648(defun precompile-truly-the (form)
649  (list 'TRULY-THE
650        (second form)
651        (precompile1 (third form))))
652
653(defun precompile-let/let*-vars (vars)
654  (let ((result nil))
655    (dolist (var vars)
656      (cond ((consp var)
657             (unless (<= 1 (length var) 2)
658               (error 'program-error
659                       :format-control
660                       "The LET/LET* binding specification ~S is invalid."
661                       :format-arguments (list var)))
662             (let ((v (%car var))
663                   (expr (cadr var)))
664               (unless (symbolp v)
665                 (error 'simple-type-error
666                        :format-control "The variable ~S is not a symbol."
667                        :format-arguments (list v)))
668               (push (list v (precompile1 expr)) result)
669               (environment-add-symbol-binding *precompile-env* v nil)))
670               ;; any value will do: we just need to shadow any symbol macros
671            (t
672             (push var result)
673             (environment-add-symbol-binding *precompile-env* var nil))))
674    (nreverse result)))
675
676(defun precompile-let (form)
677  (let ((*precompile-env* (make-environment *precompile-env*)))
678    (list* 'LET
679           (precompile-let/let*-vars (cadr form))
680           (mapcar #'precompile1 (cddr form)))))
681
682;; (LET* ((X 1)) (LET* ((Y 2)) (LET* ((Z 3)) (+ X Y Z)))) =>
683;; (LET* ((X 1) (Y 2) (Z 3)) (+ X Y Z))
684(defun maybe-fold-let* (form)
685  (if (and (= (length form) 3)
686           (consp (%caddr form))
687           (eq (%car (%caddr form)) 'LET*))
688      (let ((third (maybe-fold-let* (%caddr form))))
689        (list* 'LET* (append (%cadr form) (cadr third)) (cddr third)))
690      form))
691
692(defun precompile-let* (form)
693  (setf form (maybe-fold-let* form))
694  (let ((*precompile-env* (make-environment *precompile-env*)))
695    (list* 'LET*
696           (precompile-let/let*-vars (cadr form))
697           (mapcar #'precompile1 (cddr form)))))
698
699(defun precompile-case (form)
700  (if *in-jvm-compile*
701      (precompile1 (macroexpand form *precompile-env*))
702      (let* ((keyform (cadr form))
703             (clauses (cddr form))
704             (result (list (precompile1 keyform))))
705        (dolist (clause clauses)
706          (push (precompile-case-clause clause) result))
707        (cons (car form) (nreverse result)))))
708
709(defun precompile-case-clause (clause)
710  (let ((keys (car clause))
711        (forms (cdr clause)))
712    (cons keys (mapcar #'precompile1 forms))))
713
714(defun precompile-cond (form)
715  (if *in-jvm-compile*
716      (precompile1 (macroexpand form *precompile-env*))
717      (let ((clauses (cdr form))
718            (result nil))
719        (dolist (clause clauses)
720          (push (precompile-cond-clause clause) result))
721        (cons 'COND (nreverse result)))))
722
723(defun precompile-cond-clause (clause)
724  (let ((test (car clause))
725        (forms (cdr clause)))
726    (cons (precompile1 test) (mapcar #'precompile1 forms))))
727
728(defun precompile-local-function-def (def)
729  (let ((name (car def))
730        (body (cddr def)))
731    ;; Macro names are shadowed by local functions.
732    (environment-add-function-definition *precompile-env* name body)
733    (cdr (precompile-named-lambda (list* 'NAMED-LAMBDA def)))))
734
735(defun precompile-local-functions (defs)
736  (let ((result nil))
737    (dolist (def defs (nreverse result))
738      (push (precompile-local-function-def def) result))))
739
740(defun find-use (name expression)
741  (cond ((atom expression)
742         nil)
743        ((eq (%car expression) name)
744         t)
745        ((consp name)
746         t) ;; FIXME Recognize use of SETF functions!
747        (t
748         (or (find-use name (%car expression))
749             (find-use name (%cdr expression))))))
750
751(defun precompile-flet/labels (form)
752  (let ((*precompile-env* (make-environment *precompile-env*))
753        (operator (car form))
754        (locals (cadr form))
755        (body (cddr form)))
756    (dolist (local locals)
757      (let* ((name (car local))
758             (used-p (find-use name body)))
759        (unless used-p
760          (when (eq operator 'LABELS)
761            (dolist (local locals)
762              (when (neq name (car local))
763                (when (find-use name (cddr local))
764                  (setf used-p t)
765                  (return))
766                ;; Scope of defined function names includes
767                ;; &OPTIONAL, &KEY and &AUX parameters
768                ;; (LABELS.7B, LABELS.7C and LABELS.7D).
769                (let ((vars (or
770                             (cdr (memq '&optional (cadr local)))
771                             (cdr (memq '&key (cadr local)))
772                             (cdr (memq '&aux (cadr local))))))
773                  (when (and vars (find-use name vars)
774                             (setf used-p t)
775                             (return))))))))
776        (unless used-p
777          (format t "; Note: deleting unused local function ~A ~S~%"
778                  operator name)
779          (let* ((new-locals (remove local locals :test 'eq))
780                 (new-form
781                  (if new-locals
782                      (list* operator new-locals body)
783                      (list* 'LOCALLY body))))
784            (return-from precompile-flet/labels (precompile1 new-form))))))
785    (list* (car form)
786           (precompile-local-functions locals)
787           (mapcar #'precompile1 body))))
788
789(defun precompile-function (form)
790  (if (and (consp (cadr form)) (eq (caadr form) 'LAMBDA))
791      (list 'FUNCTION (precompile-lambda (%cadr form)))
792      form))
793
794(defun precompile-if (form)
795  (let ((args (cdr form)))
796    (case (length args)
797      (2
798       (let ((test (precompile1 (%car args))))
799         (cond ((null test)
800                nil)
801               (;;(constantp test)
802                (eq test t)
803                (precompile1 (%cadr args)))
804               (t
805                (list 'IF
806                      test
807                      (precompile1 (%cadr args)))))))
808      (3
809       (let ((test (precompile1 (%car args))))
810         (cond ((null test)
811                (precompile1 (%caddr args)))
812               (;;(constantp test)
813                (eq test t)
814                (precompile1 (%cadr args)))
815               (t
816                (list 'IF
817                      test
818                      (precompile1 (%cadr args))
819                      (precompile1 (%caddr args)))))))
820      (t
821       (error "wrong number of arguments for IF")))))
822
823(defun precompile-when (form)
824  (if *in-jvm-compile*
825      (precompile1 (macroexpand form *precompile-env*))
826      (precompile-cons form)))
827
828(defun precompile-unless (form)
829  (if *in-jvm-compile*
830      (precompile1 (macroexpand form *precompile-env*))
831      (precompile-cons form)))
832
833;; MULTIPLE-VALUE-BIND is handled explicitly by the JVM compiler.
834(defun precompile-multiple-value-bind (form)
835  (let ((vars (cadr form))
836        (values-form (caddr form))
837        (body (cdddr form))
838        (*precompile-env* (make-environment *precompile-env*)))
839    (dolist (var vars)
840      (environment-add-symbol-binding *precompile-env* var nil))
841    (list* 'MULTIPLE-VALUE-BIND
842           vars
843           (precompile1 values-form)
844           (mapcar #'precompile1 body))))
845
846;; MULTIPLE-VALUE-LIST is handled explicitly by the JVM compiler.
847(defun precompile-multiple-value-list (form)
848  (list 'MULTIPLE-VALUE-LIST (precompile1 (cadr form))))
849
850(defun precompile-nth-value (form)
851  (if *in-jvm-compile*
852      (precompile1 (macroexpand form *precompile-env*))
853      form))
854
855(defun precompile-return (form)
856  (if *in-jvm-compile*
857      (precompile1 (macroexpand form *precompile-env*))
858      (list 'RETURN (precompile1 (cadr form)))))
859
860(defun precompile-return-from (form)
861  (list 'RETURN-FROM (cadr form) (precompile1 (caddr form))))
862
863(defun precompile-tagbody (form)
864  (do ((body (cdr form) (cdr body))
865       (result ()))
866      ((null body) (cons 'TAGBODY (nreverse result)))
867    (if (atom (car body))
868        (push (car body) result)
869        (push (let* ((first-form (car body))
870                     (expanded (precompile1 first-form)))
871                (if (and (symbolp expanded)
872                         (neq expanded first-form))
873                    ;; Workaround:
874                    ;;  Since our expansion/compilation order
875                    ;;   is out of sync with the definition of
876                    ;;   TAGBODY (which requires the compiler
877                    ;;   to look for tags before expanding),
878                    ;;   we need to disguise anything which might
879                    ;;   look like a tag. We do this by wrapping
880                    ;;   it in a PROGN form.
881                    (list 'PROGN expanded)
882                    expanded)) result))))
883
884(defun precompile-eval-when (form)
885  (list* 'EVAL-WHEN (cadr form) (mapcar #'precompile1 (cddr form))))
886
887(defun precompile-unwind-protect (form)
888  (list* 'UNWIND-PROTECT
889         (precompile1 (cadr form))
890         (mapcar #'precompile1 (cddr form))))
891
892;; EXPAND-MACRO is like MACROEXPAND, but EXPAND-MACRO quits if *IN-JVM-COMPILE*
893;; is false and a macro is encountered that is also implemented as a special
894;; operator, so interpreted code can use the special operator implementation.
895(defun expand-macro (form)
896  (let (exp)
897    (loop
898       (unless *in-jvm-compile*
899         (when (and (consp form)
900                    (symbolp (%car form))
901                    (special-operator-p (%car form)))
902           (return-from expand-macro (values form exp))))
903       (multiple-value-bind (result expanded)
904           (macroexpand-1 form *precompile-env*)
905         (unless expanded
906           (return-from expand-macro (values result exp)))
907         (setf form result
908               exp t)))))
909
910(declaim (ftype (function (t t) t) precompile-form))
911(defun precompile-form (form in-jvm-compile
912                        &optional precompile-env)
913  (let ((*in-jvm-compile* in-jvm-compile)
914        (*inline-declarations* *inline-declarations*)
915        (pre::*precompile-env* precompile-env))
916    (precompile1 form)))
917
918(defun install-handler (symbol &optional handler)
919  (declare (type symbol symbol))
920  (let ((handler (or handler
921                     (find-symbol (sys::%format nil "PRECOMPILE-~A"
922                                                (symbol-name symbol))
923                                  'precompiler))))
924    (unless (and handler (fboundp handler))
925      (error "No handler for ~S." symbol))
926    (setf (get symbol 'precompile-handler) handler)))
927
928(defun install-handlers ()
929  (mapcar #'install-handler '(BLOCK
930                              CASE
931                              COND
932                              DOLIST
933                              DOTIMES
934                              EVAL-WHEN
935                              FUNCTION
936                              IF
937                              LAMBDA
938                              MACROLET
939                              MULTIPLE-VALUE-BIND
940                              MULTIPLE-VALUE-LIST
941                              NAMED-LAMBDA
942                              NTH-VALUE
943                              PROGN
944                              PROGV
945                              PSETF
946                              PSETQ
947                              RETURN
948                              RETURN-FROM
949                              SETF
950                              SETQ
951                              SYMBOL-MACROLET
952                              TAGBODY
953                              UNWIND-PROTECT
954                              UNLESS
955                              WHEN))
956
957  (dolist (pair '((ECASE                precompile-case)
958
959                  (AND                  precompile-cons)
960                  (OR                   precompile-cons)
961
962                  (CATCH                precompile-cons)
963                  (MULTIPLE-VALUE-CALL  precompile-cons)
964                  (MULTIPLE-VALUE-PROG1 precompile-cons)
965
966                  (DO                   precompile-do/do*)
967                  (DO*                  precompile-do/do*)
968
969                  (LET                  precompile-let)
970                  (LET*                 precompile-let*)
971
972                  (LOCALLY              precompile-locally)
973
974                  (FLET                 precompile-flet/labels)
975                  (LABELS               precompile-flet/labels)
976
977                  (LOAD-TIME-VALUE      precompile-load-time-value)
978
979                  (DECLARE              precompile-identity)
980                  (DEFUN                precompile-defun)
981                  (GO                   precompile-identity)
982                  (QUOTE                precompile-identity)
983                  (THE                  precompile-the)
984                  (THROW                precompile-cons)
985                  (TRULY-THE            precompile-truly-the)
986
987                  (THREADS:SYNCHRONIZED-ON
988                                        precompile-threads-synchronized-on)))
989    (install-handler (first pair) (second pair))))
990
991(install-handlers)
992
993(export '(precompile-form))
994
995(in-package #:ext)
996(defun macroexpand-all (form &optional env)
997  (precompiler:precompile-form form t env))
998
999(in-package #:lisp)
1000
1001(defmacro compiler-let (bindings &body forms &environment env)
1002  (let ((bindings (mapcar #'(lambda (binding)
1003                              (if (atom binding) (list binding) binding))
1004                          bindings)))
1005    (progv (mapcar #'car bindings)
1006           (mapcar #'(lambda (binding)
1007                       (eval (cadr binding))) bindings)
1008      (macroexpand-all `(progn ,@forms) env))))
1009
1010(in-package #:system)
1011
1012(defun set-function-definition (name new old)
1013  (let ((*warn-on-redefinition* nil))
1014    (sys::%set-lambda-name new name)
1015    (sys:set-call-count new (sys:call-count old))
1016    (sys::%set-arglist new (sys::arglist old))
1017    (when (macro-function name)
1018      (setf new (make-macro name new)))
1019    (if (typep old 'standard-generic-function)
1020        (mop:set-funcallable-instance-function old new)
1021        (setf (fdefinition name) new))))
1022
1023(defun precompile (name &optional definition)
1024  (unless definition
1025    (setq definition (or (and (symbolp name) (macro-function name))
1026                         (fdefinition name))))
1027  (let ((expr definition)
1028        env result
1029        (pre::*precompile-env* nil))
1030    (when (functionp definition)
1031      (multiple-value-bind (form closure-p)
1032          (function-lambda-expression definition)
1033        (unless form
1034          (return-from precompile (values nil t t)))
1035        (setq env closure-p)
1036        (setq expr form)))
1037    (unless (and (consp expr) (eq (car expr) 'lambda))
1038      (format t "Unable to precompile ~S.~%" name)
1039      (return-from precompile (values nil t t)))
1040    (setf result
1041          (sys:make-closure (precompiler:precompile-form expr nil env) env))
1042    (when (and name (functionp result))
1043      (sys::set-function-definition name result definition))
1044    (values (or name result) nil nil)))
1045
1046(defun precompile-package (pkg &key verbose)
1047  (dolist (sym (package-symbols pkg))
1048    (when (fboundp sym)
1049      (unless (special-operator-p sym)
1050        (let ((f (fdefinition sym)))
1051          (unless (compiled-function-p f)
1052            (when verbose
1053              (format t "Precompiling ~S~%" sym)
1054              (finish-output))
1055            (precompile sym))))))
1056  t)
1057
1058(defun %compile (name definition)
1059  (if (and name (fboundp name) (%typep (symbol-function name) 'generic-function))
1060      (values name nil nil)
1061      (precompile name definition)))
1062
1063;; ;; Redefine EVAL to precompile its argument.
1064;; (defun eval (form)
1065;;   (%eval (precompile-form form nil)))
1066
1067;; ;; Redefine DEFMACRO to precompile the expansion function on the fly.
1068;; (defmacro defmacro (name lambda-list &rest body)
1069;;   (let* ((form (gensym "WHOLE-"))
1070;;          (env (gensym "ENVIRONMENT-")))
1071;;     (multiple-value-bind (body decls)
1072;;         (parse-defmacro lambda-list form body name 'defmacro :environment env)
1073;;       (let ((expander `(lambda (,form ,env) ,@decls (block ,name ,body))))
1074;;         `(progn
1075;;            (let ((macro (make-macro ',name
1076;;                                     (or (precompile nil ,expander) ,expander))))
1077;;              ,@(if (special-operator-p name)
1078;;                    `((put ',name 'macroexpand-macro macro))
1079;;                    `((fset ',name macro)))
1080;;              (%set-arglist macro ',lambda-list)
1081;;              ',name))))))
1082
1083;; Make an exception just this one time...
1084(when (get 'defmacro 'macroexpand-macro)
1085  (fset 'defmacro (get 'defmacro 'macroexpand-macro))
1086  (remprop 'defmacro 'macroexpand-macro))
1087
1088(defvar *defined-functions*)
1089
1090(defvar *undefined-functions*)
1091
1092(defun note-name-defined (name)
1093  (when (boundp '*defined-functions*)
1094    (push name *defined-functions*))
1095  (when (and (boundp '*undefined-functions*) (not (null *undefined-functions*)))
1096    (setf *undefined-functions* (remove name *undefined-functions*))))
1097
1098;; Redefine DEFUN to precompile the definition on the fly.
1099(defmacro defun (name lambda-list &body body &environment env)
1100  (note-name-defined name)
1101  (multiple-value-bind (body decls doc)
1102      (parse-body body)
1103    (let* ((block-name (fdefinition-block-name name))
1104           (lambda-expression
1105            `(named-lambda ,name ,lambda-list
1106                           ,@decls
1107                           ,@(when doc `(,doc))
1108                           (block ,block-name ,@body))))
1109      (cond ((and (boundp 'jvm::*file-compilation*)
1110                  ;; when JVM.lisp isn't loaded yet, this variable isn't bound
1111                  ;; meaning that we're not trying to compile to a file:
1112                  ;; Both COMPILE and COMPILE-FILE bind this variable.
1113                  ;; This function is also triggered by MACROEXPAND, though
1114                  jvm::*file-compilation*)
1115             `(fset ',name ,lambda-expression))
1116            (t
1117             (when (and env (empty-environment-p env))
1118               (setf env nil))
1119             (when (null env)
1120               (setf lambda-expression (precompiler:precompile-form lambda-expression nil)))
1121             `(progn
1122                (%defun ',name ,lambda-expression)
1123                ,@(when doc
1124                   `((%set-documentation ',name 'function ,doc)))))))))
1125
1126(export '(precompile))
1127
1128;;(provide "PRECOMPILER")
Note: See TracBrowser for help on using the repository browser.