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

Last change on this file since 4764 was 4764, checked in by piso, 18 years ago

Added compiler macro for IDENTITY.

File size: 16.6 KB
Line 
1;;; precompiler.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: precompiler.lisp,v 1.6 2003-11-15 14:30:30 piso Exp $
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., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(in-package "SYSTEM")
21
22(define-compiler-macro assoc (&whole form &rest args)
23  (cond ((and (= (length args) 4)
24              (eq (third args) :test)
25              (or (equal (fourth args) '(quote eq))
26                  (equal (fourth args) '(function eq))))
27         `(assq ,(first args) ,(second args)))
28        (t form)))
29
30(define-compiler-macro identity (&whole form &rest args)
31  (if (= (length args) 1)
32      `(progn ,(car args))
33      form))
34
35(in-package "EXTENSIONS")
36
37(export '(precompile-form precompile))
38
39(unless (find-package "PRECOMPILER")
40  (make-package "PRECOMPILER"
41                :nicknames '("PRE")
42                :use '("COMMON-LISP" "EXTENSIONS")))
43
44(in-package "PRECOMPILER")
45
46(defvar *in-jvm-compile* nil)
47
48(defun precompile-identity (form)
49  form)
50
51(defun precompile-cons (form)
52  (cons (car form) (mapcar #'precompile1 (cdr form))))
53
54(defun precompile-block (form)
55  (let ((args (cdr form)))
56    (if (null (cdr args))
57        nil
58        (list* 'BLOCK (car args) (mapcar #'precompile1 (cdr args))))))
59
60(defun precompile-dolist (form)
61  (cons 'DOLIST (cons (cadr form) (mapcar #'precompile1 (cddr form)))))
62
63(defun precompile-dotimes (form)
64  (cons 'DOTIMES (cons (cadr form) (mapcar #'precompile1 (cddr form)))))
65
66(defun precompile-do/do* (form)
67  (list* (car form) (cadr form) (caddr form)
68         (mapcar #'precompile1 (cdddr form))))
69
70(defun precompile-do-symbols (form)
71   (list* (car form) (cadr form) (mapcar #'precompile1 (cddr form))))
72
73(defun precompile-progn (form)
74   (let ((body (cdr form)))
75     (if (= (length body) 1)
76         (let ((res (precompile1 (car body))))
77           ;; If the result turns out to be a bare symbol, leave it wrapped
78           ;; with PROGN so it won't be mistaken for a tag in an enclosing
79           ;; TAGBODY.
80           (if (symbolp res)
81               (list 'progn res)
82               res))
83         (cons 'PROGN (mapcar #'precompile1 body)))))
84
85(defun precompile-progv (form)
86   (list* 'PROGV (cadr form) (caddr form) (mapcar #'precompile1 (cdddr form))))
87
88(defun precompile-setq (form)
89  (let* ((args (cdr form))
90        (len (length args)))
91    (when (oddp len)
92      (error "odd number of arguments to SETQ"))
93    (if (= len 2)
94        (list 'SETQ (car args) (precompile1 (cadr args)))
95        (let ((result ()))
96          (loop
97            (when (null args)
98              (return))
99            (push (list 'SETQ (car args) (precompile1 (cadr args))) result)
100            (setq args (cddr args)))
101          (setq result (nreverse result))
102          (push 'PROGN result)
103          result))))
104
105(defun precompile-lambda (form)
106  (let* ((args (cdr form))
107         (lambda-list (car args))
108         (auxvars (memq '&AUX lambda-list)))
109    (if auxvars
110        (append (list 'LAMBDA (subseq lambda-list 0 (position '&AUX lambda-list))
111                      (append (list 'LET*
112                                    (cdr auxvars))
113                              (mapcar #'precompile1 (cdr args)))))
114        (list* 'LAMBDA lambda-list (mapcar #'precompile1 (cdr args))))))
115
116(defun define-local-macro (name lambda-list body)
117  (let* ((form (gensym))
118         (env (gensym))
119         (body (sys::parse-defmacro lambda-list form body name 'macrolet
120                                    :environment env))
121         (expander `(lambda (,form ,env) (block ,name ,body)))
122         (compiled-expander (compile nil expander)))
123    (sys::coerce-to-function (or compiled-expander expander))))
124
125(defvar *local-macros* ())
126
127(defun local-macro-function (name)
128  (getf *local-macros* name))
129
130(defun expand-local-macro (form)
131  (let ((expansion (funcall (local-macro-function (car form)) form nil)))
132    ;; If the expansion turns out to be a bare symbol, wrap it with PROGN so it
133    ;; won't be mistaken for a tag in an enclosing TAGBODY.
134    (if (symbolp expansion)
135        (list 'progn expansion)
136        expansion)))
137
138(defun precompile-macrolet (form)
139  (let ((*local-macros* *local-macros*)
140        (macros (cadr form))
141        (body (cddr form))
142        (res ())
143        compiled-body)
144    (dolist (macro macros)
145      (let ((name (car macro))
146            (lambda-list (cadr macro))
147            (forms (cddr macro)))
148        (push (define-local-macro name lambda-list forms) *local-macros*)
149        (push name *local-macros*)
150        (push (list* name lambda-list (mapcar #'precompile1 forms)) res)))
151    (setf compiled-body (mapcar #'precompile1 body))
152    (setf res (list* 'PROGN compiled-body))
153    res))
154
155(defun precompile-let/let*-vars (vars)
156  (let ((result nil))
157    (dolist (var vars)
158      (if (consp var)
159          (let* ((v (car var))
160                 (expr (cadr var)))
161            (unless (symbolp v)
162              (error 'type-error))
163            (push (list v (precompile1 expr)) result))
164          (push var result)))
165    (nreverse result)))
166
167(defun precompile-let/let* (form)
168  (list* (car form)
169         (precompile-let/let*-vars (cadr form))
170         (mapcar #'precompile1 (cddr form))))
171
172(defun precompile-case (form)
173  (let* ((keyform (cadr form))
174         (clauses (cddr form))
175         (result (list (precompile1 keyform))))
176    (dolist (clause clauses)
177      (push (precompile-case-clause clause) result))
178    (cons (car form) (nreverse result))))
179
180(defun precompile-case-clause (clause)
181  (let ((keys (car clause))
182        (forms (cdr clause)))
183    (cons keys (mapcar #'precompile1 forms))))
184
185(defun precompile-cond (form)
186  (let ((clauses (cdr form))
187        (result nil))
188    (dolist (clause clauses)
189      (push (precompile-cond-clause clause) result))
190    (cons 'COND (nreverse result))))
191
192(defun precompile-cond-clause (clause)
193  (let ((test (car clause))
194        (forms (cdr clause)))
195    (cons (precompile1 test) (mapcar #'precompile1 forms))))
196
197(defun precompile-local-function-def (def)
198  (let ((name (car def))
199        (arglist (cadr def))
200        (body (cddr def)))
201    (list* name arglist (mapcar #'precompile1 body))))
202
203(defun precompile-local-functions (defs)
204  (let ((result nil))
205    (dolist (def defs)
206      (setq result (append result (list (precompile-local-function-def def)))))
207    result))
208
209(defun precompile-flet/labels (form)
210  (let ((locals (cadr form))
211        (body (cddr form)))
212    (list* (car form)
213           (precompile-local-functions locals)
214           (mapcar #'precompile1 body))))
215
216(defun precompile-function (form)
217  (if (and (consp (cadr form)) (eq (caadr form) 'LAMBDA))
218      (list 'FUNCTION (precompile-lambda (cadr form)))
219      form))
220
221(defun precompile-if (form)
222  (let ((args (cdr form)))
223    (case (length args)
224      (2
225       (list 'IF
226             (precompile1 (car args))
227             (precompile1 (cadr args))))
228      (3
229       (list 'IF
230             (precompile1 (car args))
231             (precompile1 (cadr args))
232             (precompile1 (caddr args))))
233      (t
234       (error "wrong number of arguments for IF")))))
235
236(defun precompile-multiple-value-bind (form)
237  (let ((vars (cadr form))
238        (values-form (caddr form))
239        (body (cdddr form)))
240    (list* 'MULTIPLE-VALUE-BIND
241           vars
242           (precompile1 values-form)
243           (mapcar #'precompile1 body))))
244
245(defun precompile-multiple-value-list (form)
246   (list 'MULTIPLE-VALUE-LIST (precompile1 (cadr form))))
247
248(defun precompile-return (form)
249   (list 'RETURN (precompile1 (cadr form))))
250
251(defun precompile-return-from (form)
252  (list 'RETURN-FROM (cadr form) (precompile1 (caddr form))))
253
254(defun precompile-tagbody (form)
255  (do ((body (cdr form) (cdr body))
256       (result ()))
257      ((null body) (cons 'TAGBODY (nreverse result)))
258    (if (atom (car body))
259        (push (car body) result)
260        (push (precompile1 (car body)) result))))
261
262(defun precompile-the (form)
263  (precompile1 (caddr form)))
264
265(defun precompile-unwind-protect (form)
266   (list* 'UNWIND-PROTECT
267          (precompile1 (cadr form))
268          (mapcar #'precompile1 (cddr form))))
269
270;; EXPAND-MACRO is like MACROEXPAND, but EXPAND-MACRO quits if *in-jvm-compile*
271;; is false and a macro is encountered that's also implemented as a special
272;; operator, so interpreted code can use the special operator implementation.
273(defun expand-macro (form)
274  (loop
275    (unless *in-jvm-compile*
276      (when (and (consp form)
277                 (symbolp (car form))
278                 (special-operator-p (car form)))
279        (return-from expand-macro form)))
280    (multiple-value-bind (result expanded) (macroexpand-1 form)
281      (unless expanded
282        (return-from expand-macro result))
283      (setf form result))))
284
285;;; From OpenMCL.
286(defun compiler-macroexpand-1 (form &optional env)
287  (let ((expander nil)
288        (newdef nil))
289    (if (and (consp form)
290             (symbolp (car form))
291             (setq expander (compiler-macro-function (car form) env)))
292        (values (setq newdef (funcall expander form env))
293                (not (eq newdef form)))
294        (values form
295                nil))))
296
297;;; From OpenMCL.
298(defun compiler-macroexpand (form &optional env)
299  (multiple-value-bind (new win) (compiler-macroexpand-1 form env)
300    (do* ((won-at-least-once win))
301         ((null win) (values new won-at-least-once))
302      (multiple-value-setq (new win) (compiler-macroexpand-1 new env)))))
303
304(defun precompile1 (form)
305  (if (atom form)
306      form
307      (let ((op (car form)))
308        (when (symbolp op)
309          (cond ((local-macro-function op)
310                 (let ((result (expand-local-macro form)))
311                   (if (equal result form)
312                       (return-from precompile1 result)
313                       (return-from precompile1 (precompile1 result)))))
314                ((compiler-macro-function op)
315                 (let ((result (compiler-macroexpand form)))
316                   (if (equal result form)
317                       (return-from precompile1 result)
318                       (return-from precompile1 (precompile1 result)))))
319                ((and (not (eq op 'LAMBDA))
320                      (macro-function op))
321                 ;; It's a macro...
322                 (unless (and (special-operator-p op) (not *in-jvm-compile*))
323                   (let ((result (expand-macro form)))
324                     (return-from precompile1 (precompile1 result))))))
325          (let ((handler (get op 'precompile-handler)))
326            (when handler
327              (return-from precompile1 (funcall handler form)))))
328        (when (and (symbolp op) (special-operator-p op))
329          (format t "PRECOMPILE1: unsupported special operator ~S~%" op))
330        (precompile-cons form))))
331
332(defun precompile-form (form in-jvm-compile)
333  (let ((*in-jvm-compile* in-jvm-compile))
334    (precompile1 form)))
335
336(defun install-handler (fun &optional handler)
337  (let ((handler (or handler
338                     (find-symbol (concatenate 'string "PRECOMPILE-"
339                                               (symbol-name fun))
340                                  'precompiler))))
341    (unless (and handler (fboundp handler))
342      (error "no handler for ~S" fun))
343    (setf (get fun 'precompile-handler) handler)))
344
345(mapcar #'install-handler '(block
346                            case
347                            cond
348                            dolist
349                            dotimes
350                            function
351                            if
352                            lambda
353                            macrolet
354                            multiple-value-bind
355                            multiple-value-list
356                            progn
357                            progv
358                            return
359                            return-from
360                            setq
361                            tagbody
362                            the
363                            unwind-protect))
364
365(install-handler 'ecase                'precompile-case)
366
367(install-handler 'and                  'precompile-cons)
368(install-handler 'locally              'precompile-cons)
369(install-handler 'multiple-value-call  'precompile-cons)
370(install-handler 'multiple-value-prog1 'precompile-cons)
371(install-handler 'or                   'precompile-cons)
372(install-handler 'unless               'precompile-cons)
373(install-handler 'when                 'precompile-cons)
374
375(install-handler 'do                   'precompile-do/do*)
376(install-handler 'do*                  'precompile-do/do*)
377
378(install-handler 'flet                 'precompile-flet/labels)
379(install-handler 'labels               'precompile-flet/labels)
380
381(install-handler 'do-symbols           'precompile-do-symbols)
382(install-handler 'do-external-symbols  'precompile-do-symbols)
383
384(install-handler 'let                  'precompile-let/let*)
385(install-handler 'let*                 'precompile-let/let*)
386
387(install-handler 'catch                'precompile-identity)
388(install-handler 'declare              'precompile-identity)
389(install-handler 'go                   'precompile-identity)
390(install-handler 'handler-bind         'precompile-identity)
391(install-handler 'handler-case         'precompile-identity)
392(install-handler 'nth-value            'precompile-identity)
393(install-handler 'quote                'precompile-identity)
394(install-handler 'throw                'precompile-identity)
395
396(in-package "SYSTEM")
397
398(defun precompile (name &optional definition)
399  (unless definition
400    (setq definition (or (and (symbolp name) (macro-function name))
401                         (fdefinition name))))
402  (let (expr result)
403    (cond ((functionp definition)
404           (multiple-value-bind (form closure-p)
405             (function-lambda-expression definition)
406             (unless form
407               (format t "; No lambda expression available for ~S.~%" name)
408               (return-from precompile (values nil t t)))
409             (when closure-p
410               (format t "; Unable to compile function ~S defined in non-null lexical environment.~%" name)
411               (finish-output)
412               (return-from precompile (values nil t t)))
413             (setq expr form)))
414          ((and (consp definition) (eq (car definition) 'lambda))
415           (setq expr definition))
416          (t
417           (error 'type-error)))
418    (setf result (coerce-to-function (precompile-form expr nil)))
419    (when (and name (functionp result))
420      (%set-lambda-name result name)
421      (%set-call-count result (%call-count definition))
422      (%set-arglist result (arglist definition))
423      (if (and (symbolp name) (macro-function name))
424          (setf (fdefinition name) (make-macro result))
425          (setf (fdefinition name) result)))
426    (values (or name result) nil nil)))
427
428(defun precompile-package (pkg &key verbose)
429  (dolist (sym (package-symbols pkg))
430    (when (fboundp sym)
431      (unless (special-operator-p sym)
432        (let ((f (fdefinition sym)))
433          (unless (compiled-function-p f)
434            (when verbose
435              (format t "compiling ~S~%" sym)
436              (finish-output))
437            (precompile sym))))))
438  t)
439
440(precompile-package "PRECOMPILER")
441(precompile-package "EXTENSIONS")
442(precompile-package "SYSTEM")
443(precompile-package "COMMON-LISP")
444
445(defun compile (name &optional definition)
446  (if (and name (fboundp name) (typep (symbol-function name) 'generic-function))
447      (values name nil nil)
448      (precompile name definition)))
449
450;; Redefine DEFMACRO to compile the expansion function on the fly.
451(defmacro defmacro (name lambda-list &rest body)
452  (let* ((form (gensym))
453         (env (gensym))
454         (body (parse-defmacro lambda-list form body name 'defmacro
455                               :environment env))
456         (expander `(lambda (,form ,env) (block ,name ,body))))
457    `(progn
458       (if (special-operator-p ',name)
459           (%put ',name
460                 'macroexpand-macro
461                 (make-macro (or (precompile nil ,expander) ,expander)))
462           (fset ',name
463                 (make-macro (or (precompile nil ,expander) ,expander))))
464       ',name)))
465
466;; Make an exception just this one time...
467(fset 'defmacro (get 'defmacro 'macroexpand-macro))
468
469;; Redefine DEFUN to compile the definition on the fly.
470(defmacro defun (name lambda-list &rest body &environment env)
471  `(progn
472     (%defun ',name ',lambda-list ',body ,env)
473     (precompile ',name)
474     ',name))
Note: See TracBrowser for help on using the repository browser.