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

Last change on this file since 11833 was 11833, checked in by ehuelsmann, 13 years ago

Special bindings fixes:

compiler-pass1.lisp: set BLOCK-ENVIRONMENT-REGISTER to T,

for ENCLOSED-BY-ENVIRONMENT-SETTING-BLOCK-P to find.

p1-progv: correctness; the symbol and values forms are

outside of the progv-block-scope

p2-progv-node: from p2-progv. A node is required to

indicate to code inside the PROGV scope that bindings
restoration is in order

p1-return-from: indicate to the associated block that

a RETURN-FROM instruction will want to

p2-block-node: p2-progv-node doesn't register variables,

yet it does require a block restoration. Now that
PROGV uses a block (with an environment-register!)
it's incorrect to look at *all-variables*.

... and a little bit of re-indenting.

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