source: branches/streams/abcl/src/org/armedbear/lisp/jvm.lisp

Last change on this file was 14552, checked in by ehuelsmann, 12 years ago

Inline calls to jrun-exception-protected
(used by handler-bind to catch out of memory conditions).

This commit saves generation roughly 50 cls files.

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