1;;; jvm.lisp 2;;; 3;;; Copyright (C) 2003-2008 Peter Graves 4;;; $Id$ 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) 780