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

Last change on this file was 15141, checked in by Mark Evenson, 4 years ago

compiler: fix stack inconsistency errors

(somewhat-functional-programmer) Mark

Lately I have been starting to dive deeper into Common Lisp and have started to
use ABCL more than SBCL or CCL lately. It is a very impressive project.

I want to post a patch for review/comments and hopefully have it be worthwhile
to eventually include it in ABCL. The patch attempts to fix a couple of stack
inconsistency bugs in the compiler. I came across the stack inconsistency issue
in one of my projects and started to try to find the root cause of the problem
based on a nice minimal reproduction of the bug found in
​https://github.com/armedbear/abcl/issues/69.

However, my particular bug was slightly different. It had to do with using a
return-from in the cleanup form of an unwind-protect. The following two forms
also result in a stack inconsistency problem (and are a more minimal
reproduction of the bug my code introduced):

(defun two-arg-fn (one two)

(format t "Two args: ~S and ~S~%" one two))

(let ((fn (compile nil '(lambda ()

(two-arg-fn

(block test-block

(unwind-protect

30

(return-from test-block 8)))

-1)))))

(funcall fn))

My patch handles both the github issue and the stack inconsistency in the form
above. It also fixes jvm::print-code to print string representations of values
from the constant pool which I found useful in debugging the output.

Anyhow, let me attempt to quickly summarize the stack inconsistency problem in
general:

  • Certain common lisp control flow forms (tagbody/go/unwind-protect/block/return-from/throw/catch) require the use of JVM exceptions to implement in bytecode
  • When the JVM throws an exception, the operand stack is cleared and the exception is pushed onto the operand stack (see jvms8, 6.5/athrow, p378)
  • Therefore, any form which pushes values onto the operand stack for further use is confounded when these control flow forms are child forms
  • To properly handle these alternate control flows we need to save the result of the control flow form to a local variable in the stack frame (distinct from the operand stack, and not destroyed by an exception (well at least not until the exception passes /out/ of the method) and then reload for use by the parent form to push on the operand stack

Take the case of the ash function (from the github issue). Bytecode for ash is
emitted from jvm::p2-ash. It compiles its arguments to the operand stack, and is
therefore vulnerable to the problem discussed above. Other low level functions
(like + for example in p2-plus) use the following forms to overcome this issue:
jvm::with-operand-accumulation and jvm::compile-operand. These forms save the
results of "unsafe" forms (opstack unsafe) to "registers" (local variables in
the stack frame). This technique allows for these complicated control flow forms
to be a child form of + with no issues, but not the ash function (which does not
do this). See my patch for how I added these already present
with-operand-accumulation and compile-operand forms to ash so it is no longer
vulnerable to stack inconsistency bugs.

Generally, function calls in ABCL are not vulnerable to these stack
inconsistency bugs. Function arguments are processed in jvm::process-args, and
in this function, the opstack safety of child forms is checked, and values are
saved to "registers" when a form is known to be unsafe. My case (the return-from
in the cleanup form of an unwind-protect) simply wasn't properly being marked as
opstack unsafe. I modified jvm::p1-unwind-protect to mark all direct children of
the unwind-protect as opstack unsafe, which eliminated my problem. I believe
there may have been confusion here in the code (speculation of course on my
part) of 'protected' form referring to the form actually protected by the
unwind-protect (which is totally different than being unsafe or needing opstack
/protection/) (or I'm misinterpreting this function and potentially causing
additional bugs!).

The only other item in my patch is fixing how bytecode is printed for debugging.
Basically, most items in a class constant pool are referenced with a 2 byte
index, but one (ldc) uses a one byte index). This has been accounted for in the
new function jvm::constant-pool-index.

Let me know what you think, and again please review, there aren't many lines
changed but I am new to the internals of the project. I think I ran all tests
(ant abcl.test) but while the ant task completed successfully, my output
complained of a missing dependency and I'm not sure what actually ran.

-Mark

The attached patch was produced against b3cfee6617e0c2c380d8675f3383d81e7758f358
from ​https://github.com/easye/abcl (latest master branch).

[jvms8] ​https://docs.oracle.com/javase/specs/jvms/se8/jvms8.pdf

Addresses <​https://github.com/armedbear/abcl/issues/69>.

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