source: trunk/abcl/src/org/armedbear/lisp/jvm.lisp @ 13792

Last change on this file since 13792 was 13792, checked in by astalla, 10 years ago

A small reorganization of compiler/jvm code. Runtime-class wasn't autoloading properly in certain situations due to a wrong dependency graph among some system files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 27.3 KB
Line 
1;;; jvm.lisp
2;;;
3;;; Copyright (C) 2003-2008 Peter Graves
4;;; $Id: jvm.lisp 13792 2012-01-20 01:10:39Z 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(export '(compile-defun *catch-errors* jvm-compile-package
35          derive-compiler-type))
36
37(eval-when (:compile-toplevel :load-toplevel :execute)
38  (require "LOOP")
39  (require "FORMAT")
40  (require "CLOS")
41  (require "PRINT-OBJECT")
42  (require "COMPILER-TYPES")
43  (require "COMPILER-ERROR")
44  (require "KNOWN-FUNCTIONS")
45  (require "DUMP-FORM")
46  (require "JVM-INSTRUCTIONS")
47  (require "JVM-CLASS-FILE")
48  (require "KNOWN-SYMBOLS")
49  (require "JAVA")
50  (require "COMPILER-PASS1")
51  (require "COMPILER-PASS2"))
52
53(defvar *closure-variables* nil)
54
55(defvar *enable-dformat* nil)
56(defvar *callbacks* nil
57  "A list of functions to be called by the compiler and code generator
58in order to generate 'compilation events'.")
59
60(declaim (inline invoke-callbacks))
61(defun invoke-callbacks (&rest args)
62  (dolist (cb *callbacks*)
63    (apply cb args)))
64
65#+nil
66(defun dformat (destination control-string &rest args)
67  (when *enable-dformat*
68    (apply #'sys::%format destination control-string args)))
69
70(defmacro dformat (&rest ignored)
71  (declare (ignore ignored)))
72
73(defmacro with-saved-compiler-policy (&body body)
74  "Saves compiler policy variables, restoring them after evaluating `body'."
75  `(let ((*speed* *speed*)
76         (*space* *space*)
77         (*safety* *safety*)
78         (*debug* *debug*)
79         (*explain* *explain*)
80         (*inline-declarations* *inline-declarations*))
81     ,@body))
82
83
84
85(defvar *compiler-debug* nil)
86
87(defvar *pool* nil)
88(defvar *static-code* ())
89(defvar *class-file* nil)
90
91(defvar *externalized-objects* nil)
92(defvar *declared-functions* nil)
93
94(defstruct (abcl-class-file (:include class-file)
95                            (:constructor %make-abcl-class-file))
96  pathname ; pathname of output file
97  class-name
98  static-initializer
99  constructor
100  objects ;; an alist of externalized objects and their field names
101  (functions (make-hash-table :test 'equal)) ;; because of (SETF ...) functions
102  )
103
104(defun class-name-from-filespec (filespec)
105  (let* ((name (pathname-name filespec)))
106    (declare (type string name))
107    (dotimes (i (length name))
108      (declare (type fixnum i))
109      (when (or (char= (char name i) #\-)
110                (char= (char name i) #\Space))
111        (setf (char name i) #\_)))
112    (make-jvm-class-name
113     (concatenate 'string "org.armedbear.lisp." name))))
114
115(defun make-unique-class-name ()
116  "Creates a random class name for use with a `class-file' structure's
117`class' slot."
118  (make-jvm-class-name
119   (concatenate 'string "abcl_"
120                (substitute #\_ #\-
121                            (java:jcall (java:jmethod "java.util.UUID"
122                                                      "toString")
123                                        (java:jstatic "randomUUID"
124                                                      "java.util.UUID"))))))
125
126(defun make-abcl-class-file (&key pathname)
127  "Creates a `class-file' structure. If `pathname' is non-NIL, it's
128used to derive a class name. If it is NIL, a random one created
129using `make-unique-class-name'."
130  (let* ((class-name (if pathname
131                         (class-name-from-filespec  pathname)
132                         (make-unique-class-name)))
133         (class-file (%make-abcl-class-file :pathname pathname
134                                            :class class-name ; to be finalized
135                                            :class-name class-name
136                                            :access-flags '(:public :final))))
137    (when *file-compilation*
138      (let ((source-attribute
139             (make-source-file-attribute
140              :filename (file-namestring *compile-file-truename*))))
141        (class-add-attribute class-file source-attribute)))
142    class-file))
143
144(defmacro with-class-file (class-file &body body)
145  (let ((var (gensym)))
146    `(let* ((,var                   ,class-file)
147            (*class-file*           ,var)
148            (*pool*                 (abcl-class-file-constants ,var))
149            (*externalized-objects* (abcl-class-file-objects ,var))
150            (*declared-functions*   (abcl-class-file-functions ,var)))
151       (progn ,@body)
152       (setf (abcl-class-file-objects ,var)      *externalized-objects*
153             (abcl-class-file-functions ,var)    *declared-functions*))))
154
155(defstruct compiland
156  name
157  lambda-expression
158  arg-vars          ; variables for lambda arguments
159  free-specials     ;
160  arity             ; number of args, or NIL if the number of args can vary.
161  p1-result         ; the parse tree as created in pass 1
162  parent            ; the parent for compilands which defined within another
163  children          ; List of local functions
164                    ; defined with FLET, LABELS or LAMBDA
165  blocks            ; TAGBODY, PROGV, BLOCK, etc. blocks
166  (next-resource 0)
167  argument-register
168  closure-register
169  environment-register
170  class-file ; class-file object
171  (%single-valued-p t))
172
173(defknown compiland-single-valued-p (t) t)
174(defun compiland-single-valued-p (compiland)
175  (unless (compiland-parent compiland)
176    (let ((name (compiland-name compiland)))
177      (when name
178        (let ((result-type
179               (or (function-result-type name)
180                   (and (proclaimed-ftype name)
181                        (ftype-result-type (proclaimed-ftype name))))))
182          (when result-type
183            (return-from compiland-single-valued-p
184                         (cond ((eq result-type '*)
185                                nil)
186                               ((atom result-type)
187                                t)
188                               ((eq (%car result-type) 'VALUES)
189                                (= (length result-type) 2))
190                               (t
191                                t))))))))
192  ;; Otherwise...
193  (compiland-%single-valued-p compiland))
194
195(defvar *current-compiland* nil)
196
197(defvar *this-class* nil)
198
199;; All tags visible at the current point of compilation, some of which may not
200;; be in the current compiland.
201(defvar *visible-tags* ())
202
203;; The next available register.
204(defvar *register* 0)
205
206;; Total number of registers allocated.
207(defvar *registers-allocated* 0)
208
209;; Variables visible at the current point of compilation.
210(defvar *visible-variables* nil
211  "All variables visible to the form currently being
212processed, including free specials.")
213
214;; All variables seen so far.
215(defvar *all-variables* nil
216  "All variables in the lexical scope (thus excluding free specials)
217of the compilands being processed (p1: so far; p2: in total).")
218
219;; Undefined variables that we've already warned about.
220(defvar *undefined-variables* nil)
221
222(defvar *dump-variables* nil)
223
224(defun dump-1-variable (variable)
225  (sys::%format t "  ~S special-p = ~S register = ~S binding-reg = ~S index = ~S declared-type = ~S~%"
226           (variable-name variable)
227           (variable-special-p variable)
228           (variable-register variable)
229           (variable-binding-register variable)
230           (variable-index variable)
231           (variable-declared-type variable)))
232
233(defun dump-variables (list caption &optional (force nil))
234  (when (or force *dump-variables*)
235    (write-string caption)
236    (if list
237        (dolist (variable list)
238          (dump-1-variable variable))
239        (sys::%format t "  None.~%"))))
240
241(defstruct (variable-info (:conc-name variable-)
242                          (:constructor make-variable)
243                          (:predicate variable-p))
244  name
245  initform
246  (declared-type :none)
247  (derived-type :none)
248  ignore-p
249  ignorable-p
250  representation
251  special-p     ; indicates whether a variable is special
252
253;; A variable can be stored in a number of locations.
254;;  1. if it's passed as a normal argument, it'll be in a register (max 8)
255;;     the same is true if the variable is a local variable (at any index)
256;;  2. if it's passed in the argument array, it'll be in the array in
257;;     register 1 (register 0 contains the function object)
258;;  3. if the variable is part of a closure, it'll be in the closure array
259;;  4. if the variable is part of the outer scope of a function with a
260;;     non-null lexical environment, the variable is to be looked up
261;;     from a lexical environment object
262;;  5. the variable is a special variable and its binding has been looked
263;;     up and cached in a local register (binding-register)
264
265;; a variable can be either special-p *or* have a register *or*
266;; have an index *or* a closure-index *or* an environment
267
268  register      ; register number for a local variable
269  binding-register ; register number containing the binding reference
270  index         ; index number for a variable in the argument array
271  closure-index ; index number for a variable in the closure context array
272  environment   ; the environment for the variable, if we're compiling in
273                ; a non-null lexical environment with variables
274
275  (reads 0 :type fixnum)
276  (writes 0 :type fixnum)
277  references
278  (references-allowed-p t) ; NIL if this is a symbol macro in the enclosing
279                           ; lexical environment
280  used-non-locally-p
281  (compiland *current-compiland*)
282  block)
283
284(defstruct (var-ref (:constructor make-var-ref (variable)))
285  ;; The variable this reference refers to. Will be NIL if the VAR-REF has been
286  ;; rewritten to reference a constant value.
287  variable
288  ;; True if the VAR-REF has been rewritten to reference a constant value.
289  constant-p
290  ;; The constant value of this VAR-REF.
291  constant-value)
292
293;; obj can be a symbol or variable
294;; returns variable or nil
295(declaim (ftype (function (t) t) unboxed-fixnum-variable))
296(defun unboxed-fixnum-variable (obj)
297  (cond ((symbolp obj)
298         (let ((variable (find-visible-variable obj)))
299           (if (and variable
300                    (eq (variable-representation variable) :int))
301               variable
302               nil)))
303        ((variable-p obj)
304         (if (eq (variable-representation obj) :int)
305             obj
306             nil))
307        (t
308         nil)))
309
310(defvar *child-p* nil
311  "True for local functions created by FLET, LABELS and (NAMED-)LAMBDA")
312
313(defknown find-variable (symbol list) t)
314(defun find-variable (name variables)
315  (dolist (variable variables)
316    (when (eq name (variable-name variable))
317      (return variable))))
318
319(defknown find-visible-variable (t) t)
320(defun find-visible-variable (name)
321  (dolist (variable *visible-variables*)
322    (when (eq name (variable-name variable))
323      (return variable))))
324
325(defknown representation-size (t) (integer 0 65535))
326(defun representation-size (representation)
327  (ecase representation
328    ((NIL :int :boolean :float :char) 1)
329    ((:long :double) 2)))
330
331(defknown allocate-register (t) (integer 0 65535))
332(defun allocate-register (representation)
333  (let ((register *register*))
334    (incf *register* (representation-size representation))
335    (setf *registers-allocated*
336          (max *registers-allocated* *register*))
337    register))
338
339
340(defstruct local-function
341  name
342  definition
343  compiland
344  field
345  inline-expansion
346  environment ;; the environment in which the function is stored in
347              ;; case of a function from an enclosing lexical environment
348              ;; which itself isn't being compiled
349  (references-allowed-p t) ;;whether a reference to the function CAN be captured
350  (references-needed-p nil) ;;whether a reference to the function NEEDS to be
351                            ;;captured, because the function name is used in a
352                            ;;(function ...) form. Obviously implies
353                            ;;references-allowed-p.
354  )
355
356(defvar *local-functions* ())
357
358(defknown find-local-function (t) t)
359(defun find-local-function (name)
360  (dolist (local-function *local-functions* nil)
361    (when (equal name (local-function-name local-function))
362        (return local-function))))
363
364(defvar *using-arg-array* nil)
365(defvar *hairy-arglist-p* nil)
366
367
368(defvar *block* nil
369  "The innermost block applicable to the current lexical environment.")
370(defvar *blocks* ()
371  "The list of blocks in effect in the current lexical environment.
372
373The top node does not need to be equal to the value of `*block*`. E.g.
374when processing the bindings of a LET form, `*block*` is bound to the node
375of that LET, while the block is not considered 'in effect': that only happens
376until the body is being processed.")
377
378(defstruct node
379  form
380  children
381  (compiland *current-compiland*))
382;; No need for a special constructor: nobody instantiates
383;; nodes directly
384
385(declaim (inline add-node-child))
386(defun add-node-child (parent child)
387  "Add a child node to the `children` list of a parent node,
388if that parent belongs to the same compiland."
389  (when parent
390    (when (eq (node-compiland parent) *current-compiland*)
391      (push child (node-children parent)))))
392
393;; control-transferring blocks: TAGBODY, CATCH, to do: BLOCK
394
395(defstruct (control-transferring-node (:include node))
396  ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the
397  ;; environment, with GO forms in them which target tags in this TAGBODY
398  ;; Non-nil if and only if the block doesn't modify the environment
399  needs-environment-restoration
400  )
401;; No need for a special constructor: nobody instantiates
402;; control-transferring-nodes directly
403
404(defstruct (tagbody-node (:conc-name tagbody-)
405                         (:include control-transferring-node)
406                         (:constructor %make-tagbody-node ()))
407  ;; True if a tag in this tagbody is the target of a non-local GO.
408  non-local-go-p
409  ;; Tags in the tagbody form; a list of tag structures
410  tags
411  ;; Contains a variable whose value uniquely identifies the
412  ;; lexical scope from this block, to be used by GO
413  id-variable)
414(defknown make-tagbody-node () t)
415(defun make-tagbody-node ()
416  (let ((block (%make-tagbody-node)))
417    (push block (compiland-blocks *current-compiland*))
418    (add-node-child *block* block)
419    block))
420
421(defstruct (catch-node (:conc-name catch-)
422                       (:include control-transferring-node)
423                       (:constructor %make-catch-node ()))
424  ;; The catch tag-form is evaluated, meaning we
425  ;; have no predefined value to store here
426  )
427(defknown make-catch-node () t)
428(defun make-catch-node ()
429  (let ((block (%make-catch-node)))
430    (push block (compiland-blocks *current-compiland*))
431    (add-node-child *block* block)
432    block))
433
434(defstruct (block-node (:conc-name block-)
435                       (:include control-transferring-node)
436                       (:constructor %make-block-node (name)))
437  name  ;; Block name
438  (exit (gensym))
439  target
440  ;; True if there is a non-local RETURN from this block.
441  non-local-return-p
442  ;; Contains a variable whose value uniquely identifies the
443  ;; lexical scope from this block, to be used by RETURN-FROM
444  id-variable
445  ;; A list of all RETURN-FROM value forms associated with this block
446  return-value-forms)
447
448(defknown make-block-node (t) t)
449(defun make-block-node (name)
450  (let ((block (%make-block-node name)))
451    (push block (compiland-blocks *current-compiland*))
452    (add-node-child *block* block)
453    block))
454
455(defstruct (jump-node (:conc-name jump-)
456                      (:include node)
457                      (:constructor
458                       %make-jump-node (non-local-p target-block target-tag)))
459  non-local-p
460  target-block
461  target-tag)
462(defun make-jump-node (form non-local-p target-block &optional target-tag)
463  (let ((node (%make-jump-node non-local-p target-block target-tag)))
464    ;; Don't push into compiland blocks, as this as a node rather than a block
465    (setf (node-form node) form)
466    (add-node-child *block* node)
467    node))
468
469
470;; binding blocks: LET, LET*, FLET, LABELS, M-V-B, PROGV, LOCALLY
471;;
472;; Binding blocks can carry references to local (optionally special) variable bindings,
473;;  contain free special bindings or both
474
475(defstruct (binding-node (:include node))
476  ;; number of the register of the saved dynamic env, or NIL if none
477  environment-register
478  ;; Not used for LOCALLY and FLET; LABELS uses vars to store its functions
479  vars
480  free-specials)
481;; nobody instantiates any binding nodes directly, so there's no reason
482;; to create a constructor with the approprate administration code
483
484(defstruct (let/let*-node (:conc-name let-)
485                          (:include binding-node)
486                          (:constructor %make-let/let*-node ())))
487(defknown make-let/let*-node () t)
488(defun make-let/let*-node ()
489  (let ((block (%make-let/let*-node)))
490    (push block (compiland-blocks *current-compiland*))
491    (add-node-child *block* block)
492    block))
493
494(defstruct (flet-node (:conc-name flet-)
495                      (:include binding-node)
496                      (:constructor %make-flet-node ())))
497(defknown make-flet-node () t)
498(defun make-flet-node ()
499  (let ((block (%make-flet-node)))
500    (push block (compiland-blocks *current-compiland*))
501    (add-node-child *block* block)
502    block))
503
504(defstruct (labels-node (:conc-name labels-)
505                        (:include binding-node)
506                        (:constructor %make-labels-node ())))
507(defknown make-labels-node () t)
508(defun make-labels-node ()
509  (let ((block (%make-labels-node)))
510    (push block (compiland-blocks *current-compiland*))
511    (add-node-child *block* block)
512    block))
513
514(defstruct (m-v-b-node (:conc-name m-v-b-)
515                       (:include binding-node)
516                       (:constructor %make-m-v-b-node ())))
517(defknown make-m-v-b-node () t)
518(defun make-m-v-b-node ()
519  (let ((block (%make-m-v-b-node)))
520    (push block (compiland-blocks *current-compiland*))
521    (add-node-child *block* block)
522    block))
523
524(defstruct (progv-node (:conc-name progv-)
525                       (:include binding-node)
526                       (:constructor %make-progv-node ())))
527(defknown make-progv-node () t)
528(defun make-progv-node ()
529  (let ((block (%make-progv-node)))
530    (push block (compiland-blocks *current-compiland*))
531    block))
532
533(defstruct (locally-node (:conc-name locally-)
534                         (:include binding-node)
535                         (:constructor %make-locally-node ())))
536(defknown make-locally-node () t)
537(defun make-locally-node ()
538  (let ((block (%make-locally-node)))
539    (push block (compiland-blocks *current-compiland*))
540    (add-node-child *block* block)
541    block))
542
543;; blocks requiring non-local exits: UNWIND-PROTECT, SYS:SYNCHRONIZED-ON
544
545(defstruct (protected-node (:include node)
546                           (:constructor %make-protected-node ())))
547(defknown make-protected-node () t)
548(defun make-protected-node ()
549  (let ((block (%make-protected-node)))
550    (push block (compiland-blocks *current-compiland*))
551    (add-node-child *block* block)
552    block))
553
554(defstruct (unwind-protect-node (:conc-name unwind-protect-)
555                                (:include protected-node)
556                                (:constructor %make-unwind-protect-node ())))
557(defknown make-unwind-protect-node () t)
558(defun make-unwind-protect-node ()
559  (let ((block (%make-unwind-protect-node)))
560    (push block (compiland-blocks *current-compiland*))
561    (add-node-child *block* block)
562    block))
563
564(defstruct (synchronized-node (:conc-name synchronized-)
565                              (:include protected-node)
566                              (:constructor %make-synchronized-node ())))
567(defknown make-synchronized-node () t)
568(defun make-synchronized-node ()
569  (let ((block (%make-synchronized-node)))
570    (push block (compiland-blocks *current-compiland*))
571    (add-node-child *block* block)
572    block))
573
574(defun find-block (name)
575  (dolist (block *blocks*)
576    (when (and (block-node-p block)
577               (eq name (block-name block)))
578      (return block))))
579
580(defun %find-enclosed-blocks (form)
581  "Helper function for `find-enclosed-blocks`, implementing the actual
582algorithm specified there."
583  (cond
584   ((node-p form) (list form))
585   ((atom form) nil)
586   (t
587    ;; We can't use MAPCAN or DOLIST here: they'll choke on dotted lists
588    (do* ((tail form (cdr tail))
589          blocks)
590         ((null tail) blocks)
591      (setf blocks
592            (nconc (%find-enclosed-blocks (if (consp tail)
593                                              (car tail) tail))
594                   blocks))
595      (when (not (listp tail))
596        (return blocks))))))
597
598(defun find-enclosed-blocks (form)
599  "Returns the immediate enclosed blocks by searching the form's subforms.
600
601More deeply nested blocks can be reached through the `node-children`
602field of the immediate enclosed blocks."
603  (when *blocks*
604    ;; when the innermost enclosing block doesn't have node-children,
605    ;;  there's really nothing to search for.
606    (let ((first-enclosing-block (car *blocks*)))
607      (when (and (eq *current-compiland*
608                     (node-compiland first-enclosing-block))
609                 (null (node-children first-enclosing-block)))
610        (return-from find-enclosed-blocks))))
611
612  (%find-enclosed-blocks form))
613
614
615(defun some-nested-block (predicate blocks)
616  "Applies `predicate` recursively to the `blocks` and its children,
617until predicate returns non-NIL, returning that value.
618
619`blocks` may be a single block or a list of blocks."
620  (when blocks
621    (some #'(lambda (b)
622              (or (funcall predicate b)
623                  (some-nested-block predicate (node-children b))))
624          (if (listp blocks)
625              blocks
626            (list blocks)))))
627
628(defknown node-constant-p (t) boolean)
629(defun node-constant-p (object)
630  (cond ((node-p object)
631         nil)
632        ((var-ref-p object)
633         nil)
634        ((constantp object)
635         t)
636        (t
637         nil)))
638
639(defknown block-requires-non-local-exit-p (t) boolean)
640(defun block-requires-non-local-exit-p (object)
641  "A block which *always* requires a 'non-local-exit' is a block which
642requires a transfer control exception to be thrown: e.g. Go and Return.
643
644Non-local exits are required by blocks which do more in their cleanup
645than just restore the lastSpecialBinding (= dynamic environment).
646"
647  (or (unwind-protect-node-p object)
648      (catch-node-p object)
649      (synchronized-node-p object)))
650
651(defun node-opstack-unsafe-p (node)
652  (or (when (jump-node-p node)
653        (let ((target-block (jump-target-block node)))
654          (and (null (jump-non-local-p node))
655               (member target-block *blocks*))))
656      (when (tagbody-node-p node) (tagbody-non-local-go-p node))
657      (when (block-node-p node) (block-non-local-return-p node))
658      (catch-node-p node)))
659
660(defknown block-creates-runtime-bindings-p (t) boolean)
661(defun block-creates-runtime-bindings-p (block)
662  ;; FIXME: This may be false, if the bindings to be
663  ;; created are a quoted list
664  (progv-node-p block))
665
666(defknown enclosed-by-runtime-bindings-creating-block-p (t) boolean)
667(defun enclosed-by-runtime-bindings-creating-block-p (outermost-block)
668  "Indicates whether the code being compiled/analyzed is enclosed in a
669block which creates special bindings at runtime."
670  (dolist (enclosing-block *blocks*)
671    (when (eq enclosing-block outermost-block)
672      (return-from enclosed-by-runtime-bindings-creating-block-p nil))
673    (when (block-creates-runtime-bindings-p enclosing-block)
674      (return-from enclosed-by-runtime-bindings-creating-block-p t))))
675
676(defknown enclosed-by-protected-block-p (&optional t) boolean)
677(defun enclosed-by-protected-block-p (&optional outermost-block)
678  "Indicates whether the code being compiled/analyzed is enclosed in
679a block which requires a non-local transfer of control exception to
680be generated.
681"
682  (dolist (enclosing-block *blocks*)
683    (when (eq enclosing-block outermost-block)
684      (return-from enclosed-by-protected-block-p nil))
685    (when (block-requires-non-local-exit-p enclosing-block)
686      (return-from enclosed-by-protected-block-p t))))
687
688(defknown enclosed-by-environment-setting-block-p (&optional t) boolean)
689(defun enclosed-by-environment-setting-block-p (&optional outermost-block)
690  (dolist (enclosing-block *blocks*)
691    (when (eq enclosing-block outermost-block)
692      (return nil))
693    (when (and (binding-node-p enclosing-block)
694               (binding-node-environment-register enclosing-block))
695      (return t))))
696
697(defknown environment-register-to-restore (&optional t) t)
698(defun environment-register-to-restore (&optional outermost-block)
699  "Returns the environment register which contains the
700saved environment from the outermost enclosing block:
701
702That's the one which contains the environment used in the outermost block."
703  (flet ((outermost-register (last-register block)
704           (when (eq block outermost-block)
705             (return-from environment-register-to-restore last-register))
706           (or (and (binding-node-p block)
707                    (binding-node-environment-register block))
708               last-register)))
709    (reduce #'outermost-register *blocks*
710            :initial-value nil)))
711
712(defstruct tag
713  ;; The symbol (or integer) naming the tag
714  name
715  ;; The symbol which is the jump target in JVM byte code
716  label
717  ;; The associated TAGBODY
718  block
719  (compiland *current-compiland*)
720  used
721  used-non-locally)
722
723(defknown find-tag (t) t)
724(defun find-tag (name)
725  (dolist (tag *visible-tags*)
726    (when (eql name (tag-name tag))
727      (return tag))))
728
729(defun process-ignore/ignorable (declaration names variables)
730  (when (memq declaration '(IGNORE IGNORABLE))
731    (let ((what (if (eq declaration 'IGNORE) "ignored" "ignorable")))
732      (dolist (name names)
733        (unless (and (consp name) (eq (car name) 'FUNCTION))
734          (let ((variable (find-variable name variables)))
735            (cond ((null variable)
736                   (compiler-style-warn "Declaring unknown variable ~S to be ~A."
737                                        name what))
738                  ((variable-special-p variable)
739                   (compiler-style-warn "Declaring special variable ~S to be ~A."
740                                        name what))
741                  ((eq declaration 'IGNORE)
742                   (setf (variable-ignore-p variable) t))
743                  (t
744                   (setf (variable-ignorable-p variable) t)))))))))
745
746(defun finalize-generic-functions ()
747  (dolist (sym '(make-instance
748                 initialize-instance
749                 shared-initialize))
750    (let ((gf (and (fboundp sym) (fdefinition sym))))
751      (when (typep gf 'generic-function)
752        (unless (compiled-function-p gf)
753          (mop::finalize-generic-function gf))))))
754
755(finalize-generic-functions)
756
757(provide 'jvm)
Note: See TracBrowser for help on using the repository browser.