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

Last change on this file since 11919 was 11919, checked in by ehuelsmann, 12 years ago

Separate the precompiler and the file compiler
by giving each its own 'current environment' variable:
introduce *PRECOMPILE-ENV* in precompiler.lisp.

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