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

Last change on this file since 13466 was 13466, checked in by ehuelsmann, 10 years ago

Reduce load time of nested functions and the number of class loader objects.

This commit groups all nested function objects resulting from a COMPILE call
into one class loader (instead of a class loader each). Additionally, nested
function objects aren't instantiated using reflection anymore, instead, the
'new' instruction is used, winning a factor 100 per local function.

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