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

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

Work in progress.

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