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

Last change on this file since 14215 was 14133, checked in by ehuelsmann, 8 years ago

Remove code duplication. Rename MAKE-EXPANDER-FOR-MACROLET because it
is no longer used solely for MACROLET.

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