Context Navigation

source: branches/0.16.x/abcl/src/org/armedbear/lisp/precompiler.lisp

Visit:

Last change on this file was 12040, checked in by ehuelsmann, 16 years ago
Add synchronization like in Java through the special operator SYNCHRONIZED-ON.
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 41.4 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: