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

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

Initial checkin.

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