source: trunk/j/src/org/armedbear/lisp/precompiler.lisp @ 11443

Last change on this file since 11443 was 11443, checked in by vvoutilainen, 12 years ago

Fix macrolet.39 in compiled tests by using environment for
local functions.

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