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

Last change on this file since 12174 was 12174, checked in by ehuelsmann, 12 years ago

Rewrite RETURN-FROM to fix MISC.293A, MISC.293B and MISC.293C.

Add documentation as to why this type of rewriting is necessary.

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