Context Navigation

compiler-pass1.lisp @ 12086

Visit:

Last change on this file since 12086 was 12086, checked in by ehuelsmann, 14 years ago

Make every form which may contain free specials declarations a BLOCK-NODE.

LOCALLY, FLET and LABELS were not converted to blocks - yet.

While at it, change the block dispatch routine: we're not smart enough to
detect that the (block-name form) form will generate the same value every
time - so we don't cache the function result, but evaluate it each time.

Property svn:eol-style set to native
Property svn:keywords set to Id

File size: 45.8 KB

Line
1	;;; compiler-pass1.lisp
2	;;;
3	;;; Copyright (C) 2003-2008 Peter Graves
4	;;; $Id: compiler-pass1.lisp 12086 2009-08-08 15:20:28Z 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 "JVM")
33
34	(eval-when (:compile-toplevel :load-toplevel :execute)
35	(require "LOOP")
36	(require "FORMAT")
37	(require "CLOS")
38	(require "PRINT-OBJECT")
39	(require "COMPILER-TYPES")
40	(require "KNOWN-FUNCTIONS")
41	(require "KNOWN-SYMBOLS")
42	(require "DUMP-FORM")
43	(require "OPCODES")
44	(require "JAVA"))
45
46
47	(eval-when (:compile-toplevel :load-toplevel :execute)
48	(defun generate-inline-expansion (block-name lambda-list body)
49	(cond ((intersection lambda-list
50	'(&optional &rest &key &allow-other-keys &aux)
51	:test #'eq)
52	nil)
53	(t
54	(setf body (copy-tree body))
55	(list 'LAMBDA lambda-list
56	(list* 'BLOCK block-name body)))))
57	) ; EVAL-WHEN
58
59	;;; Pass 1.
60
61
62	;; Returns a list of declared free specials, if any are found.
63	(declaim (ftype (function (list list) list) process-declarations-for-vars))
64	(defun process-declarations-for-vars (body variables)
65	(let ((free-specials '()))
66	(dolist (subform body)
67	(unless (and (consp subform) (eq (%car subform) 'DECLARE))
68	(return))
69	(let ((decls (%cdr subform)))
70	(dolist (decl decls)
71	(case (car decl)
72	((DYNAMIC-EXTENT FTYPE INLINE NOTINLINE OPTIMIZE)
73	;; Nothing to do here.
74	)
75	((IGNORE IGNORABLE)
76	(process-ignore/ignorable (%car decl) (%cdr decl) variables))
77	(SPECIAL
78	(dolist (name (%cdr decl))
79	(let ((variable (find-variable name variables)))
80	(cond ((and variable
81	;; see comment below (and DO-ALL-SYMBOLS.11)
82	(eq (variable-compiland variable)
83	current-compiland))
84	(setf (variable-special-p variable) t))
85	(t
86	(dformat t "adding free special ~S~%" name)
87	(push (make-variable :name name :special-p t)
88	free-specials))))))
89	(TYPE
90	(dolist (name (cddr decl))
91	(let ((variable (find-variable name variables)))
92	(when (and variable
93	;; Don't apply a declaration in a local function to
94	;; a variable defined in its parent. For an example,
95	;; see CREATE-GREEDY-NO-ZERO-MATCHER in cl-ppcre.
96	;; FIXME suboptimal, since we ignore the declaration
97	(eq (variable-compiland variable)
98	current-compiland))
99	(setf (variable-declared-type variable)
100	(make-compiler-type (cadr decl)))))))
101	(t
102	(dolist (name (cdr decl))
103	(let ((variable (find-variable name variables)))
104	(when variable
105	(setf (variable-declared-type variable)
106	(make-compiler-type (%car decl)))))))))))
107	free-specials))
108
109	(defun check-name (name)
110	;; FIXME Currently this error is signalled by the precompiler.
111	(unless (symbolp name)
112	(compiler-error "The variable ~S is not a symbol." name))
113	(when (constantp name)
114	(compiler-error "The name of the variable ~S is already in use to name a constant." name))
115	name)
116
117	(declaim (ftype (function (t) t) p1-body))
118	(defun p1-body (body)
119	(declare (optimize speed))
120	(let ((tail body))
121	(loop
122	(when (endp tail)
123	(return))
124	(setf (car tail) (p1 (%car tail)))
125	(setf tail (%cdr tail))))
126	body)
127
128	(defknown p1-default (t) t)
129	(declaim (inline p1-default))
130	(defun p1-default (form)
131	(setf (cdr form) (p1-body (cdr form)))
132	form)
133
134	(defknown p1-if (t) t)
135	(defun p1-if (form)
136	(let ((test (cadr form)))
137	(cond ((unsafe-p test)
138	(cond ((and (consp test)
139	(memq (%car test) '(GO RETURN-FROM THROW)))
140	(p1 test))
141	(t
142	(let* ((var (gensym))
143	(new-form
144	`(let ((,var ,test))
145	(if ,var ,(third form) ,(fourth form)))))
146	(p1 new-form)))))
147	(t
148	(p1-default form)))))
149
150
151	(defmacro p1-let/let*-vars
152	(varlist variables-var var body1 body2)
153	(let ((varspec (gensym))
154	(initform (gensym))
155	(name (gensym)))
156	`(let ((,variables-var ()))
157	(dolist (,varspec ,varlist)
158	(cond ((consp ,varspec)
159	;; Even though the precompiler already signals this
160	;; error, double checking can't hurt; after all, we're
161	;; also rewriting &AUX into LET* bindings.
162	(unless (<= 1 (length ,varspec) 2)
163	(compiler-error "The LET/LET* binding specification ~S is invalid."
164	,varspec))
165	(let* ((,name (%car ,varspec))
166	(,initform (p1 (%cadr ,varspec)))
167	(,var (make-variable :name (check-name ,name)
168	:initform ,initform)))
169	(push ,var ,variables-var)
170	,@body1))
171	(t
172	(let ((,var (make-variable :name (check-name ,varspec))))
173	(push ,var ,variables-var)
174	,@body1))))
175	,@body2)))
176
177	(defknown p1-let-vars (t) t)
178	(defun p1-let-vars (varlist)
179	(p1-let/let*-vars
180	varlist vars var
181	()
182	((setf vars (nreverse vars))
183	(dolist (variable vars)
184	(push variable visible-variables)
185	(push variable all-variables))
186	vars)))
187
188	(defknown p1-let*-vars (t) t)
189	(defun p1-let*-vars (varlist)
190	(p1-let/let*-vars
191	varlist vars var
192	((push var visible-variables)
193	(push var all-variables))
194	((nreverse vars))))
195
196	(defun p1-let/let* (form)
197	(declare (type cons form))
198	(let* ((visible-variables visible-variables)
199	(block (make-block-node '(LET)))
200	(blocks (cons block blocks))
201	(op (%car form))
202	(varlist (cadr form))
203	(body (cddr form)))
204	(aver (or (eq op 'LET) (eq op 'LET*)))
205	(when (eq op 'LET)
206	;; Convert to LET* if possible.
207	(if (null (cdr varlist))
208	(setf op 'LET*)
209	(dolist (varspec varlist (setf op 'LET*))
210	(or (atom varspec)
211	(constantp (cadr varspec))
212	(eq (car varspec) (cadr varspec))
213	(return)))))
214	(let ((vars (if (eq op 'LET)
215	(p1-let-vars varlist)
216	(p1-let*-vars varlist))))
217	;; Check for globally declared specials.
218	(dolist (variable vars)
219	(when (special-variable-p (variable-name variable))
220	(setf (variable-special-p variable) t
221	(block-environment-register block) t)))
222	;; For processing declarations, we want to walk the variable list from
223	;; last to first, since declarations apply to the last-defined variable
224	;; with the specified name.
225	(setf (block-free-specials block)
226	(process-declarations-for-vars body (reverse vars)))
227	(setf (block-vars block) vars)
228	;; Make free specials visible.
229	(dolist (variable (block-free-specials block))
230	(push variable visible-variables)))
231	(setf body (p1-body body))
232	(setf (block-form block) (list* op varlist body))
233	block))
234
235	(defun p1-locally (form)
236	(let* ((visible-variables visible-variables)
237	(block (make-block-node '(LOCALLY)))
238	(free-specials (process-declarations-for-vars (cdr form) nil)))
239	(setf (block-free-specials block) free-specials)
240	(dolist (special free-specials)
241	;; (format t "p1-locally ~S is special~%" name)
242	(push special visible-variables))
243	(let ((blocks (cons block blocks)))
244	(setf (block-form block)
245	(list* 'LOCALLY (p1-body (cdr form))))
246	block)))
247
248	(defknown p1-m-v-b (t) t)
249	(defun p1-m-v-b (form)
250	(when (= (length (cadr form)) 1)
251	(let ((new-form `(let* ((,(caadr form) ,(caddr form))) ,@(cdddr form))))
252	(return-from p1-m-v-b (p1-let/let* new-form))))
253	(let* ((visible-variables visible-variables)
254	(block (make-block-node '(MULTIPLE-VALUE-BIND)))
255	(blocks (cons block blocks))
256	(varlist (cadr form))
257	(values-form (caddr form))
258	(body (cdddr form)))
259	;; Process the values-form first. ("The scopes of the name binding and
260	;; declarations do not include the values-form.")
261	(setf values-form (p1 values-form))
262	(let ((vars ()))
263	(dolist (symbol varlist)
264	(let ((var (make-variable :name symbol)))
265	(push var vars)
266	(push var visible-variables)
267	(push var all-variables)))
268	;; Check for globally declared specials.
269	(dolist (variable vars)
270	(when (special-variable-p (variable-name variable))
271	(setf (variable-special-p variable) t
272	(block-environment-register block) t)))
273	(setf (block-free-specials block)
274	(process-declarations-for-vars body vars))
275	(setf (block-vars block) (nreverse vars)))
276	(setf body (p1-body body))
277	(setf (block-form block)
278	(list* 'MULTIPLE-VALUE-BIND varlist values-form body))
279	block))
280
281	(defun p1-block (form)
282	(let* ((block (make-block-node (cadr form)))
283	(blocks (cons block blocks)))
284	(setf (cddr form) (p1-body (cddr form)))
285	(setf (block-form block) form)
286	block))
287
288	(defun p1-catch (form)
289	(let* ((tag (p1 (cadr form)))
290	(body (cddr form))
291	(block (make-block-node '(CATCH)))
292	;; our subform processors need to know
293	;; they're enclosed in a CATCH block
294	(blocks (cons block blocks))
295	(result '()))
296	(dolist (subform body)
297	(let ((op (and (consp subform) (%car subform))))
298	(push (p1 subform) result)
299	(when (memq op '(GO RETURN-FROM THROW))
300	(return))))
301	(setf result (nreverse result))
302	(when (and (null (cdr result))
303	(consp (car result))
304	(eq (caar result) 'GO))
305	(return-from p1-catch (car result)))
306	(push tag result)
307	(push 'CATCH result)
308	(setf (block-form block) result)
309	block))
310
311	(defun p1-threads-synchronized-on (form)
312	(let* ((synchronized-object (p1 (cadr form)))
313	(body (cddr form))
314	(block (make-block-node '(THREADS:SYNCHRONIZED-ON)))
315	(blocks (cons block blocks))
316	result)
317	(dolist (subform body)
318	(let ((op (and (consp subform) (%car subform))))
319	(push (p1 subform) result)
320	(when (memq op '(GO RETURN-FROM THROW))
321	(return))))
322	(setf (block-form block)
323	(list* 'threads:synchronized-on synchronized-object
324	(nreverse result)))
325	block))
326
327	(defun p1-unwind-protect (form)
328	(if (= (length form) 2)
329	(p1 (second form)) ; No cleanup forms: (unwind-protect (...)) => (...)
330
331	;; in order to compile the cleanup forms twice (see
332	;; p2-unwind-protect-node), we need to p1 them twice; p1 outcomes
333	;; can be compiled (in the same compiland?) only once.
334	;;
335	;; However, p1 transforms the forms being processed, so, we
336	;; need to copy the forms to create a second copy.
337	(let* ((block (make-block-node '(UNWIND-PROTECT)))
338	;; a bit of jumping through hoops...
339	(unwinding-forms (p1-body (copy-tree (cddr form))))
340	(unprotected-forms (p1-body (cddr form)))
341	;; ... because only the protected form is
342	;; protected by the UNWIND-PROTECT block
343	(blocks (cons block blocks))
344	(protected-form (p1 (cadr form))))
345	(setf (block-form block)
346	`(unwind-protect ,protected-form
347	(progn ,@unwinding-forms)
348	,@unprotected-forms))
349	block)))
350
351	(defknown p1-return-from (t) t)
352	(defun p1-return-from (form)
353	(let* ((name (second form))
354	(block (find-block name)))
355	(when (null block)
356	(compiler-error "RETURN-FROM ~S: no block named ~S is currently visible."
357	name name))
358	(dformat t "p1-return-from block = ~S~%" (block-name block))
359	(setf (block-return-p block) t)
360	(cond ((eq (block-compiland block) current-compiland)
361	;; Local case. If the RETURN is nested inside an UNWIND-PROTECT
362	;; which is inside the block we're returning from, we'll do a non-
363	;; local return anyway so that UNWIND-PROTECT can catch it and run
364	;; its cleanup forms.
365	(dformat t "blocks = ~S~%" (mapcar #'block-name blocks))
366	(let ((protected (enclosed-by-protected-block-p block)))
367	(dformat t "p1-return-from protected = ~S~%" protected)
368	(if protected
369	(setf (block-non-local-return-p block) t)
370	;; non-local GO's ensure environment restoration
371	;; find out about this local GO
372	(when (null (block-needs-environment-restoration block))
373	(setf (block-needs-environment-restoration block)
374	(enclosed-by-environment-setting-block-p block))))))
375	(t
376	(setf (block-non-local-return-p block) t)))
377	(when (block-non-local-return-p block)
378	(dformat t "non-local return from block ~S~%" (block-name block))))
379	(list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form))))
380
381	(defun p1-tagbody (form)
382	(let* ((block (make-block-node '(TAGBODY)))
383	(blocks (cons block blocks))
384	(visible-tags visible-tags)
385	(local-tags '())
386	(body (cdr form)))
387	;; Make all the tags visible before processing the body forms.
388	(dolist (subform body)
389	(when (or (symbolp subform) (integerp subform))
390	(let* ((tag (make-tag :name subform :label (gensym) :block block)))
391	(push tag local-tags)
392	(push tag visible-tags))))
393	(let ((new-body '())
394	(live t))
395	(dolist (subform body)
396	(cond ((or (symbolp subform) (integerp subform))
397	(push subform new-body)
398	(push (find subform local-tags :key #'tag-name :test #'eql)
399	(block-tags block))
400	(setf live t))
401	((not live)
402	;; Nothing to do.
403	)
404	(t
405	(when (and (consp subform)
406	(memq (%car subform) '(GO RETURN-FROM THROW)))
407	;; Subsequent subforms are unreachable until we see another
408	;; tag.
409	(setf live nil))
410	(push (p1 subform) new-body))))
411	(setf (block-form block) (list* 'TAGBODY (nreverse new-body))))
412	block))
413
414	(defknown p1-go (t) t)
415	(defun p1-go (form)
416	(let* ((name (cadr form))
417	(tag (find-tag name)))
418	(unless tag
419	(error "p1-go: tag not found: ~S" name))
420	(setf (tag-used tag) t)
421	(let ((tag-block (tag-block tag)))
422	(cond ((eq (tag-compiland tag) current-compiland)
423	;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH?
424	(if (enclosed-by-protected-block-p tag-block)
425	(setf (block-non-local-go-p tag-block) t)
426	;; non-local GO's ensure environment restoration
427	;; find out about this local GO
428	(when (null (block-needs-environment-restoration tag-block))
429	(setf (block-needs-environment-restoration tag-block)
430	(enclosed-by-environment-setting-block-p tag-block)))))
431	(t
432	(setf (block-non-local-go-p tag-block) t)))))
433	form)
434
435	(defun validate-function-name (name)
436	(unless (or (symbolp name) (setf-function-name-p name))
437	(compiler-error "~S is not a valid function name." name)))
438
439	(defmacro with-local-functions-for-flet/labels
440	(form local-functions-var lambda-list-var name-var body-var body1 body2)
441	`(progn (incf (compiland-children current-compiland) (length (cadr ,form)))
442	(let ((visible-variables visible-variables)
443	(local-functions local-functions)
444	(current-compiland current-compiland)
445	(,local-functions-var '()))
446	(dolist (definition (cadr ,form))
447	(let ((,name-var (car definition))
448	(,lambda-list-var (cadr definition)))
449	(validate-function-name ,name-var)
450	(let* ((,body-var (cddr definition))
451	(compiland (make-compiland :name ,name-var
452	:parent current-compiland)))
453	,@body1)))
454	(setf ,local-functions-var (nreverse ,local-functions-var))
455	;; Make the local functions visible.
456	(dolist (local-function ,local-functions-var)
457	(push local-function local-functions)
458	(let ((variable (local-function-variable local-function)))
459	(when variable
460	(push variable visible-variables))))
461	,@body2)))
462
463	(defun split-decls (forms specific-vars)
464	(let ((other-decls nil)
465	(specific-decls nil))
466	(dolist (form forms)
467	(unless (and (consp form) (eq (car form) 'DECLARE)) ; shouldn't happen
468	(return))
469	(dolist (decl (cdr form))
470	(case (car decl)
471	((OPTIMIZE DECLARATION DYNAMIC-EXTENT FTYPE INLINE NOTINLINE)
472	(push (list 'DECLARE decl) other-decls))
473	(SPECIAL
474	(dolist (name (cdr decl))
475	(if (memq name specific-vars)
476	(push `(DECLARE (SPECIAL ,name)) specific-decls)
477	(push `(DECLARE (SPECIAL ,name)) other-decls))))
478	(TYPE
479	(dolist (name (cddr decl))
480	(if (memq name specific-vars)
481	(push `(DECLARE (TYPE ,(cadr decl) ,name)) specific-decls)
482	(push `(DECLARE (TYPE ,(cadr decl) ,name)) other-decls))))
483	(t
484	(dolist (name (cdr decl))
485	(if (memq name specific-vars)
486	(push `(DECLARE (,(car decl) ,name)) specific-decls)
487	(push `(DECLARE (,(car decl) ,name)) other-decls)))))))
488	(values (nreverse other-decls)
489	(nreverse specific-decls))))
490
491	(defun rewrite-aux-vars (form)
492	(let* ((lambda-list (cadr form))
493	(aux-p (memq '&AUX lambda-list))
494	(lets (cdr aux-p))
495	aux-vars)
496	(unless aux-p
497	;; no rewriting required
498	(return-from rewrite-aux-vars form))
499	(multiple-value-bind (body decls)
500	(parse-body (cddr form))
501	(dolist (form lets)
502	(cond ((consp form)
503	(push (car form) aux-vars))
504	(t
505	(push form aux-vars))))
506	(setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
507	(multiple-value-bind (let-decls lambda-decls)
508	(split-decls decls (lambda-list-names lambda-list))
509	`(lambda ,lambda-list
510	,@lambda-decls
511	(let* ,lets
512	,@let-decls
513	,@body))))))
514
515	(defun rewrite-lambda (form)
516	(setf form (rewrite-aux-vars form))
517	(let* ((lambda-list (cadr form)))
518	(if (not (or (memq '&optional lambda-list)
519	(memq '&key lambda-list)))
520	;; no need to rewrite: no arguments with possible initforms anyway
521	form
522	(multiple-value-bind (body decls doc)
523	(parse-body (cddr form))
524	(let (state let-bindings new-lambda-list
525	(non-constants 0))
526	(do* ((vars lambda-list (cdr vars))
527	(var (car vars) (car vars)))
528	((endp vars))
529	(push (car vars) new-lambda-list)
530	(let ((replacement (gensym)))
531	(flet ((parse-compound-argument (arg)
532	"Returns the values NAME, KEYWORD, INITFORM, INITFORM-P,
533	SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument."
534	(destructuring-bind
535	(name &optional (initform nil initform-supplied-p)
536	(supplied-p nil supplied-p-supplied-p))
537	(if (listp arg) arg (list arg))
538	(if (listp name)
539	(values (cadr name) (car name)
540	initform initform-supplied-p
541	supplied-p supplied-p-supplied-p)
542	(values name (make-keyword name)
543	initform initform-supplied-p
544	supplied-p supplied-p-supplied-p)))))
545	(case var
546	(&optional (setf state :optional))
547	(&key (setf state :key))
548	((&whole &environment &rest &body &allow-other-keys)
549	;; do nothing special
550	)
551	(t
552	(cond
553	((atom var)
554	(setf (car new-lambda-list)
555	(if (eq state :key)
556	(list (list (make-keyword var) replacement))
557	replacement))
558	(push (list var replacement) let-bindings))
559	((constantp (second var))
560	;; so, we must have a consp-type var we're looking at
561	;; and it has a constantp initform
562	(multiple-value-bind
563	(name keyword initform initform-supplied-p
564	supplied-p supplied-p-supplied-p)
565	(parse-compound-argument var)
566	(let ((var-form (if (eq state :key)
567	(list keyword replacement)
568	replacement))
569	(supplied-p-replacement (gensym)))
570	(setf (car new-lambda-list)
571	(cond
572	((not initform-supplied-p)
573	(list var-form))
574	((not supplied-p-supplied-p)
575	(list var-form initform))
576	(t
577	(list var-form initform
578	supplied-p-replacement))))
579	(push (list name replacement) let-bindings)
580	;; if there was a 'supplied-p' variable, it might
581	;; be used in the declarations. Since those will be
582	;; moved below the LET* block, we need to move the
583	;; supplied-p parameter too.
584	(when supplied-p-supplied-p
585	(push (list supplied-p supplied-p-replacement)
586	let-bindings)))))
587	(t
588	(incf non-constants)
589	;; this is either a keyword or an optional argument
590	;; with a non-constantp initform
591	(multiple-value-bind
592	(name keyword initform initform-supplied-p
593	supplied-p supplied-p-supplied-p)
594	(parse-compound-argument var)
595	(declare (ignore initform-supplied-p))
596	(let ((var-form (if (eq state :key)
597	(list keyword replacement)
598	replacement))
599	(supplied-p-replacement (gensym)))
600	(setf (car new-lambda-list)
601	(list var-form nil supplied-p-replacement))
602	(push (list name `(if ,supplied-p-replacement
603	,replacement ,initform))
604	let-bindings)
605	(when supplied-p-supplied-p
606	(push (list supplied-p supplied-p-replacement)
607	let-bindings)))))))))))
608	(if (zerop non-constants)
609	;; there was no reason to rewrite...
610	form
611	(let ((rv
612	`(lambda ,(nreverse new-lambda-list)
613	,@(when doc (list doc))
614	(let* ,(nreverse let-bindings)
615	,@decls ,@body))))
616	rv)))))))
617
618	(defun p1-flet (form)
619	(with-local-functions-for-flet/labels
620	form local-functions lambda-list name body
621	((let ((local-function (make-local-function :name name
622	:compiland compiland)))
623	(multiple-value-bind (body decls) (parse-body body)
624	(let* ((block-name (fdefinition-block-name name))
625	(lambda-expression
626	(rewrite-lambda
627	`(lambda ,lambda-list ,@decls (block ,block-name ,@body))))
628	(visible-variables visible-variables)
629	(local-functions local-functions)
630	(current-compiland compiland))
631	(setf (compiland-lambda-expression compiland) lambda-expression)
632	(setf (local-function-inline-expansion local-function)
633	(generate-inline-expansion block-name lambda-list body))
634	(p1-compiland compiland)))
635	(push local-function local-functions)))
636	((with-saved-compiler-policy
637	(process-optimization-declarations (cddr form))
638	(let* ((block (make-block-node '(FLET)))
639	(blocks (cons block blocks))
640	(body (cddr form))
641	(visible-variables visible-variables))
642	(setf (block-free-specials block)
643	(process-declarations-for-vars body nil))
644	(dolist (special (block-free-specials block))
645	(push special visible-variables))
646	(setf (block-form block)
647	(list* (car form) local-functions (p1-body (cddr form))))
648	block)))))
649
650
651	(defun p1-labels (form)
652	(with-local-functions-for-flet/labels
653	form local-functions lambda-list name body
654	((let* ((variable (make-variable :name (gensym)))
655	(local-function (make-local-function :name name
656	:compiland compiland
657	:variable variable)))
658	(multiple-value-bind (body decls) (parse-body body)
659	(setf (compiland-lambda-expression compiland)
660	(rewrite-lambda
661	`(lambda ,lambda-list ,@decls (block ,name ,@body)))))
662	(push variable all-variables)
663	(push local-function local-functions)))
664	((dolist (local-function local-functions)
665	(let ((visible-variables visible-variables)
666	(current-compiland (local-function-compiland local-function)))
667	(p1-compiland (local-function-compiland local-function))))
668	(let* ((block (make-block-node '(LABELS)))
669	(blocks (cons block blocks))
670	(body (cddr form))
671	(visible-variables visible-variables))
672	(setf (block-free-specials block)
673	(process-declarations-for-vars body nil))
674	(dolist (special (block-free-specials block))
675	(push special visible-variables))
676	(setf (block-form block)
677	(list* (car form) local-functions (p1-body (cddr form))))
678	block))))
679
680	(defknown p1-funcall (t) t)
681	(defun p1-funcall (form)
682	(unless (> (length form) 1)
683	(compiler-warn "Wrong number of arguments for ~A." (car form))
684	(return-from p1-funcall form))
685	(let ((function-form (%cadr form)))
686	(when (and (consp function-form)
687	(eq (%car function-form) 'FUNCTION))
688	(let ((name (%cadr function-form)))
689	;; (format t "p1-funcall name = ~S~%" name)
690	(let ((source-transform (source-transform name)))
691	(when source-transform
692	;; (format t "found source transform for ~S~%" name)
693	;; (format t "old form = ~S~%" form)
694	;; (let ((new-form (expand-source-transform form)))
695	;; (when (neq new-form form)
696	;; (format t "new form = ~S~%" new-form)
697	;; (return-from p1-funcall (p1 new-form))))
698	(let ((new-form (expand-source-transform (list* name (cddr form)))))
699	;; (format t "new form = ~S~%" new-form)
700	(return-from p1-funcall (p1 new-form)))
701	)))))
702	;; Otherwise...
703	(p1-function-call form))
704
705	(defun p1-function (form)
706	(let ((form (copy-tree form))
707	local-function)
708	(cond ((and (consp (cadr form))
709	(or (eq (caadr form) 'LAMBDA)
710	(eq (caadr form) 'NAMED-LAMBDA)))
711	(let* ((named-lambda-p (eq (caadr form) 'NAMED-LAMBDA))
712	(named-lambda-form (when named-lambda-p
713	(cadr form)))
714	(name (when named-lambda-p
715	(cadr named-lambda-form)))
716	(lambda-form (if named-lambda-p
717	(cons 'LAMBDA (cddr named-lambda-form))
718	(cadr form)))
719	(lambda-list (cadr lambda-form))
720	(body (cddr lambda-form))
721	(compiland (make-compiland :name (if named-lambda-p
722	name (gensym "ANONYMOUS-LAMBDA-"))
723	:lambda-expression lambda-form
724	:parent current-compiland)))
725	(when current-compiland
726	(incf (compiland-children current-compiland)))
727	(multiple-value-bind (body decls)
728	(parse-body body)
729	(setf (compiland-lambda-expression compiland)
730	;; if there still was a doc-string present, remove it
731	(rewrite-lambda
732	`(lambda ,lambda-list ,@decls ,@body)))
733	(let ((visible-variables visible-variables)
734	(current-compiland compiland))
735	(p1-compiland compiland)))
736	(list 'FUNCTION compiland)))
737	((setf local-function (find-local-function (cadr form)))
738	(dformat t "p1-function local function ~S~%" (cadr form))
739	(let ((variable (local-function-variable local-function)))
740	(when variable
741	(dformat t "p1-function ~S used non-locally~%"
742	(variable-name variable))
743	(setf (variable-used-non-locally-p variable) t)))
744	form)
745	(t
746	form))))
747
748	(defun p1-lambda (form)
749	(setf form (rewrite-lambda form))
750	(let* ((lambda-list (cadr form)))
751	(when (or (memq '&optional lambda-list)
752	(memq '&key lambda-list))
753	(let ((state nil))
754	(dolist (arg lambda-list)
755	(cond ((memq arg lambda-list-keywords)
756	(setf state arg))
757	((memq state '(&optional &key))
758	(when (and (consp arg)
759	(not (constantp (second arg))))
760	(compiler-unsupported
761	"P1-LAMBDA: can't handle optional argument with non-constant initform.")))))))
762	(p1-function (list 'FUNCTION form))))
763
764	(defun p1-eval-when (form)
765	(list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
766
767	(defknown p1-progv (t) t)
768	(defun p1-progv (form)
769	;; We've already checked argument count in PRECOMPILE-PROGV.
770
771	;; ### FIXME: we need to return a block here, so that
772	;; (local) GO in p2 can restore the lastSpecialBinding environment
773	(let ((new-form (rewrite-progv form)))
774	(when (neq new-form form)
775	(return-from p1-progv (p1 new-form))))
776	(let* ((symbols-form (p1 (cadr form)))
777	(values-form (p1 (caddr form)))
778	(block (make-block-node '(PROGV)))
779	(blocks (cons block blocks))
780	(body (cdddr form)))
781	(setf (block-form block)
782	`(progv ,symbols-form ,values-form ,@(p1-body body))
783	(block-environment-register block) t)
784	block))
785
786	(defknown rewrite-progv (t) t)
787	(defun rewrite-progv (form)
788	(let ((symbols-form (cadr form))
789	(values-form (caddr form))
790	(body (cdddr form)))
791	(cond ((or (unsafe-p symbols-form) (unsafe-p values-form))
792	(let ((g1 (gensym))
793	(g2 (gensym)))
794	`(let ((,g1 ,symbols-form)
795	(,g2 ,values-form))
796	(progv ,g1 ,g2 ,@body))))
797	(t
798	form))))
799
800	(defun p1-quote (form)
801	(unless (= (length form) 2)
802	(compiler-error "Wrong number of arguments for special operator ~A (expected 1, but received ~D)."
803	'QUOTE
804	(1- (length form))))
805	(let ((arg (%cadr form)))
806	(if (or (numberp arg) (characterp arg))
807	arg
808	form)))
809
810	(defun p1-setq (form)
811	(unless (= (length form) 3)
812	(error "Too many arguments for SETQ."))
813	(let ((arg1 (%cadr form))
814	(arg2 (%caddr form)))
815	(let ((variable (find-visible-variable arg1)))
816	(if variable
817	(progn
818	(when (variable-ignore-p variable)
819	(compiler-style-warn
820	"Variable ~S is assigned even though it was declared to be ignored."
821	(variable-name variable)))
822	(incf (variable-writes variable))
823	(cond ((eq (variable-compiland variable) current-compiland)
824	(dformat t "p1-setq: write ~S~%" arg1))
825	(t
826	(dformat t "p1-setq: non-local write ~S~%" arg1)
827	(setf (variable-used-non-locally-p variable) t))))
828	(dformat t "p1-setq: unknown variable ~S~%" arg1)))
829	(list 'SETQ arg1 (p1 arg2))))
830
831	(defun p1-the (form)
832	(unless (= (length form) 3)
833	(compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)."
834	'THE
835	(1- (length form))))
836	(let ((type (%cadr form))
837	(expr (%caddr form)))
838	(cond ((and (listp type) (eq (car type) 'VALUES))
839	;; FIXME
840	(p1 expr))
841	((= safety 3)
842	(let* ((sym (gensym))
843	(new-expr `(let ((,sym ,expr))
844	(require-type ,sym ',type)
845	,sym)))
846	(p1 new-expr)))
847	(t
848	(list 'THE type (p1 expr))))))
849
850	(defun p1-truly-the (form)
851	(unless (= (length form) 3)
852	(compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)."
853	'TRULY-THE
854	(1- (length form))))
855	(list 'TRULY-THE (%cadr form) (p1 (%caddr form))))
856
857	(defknown unsafe-p (t) t)
858	(defun unsafe-p (args)
859	(cond ((node-p args)
860	(unsafe-p (node-form args)))
861	((atom args)
862	nil)
863	(t
864	(case (%car args)
865	(QUOTE
866	nil)
867	(LAMBDA
868	nil)
869	((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK)
870	t)
871	(t
872	(dolist (arg args)
873	(when (unsafe-p arg)
874	(return t))))))))
875
876	(defknown rewrite-throw (t) t)
877	(defun rewrite-throw (form)
878	(let ((args (cdr form)))
879	(if (unsafe-p args)
880	(let ((syms ())
881	(lets ()))
882	;; Tag.
883	(let ((arg (first args)))
884	(if (constantp arg)
885	(push arg syms)
886	(let ((sym (gensym)))
887	(push sym syms)
888	(push (list sym arg) lets))))
889	;; Result. "If the result-form produces multiple values, then all the
890	;; values are saved."
891	(let ((arg (second args)))
892	(if (constantp arg)
893	(push arg syms)
894	(let ((sym (gensym)))
895	(cond ((single-valued-p arg)
896	(push sym syms)
897	(push (list sym arg) lets))
898	(t
899	(push (list 'VALUES-LIST sym) syms)
900	(push (list sym
901	(list 'MULTIPLE-VALUE-LIST arg))
902	lets))))))
903	(list 'LET* (nreverse lets) (list* 'THROW (nreverse syms))))
904	form)))
905
906	(defknown p1-throw (t) t)
907	(defun p1-throw (form)
908	(let ((new-form (rewrite-throw form)))
909	(when (neq new-form form)
910	(return-from p1-throw (p1 new-form))))
911	(list* 'THROW (mapcar #'p1 (cdr form))))
912
913	(defknown rewrite-function-call (t) t)
914	(defun rewrite-function-call (form)
915	(let ((args (cdr form)))
916	(if (unsafe-p args)
917	(let ((arg1 (car args)))
918	(cond ((and (consp arg1) (eq (car arg1) 'GO))
919	arg1)
920	(t
921	(let ((syms ())
922	(lets ()))
923	;; Preserve the order of evaluation of the arguments!
924	(dolist (arg args)
925	(cond ((constantp arg)
926	(push arg syms))
927	((and (consp arg) (eq (car arg) 'GO))
928	(return-from rewrite-function-call
929	(list 'LET* (nreverse lets) arg)))
930	(t
931	(let ((sym (gensym)))
932	(push sym syms)
933	(push (list sym arg) lets)))))
934	(list 'LET* (nreverse lets)
935	(list* (car form) (nreverse syms)))))))
936	form)))
937
938	(defknown p1-function-call (t) t)
939	(defun p1-function-call (form)
940	(let ((new-form (rewrite-function-call form)))
941	(when (neq new-form form)
942	;; (let ((print-structure nil))
943	;; (format t "old form = ~S~%" form)
944	;; (format t "new form = ~S~%" new-form))
945	(return-from p1-function-call (p1 new-form))))
946	(let* ((op (car form))
947	(local-function (find-local-function op)))
948	(cond (local-function
949	;; (format t "p1 local call to ~S~%" op)
950	;; (format t "inline-p = ~S~%" (inline-p op))
951
952	(when (and enable-inline-expansion (inline-p op))
953	(let ((expansion (local-function-inline-expansion local-function)))
954	(when expansion
955	(let ((explain explain))
956	(when (and explain (memq :calls explain))
957	(format t "; inlining call to local function ~S~%" op)))
958	(return-from p1-function-call
959	(p1 (expand-inline form expansion))))))
960
961	;; FIXME
962	(dformat t "local function assumed not single-valued~%")
963	(setf (compiland-%single-valued-p current-compiland) nil)
964
965	(let ((variable (local-function-variable local-function)))
966	(when variable
967	(dformat t "p1 ~S used non-locally~%" (variable-name variable))
968	(setf (variable-used-non-locally-p variable) t))))
969	(t
970	;; Not a local function call.
971	(dformat t "p1 non-local call to ~S~%" op)
972	(unless (single-valued-p form)
973	;; (format t "not single-valued op = ~S~%" op)
974	(setf (compiland-%single-valued-p current-compiland) nil)))))
975	(p1-default form))
976
977	(defknown p1 (t) t)
978	(defun p1 (form)
979	(cond ((symbolp form)
980	(let (value)
981	(cond ((null form)
982	form)
983	((eq form t)
984	form)
985	((keywordp form)
986	form)
987	((and (constantp form)
988	(progn
989	(setf value (symbol-value form))
990	(or (numberp value)
991	(stringp value)
992	(pathnamep value))))
993	(setf form value))
994	(t
995	(let ((variable (find-visible-variable form)))
996	(when (null variable)
997	(unless (or (special-variable-p form)
998	(memq form undefined-variables))
999	(compiler-style-warn
1000	"Undefined variable ~S assumed special" form)
1001	(push form undefined-variables))
1002	(setf variable (make-variable :name form :special-p t))
1003	(push variable visible-variables))
1004	(let ((ref (make-var-ref variable)))
1005	(unless (variable-special-p variable)
1006	(when (variable-ignore-p variable)
1007	(compiler-style-warn
1008	"Variable ~S is read even though it was declared to be ignored."
1009	(variable-name variable)))
1010	(push ref (variable-references variable))
1011	(incf (variable-reads variable))
1012	(cond ((eq (variable-compiland variable) current-compiland)
1013	(dformat t "p1: read ~S~%" form))
1014	(t
1015	(dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%"
1016	form
1017	(compiland-name (variable-compiland variable))
1018	(compiland-name current-compiland))
1019	(setf (variable-used-non-locally-p variable) t))))
1020	(setf form ref)))
1021	form))))
1022	((atom form)
1023	form)
1024	(t
1025	(let ((op (%car form))
1026	handler)
1027	(cond ((symbolp op)
1028	(when (compiler-macro-function op)
1029	(unless (notinline-p op)
1030	(multiple-value-bind (expansion expanded-p)
1031	(compiler-macroexpand form)
1032	;; Fall through if no change...
1033	(when expanded-p
1034	(return-from p1 (p1 expansion))))))
1035	(cond ((setf handler (get op 'p1-handler))
1036	(funcall handler form))
1037	((macro-function op compile-file-environment)
1038	(p1 (macroexpand form compile-file-environment)))
1039	((special-operator-p op)
1040	(compiler-unsupported "P1: unsupported special operator ~S" op))
1041	(t
1042	(p1-function-call form))))
1043	((and (consp op) (eq (%car op) 'LAMBDA))
1044	(p1 (list* 'FUNCALL form)))
1045	(t
1046	form))))))
1047
1048	(defun install-p1-handler (symbol handler)
1049	(setf (get symbol 'p1-handler) handler))
1050
1051	(defun initialize-p1-handlers ()
1052	(dolist (pair '((AND p1-default)
1053	(BLOCK p1-block)
1054	(CATCH p1-catch)
1055	(DECLARE identity)
1056	(EVAL-WHEN p1-eval-when)
1057	(FLET p1-flet)
1058	(FUNCALL p1-funcall)
1059	(FUNCTION p1-function)
1060	(GO p1-go)
1061	(IF p1-if)
1062	(LABELS p1-labels)
1063	(LAMBDA p1-lambda)
1064	(LET p1-let/let*)
1065	(LET* p1-let/let*)
1066	(LOAD-TIME-VALUE identity)
1067	(LOCALLY p1-locally)
1068	(MULTIPLE-VALUE-BIND p1-m-v-b)
1069	(MULTIPLE-VALUE-CALL p1-default)
1070	(MULTIPLE-VALUE-LIST p1-default)
1071	(MULTIPLE-VALUE-PROG1 p1-default)
1072	(OR p1-default)
1073	(PROGN p1-default)
1074	(PROGV p1-progv)
1075	(QUOTE p1-quote)
1076	(RETURN-FROM p1-return-from)
1077	(SETQ p1-setq)
1078	(SYMBOL-MACROLET identity)
1079	(TAGBODY p1-tagbody)
1080	(THE p1-the)
1081	(THROW p1-throw)
1082	(TRULY-THE p1-truly-the)
1083	(UNWIND-PROTECT p1-unwind-protect)
1084	(THREADS:SYNCHRONIZED-ON
1085	p1-threads-synchronized-on)))
1086	(install-p1-handler (%car pair) (%cadr pair))))
1087
1088	(initialize-p1-handlers)
1089
1090	(defun p1-compiland (compiland)
1091	;; (format t "p1-compiland name = ~S~%" (compiland-name compiland))
1092	(let ((form (compiland-lambda-expression compiland)))
1093	(aver (eq (car form) 'LAMBDA))
1094	(setf form (rewrite-lambda form))
1095	(process-optimization-declarations (cddr form))
1096
1097	(let* ((lambda-list (cadr form))
1098	(body (cddr form))
1099	(visible-variables visible-variables)
1100	(closure (make-closure `(lambda ,lambda-list nil) nil))
1101	(syms (sys::varlist closure))
1102	(vars nil))
1103	(dolist (sym syms)
1104	(let ((var (make-variable :name sym
1105	:special-p (special-variable-p sym))))
1106	(push var vars)
1107	(push var all-variables)
1108	(push var visible-variables)))
1109	(setf (compiland-arg-vars compiland) (nreverse vars))
1110	(let ((free-specials (process-declarations-for-vars body vars)))
1111	(setf (compiland-free-specials compiland) free-specials)
1112	(dolist (var free-specials)
1113	(push var visible-variables)))
1114	(setf (compiland-p1-result compiland)
1115	(list* 'LAMBDA lambda-list (p1-body body))))))
1116
1117	(provide "COMPILER-PASS1")

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

Context Navigation

source: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp @ 12086

Download in other formats: