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

Last change on this file since 13486 was 13486, checked in by ehuelsmann, 11 years ago

Assign all local functions a field in the immediate parent;
also make sure all compiland children have known class names
before processing the body of the compiland.

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