source: branches/streams/abcl/src/org/armedbear/lisp/precompiler.lisp

Last change on this file was 14763, checked in by ehuelsmann, 10 years ago

Fix #289: allow special handling of multiple-value-bind by expanding one level at a time.

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