source: branches/0.20.x/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

Last change on this file was 12562, checked in by astalla, 16 years ago

Inlining of lambda calls: handled the case (funcall (lambda (...) ...) ...)
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 58.2 KB
Line 
1;;; compiler-pass1.lisp
2;;;
3;;; Copyright (C) 2003-2008 Peter Graves
4;;; $Id: compiler-pass1.lisp 12562 2010-03-19 21:19:34Z astalla $
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 (name lambda-list body
49            &optional (args nil args-p))
50    "Generates code that can be used to expand a named local function inline. It can work either per-function (no args provided) or per-call."
51    (if args-p
52  (expand-function-call-inline
53   nil lambda-list
54   (copy-tree `((block ,name ,@body)))
55   args)
56  (cond ((intersection lambda-list
57           '(&optional &rest &key &allow-other-keys &aux)
58           :test #'eq)
59         nil)
60        (t
61         (setf body (copy-tree body))
62         (list 'LAMBDA lambda-list
63         (list* 'BLOCK name body))))))
64    ) ; EVAL-WHEN
65
66;;; Pass 1.
67
68(defun parse-lambda-list (lambda-list)
69  "Breaks the lambda list into the different elements, returning the values
70
71 required-vars
72 optional-vars
73 key-vars
74 key-p
75 rest-var
76 allow-other-keys-p
77 aux-vars
78 whole-var
79 env-var
80
81where each of the vars returned is a list with these elements:
82
83 var      - the actual variable name
84 initform - the init form if applicable; optional, keyword and aux vars
85 p-var    - variable indicating presence
86 keyword  - the keyword argument to match against
87
88"
89  (let ((state :req)
90        req opt key rest whole env aux key-p allow-others-p)
91    (dolist (arg lambda-list)
92      (case arg
93        (&optional (setf state :opt))
94        (&key (setf state :key
95                    key-p t))
96        (&rest (setf state :rest))
97        (&aux (setf state :aux))
98        (&allow-other-keys (setf state :none
99                                 allow-others-p t))
100        (&whole (setf state :whole))
101        (&environment (setf state :env))
102        (t
103         (case state
104           (:req (push arg req))
105           (:rest (setf rest (list arg)
106                        state :none))
107           (:env (setf env (list arg)
108                       state :req))
109           (:whole (setf whole (list arg)
110                         state :req))
111           (:none
112            (error "Invalid lambda list: argument found in :none state."))
113           (:opt
114            (cond
115              ((symbolp arg)
116               (push (list arg nil nil nil) opt))
117              ((consp arg)
118               (push (list (car arg) (cadr arg) (caddr arg)) opt))
119              (t
120               (error "Invalid state."))))
121           (:aux
122            (cond
123              ((symbolp arg)
124               (push (list arg nil nil nil) aux))
125              ((consp arg)
126               (push (list (car arg) (cadr arg) nil nil) aux))
127              (t
128               (error "Invalid :aux state."))))
129           (:key
130            (cond
131              ((symbolp arg)
132               (push (list arg nil nil (sys::keywordify arg)) key))
133              ((and (consp arg)
134                    (consp (car arg)))
135               (push (list (cadar arg) (cadr arg) (caddr arg) (caar arg)) key))
136              ((consp arg)
137               (push (list (car arg) (cadr arg) (caddr arg)
138                           (sys::keywordify (car arg))) key))
139              (t
140               (error "Invalid :key state."))))
141           (t (error "Invalid state found."))))))
142    (values
143     (nreverse req)
144     (nreverse opt)
145     (nreverse key)
146     key-p
147     rest allow-others-p
148     (nreverse aux) whole env)))
149
150(define-condition lambda-list-mismatch (error)
151  ((mismatch-type :reader lambda-list-mismatch-type :initarg :mismatch-type)))
152
153(defmacro push-argument-binding (var form temp-bindings bindings)
154  (let ((g (gensym)))
155    `(let ((,g (gensym (symbol-name '#:temp))))
156       (push (list ,g ,form) ,temp-bindings)
157       (push (list ,var ,g) ,bindings))))
158
159(defun match-lambda-list (parsed-lambda-list arguments)
160  (flet ((pop-required-argument ()
161     (if (null arguments)
162         (error 'lambda-list-mismatch :mismatch-type :too-few-arguments)
163         (pop arguments)))
164   (var (var-info) (car var-info))
165   (initform (var-info) (cadr var-info))
166   (p-var (var-info) (caddr var-info)))
167    (destructuring-bind (req opt key key-p rest allow-others-p aux whole env)
168  parsed-lambda-list
169      (declare (ignore whole env))
170      (let (req-bindings temp-bindings bindings ignorables)
171  ;;Required arguments.
172  (setf req-bindings
173        (loop :for var :in req :collect `(,var ,(pop-required-argument))))
174
175  ;;Optional arguments.
176  (when opt
177    (dolist (var-info opt)
178      (if arguments
179    (progn
180      (push-argument-binding (var var-info) (pop arguments)
181           temp-bindings bindings)
182      (when (p-var var-info)
183        (push `(,(p-var var-info) t) bindings)))
184    (progn
185      (push `(,(var var-info) ,(initform var-info)) bindings)
186      (when (p-var var-info)
187        (push `(,(p-var var-info) nil) bindings)))))
188    (setf bindings (nreverse bindings)))
189 
190  (unless (or key-p rest (null arguments))
191    (error 'lambda-list-mismatch :mismatch-type :too-many-arguments))
192
193  ;;Keyword and rest arguments.
194  (if key-p
195      (multiple-value-bind (kbindings ktemps kignor)
196    (match-keyword-and-rest-args 
197     key allow-others-p rest arguments)
198        (setf bindings (append bindings kbindings)
199        temp-bindings (append temp-bindings ktemps)
200        ignorables (append kignor ignorables)))
201      (when rest
202        (let (rest-binding)
203    (push-argument-binding (var rest) `(list ,@arguments)
204               temp-bindings rest-binding)
205    (setf bindings (append bindings rest-binding)))))
206  ;;Aux parameters.
207  (when aux
208    (setf bindings
209    `(,@bindings
210      ,@(loop
211           :for var-info :in aux
212           :collect `(,(var var-info) ,(initform var-info))))))
213  (values (append req-bindings temp-bindings bindings)
214    ignorables)))))
215
216(defun match-keyword-and-rest-args (key allow-others-p rest arguments)
217  (flet ((var (var-info) (car var-info))
218   (initform (var-info) (cadr var-info))
219   (p-var (var-info) (caddr var-info))
220   (keyword (var-info) (cadddr var-info)))
221    (when (oddp (list-length arguments))
222      (error 'lambda-list-mismatch
223       :mismatch-type :odd-number-of-keyword-arguments))
224   
225    (let (temp-bindings bindings other-keys-found-p ignorables already-seen
226    args)
227      ;;If necessary, make up a fake argument to hold :allow-other-keys,
228      ;;needed later. This also handles nicely:
229      ;;  3.4.1.4.1 Suppressing Keyword Argument Checking
230      ;;third statement.
231      (unless (find :allow-other-keys key :key #'keyword)
232  (let ((allow-other-keys-temp (gensym (symbol-name :allow-other-keys))))
233    (push allow-other-keys-temp ignorables)
234    (push (list allow-other-keys-temp nil nil :allow-other-keys) key)))
235     
236      ;;First, let's bind the keyword arguments that have been passed by
237      ;;the caller. If we encounter an unknown keyword, remember it.
238      ;;As per the above, :allow-other-keys will never be considered
239      ;;an unknown keyword.
240      (loop
241   :for var :in arguments :by #'cddr
242   :for value :in (cdr arguments) :by #'cddr
243   :do (let ((var-info (find var key :key #'keyword)))
244         (if (and var-info (not (member var already-seen)))
245       ;;var is one of the declared keyword arguments
246       (progn
247         (push-argument-binding (var var-info) value
248              temp-bindings bindings)
249         (when (p-var var-info)
250           (push `(,(p-var var-info) t) bindings))
251         (push var args)
252         (push (var var-info) args)
253         (push var already-seen))
254       (let ((g (gensym)))
255         (push `(,g ,value) temp-bindings)
256         (push var args)
257         (push g args)
258         (push g ignorables)
259         (unless var-info
260           (setf other-keys-found-p t))))))
261     
262      ;;Then, let's bind those arguments that haven't been passed in
263      ;;to their default value, in declaration order.
264      (let (defaults)
265  (loop
266     :for var-info :in key
267     :do (unless (find (var var-info) bindings :key #'car)
268     (push `(,(var var-info) ,(initform var-info)) defaults)
269     (when (p-var var-info)
270       (push `(,(p-var var-info) nil) defaults))))
271  (setf bindings (append (nreverse defaults) bindings)))
272     
273      ;;If necessary, check for unrecognized keyword arguments.
274      (when (and other-keys-found-p (not allow-others-p))
275  (if (loop
276         :for var :in arguments :by #'cddr
277         :if (eq var :allow-other-keys)
278         :do (return t))
279      ;;We know that :allow-other-keys has been passed, so we
280      ;;can access the binding for it and be sure to get the
281      ;;value passed by the user and not an initform.
282      (let* ((arg (var (find :allow-other-keys key :key #'keyword)))
283       (binding (find arg bindings :key #'car))
284       (form (cadr binding)))
285        (if (constantp form)
286      (unless (eval form)
287        (error 'lambda-list-mismatch
288         :mismatch-type :unknown-keyword))
289      (setf (cadr binding)
290      `(or ,(cadr binding)
291           (error 'program-error
292            "Unrecognized keyword argument")))))
293      ;;TODO: it would be nice to report *which* keyword
294      ;;is unknown
295      (error 'lambda-list-mismatch :mismatch-type :unknown-keyword)))
296      (when rest
297  (setf bindings (append bindings `((,(var rest) (list ,@(nreverse args)))))))
298      (values bindings temp-bindings ignorables))))
299
300#||test for the above
301(handler-case
302    (let ((lambda-list
303     (multiple-value-list
304      (jvm::parse-lambda-list
305       '(a b &optional (c 42) &rest foo &key (bar c) baz ((kaz kuz) bar))))))
306      (jvm::match-lambda-list
307       lambda-list
308       '((print 1) 3 (print 32) :bar 2)))
309  (jvm::lambda-list-mismatch (x) (jvm::lambda-list-mismatch-type x)))
310||#
311
312(defun expand-function-call-inline (form lambda-list body args)
313  (handler-case
314      (multiple-value-bind (bindings ignorables)
315    (match-lambda-list (multiple-value-list
316            (parse-lambda-list lambda-list))
317           args)
318  `(let* ,bindings
319     ,@(when ignorables
320       `((declare (ignorable ,@ignorables))))
321     ,@body))
322    (lambda-list-mismatch (x)
323      (compiler-warn "Invalid function call: ~S (mismatch type: ~A)"
324         form (lambda-list-mismatch-type x))
325      form)))
326
327;; Returns a list of declared free specials, if any are found.
328(declaim (ftype (function (list list block-node) list)
329                process-declarations-for-vars))
330(defun process-declarations-for-vars (body variables block)
331  (let ((free-specials '()))
332    (dolist (subform body)
333      (unless (and (consp subform) (eq (%car subform) 'DECLARE))
334        (return))
335      (let ((decls (%cdr subform)))
336        (dolist (decl decls)
337          (case (car decl)
338            ((DYNAMIC-EXTENT FTYPE INLINE NOTINLINE OPTIMIZE)
339             ;; Nothing to do here.
340             )
341            ((IGNORE IGNORABLE)
342             (process-ignore/ignorable (%car decl) (%cdr decl) variables))
343            (SPECIAL
344             (dolist (name (%cdr decl))
345               (let ((variable (find-variable name variables)))
346                 (cond ((and variable
347                             ;; see comment below (and DO-ALL-SYMBOLS.11)
348                             (eq (variable-compiland variable)
349                                 *current-compiland*))
350                        (setf (variable-special-p variable) t))
351                       (t
352                        (dformat t "adding free special ~S~%" name)
353                        (push (make-variable :name name :special-p t
354                                             :block block)
355                              free-specials))))))
356            (TYPE
357             (dolist (name (cddr decl))
358               (let ((variable (find-variable name variables)))
359                 (when (and variable
360                            ;; Don't apply a declaration in a local function to
361                            ;; a variable defined in its parent. For an example,
362                            ;; see CREATE-GREEDY-NO-ZERO-MATCHER in cl-ppcre.
363                            ;; FIXME suboptimal, since we ignore the declaration
364                            (eq (variable-compiland variable)
365                                *current-compiland*))
366                   (setf (variable-declared-type variable)
367                         (make-compiler-type (cadr decl)))))))
368            (t
369             (dolist (name (cdr decl))
370               (let ((variable (find-variable name variables)))
371                 (when variable
372                   (setf (variable-declared-type variable)
373                         (make-compiler-type (%car decl)))))))))))
374    free-specials))
375
376(defun check-name (name)
377  ;; FIXME Currently this error is signalled by the precompiler.
378  (unless (symbolp name)
379    (compiler-error "The variable ~S is not a symbol." name))
380  (when (constantp name)
381    (compiler-error "The name of the variable ~S is already in use to name a constant." name))
382  name)
383
384(declaim (ftype (function (t) t) p1-body))
385(defun p1-body (body)
386  (declare (optimize speed))
387  (let ((tail body))
388    (loop
389      (when (endp tail)
390        (return))
391      (setf (car tail) (p1 (%car tail)))
392      (setf tail (%cdr tail))))
393  body)
394
395(defknown p1-default (t) t)
396(declaim (inline p1-default))
397(defun p1-default (form)
398  (setf (cdr form) (p1-body (cdr form)))
399  form)
400
401(defknown p1-if (t) t)
402(defun p1-if (form)
403  (let ((test (cadr form)))
404    (cond ((unsafe-p test)
405           (cond ((and (consp test)
406                       (memq (%car test) '(GO RETURN-FROM THROW)))
407                  (p1 test))
408                 (t
409                  (let* ((var (gensym))
410                         (new-form
411                          `(let ((,var ,test))
412                             (if ,var ,(third form) ,(fourth form)))))
413                    (p1 new-form)))))
414          (t
415           (p1-default form)))))
416
417
418(defmacro p1-let/let*-vars 
419    (block varlist variables-var var body1 body2)
420  (let ((varspec (gensym))
421  (initform (gensym))
422  (name (gensym)))
423    `(let ((,variables-var ()))
424       (dolist (,varspec ,varlist)
425   (cond ((consp ,varspec)
426                ;; Even though the precompiler already signals this
427                ;; error, double checking can't hurt; after all, we're
428                ;; also rewriting &AUX into LET* bindings.
429    (unless (<= 1 (length ,varspec) 2)
430      (compiler-error "The LET/LET* binding specification ~S is invalid."
431          ,varspec))
432    (let* ((,name (%car ,varspec))
433           (,initform (p1 (%cadr ,varspec)))
434           (,var (make-variable :name (check-name ,name)
435                                            :initform ,initform
436                                            :block ,block)))
437      (push ,var ,variables-var)
438      ,@body1))
439         (t
440    (let ((,var (make-variable :name (check-name ,varspec)
441                                           :block ,block)))
442      (push ,var ,variables-var)
443      ,@body1))))
444       ,@body2)))
445
446(defknown p1-let-vars (t) t)
447(defun p1-let-vars (block varlist)
448  (p1-let/let*-vars block
449   varlist vars var
450   ()
451   ((setf vars (nreverse vars))
452    (dolist (variable vars)
453      (push variable *visible-variables*)
454      (push variable *all-variables*))
455    vars)))
456
457(defknown p1-let*-vars (t) t)
458(defun p1-let*-vars (block varlist)
459  (p1-let/let*-vars block
460   varlist vars var
461   ((push var *visible-variables*)
462    (push var *all-variables*))
463   ((nreverse vars))))
464
465(defun p1-let/let* (form)
466  (declare (type cons form))
467  (let* ((*visible-variables* *visible-variables*)
468         (block (make-let/let*-node))
469         (op (%car form))
470         (varlist (cadr form))
471         (body (cddr form)))
472    (aver (or (eq op 'LET) (eq op 'LET*)))
473    (when (eq op 'LET)
474      ;; Convert to LET* if possible.
475      (if (null (cdr varlist))
476          (setf op 'LET*)
477          (dolist (varspec varlist (setf op 'LET*))
478            (or (atom varspec)
479                (constantp (cadr varspec))
480                (eq (car varspec) (cadr varspec))
481                (return)))))
482    (let ((vars (if (eq op 'LET)
483                    (p1-let-vars block varlist)
484                    (p1-let*-vars block varlist))))
485      ;; Check for globally declared specials.
486      (dolist (variable vars)
487        (when (special-variable-p (variable-name variable))
488          (setf (variable-special-p variable) t
489                (let-environment-register block) t)))
490      ;; For processing declarations, we want to walk the variable list from
491      ;; last to first, since declarations apply to the last-defined variable
492      ;; with the specified name.
493      (setf (let-free-specials block)
494            (process-declarations-for-vars body (reverse vars) block))
495      (setf (let-vars block) vars)
496      ;; Make free specials visible.
497      (dolist (variable (let-free-specials block))
498        (push variable *visible-variables*)))
499    (let ((*blocks* (cons block *blocks*)))
500      (setf body (p1-body body)))
501    (setf (let-form block) (list* op varlist body))
502    block))
503
504(defun p1-locally (form)
505  (let* ((*visible-variables* *visible-variables*)
506         (block (make-locally-node))
507         (free-specials (process-declarations-for-vars (cdr form) nil block)))
508    (setf (locally-free-specials block) free-specials)
509    (dolist (special free-specials)
510;;       (format t "p1-locally ~S is special~%" name)
511      (push special *visible-variables*))
512    (let ((*blocks* (cons block *blocks*)))
513      (setf (locally-form block)
514            (list* 'LOCALLY (p1-body (cdr form))))
515      block)))
516
517(defknown p1-m-v-b (t) t)
518(defun p1-m-v-b (form)
519  (when (= (length (cadr form)) 1)
520    (let ((new-form `(let* ((,(caadr form) ,(caddr form))) ,@(cdddr form))))
521      (return-from p1-m-v-b (p1-let/let* new-form))))
522  (let* ((*visible-variables* *visible-variables*)
523         (block (make-m-v-b-node))
524         (varlist (cadr form))
525         ;; Process the values-form first. ("The scopes of the name binding and
526         ;; declarations do not include the values-form.")
527         (values-form (p1 (caddr form)))
528         (*blocks* (cons block *blocks*))
529         (body (cdddr form)))
530    (let ((vars ()))
531      (dolist (symbol varlist)
532        (let ((var (make-variable :name symbol :block block)))
533          (push var vars)
534          (push var *visible-variables*)
535          (push var *all-variables*)))
536      ;; Check for globally declared specials.
537      (dolist (variable vars)
538        (when (special-variable-p (variable-name variable))
539          (setf (variable-special-p variable) t
540                (m-v-b-environment-register block) t)))
541      (setf (m-v-b-free-specials block)
542            (process-declarations-for-vars body vars block))
543      (dolist (special (m-v-b-free-specials block))
544        (push special *visible-variables*))
545      (setf (m-v-b-vars block) (nreverse vars)))
546    (setf body (p1-body body))
547    (setf (m-v-b-form block)
548          (list* 'MULTIPLE-VALUE-BIND varlist values-form body))
549    block))
550
551(defun p1-block (form)
552  (let* ((block (make-block-node (cadr form)))
553         (*blocks* (cons block *blocks*)))
554    (setf (cddr form) (p1-body (cddr form)))
555    (setf (block-form block) form)
556    (when (block-non-local-return-p block)
557      ;; Add a closure variable for RETURN-FROM to use
558      (push (setf (block-id-variable block)
559                  (make-variable :name (gensym)
560                                 :block block
561                                 :used-non-locally-p t))
562            *all-variables*))
563    block))
564
565(defun p1-catch (form)
566  (let* ((tag (p1 (cadr form)))
567         (body (cddr form))
568         (block (make-catch-node))
569         ;; our subform processors need to know
570         ;; they're enclosed in a CATCH block
571         (*blocks* (cons block *blocks*))
572         (result '()))
573    (dolist (subform body)
574      (let ((op (and (consp subform) (%car subform))))
575        (push (p1 subform) result)
576        (when (memq op '(GO RETURN-FROM THROW))
577          (return))))
578    (setf result (nreverse result))
579    (when (and (null (cdr result))
580               (consp (car result))
581               (eq (caar result) 'GO))
582      (return-from p1-catch (car result)))
583    (push tag result)
584    (push 'CATCH result)
585    (setf (catch-form block) result)
586    block))
587
588(defun p1-threads-synchronized-on (form)
589  (let* ((synchronized-object (p1 (cadr form)))
590         (body (cddr form))
591         (block (make-synchronized-node))
592         (*blocks* (cons block *blocks*))
593         result)
594    (dolist (subform body)
595      (let ((op (and (consp subform) (%car subform))))
596        (push (p1 subform) result)
597        (when (memq op '(GO RETURN-FROM THROW))
598          (return))))
599    (setf (synchronized-form block)
600          (list* 'threads:synchronized-on synchronized-object
601                 (nreverse result)))
602    block))
603
604(defun p1-unwind-protect (form)
605  (if (= (length form) 2)
606      (p1 (second form)) ; No cleanup forms: (unwind-protect (...)) => (...)
607
608      ;; in order to compile the cleanup forms twice (see
609      ;; p2-unwind-protect-node), we need to p1 them twice; p1 outcomes
610      ;; can be compiled (in the same compiland?) only once.
611      ;;
612      ;; However, p1 transforms the forms being processed, so, we
613      ;; need to copy the forms to create a second copy.
614      (let* ((block (make-unwind-protect-node))
615             ;; a bit of jumping through hoops...
616             (unwinding-forms (p1-body (copy-tree (cddr form))))
617             (unprotected-forms (p1-body (cddr form)))
618             ;; ... because only the protected form is
619             ;; protected by the UNWIND-PROTECT block
620             (*blocks* (cons block *blocks*))
621             (protected-form (p1 (cadr form))))
622        (setf (unwind-protect-form block)
623              `(unwind-protect ,protected-form
624                 (progn ,@unwinding-forms)
625                 ,@unprotected-forms))
626        block)))
627
628(defknown p1-return-from (t) t)
629(defun p1-return-from (form)
630  (let ((new-form (rewrite-return-from form)))
631    (when (neq form new-form)
632      (return-from p1-return-from (p1 new-form))))
633  (let* ((name (second form))
634         (block (find-block name)))
635    (when (null block)
636      (compiler-error "RETURN-FROM ~S: no block named ~S is currently visible."
637                      name name))
638    (dformat t "p1-return-from block = ~S~%" (block-name block))
639    (cond ((eq (block-compiland block) *current-compiland*)
640           ;; Local case. If the RETURN is nested inside an UNWIND-PROTECT
641           ;; which is inside the block we're returning from, we'll do a non-
642           ;; local return anyway so that UNWIND-PROTECT can catch it and run
643           ;; its cleanup forms.
644           ;;(dformat t "*blocks* = ~S~%" (mapcar #'node-name *blocks*))
645           (let ((protected (enclosed-by-protected-block-p block)))
646             (dformat t "p1-return-from protected = ~S~%" protected)
647             (if protected
648                 (setf (block-non-local-return-p block) t)
649                 ;; non-local GO's ensure environment restoration
650                 ;; find out about this local GO
651                 (when (null (block-needs-environment-restoration block))
652                   (setf (block-needs-environment-restoration block)
653                         (enclosed-by-environment-setting-block-p block))))))
654          (t
655           (setf (block-non-local-return-p block) t)))
656    (when (block-non-local-return-p block)
657      (dformat t "non-local return from block ~S~%" (block-name block))))
658  (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form))))
659
660(defun p1-tagbody (form)
661  (let* ((block (make-tagbody-node))
662         (*blocks* (cons block *blocks*))
663         (*visible-tags* *visible-tags*)
664         (local-tags '())
665         (body (cdr form)))
666    ;; Make all the tags visible before processing the body forms.
667    (dolist (subform body)
668      (when (or (symbolp subform) (integerp subform))
669        (let* ((tag (make-tag :name subform :label (gensym) :block block)))
670          (push tag local-tags)
671          (push tag *visible-tags*))))
672    (let ((new-body '())
673          (live t))
674      (dolist (subform body)
675        (cond ((or (symbolp subform) (integerp subform))
676               (push subform new-body)
677               (push (find subform local-tags :key #'tag-name :test #'eql)
678                     (tagbody-tags block))
679               (setf live t))
680              ((not live)
681               ;; Nothing to do.
682               )
683              (t
684               (when (and (consp subform)
685                          (memq (%car subform) '(GO RETURN-FROM THROW)))
686                 ;; Subsequent subforms are unreachable until we see another
687                 ;; tag.
688                 (setf live nil))
689               (push (p1 subform) new-body))))
690      (setf (tagbody-form block) (list* 'TAGBODY (nreverse new-body))))
691    (when (some #'tag-used-non-locally (tagbody-tags block))
692      (push (setf (tagbody-id-variable block)
693                  (make-variable :name (gensym)
694                                 :block block
695                                 :used-non-locally-p t))
696            *all-variables*))
697    block))
698
699(defknown p1-go (t) t)
700(defun p1-go (form)
701  (let* ((name (cadr form))
702         (tag (find-tag name)))
703    (unless tag
704      (error "p1-go: tag not found: ~S" name))
705    (setf (tag-used tag) t)
706    (let ((tag-block (tag-block tag)))
707      (cond ((eq (tag-compiland tag) *current-compiland*)
708             ;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH?
709             (if (enclosed-by-protected-block-p tag-block)
710                 (setf (tagbody-non-local-go-p tag-block) t
711                       (tag-used-non-locally tag) t)
712                 ;; non-local GO's ensure environment restoration
713                 ;; find out about this local GO
714                 (when (null (tagbody-needs-environment-restoration tag-block))
715                   (setf (tagbody-needs-environment-restoration tag-block)
716                         (enclosed-by-environment-setting-block-p tag-block)))))
717            (t
718             (setf (tagbody-non-local-go-p tag-block) t
719                   (tag-used-non-locally tag) t)))))
720  form)
721
722(defun validate-function-name (name)
723  (unless (or (symbolp name) (setf-function-name-p name))
724    (compiler-error "~S is not a valid function name." name)))
725
726(defmacro with-local-functions-for-flet/labels
727    (form local-functions-var lambda-list-var name-var body-var body1 body2)
728  `(progn (incf (compiland-children *current-compiland*) (length (cadr ,form)))
729    (let ((*visible-variables* *visible-variables*)
730    (*local-functions* *local-functions*)
731    (*current-compiland* *current-compiland*)
732    (,local-functions-var '()))
733      (dolist (definition (cadr ,form))
734        (let ((,name-var (car definition))
735        (,lambda-list-var (cadr definition)))
736    (validate-function-name ,name-var)
737    (let* ((,body-var (cddr definition))
738           (compiland (make-compiland :name ,name-var
739              :parent *current-compiland*)))
740      ,@body1)))
741      (setf ,local-functions-var (nreverse ,local-functions-var))
742      ;; Make the local functions visible.
743      (dolist (local-function ,local-functions-var)
744        (push local-function *local-functions*)
745        (let ((variable (local-function-variable local-function)))
746    (when variable
747      (push variable *visible-variables*))))
748      ,@body2)))
749
750(defun split-decls (forms specific-vars)
751  (let ((other-decls nil)
752        (specific-decls nil))
753    (dolist (form forms)
754      (unless (and (consp form) (eq (car form) 'DECLARE)) ; shouldn't happen
755        (return))
756      (dolist (decl (cdr form))
757        (case (car decl)
758          ((OPTIMIZE DECLARATION DYNAMIC-EXTENT FTYPE INLINE NOTINLINE)
759           (push (list 'DECLARE decl) other-decls))
760          (SPECIAL
761           (dolist (name (cdr decl))
762             (if (memq name specific-vars)
763                 (push `(DECLARE (SPECIAL ,name)) specific-decls)
764                 (push `(DECLARE (SPECIAL ,name)) other-decls))))
765          (TYPE
766           (dolist (name (cddr decl))
767             (if (memq name specific-vars)
768                 (push `(DECLARE (TYPE ,(cadr decl) ,name)) specific-decls)
769                 (push `(DECLARE (TYPE ,(cadr decl) ,name)) other-decls))))
770          (t
771           (dolist (name (cdr decl))
772             (if (memq name specific-vars)
773                 (push `(DECLARE (,(car decl) ,name)) specific-decls)
774                 (push `(DECLARE (,(car decl) ,name)) other-decls)))))))
775    (values (nreverse other-decls)
776            (nreverse specific-decls))))
777
778(defun rewrite-aux-vars (form)
779  (let* ((lambda-list (cadr form))
780         (aux-p (memq '&AUX lambda-list))
781         (lets (cdr aux-p))
782         aux-vars)
783    (unless aux-p
784      ;; no rewriting required
785      (return-from rewrite-aux-vars form))
786    (multiple-value-bind (body decls)
787        (parse-body (cddr form))
788      (dolist (form lets)
789        (cond ((consp form)
790               (push (car form) aux-vars))
791              (t
792               (push form aux-vars))))
793      (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
794      (multiple-value-bind (let-decls lambda-decls)
795          (split-decls decls (lambda-list-names lambda-list))
796        `(lambda ,lambda-list
797           ,@lambda-decls
798           (let* ,lets
799             ,@let-decls
800             ,@body))))))
801
802(defun rewrite-lambda (form)
803  (setf form (rewrite-aux-vars form))
804  (let* ((lambda-list (cadr form)))
805    (if (not (or (memq '&optional lambda-list)
806                 (memq '&key lambda-list)))
807        ;; no need to rewrite: no arguments with possible initforms anyway
808        form
809      (multiple-value-bind (body decls doc)
810          (parse-body (cddr form))
811        (let (state let-bindings new-lambda-list
812                    (non-constants 0))
813          (do* ((vars lambda-list (cdr vars))
814                (var (car vars) (car vars)))
815               ((endp vars))
816            (push (car vars) new-lambda-list)
817            (let ((replacement (gensym)))
818              (flet ((parse-compound-argument (arg)
819                       "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P,
820   SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument."
821                       (destructuring-bind
822                             (name &optional (initform nil initform-supplied-p)
823                                   (supplied-p nil supplied-p-supplied-p))
824                           (if (listp arg) arg (list arg))
825                         (if (listp name)
826                             (values (cadr name) (car name)
827                                     initform initform-supplied-p
828                                     supplied-p supplied-p-supplied-p)
829                             (values name (make-keyword name)
830                                     initform initform-supplied-p
831                                     supplied-p supplied-p-supplied-p)))))
832                (case var
833                  (&optional (setf state :optional))
834                  (&key (setf state :key))
835                  ((&whole &environment &rest &body &allow-other-keys)
836                   ;; do nothing special
837                   )
838                  (t
839                   (cond
840                     ((atom var)
841                      (setf (car new-lambda-list)
842                            (if (eq state :key)
843                                (list (list (make-keyword var) replacement))
844                                replacement))
845                      (push (list var replacement) let-bindings))
846                     ((constantp (second var))
847                      ;; so, we must have a consp-type var we're looking at
848                      ;; and it has a constantp initform
849                      (multiple-value-bind
850                            (name keyword initform initform-supplied-p
851                                  supplied-p supplied-p-supplied-p)
852                          (parse-compound-argument var)
853                        (let ((var-form (if (eq state :key)
854                                            (list keyword replacement)
855                                            replacement))
856                              (supplied-p-replacement (gensym)))
857                          (setf (car new-lambda-list)
858                                (cond
859                                  ((not initform-supplied-p)
860                                   (list var-form))
861                                  ((not supplied-p-supplied-p)
862                                   (list var-form initform))
863                                  (t
864                                   (list var-form initform
865                                         supplied-p-replacement))))
866                          (push (list name replacement) let-bindings)
867                          ;; if there was a 'supplied-p' variable, it might
868                          ;; be used in the declarations. Since those will be
869                          ;; moved below the LET* block, we need to move the
870                          ;; supplied-p parameter too.
871                          (when supplied-p-supplied-p
872                            (push (list supplied-p supplied-p-replacement)
873                                  let-bindings)))))
874                     (t
875                      (incf non-constants)
876                      ;; this is either a keyword or an optional argument
877                      ;; with a non-constantp initform
878                      (multiple-value-bind
879                            (name keyword initform initform-supplied-p
880                                  supplied-p supplied-p-supplied-p)
881                          (parse-compound-argument var)
882                        (declare (ignore initform-supplied-p))
883                        (let ((var-form (if (eq state :key)
884                                            (list keyword replacement)
885                                            replacement))
886                              (supplied-p-replacement (gensym)))
887                          (setf (car new-lambda-list)
888                                (list var-form nil supplied-p-replacement))
889                          (push (list name `(if ,supplied-p-replacement
890                                                ,replacement ,initform))
891                                let-bindings)
892                          (when supplied-p-supplied-p
893                            (push (list supplied-p supplied-p-replacement)
894                                  let-bindings)))))))))))
895          (if (zerop non-constants)
896              ;; there was no reason to rewrite...
897              form
898              (let ((rv
899                     `(lambda ,(nreverse new-lambda-list)
900                        ,@(when doc (list doc))
901                        (let* ,(nreverse let-bindings)
902                          ,@decls ,@body))))
903                rv)))))))
904
905(defun p1-flet (form)
906  (with-local-functions-for-flet/labels
907      form local-functions lambda-list name body
908      ((let ((local-function (make-local-function :name name
909                                                  :compiland compiland))
910       (definition (cons lambda-list body)))
911   (multiple-value-bind (body decls) (parse-body body)
912     (let* ((block-name (fdefinition-block-name name))
913      (lambda-expression
914       (rewrite-lambda `(lambda ,lambda-list ,@decls (block ,block-name ,@body))))
915      (*visible-variables* *visible-variables*)
916      (*local-functions* *local-functions*)
917      (*current-compiland* compiland))
918       (setf (compiland-lambda-expression compiland) lambda-expression)
919       (setf (local-function-definition local-function)
920       (copy-tree definition))
921       (setf (local-function-inline-expansion local-function)
922       (generate-inline-expansion block-name lambda-list body))
923       (p1-compiland compiland)))
924   (push local-function local-functions)))
925      ((with-saved-compiler-policy
926   (process-optimization-declarations (cddr form))
927   (let* ((block (make-flet-node))
928    (*blocks* (cons block *blocks*))
929    (body (cddr form))
930    (*visible-variables* *visible-variables*))
931     (setf (flet-free-specials block)
932     (process-declarations-for-vars body nil block))
933     (dolist (special (flet-free-specials block))
934       (push special *visible-variables*))
935     (setf (flet-form block)
936     (list* (car form) local-functions (p1-body (cddr form))))
937     block)))))
938
939
940(defun p1-labels (form)
941  (with-local-functions-for-flet/labels
942      form local-functions lambda-list name body
943      ((let* ((variable (make-variable :name (gensym)))
944        (local-function (make-local-function :name name
945               :compiland compiland
946               :variable variable))
947              (block-name (fdefinition-block-name name)))
948   (setf (local-function-definition local-function)
949         (copy-tree (cons lambda-list body)))
950   (multiple-value-bind (body decls) (parse-body body)
951     (setf (compiland-lambda-expression compiland)
952                 (rewrite-lambda
953     `(lambda ,lambda-list ,@decls (block ,block-name ,@body)))))
954   (push variable *all-variables*)
955   (push local-function local-functions)))
956      ((dolist (local-function local-functions)
957   (let ((*visible-variables* *visible-variables*)
958         (*current-compiland* (local-function-compiland local-function)))
959     (p1-compiland (local-function-compiland local-function))))
960       (let* ((block (make-labels-node))
961              (*blocks* (cons block *blocks*))
962              (body (cddr form))
963              (*visible-variables* *visible-variables*))
964         (setf (labels-free-specials block)
965               (process-declarations-for-vars body nil block))
966         (dolist (special (labels-free-specials block))
967           (push special *visible-variables*))
968         (setf (labels-form block)
969               (list* (car form) local-functions (p1-body (cddr form))))
970         block))))
971
972(defknown p1-funcall (t) t)
973(defun p1-funcall (form)
974  (unless (> (length form) 1)
975    (compiler-warn "Wrong number of arguments for ~A." (car form))
976    (return-from p1-funcall form))
977  (let ((function-form (%cadr form)))
978    (when (and (consp function-form)
979               (eq (%car function-form) 'FUNCTION))
980      (let ((name (%cadr function-form)))
981;;         (format t "p1-funcall name = ~S~%" name)
982        (let ((source-transform (source-transform name)))
983          (when source-transform
984;;             (format t "found source transform for ~S~%" name)
985;;             (format t "old form = ~S~%" form)
986;;             (let ((new-form (expand-source-transform form)))
987;;               (when (neq new-form form)
988;;                 (format t "new form = ~S~%" new-form)
989;;                 (return-from p1-funcall (p1 new-form))))
990            (let ((new-form (expand-source-transform (list* name (cddr form)))))
991;;               (format t "new form = ~S~%" new-form)
992              (return-from p1-funcall (p1 new-form)))
993            )))))
994  ;; Otherwise...
995  (p1-function-call form))
996
997(defun p1-function (form)
998  (let ((form (copy-tree form))
999        local-function)
1000    (cond ((and (consp (cadr form))
1001                (or (eq (caadr form) 'LAMBDA)
1002                    (eq (caadr form) 'NAMED-LAMBDA)))
1003           (let* ((named-lambda-p (eq (caadr form) 'NAMED-LAMBDA))
1004                  (named-lambda-form (when named-lambda-p
1005                                       (cadr form)))
1006                  (name (when named-lambda-p
1007                          (cadr named-lambda-form)))
1008                  (lambda-form (if named-lambda-p
1009                                   (cons 'LAMBDA (cddr named-lambda-form))
1010                                   (cadr form)))
1011                  (lambda-list (cadr lambda-form))
1012                  (body (cddr lambda-form))
1013                  (compiland (make-compiland :name (if named-lambda-p
1014                                                       name (gensym "ANONYMOUS-LAMBDA-"))
1015                                             :lambda-expression lambda-form
1016                                             :parent *current-compiland*)))
1017             (when *current-compiland*
1018               (incf (compiland-children *current-compiland*)))
1019             (multiple-value-bind (body decls)
1020                 (parse-body body)
1021               (setf (compiland-lambda-expression compiland)
1022                     ;; if there still was a doc-string present, remove it
1023                     (rewrite-lambda
1024                      `(lambda ,lambda-list ,@decls ,@body)))
1025               (let ((*visible-variables* *visible-variables*)
1026                     (*current-compiland* compiland))
1027                 (p1-compiland compiland)))
1028             (list 'FUNCTION compiland)))
1029          ((setf local-function (find-local-function (cadr form)))
1030           (dformat t "p1-function local function ~S~%" (cadr form))
1031     ;;we found out that the function needs a reference
1032     (setf (local-function-references-needed-p local-function) t)
1033           (let ((variable (local-function-variable local-function)))
1034             (when variable
1035                 (dformat t "p1-function ~S used non-locally~%"
1036                          (variable-name variable))
1037                 (setf (variable-used-non-locally-p variable) t)))
1038           form)
1039          (t
1040           form))))
1041
1042(defun p1-lambda (form)
1043  (setf form (rewrite-lambda form))
1044  (let* ((lambda-list (cadr form)))
1045    (when (or (memq '&optional lambda-list)
1046              (memq '&key lambda-list))
1047      (let ((state nil))
1048        (dolist (arg lambda-list)
1049          (cond ((memq arg lambda-list-keywords)
1050                 (setf state arg))
1051                ((memq state '(&optional &key))
1052                 (when (and (consp arg)
1053                            (not (constantp (second arg))))
1054                   (compiler-unsupported
1055                    "P1-LAMBDA: can't handle optional argument with non-constant initform.")))))))
1056    (p1-function (list 'FUNCTION form))))
1057
1058(defun p1-eval-when (form)
1059  (list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
1060
1061(defknown p1-progv (t) t)
1062(defun p1-progv (form)
1063  ;; We've already checked argument count in PRECOMPILE-PROGV.
1064
1065  (let ((new-form (rewrite-progv form)))
1066    (when (neq new-form form)
1067      (return-from p1-progv (p1 new-form))))
1068  (let* ((symbols-form (p1 (cadr form)))
1069         (values-form (p1 (caddr form)))
1070         (block (make-progv-node))
1071         (*blocks* (cons block *blocks*))
1072         (body (cdddr form)))
1073;;  The (commented out) block below means to detect compile-time
1074;;  enumeration of bindings to be created (a quoted form in the symbols
1075;;  position).
1076;;    (when (and (quoted-form-p symbols-form)
1077;;               (listp (second symbols-form)))
1078;;      (dolist (name (second symbols-form))
1079;;        (let ((variable (make-variable :name name :special-p t)))
1080;;          (push
1081    (setf (progv-environment-register block) t
1082          (progv-form block)
1083          `(progv ,symbols-form ,values-form ,@(p1-body body)))
1084    block))
1085
1086(defknown rewrite-progv (t) t)
1087(defun rewrite-progv (form)
1088  (let ((symbols-form (cadr form))
1089        (values-form (caddr form))
1090        (body (cdddr form)))
1091    (cond ((or (unsafe-p symbols-form) (unsafe-p values-form))
1092           (let ((g1 (gensym))
1093                 (g2 (gensym)))
1094             `(let ((,g1 ,symbols-form)
1095                    (,g2 ,values-form))
1096                (progv ,g1 ,g2 ,@body))))
1097          (t
1098           form))))
1099
1100(defun p1-quote (form)
1101  (unless (= (length form) 2)
1102    (compiler-error "Wrong number of arguments for special operator ~A (expected 1, but received ~D)."
1103                    'QUOTE
1104                    (1- (length form))))
1105  (let ((arg (%cadr form)))
1106    (if (or (numberp arg) (characterp arg))
1107        arg
1108        form)))
1109
1110(defun p1-setq (form)
1111  (unless (= (length form) 3)
1112    (error "Too many arguments for SETQ."))
1113  (let ((arg1 (%cadr form))
1114        (arg2 (%caddr form)))
1115    (let ((variable (find-visible-variable arg1)))
1116      (if variable
1117          (progn
1118            (when (variable-ignore-p variable)
1119              (compiler-style-warn
1120               "Variable ~S is assigned even though it was declared to be ignored."
1121               (variable-name variable)))
1122            (incf (variable-writes variable))
1123            (cond ((eq (variable-compiland variable) *current-compiland*)
1124                   (dformat t "p1-setq: write ~S~%" arg1))
1125                  (t
1126                   (dformat t "p1-setq: non-local write ~S~%" arg1)
1127                   (setf (variable-used-non-locally-p variable) t))))
1128          (dformat t "p1-setq: unknown variable ~S~%" arg1)))
1129    (list 'SETQ arg1 (p1 arg2))))
1130
1131(defun p1-the (form)
1132  (unless (= (length form) 3)
1133    (compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)."
1134                    'THE
1135                    (1- (length form))))
1136  (let ((type (%cadr form))
1137        (expr (%caddr form)))
1138    (cond ((and (listp type) (eq (car type) 'VALUES))
1139           ;; FIXME
1140           (p1 expr))
1141          ((= *safety* 3)
1142           (let* ((sym (gensym))
1143                  (new-expr `(let ((,sym ,expr))
1144                               (require-type ,sym ',type)
1145                               ,sym)))
1146             (p1 new-expr)))
1147          ((and (<= 1 *safety* 2) ;; at safety 1 or 2 check relatively
1148                (symbolp type))   ;; simple types (those specified by a single symbol)
1149           (let* ((sym (gensym))
1150                  (new-expr `(let ((,sym ,expr))
1151                               (require-type ,sym ',type)
1152                               ,sym)))
1153             (p1 new-expr)))
1154          (t
1155           (list 'THE type (p1 expr))))))
1156
1157(defun p1-truly-the (form)
1158  (unless (= (length form) 3)
1159    (compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)."
1160                    'TRULY-THE
1161                    (1- (length form))))
1162  (list 'TRULY-THE (%cadr form) (p1 (%caddr form))))
1163
1164(defknown unsafe-p (t) t)
1165(defun unsafe-p (args)
1166  "Determines whether the args can cause 'stack unsafe situations'.
1167Returns T if this is the case.
1168
1169When a 'stack unsafe situation' is encountered, the stack cannot
1170be used for temporary storage of intermediary results. This happens
1171because one of the forms in ARGS causes a local transfer of control
1172- local GO instruction - which assumes an empty stack, or if one of
1173the args causes a Java exception handler to be installed, which
1174- when triggered - clears out the stack.
1175"
1176  (cond ((node-p args)
1177         (unsafe-p (node-form args)))
1178        ((atom args)
1179         nil)
1180        (t
1181         (case (%car args)
1182           (QUOTE
1183            nil)
1184           (LAMBDA
1185            nil)
1186           ((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK)
1187            t)
1188           (t
1189            (dolist (arg args)
1190              (when (unsafe-p arg)
1191                (return t))))))))
1192
1193(defknown rewrite-return-from (t) t)
1194(defun rewrite-return-from (form)
1195  (let* ((args (cdr form))
1196         (result-form (second args))
1197         (var (gensym)))
1198    (if (unsafe-p (cdr args))
1199        (if (single-valued-p result-form)
1200            `(let ((,var ,result-form))
1201               (return-from ,(first args) ,var))
1202            `(let ((,var (multiple-value-list ,result-form)))
1203               (return-from ,(first args) (values-list ,var))))
1204        form)))
1205
1206
1207(defknown rewrite-throw (t) t)
1208(defun rewrite-throw (form)
1209  (let ((args (cdr form)))
1210    (if (unsafe-p args)
1211        (let ((syms ())
1212              (lets ()))
1213          ;; Tag.
1214          (let ((arg (first args)))
1215            (if (constantp arg)
1216                (push arg syms)
1217                (let ((sym (gensym)))
1218                  (push sym syms)
1219                  (push (list sym arg) lets))))
1220          ;; Result. "If the result-form produces multiple values, then all the
1221          ;; values are saved."
1222          (let ((arg (second args)))
1223            (if (constantp arg)
1224                (push arg syms)
1225                (let ((sym (gensym)))
1226                  (cond ((single-valued-p arg)
1227                         (push sym syms)
1228                         (push (list sym arg) lets))
1229                        (t
1230                         (push (list 'VALUES-LIST sym) syms)
1231                         (push (list sym
1232                                     (list 'MULTIPLE-VALUE-LIST arg))
1233                               lets))))))
1234          (list 'LET* (nreverse lets) (list* 'THROW (nreverse syms))))
1235        form)))
1236
1237(defknown p1-throw (t) t)
1238(defun p1-throw (form)
1239  (let ((new-form (rewrite-throw form)))
1240    (when (neq new-form form)
1241      (return-from p1-throw (p1 new-form))))
1242  (list* 'THROW (mapcar #'p1 (cdr form))))
1243
1244(defknown rewrite-function-call (t) t)
1245(defun rewrite-function-call (form)
1246  (let ((op (car form)) (args (cdr form)))
1247    (cond
1248      ((and (eq op 'funcall) (listp (car args)) (eq (caar args) 'lambda))
1249       ;;(funcall (lambda (...) ...) ...)
1250       (let ((op (car args)) (args (cdr args)))
1251   (expand-function-call-inline form (cadr op) (copy-tree (cddr op))
1252              args)))
1253      ((and (listp op) (eq (car op) 'lambda))
1254       ;;((lambda (...) ...) ...)
1255       (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) args))
1256      (t (if (unsafe-p args)
1257       (let ((arg1 (car args)))
1258         (cond ((and (consp arg1) (eq (car arg1) 'GO))
1259          arg1)
1260         (t
1261          (let ((syms ())
1262          (lets ()))
1263      ;; Preserve the order of evaluation of the arguments!
1264      (dolist (arg args)
1265        (cond ((constantp arg)
1266         (push arg syms))
1267        ((and (consp arg) (eq (car arg) 'GO))
1268         (return-from rewrite-function-call
1269           (list 'LET* (nreverse lets) arg)))
1270        (t
1271         (let ((sym (gensym)))
1272           (push sym syms)
1273           (push (list sym arg) lets)))))
1274      (list 'LET* (nreverse lets)
1275            (list* (car form) (nreverse syms)))))))
1276       form)))))
1277
1278(defknown p1-function-call (t) t)
1279(defun p1-function-call (form)
1280  (let ((new-form (rewrite-function-call form)))
1281    (when (neq new-form form)
1282      (return-from p1-function-call (p1 new-form))))
1283  (let* ((op (car form))
1284         (local-function (find-local-function op)))
1285    (cond (local-function
1286;;            (format t "p1 local call to ~S~%" op)
1287;;            (format t "inline-p = ~S~%" (inline-p op))
1288           (when (and *enable-inline-expansion* (inline-p op)
1289          (local-function-definition local-function))
1290             (let* ((definition (local-function-definition local-function))
1291        (lambda-list (car definition))
1292        (body (cdr definition))
1293        (expansion (generate-inline-expansion op lambda-list body
1294                (cdr form))))
1295               (when expansion
1296                 (let ((explain *explain*))
1297                   (when (and explain (memq :calls explain))
1298                     (format t ";   inlining call to local function ~S~%" op)))
1299                 (return-from p1-function-call
1300       (let ((*inline-declarations*
1301        (remove op *inline-declarations* :key #'car)))
1302         (p1 expansion))))))
1303
1304           ;; FIXME
1305           (dformat t "local function assumed not single-valued~%")
1306           (setf (compiland-%single-valued-p *current-compiland*) nil)
1307
1308           (let ((variable (local-function-variable local-function)))
1309             (when variable
1310               (dformat t "p1 ~S used non-locally~%" (variable-name variable))
1311               (setf (variable-used-non-locally-p variable) t))))
1312          (t
1313           ;; Not a local function call.
1314           (dformat t "p1 non-local call to ~S~%" op)
1315           (unless (single-valued-p form)
1316;;                (format t "not single-valued op = ~S~%" op)
1317             (setf (compiland-%single-valued-p *current-compiland*) nil)))))
1318  (p1-default form))
1319
1320(defun %funcall (fn &rest args)
1321  "Dummy FUNCALL wrapper to force p1 not to optimize the call."
1322  (apply fn args))
1323
1324(defknown p1 (t) t)
1325(defun p1 (form)
1326  (cond ((symbolp form)
1327         (let (value)
1328           (cond ((null form)
1329                  form)
1330                 ((eq form t)
1331                  form)
1332                 ((keywordp form)
1333                  form)
1334                 ((and (constantp form)
1335                       (progn
1336                         (setf value (symbol-value form))
1337                         (or (numberp value)
1338                             (stringp value)
1339                             (pathnamep value))))
1340                  (setf form value))
1341                 (t
1342                  (let ((variable (find-visible-variable form)))
1343                    (when (null variable)
1344          (unless (or (special-variable-p form)
1345                                  (memq form *undefined-variables*))
1346      (compiler-style-warn
1347                         "Undefined variable ~S assumed special" form)
1348      (push form *undefined-variables*))
1349                      (setf variable (make-variable :name form :special-p t))
1350                      (push variable *visible-variables*))
1351                    (let ((ref (make-var-ref variable)))
1352                      (unless (variable-special-p variable)
1353                        (when (variable-ignore-p variable)
1354                          (compiler-style-warn
1355                           "Variable ~S is read even though it was declared to be ignored."
1356                           (variable-name variable)))
1357                        (push ref (variable-references variable))
1358                        (incf (variable-reads variable))
1359                        (cond ((eq (variable-compiland variable) *current-compiland*)
1360                               (dformat t "p1: read ~S~%" form))
1361                              (t
1362                               (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%"
1363                                        form
1364                                        (compiland-name (variable-compiland variable))
1365                                        (compiland-name *current-compiland*))
1366                               (setf (variable-used-non-locally-p variable) t))))
1367                      (setf form ref)))
1368                  form))))
1369        ((atom form)
1370         form)
1371        (t
1372         (let ((op (%car form))
1373               handler)
1374           (cond ((symbolp op)
1375                  (when (compiler-macro-function op)
1376                    (unless (notinline-p op)
1377                      (multiple-value-bind (expansion expanded-p)
1378                          (compiler-macroexpand form)
1379                        ;; Fall through if no change...
1380                        (when expanded-p
1381                          (return-from p1 (p1 expansion))))))
1382                  (cond ((setf handler (get op 'p1-handler))
1383                         (funcall handler form))
1384                        ((macro-function op *compile-file-environment*)
1385                         (p1 (macroexpand form *compile-file-environment*)))
1386                        ((special-operator-p op)
1387                         (compiler-unsupported "P1: unsupported special operator ~S" op))
1388                        (t
1389                         (p1-function-call form))))
1390                 ((and (consp op) (eq (%car op) 'LAMBDA))
1391      (let ((maybe-optimized-call (rewrite-function-call form)))
1392        (if (eq maybe-optimized-call form)
1393      (p1 `(%funcall (function ,op) ,@(cdr form)))
1394      (p1 maybe-optimized-call))))
1395                 (t
1396                  form))))))
1397
1398(defun install-p1-handler (symbol handler)
1399  (setf (get symbol 'p1-handler) handler))
1400
1401(defun initialize-p1-handlers ()
1402  (dolist (pair '((AND                  p1-default)
1403                  (BLOCK                p1-block)
1404                  (CATCH                p1-catch)
1405                  (DECLARE              identity)
1406                  (EVAL-WHEN            p1-eval-when)
1407                  (FLET                 p1-flet)
1408                  (FUNCALL              p1-funcall)
1409                  (FUNCTION             p1-function)
1410                  (GO                   p1-go)
1411                  (IF                   p1-if)
1412                  (LABELS               p1-labels)
1413                  (LAMBDA               p1-lambda)
1414                  (LET                  p1-let/let*)
1415                  (LET*                 p1-let/let*)
1416                  (LOAD-TIME-VALUE      identity)
1417                  (LOCALLY              p1-locally)
1418                  (MULTIPLE-VALUE-BIND  p1-m-v-b)
1419                  (MULTIPLE-VALUE-CALL  p1-default)
1420                  (MULTIPLE-VALUE-LIST  p1-default)
1421                  (MULTIPLE-VALUE-PROG1 p1-default)
1422                  (OR                   p1-default)
1423                  (PROGN                p1-default)
1424                  (PROGV                p1-progv)
1425                  (QUOTE                p1-quote)
1426                  (RETURN-FROM          p1-return-from)
1427                  (SETQ                 p1-setq)
1428                  (SYMBOL-MACROLET      identity)
1429                  (TAGBODY              p1-tagbody)
1430                  (THE                  p1-the)
1431                  (THROW                p1-throw)
1432                  (TRULY-THE            p1-truly-the)
1433                  (UNWIND-PROTECT       p1-unwind-protect)
1434                  (THREADS:SYNCHRONIZED-ON
1435                                        p1-threads-synchronized-on)))
1436    (install-p1-handler (%car pair) (%cadr pair))))
1437
1438(initialize-p1-handlers)
1439
1440(defun p1-compiland (compiland)
1441;;   (format t "p1-compiland name = ~S~%" (compiland-name compiland))
1442  (let ((form (compiland-lambda-expression compiland)))
1443    (aver (eq (car form) 'LAMBDA))
1444    (setf form (rewrite-lambda form))
1445    (process-optimization-declarations (cddr form))
1446
1447    (let* ((lambda-list (cadr form))
1448           (body (cddr form))
1449           (*visible-variables* *visible-variables*)
1450           (closure (make-closure `(lambda ,lambda-list nil) nil))
1451           (syms (sys::varlist closure))
1452           (vars nil))
1453      (dolist (sym syms)
1454        (let ((var (make-variable :name sym
1455                                  :special-p (special-variable-p sym))))
1456          (push var vars)
1457          (push var *all-variables*)
1458          (push var *visible-variables*)))
1459      (setf (compiland-arg-vars compiland) (nreverse vars))
1460      (let ((free-specials (process-declarations-for-vars body vars nil)))
1461        (setf (compiland-free-specials compiland) free-specials)
1462        (dolist (var free-specials)
1463          (push var *visible-variables*)))
1464      (setf (compiland-p1-result compiland)
1465            (list* 'LAMBDA lambda-list (p1-body body))))))
1466
1467(provide "COMPILER-PASS1")
Note: See TracBrowser for help on using the repository browser.