Context Navigation

source: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp @ 11797

Visit:

Last change on this file since 11797 was 11797, checked in by ehuelsmann, 16 years ago
Fix the build. Removal of &aux variables rewriting broke it.
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 46.1 KB

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

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

Download in other formats: