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

Last change on this file since 11643 was 11643, checked in by vvoutilainen, 13 years ago

Remove duplication from p1-flet and p1-labels.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 40.0 KB
Line 
1;;; compiler-pass1.lisp
2;;;
3;;; Copyright (C) 2003-2008 Peter Graves
4;;; $Id: compiler-pass1.lisp 11643 2009-02-08 13:14:20Z vvoutilainen $
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(defknown p1-let-vars (t) t)
145(defun p1-let-vars (varlist)
146  (let ((vars ()))
147    (dolist (varspec varlist)
148      (cond ((consp varspec)
149              ;; FIXME Currently this error is signalled by the precompiler.
150             (unless (= (length varspec) 2)
151               (compiler-error "The LET binding specification ~S is invalid."
152                               varspec))
153             (let ((name (check-name (%car varspec)))
154                   (initform (p1 (%cadr varspec))))
155               (push (make-variable :name name :initform initform) vars)))
156            (t
157             (push (make-variable :name (check-name varspec)) vars))))
158    (setf vars (nreverse vars))
159    (dolist (variable vars)
160      (push variable *visible-variables*)
161      (push variable *all-variables*))
162    vars))
163
164(defknown p1-let*-vars (t) t)
165(defun p1-let*-vars (varlist)
166  (let ((vars ()))
167    (dolist (varspec varlist)
168      (cond ((consp varspec)
169              ;; FIXME Currently this error is signalled by the precompiler.
170             (unless (= (length varspec) 2)
171               (compiler-error "The LET* binding specification ~S is invalid."
172                               varspec))
173             (let* ((name (%car varspec))
174                    (initform (p1 (%cadr varspec)))
175                    (var (make-variable :name (check-name name) :initform initform)))
176               (push var vars)
177               (push var *visible-variables*)
178               (push var *all-variables*)))
179            (t
180             (let ((var (make-variable :name (check-name varspec))))
181               (push var vars)
182               (push var *visible-variables*)
183               (push var *all-variables*)))))
184    (nreverse vars)))
185
186(defun p1-let/let* (form)
187  (declare (type cons form))
188  (let* ((*visible-variables* *visible-variables*)
189         (block (make-block-node '(LET)))
190         (*blocks* (cons block *blocks*))
191         (op (%car form))
192         (varlist (cadr form))
193         (body (cddr form)))
194    (aver (or (eq op 'LET) (eq op 'LET*)))
195    (when (eq op 'LET)
196      ;; Convert to LET* if possible.
197      (if (null (cdr varlist))
198          (setf op 'LET*)
199          (dolist (varspec varlist (setf op 'LET*))
200            (or (atom varspec)
201                (constantp (cadr varspec))
202                (eq (car varspec) (cadr varspec))
203                (return)))))
204    (let ((vars (if (eq op 'LET)
205                    (p1-let-vars varlist)
206                    (p1-let*-vars varlist))))
207      ;; Check for globally declared specials.
208      (dolist (variable vars)
209        (when (special-variable-p (variable-name variable))
210          (setf (variable-special-p variable) t)))
211      ;; For processing declarations, we want to walk the variable list from
212      ;; last to first, since declarations apply to the last-defined variable
213      ;; with the specified name.
214      (setf (block-free-specials block) (process-declarations-for-vars body (reverse vars)))
215      (setf (block-vars block) vars)
216      ;; Make free specials visible.
217      (dolist (variable (block-free-specials block))
218        (push variable *visible-variables*)))
219    (setf body (p1-body body))
220    (setf (block-form block) (list* op varlist body))
221    block))
222
223(defun p1-locally (form)
224  (let ((*visible-variables* *visible-variables*)
225        (specials (process-special-declarations (cdr form))))
226    (dolist (name specials)
227;;       (format t "p1-locally ~S is special~%" name)
228      (push (make-variable :name name :special-p t) *visible-variables*))
229    (setf (cdr form) (p1-body (cdr form)))
230    form))
231
232(defknown p1-m-v-b (t) t)
233(defun p1-m-v-b (form)
234  (when (= (length (cadr form)) 1)
235    (let ((new-form `(let* ((,(caadr form) ,(caddr form))) ,@(cdddr form))))
236      (return-from p1-m-v-b (p1-let/let* new-form))))
237  (let* ((*visible-variables* *visible-variables*)
238         (block (make-block-node '(MULTIPLE-VALUE-BIND)))
239         (*blocks* (cons block *blocks*))
240         (varlist (cadr form))
241         (values-form (caddr form))
242         (body (cdddr form)))
243    ;; Process the values-form first. ("The scopes of the name binding and
244    ;; declarations do not include the values-form.")
245    (setf values-form (p1 values-form))
246    (let ((vars ()))
247      (dolist (symbol varlist)
248        (let ((var (make-variable :name symbol)))
249          (push var vars)
250          (push var *visible-variables*)
251          (push var *all-variables*)))
252      ;; Check for globally declared specials.
253      (dolist (variable vars)
254        (when (special-variable-p (variable-name variable))
255          (setf (variable-special-p variable) t)))
256      (setf (block-free-specials block) (process-declarations-for-vars body vars))
257      (setf (block-vars block) (nreverse vars)))
258    (setf body (p1-body body))
259    (setf (block-form block) (list* 'MULTIPLE-VALUE-BIND varlist values-form body))
260    block))
261
262(defun p1-block (form)
263  (let* ((block (make-block-node (cadr form)))
264         (*blocks* (cons block *blocks*)))
265    (setf (cddr form) (p1-body (cddr form)))
266    (setf (block-form block) form)
267    block))
268
269(defun p1-catch (form)
270  (let* ((tag (p1 (cadr form)))
271         (body (cddr form))
272         (result '()))
273    (dolist (subform body)
274      (let ((op (and (consp subform) (%car subform))))
275        (push (p1 subform) result)
276        (when (memq op '(GO RETURN-FROM THROW))
277          (return))))
278    (setf result (nreverse result))
279    (when (and (null (cdr result))
280               (consp (car result))
281               (eq (caar result) 'GO))
282      (return-from p1-catch (car result)))
283    (push tag result)
284    (push 'CATCH result)
285    (let ((block (make-block-node '(CATCH))))
286      (setf (block-form block) result)
287      block)))
288
289(defun p1-unwind-protect (form)
290  (if (= (length form) 2)
291      (p1 (second form)) ; No cleanup forms: (unwind-protect (...)) => (...)
292      (let* ((block (make-block-node '(UNWIND-PROTECT)))
293             (*blocks* (cons block *blocks*)))
294        (setf (block-form block) (p1-default form))
295        block)))
296
297(defknown p1-return-from (t) t)
298(defun p1-return-from (form)
299  (let* ((name (second form))
300         (block (find-block name)))
301    (when (null block)
302      (compiler-error "RETURN-FROM ~S: no block named ~S is currently visible."
303                      name name))
304    (dformat t "p1-return-from block = ~S~%" (block-name block))
305    (setf (block-return-p block) t)
306    (cond ((eq (block-compiland block) *current-compiland*)
307           ;; Local case. If the RETURN is nested inside an UNWIND-PROTECT
308           ;; which is inside the block we're returning from, we'll do a non-
309           ;; local return anyway so that UNWIND-PROTECT can catch it and run
310           ;; its cleanup forms.
311           (dformat t "*blocks* = ~S~%" (mapcar #'block-name *blocks*))
312           (let ((protected
313                  (dolist (enclosing-block *blocks*)
314                    (when (eq enclosing-block block)
315                      (return nil))
316                    (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
317                      (return t)))))
318             (dformat t "p1-return-from protected = ~S~%" protected)
319             (when protected
320               (setf (block-non-local-return-p block) t))))
321          (t
322           (setf (block-non-local-return-p block) t)))
323    (when (block-non-local-return-p block)
324      (dformat t "non-local return from block ~S~%" (block-name block))))
325  (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form))))
326
327(defun p1-tagbody (form)
328  (let* ((block (make-block-node '(TAGBODY)))
329         (*blocks* (cons block *blocks*))
330         (*visible-tags* *visible-tags*)
331         (body (cdr form)))
332    ;; Make all the tags visible before processing the body forms.
333    (dolist (subform body)
334      (when (or (symbolp subform) (integerp subform))
335        (let* ((tag (make-tag :name subform :label (gensym) :block block)))
336          (push tag *visible-tags*))))
337    (let ((new-body '())
338          (live t))
339      (dolist (subform body)
340        (cond ((or (symbolp subform) (integerp subform))
341               (push subform new-body)
342               (setf live t))
343              ((not live)
344               ;; Nothing to do.
345               )
346              (t
347               (when (and (consp subform)
348                          (memq (%car subform) '(GO RETURN-FROM THROW)))
349                 ;; Subsequent subforms are unreachable until we see another
350                 ;; tag.
351                 (setf live nil))
352               (push (p1 subform) new-body))))
353      (setf (block-form block) (list* 'TAGBODY (nreverse new-body))))
354    block))
355
356(defknown p1-go (t) t)
357(defun p1-go (form)
358  (let* ((name (cadr form))
359         (tag (find-tag name)))
360    (unless tag
361      (error "p1-go: tag not found: ~S" name))
362    (let ((tag-block (tag-block tag)))
363      (cond ((eq (tag-compiland tag) *current-compiland*)
364             ;; Does the GO leave an enclosing UNWIND-PROTECT?
365             (let ((protected
366                    (dolist (enclosing-block *blocks*)
367                      (when (eq enclosing-block tag-block)
368                        (return nil))
369                      (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
370                        (return t)))))
371               (when protected
372                 (setf (block-non-local-go-p tag-block) t))))
373            (t
374             (setf (block-non-local-go-p tag-block) t)))))
375  form)
376
377(defun validate-name-and-lambda-list (name lambda-list context)
378  (unless (or (symbolp name) (setf-function-name-p name))
379    (compiler-error "~S is not a valid function name." name))
380  (when (or (memq '&optional lambda-list)
381            (memq '&key lambda-list))
382    (let ((state nil))
383      (dolist (arg lambda-list)
384        (cond ((memq arg lambda-list-keywords)
385               (setf state arg))
386              ((memq state '(&optional &key))
387               (when (and (consp arg) (not (constantp (second arg))))
388                 (compiler-unsupported
389                  "~A: can't handle ~A argument with non-constant initform."
390                  context
391                  (if (eq state '&optional) "optional" "keyword")))))))))
392
393(defmacro with-local-functions-for-flet/labels 
394    (form local-functions-var lambda-name lambda-list-var name-var body-var body1 body2)
395  `(progn (incf (compiland-children *current-compiland*) (length (cadr ,form)))
396    (let ((*visible-variables* *visible-variables*)
397    (*local-functions* *local-functions*)
398    (*current-compiland* *current-compiland*)
399    (,local-functions-var '()))
400      (dolist (definition (cadr ,form))
401        (let ((,name-var (car definition))
402        (,lambda-list-var (cadr definition)))
403    (validate-name-and-lambda-list ,name-var ,lambda-list-var ,lambda-name)
404 
405    (let* ((,body-var (cddr definition))
406           (compiland (make-compiland :name ,name-var
407              :parent *current-compiland*)))
408      ,@body1)))
409      (setf ,local-functions-var (nreverse ,local-functions-var))
410      ,@body2)))
411
412(defun p1-flet (form)
413  (with-local-functions-for-flet/labels 
414      form local-functions 'FLET lambda-list name body
415      ((let ((local-function (make-local-function :name name
416             :compiland compiland)))
417   (multiple-value-bind (body decls) (parse-body body)
418     (let* ((block-name (fdefinition-block-name name))
419      (lambda-expression
420       `(lambda ,lambda-list ,@decls (block ,block-name ,@body)))
421      (*visible-variables* *visible-variables*)
422      (*local-functions* *local-functions*)
423      (*current-compiland* compiland))
424       (setf (compiland-lambda-expression compiland) lambda-expression)
425       (setf (local-function-inline-expansion local-function)
426       (generate-inline-expansion block-name lambda-list body))
427       (p1-compiland compiland)))
428   (when *closure-variables*
429     (let ((variable (make-variable :name (gensym))))
430       (setf (local-function-variable local-function) variable)
431       (push variable *all-variables*)))
432   (push local-function local-functions)))
433      ;; Make the local functions visible.
434      ((dolist (local-function local-functions)
435   (push local-function *local-functions*)
436   (let ((variable (local-function-variable local-function)))
437     (when variable
438       (push variable *visible-variables*))))
439       (with-saved-compiler-policy
440     (process-optimization-declarations (cddr form))
441   (list* (car form) local-functions (p1-body (cddr form)))))))
442
443
444(defun p1-labels (form)
445  (with-local-functions-for-flet/labels 
446      form local-functions 'LABELS lambda-list name body
447      ((let* ((variable (make-variable :name (gensym)))
448        (local-function (make-local-function :name name
449               :compiland compiland
450               :variable variable)))
451   (multiple-value-bind (body decls) (parse-body body)
452     (setf (compiland-lambda-expression compiland)
453     `(lambda ,lambda-list ,@decls (block ,name ,@body))))
454   (push variable *all-variables*)
455   (push local-function local-functions)))
456      ;; Make the local functions visible.
457      ((dolist (local-function local-functions)
458   (push local-function *local-functions*)
459   (push (local-function-variable local-function) *visible-variables*))
460       (dolist (local-function local-functions)
461   (let ((*visible-variables* *visible-variables*)
462         (*current-compiland* (local-function-compiland local-function)))
463     (p1-compiland (local-function-compiland local-function))))
464       (list* (car form) local-functions (p1-body (cddr form))))))
465
466(defknown p1-funcall (t) t)
467(defun p1-funcall (form)
468  (unless (> (length form) 1)
469    (compiler-warn "Wrong number of arguments for ~A." (car form))
470    (return-from p1-funcall form))
471  (let ((function-form (%cadr form)))
472    (when (and (consp function-form)
473               (eq (%car function-form) 'FUNCTION))
474      (let ((name (%cadr function-form)))
475;;         (format t "p1-funcall name = ~S~%" name)
476        (let ((source-transform (source-transform name)))
477          (when source-transform
478;;             (format t "found source transform for ~S~%" name)
479;;             (format t "old form = ~S~%" form)
480;;             (let ((new-form (expand-source-transform form)))
481;;               (when (neq new-form form)
482;;                 (format t "new form = ~S~%" new-form)
483;;                 (return-from p1-funcall (p1 new-form))))
484            (let ((new-form (expand-source-transform (list* name (cddr form)))))
485;;               (format t "new form = ~S~%" new-form)
486              (return-from p1-funcall (p1 new-form)))
487            )))))
488  ;; Otherwise...
489  (p1-function-call form))
490
491(defun p1-function (form)
492  (let ((form (copy-tree form))
493        local-function)
494    (cond ((and (consp (cadr form))
495                (or (eq (caadr form) 'LAMBDA)
496                    (eq (caadr form) 'NAMED-LAMBDA)))
497           (let* ((named-lambda-p (eq (caadr form) 'NAMED-LAMBDA))
498                  (named-lambda-form (when named-lambda-p
499                                       (cadr form)))
500                  (name (when named-lambda-p
501                          (cadr named-lambda-form)))
502                  (lambda-form (if named-lambda-p
503                                   (cons 'LAMBDA (cddr named-lambda-form))
504                                   (cadr form)))
505                  (lambda-list (cadr lambda-form))
506                  (body (cddr lambda-form))
507                  (compiland (make-compiland :name (if named-lambda-p
508                                                       name (gensym "ANONYMOUS-LAMBDA-"))
509                                             :lambda-expression lambda-form
510                                             :parent *current-compiland*)))
511             (when *current-compiland*
512               (incf (compiland-children *current-compiland*)))
513             (multiple-value-bind (body decls)
514                 (parse-body body)
515               (setf (compiland-lambda-expression compiland)
516                     (if named-lambda-p
517                         `(lambda ,lambda-list ,@decls (block nil ,@body))
518                         `(lambda ,lambda-list ,@decls ,@body)))
519               (let ((*visible-variables* *visible-variables*)
520                     (*current-compiland* compiland))
521                 (p1-compiland compiland)))
522             (list 'FUNCTION compiland)))
523          ((setf local-function (find-local-function (cadr form)))
524           (dformat t "p1-function local function ~S~%" (cadr form))
525           (let ((variable (local-function-variable local-function)))
526             (when variable
527                 (dformat t "p1-function ~S used non-locally~%" (variable-name variable))
528                 (setf (variable-used-non-locally-p variable) t)))
529           form)
530          (t
531           form))))
532
533(defun p1-lambda (form)
534  (let* ((lambda-list (cadr form))
535         (body (cddr form))
536         (auxvars (memq '&AUX lambda-list)))
537    (when (or (memq '&optional lambda-list)
538              (memq '&key lambda-list))
539      (let ((state nil))
540        (dolist (arg lambda-list)
541          (cond ((memq arg lambda-list-keywords)
542                 (setf state arg))
543                ((memq state '(&optional &key))
544                 (when (and (consp arg)
545                            (not (constantp (second arg))))
546                   (compiler-unsupported
547                    "P1-LAMBDA: can't handle optional argument with non-constant initform.")))))))
548    (when auxvars
549      (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
550      (setf body (list (append (list 'LET* (cdr auxvars)) body))))
551    (p1-function (list 'FUNCTION (list* 'LAMBDA lambda-list body)))))
552
553(defun p1-eval-when (form)
554  (list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
555
556(defknown p1-progv (t) t)
557(defun p1-progv (form)
558  ;; We've already checked argument count in PRECOMPILE-PROGV.
559  (let ((new-form (rewrite-progv form)))
560    (when (neq new-form form)
561      (return-from p1-progv (p1 new-form))))
562  (let ((symbols-form (cadr form))
563        (values-form (caddr form))
564        (body (cdddr form)))
565    `(progv ,(p1 symbols-form) ,(p1 values-form) ,@(p1-body body))))
566
567(defknown rewrite-progv (t) t)
568(defun rewrite-progv (form)
569  (let ((symbols-form (cadr form))
570        (values-form (caddr form))
571        (body (cdddr form)))
572    (cond ((or (unsafe-p symbols-form) (unsafe-p values-form))
573           (let ((g1 (gensym))
574                 (g2 (gensym)))
575             `(let ((,g1 ,symbols-form)
576                    (,g2 ,values-form))
577                (progv ,g1 ,g2 ,@body))))
578          (t
579           form))))
580
581(defun p1-quote (form)
582  (unless (= (length form) 2)
583    (compiler-error "Wrong number of arguments for special operator ~A (expected 1, but received ~D)."
584                    'QUOTE
585                    (1- (length form))))
586  (let ((arg (%cadr form)))
587    (if (or (numberp arg) (characterp arg))
588        arg
589        form)))
590
591(defun p1-setq (form)
592  (unless (= (length form) 3)
593    (error "Too many arguments for SETQ."))
594  (let ((arg1 (%cadr form))
595        (arg2 (%caddr form)))
596    (let ((variable (find-visible-variable arg1)))
597      (if variable
598          (progn
599            (when (variable-ignore-p variable)
600              (compiler-style-warn
601               "Variable ~S is assigned even though it was declared to be ignored."
602               (variable-name variable)))
603            (incf (variable-writes variable))
604            (cond ((eq (variable-compiland variable) *current-compiland*)
605                   (dformat t "p1-setq: write ~S~%" arg1))
606                  (t
607                   (dformat t "p1-setq: non-local write ~S~%" arg1)
608                   (setf (variable-used-non-locally-p variable) t))))
609          (dformat t "p1-setq: unknown variable ~S~%" arg1)))
610    (list 'SETQ arg1 (p1 arg2))))
611
612(defun p1-the (form)
613  (unless (= (length form) 3)
614    (compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)."
615                    'THE
616                    (1- (length form))))
617  (let ((type (%cadr form))
618        (expr (%caddr form)))
619    (cond ((and (listp type) (eq (car type) 'VALUES))
620           ;; FIXME
621           (p1 expr))
622          ((= *safety* 3)
623           (let* ((sym (gensym))
624                  (new-expr `(let ((,sym ,expr))
625                               (require-type ,sym ',type)
626                               ,sym)))
627             (p1 new-expr)))
628          (t
629           (list 'THE type (p1 expr))))))
630
631(defun p1-truly-the (form)
632  (unless (= (length form) 3)
633    (compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)."
634                    'TRULY-THE
635                    (1- (length form))))
636  (list 'TRULY-THE (%cadr form) (p1 (%caddr form))))
637
638(defknown unsafe-p (t) t)
639(defun unsafe-p (args)
640  (cond ((node-p args)
641         (unsafe-p (node-form args)))
642        ((atom args)
643         nil)
644        (t
645         (case (%car args)
646           (QUOTE
647            nil)
648           (LAMBDA
649            nil)
650           ((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK)
651            t)
652           (t
653            (dolist (arg args)
654              (when (unsafe-p arg)
655                (return t))))))))
656
657(defknown rewrite-throw (t) t)
658(defun rewrite-throw (form)
659  (let ((args (cdr form)))
660    (if (unsafe-p args)
661        (let ((syms ())
662              (lets ()))
663          ;; Tag.
664          (let ((arg (first args)))
665            (if (constantp arg)
666                (push arg syms)
667                (let ((sym (gensym)))
668                  (push sym syms)
669                  (push (list sym arg) lets))))
670          ;; Result. "If the result-form produces multiple values, then all the
671          ;; values are saved."
672          (let ((arg (second args)))
673            (if (constantp arg)
674                (push arg syms)
675                (let ((sym (gensym)))
676                  (cond ((single-valued-p arg)
677                         (push sym syms)
678                         (push (list sym arg) lets))
679                        (t
680                         (push (list 'VALUES-LIST sym) syms)
681                         (push (list sym (list 'MULTIPLE-VALUE-LIST arg)) lets))))))
682          (list 'LET* (nreverse lets) (list* 'THROW (nreverse syms))))
683        form)))
684
685(defknown p1-throw (t) t)
686(defun p1-throw (form)
687  (let ((new-form (rewrite-throw form)))
688    (when (neq new-form form)
689      (return-from p1-throw (p1 new-form))))
690  (list* 'THROW (mapcar #'p1 (cdr form))))
691
692(defknown rewrite-function-call (t) t)
693(defun rewrite-function-call (form)
694  (let ((args (cdr form)))
695    (if (unsafe-p args)
696        (let ((arg1 (car args)))
697          (cond ((and (consp arg1) (eq (car arg1) 'GO))
698                 arg1)
699                (t
700                 (let ((syms ())
701                       (lets ()))
702                   ;; Preserve the order of evaluation of the arguments!
703                   (dolist (arg args)
704                     (cond ((constantp arg)
705                            (push arg syms))
706                           ((and (consp arg) (eq (car arg) 'GO))
707                            (return-from rewrite-function-call
708                                         (list 'LET* (nreverse lets) arg)))
709                           (t
710                            (let ((sym (gensym)))
711                              (push sym syms)
712                              (push (list sym arg) lets)))))
713                   (list 'LET* (nreverse lets) (list* (car form) (nreverse syms)))))))
714        form)))
715
716(defknown p1-function-call (t) t)
717(defun p1-function-call (form)
718  (let ((new-form (rewrite-function-call form)))
719    (when (neq new-form form)
720;;       (let ((*print-structure* nil))
721;;         (format t "old form = ~S~%" form)
722;;         (format t "new form = ~S~%" new-form))
723      (return-from p1-function-call (p1 new-form))))
724  (let* ((op (car form))
725         (local-function (find-local-function op)))
726    (cond (local-function
727;;            (format t "p1 local call to ~S~%" op)
728;;            (format t "inline-p = ~S~%" (inline-p op))
729
730           (when (and *enable-inline-expansion* (inline-p op))
731             (let ((expansion (local-function-inline-expansion local-function)))
732               (when expansion
733                 (let ((explain *explain*))
734                   (when (and explain (memq :calls explain))
735                     (format t ";   inlining call to local function ~S~%" op)))
736                 (return-from p1-function-call (p1 (expand-inline form expansion))))))
737
738           ;; FIXME
739           (dformat t "local function assumed not single-valued~%")
740           (setf (compiland-%single-valued-p *current-compiland*) nil)
741
742           (let ((variable (local-function-variable local-function)))
743             (when variable
744               (dformat t "p1 ~S used non-locally~%" (variable-name variable))
745               (setf (variable-used-non-locally-p variable) t))))
746          (t
747           ;; Not a local function call.
748           (dformat t "p1 non-local call to ~S~%" op)
749           (unless (single-valued-p form)
750;;                (format t "not single-valued op = ~S~%" op)
751             (setf (compiland-%single-valued-p *current-compiland*) nil)))))
752  (p1-default form))
753
754(defknown p1 (t) t)
755(defun p1 (form)
756  (cond ((symbolp form)
757         (let (value)
758           (cond ((null form)
759                  form)
760                 ((eq form t)
761                  form)
762                 ((keywordp form)
763                  form)
764                 ((and (constantp form)
765                       (progn
766                         (setf value (symbol-value form))
767                         (or (numberp value)
768                             (stringp value)
769                             (pathnamep value))))
770                  (setf form value))
771                 (t
772                  (let ((variable (find-visible-variable form)))
773                    (when (null variable)
774          (unless (or (special-variable-p form)
775                                  (memq form *undefined-variables*))
776      (compiler-style-warn "Undefined variable: ~S" form)
777      (push form *undefined-variables*))
778                      (setf variable (make-variable :name form :special-p t))
779                      (push variable *visible-variables*))
780                    (let ((ref (make-var-ref variable)))
781                      (unless (variable-special-p variable)
782                        (when (variable-ignore-p variable)
783                          (compiler-style-warn
784                           "Variable ~S is read even though it was declared to be ignored."
785                           (variable-name variable)))
786                        (push ref (variable-references variable))
787                        (incf (variable-reads variable))
788                        (cond ((eq (variable-compiland variable) *current-compiland*)
789                               (dformat t "p1: read ~S~%" form))
790                              (t
791                               (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%"
792                                        form
793                                        (compiland-name (variable-compiland variable))
794                                        (compiland-name *current-compiland*))
795                               (setf (variable-used-non-locally-p variable) t))))
796                      (setf form ref)))
797                  form))))
798        ((atom form)
799         form)
800        (t
801         (let ((op (%car form))
802               handler)
803           (cond ((symbolp op)
804                  (when (compiler-macro-function op)
805                    (unless (notinline-p op)
806                      (multiple-value-bind (expansion expanded-p)
807                          (compiler-macroexpand form)
808                        ;; Fall through if no change...
809                        (when expanded-p
810                          (return-from p1 (p1 expansion))))))
811                  (cond ((setf handler (get op 'p1-handler))
812                         (funcall handler form))
813                        ((macro-function op *compile-file-environment*)
814                         (p1 (macroexpand form *compile-file-environment*)))
815                        ((special-operator-p op)
816                         (compiler-unsupported "P1: unsupported special operator ~S" op))
817                        (t
818                         (p1-function-call form))))
819                 ((and (consp op) (eq (%car op) 'LAMBDA))
820                  (p1 (list* 'FUNCALL form)))
821                 (t
822                  form))))))
823
824(defun install-p1-handler (symbol handler)
825  (setf (get symbol 'p1-handler) handler))
826
827(defun initialize-p1-handlers ()
828  (dolist (pair '((AND                  p1-default)
829                  (BLOCK                p1-block)
830                  (CATCH                p1-catch)
831                  (DECLARE              identity)
832                  (EVAL-WHEN            p1-eval-when)
833                  (FLET                 p1-flet)
834                  (FUNCALL              p1-funcall)
835                  (FUNCTION             p1-function)
836                  (GO                   p1-go)
837                  (IF                   p1-if)
838                  (LABELS               p1-labels)
839                  (LAMBDA               p1-lambda)
840                  (LET                  p1-let/let*)
841                  (LET*                 p1-let/let*)
842                  (LOAD-TIME-VALUE      identity)
843                  (LOCALLY              p1-locally)
844                  (MULTIPLE-VALUE-BIND  p1-m-v-b)
845                  (MULTIPLE-VALUE-CALL  p1-default)
846                  (MULTIPLE-VALUE-LIST  p1-default)
847                  (MULTIPLE-VALUE-PROG1 p1-default)
848                  (OR                   p1-default)
849                  (PROGN                p1-default)
850                  (PROGV                p1-progv)
851                  (QUOTE                p1-quote)
852                  (RETURN-FROM          p1-return-from)
853                  (SETQ                 p1-setq)
854                  (SYMBOL-MACROLET      identity)
855                  (TAGBODY              p1-tagbody)
856                  (THE                  p1-the)
857                  (THROW                p1-throw)
858                  (TRULY-THE            p1-truly-the)
859                  (UNWIND-PROTECT       p1-unwind-protect)))
860    (install-p1-handler (%car pair) (%cadr pair))))
861
862(initialize-p1-handlers)
863
864(defun p1-compiland (compiland)
865;;   (format t "p1-compiland name = ~S~%" (compiland-name compiland))
866  (let ((form (compiland-lambda-expression compiland)))
867    (aver (eq (car form) 'LAMBDA))
868    (process-optimization-declarations (cddr form))
869
870    (let* ((lambda-list (cadr form))
871           (body (cddr form))
872           (auxvars (memq '&AUX lambda-list)))
873      (when auxvars
874        (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
875        (setf body (list (append (list 'LET* (cdr auxvars)) body))))
876
877      (when (and (null (compiland-parent compiland))
878                 ;; FIXME support SETF functions!
879                 (symbolp (compiland-name compiland)))
880        (when (memq '&OPTIONAL lambda-list)
881          (unless (or (memq '&KEY lambda-list) (memq '&REST lambda-list))
882            (let ((required-args (subseq lambda-list 0 (position '&OPTIONAL lambda-list)))
883                  (optional-args (cdr (memq '&OPTIONAL lambda-list))))
884            (dformat t "optional-args = ~S~%" optional-args)
885            (when (= (length optional-args) 1)
886              (let* ((optional-arg (car optional-args))
887                     (name (if (consp optional-arg) (%car optional-arg) optional-arg))
888                     (initform (if (consp optional-arg) (cadr optional-arg) nil))
889                     (supplied-p-var (and (consp optional-arg)
890                                          (= (length optional-arg) 3)
891                                          (third optional-arg)))
892                     (all-args
893                      (append required-args (list name)
894                              (when supplied-p-var (list supplied-p-var)))))
895                (when (<= (length all-args) call-registers-limit)
896                  (dformat t "optional-arg = ~S~%" optional-arg)
897                  (dformat t "supplied-p-var = ~S~%" supplied-p-var)
898                  (dformat t "required-args = ~S~%" required-args)
899                  (dformat t "all-args = ~S~%" all-args)
900                  (cond (supplied-p-var
901                         (let ((xep-lambda-expression
902                                `(lambda ,required-args
903                                   (let* ((,name ,initform)
904                                          (,supplied-p-var nil))
905                                     (%call-internal ,@all-args)))))
906                           (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression)
907                           (let ((xep-compiland
908                                  (make-compiland :lambda-expression (precompile-form xep-lambda-expression t)
909                                                  :class-file (compiland-class-file compiland))))
910                             (compile-xep xep-compiland)))
911                         (let ((xep-lambda-expression
912                                `(lambda ,(append required-args (list name))
913                                   (let* ((,supplied-p-var t))
914                                     (%call-internal ,@all-args)))))
915                           (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression)
916                           (let ((xep-compiland
917                                  (make-compiland :lambda-expression (precompile-form xep-lambda-expression t)
918                                                  :class-file (compiland-class-file compiland))))
919                             (compile-xep xep-compiland)))
920                         (setf lambda-list all-args)
921                         (setf (compiland-kind compiland) :internal))
922                        (t
923                         (let ((xep-lambda-expression
924                                `(lambda ,required-args
925                                   (let* ((,name ,initform))
926                                     (,(compiland-name compiland) ,@all-args)))))
927                           (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression)
928                           (let ((xep-compiland
929                                  (make-compiland :lambda-expression (precompile-form xep-lambda-expression t)
930                                                  :class-file (compiland-class-file compiland))))
931                             (compile-xep xep-compiland)))
932                         (setf lambda-list all-args))))))))))
933
934      (let* ((closure (make-closure `(lambda ,lambda-list nil) nil))
935             (syms (sys::varlist closure))
936             (vars nil))
937        (dolist (sym syms)
938          (let ((var (make-variable :name sym)))
939            (push var vars)
940            (push var *all-variables*)))
941        (setf (compiland-arg-vars compiland) (nreverse vars))
942        (let ((*visible-variables* *visible-variables*))
943          (dolist (var (compiland-arg-vars compiland))
944            (push var *visible-variables*))
945          (let ((free-specials (process-declarations-for-vars body *visible-variables*)))
946            (dolist (var free-specials)
947              (push var *visible-variables*)))
948          (setf (compiland-p1-result compiland)
949                (list* 'LAMBDA lambda-list (p1-body body))))))))
950
951(provide "COMPILER-PASS1")
Note: See TracBrowser for help on using the repository browser.