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

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

Fix #116 (fail to load cl-unicode) by saving serialized resources with a
size bigger that 64k in a separate file instead of within-classfile.

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