[armedbear-cvs] r14418 - branches/typed-asm/abcl/src/org/armedbear/lisp
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Sun Mar 3 22:02:51 UTC 2013
Author: ehuelsmann
Date: Sun Mar 3 14:02:50 2013
New Revision: 14418
Log:
Commit progress:
* Split out a number of functions from jvm-instructions to jvm-method
* Create jvm-method to hold method generation functionality
* Adjust autoloads-gen bootstrapping file to point existing symbols to
the new jvm-method file
* Add asserts all over the place to make sure we're generating
valid output
Added:
branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-method.lisp
Modified:
branches/typed-asm/abcl/src/org/armedbear/lisp/autoloads-gen.lisp
branches/typed-asm/abcl/src/org/armedbear/lisp/compile-system.lisp
branches/typed-asm/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
Modified: branches/typed-asm/abcl/src/org/armedbear/lisp/autoloads-gen.lisp
==============================================================================
--- branches/typed-asm/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Sun Mar 3 13:57:41 2013 (r14417)
+++ branches/typed-asm/abcl/src/org/armedbear/lisp/autoloads-gen.lisp Sun Mar 3 14:02:50 2013 (r14418)
@@ -103,7 +103,7 @@
;; FUNCTIONS
(IN-PACKAGE :JVM)
-(DOLIST (SYSTEM::FS (QUOTE ((("compiler-pass1") GENERATE-INLINE-EXPANSION PARSE-LAMBDA-LIST MATCH-LAMBDA-LIST MATCH-KEYWORD-AND-REST-ARGS EXPAND-FUNCTION-CALL-INLINE PROCESS-DECLARATIONS-FOR-VARS CHECK-NAME P1-BODY P1-DEFAULT P1-LET-VARS P1-LET*-VARS P1-LET/LET* P1-LOCALLY P1-M-V-B P1-BLOCK P1-CATCH P1-THREADS-SYNCHRONIZED-ON P1-UNWIND-PROTECT P1-RETURN-FROM P1-TAGBODY P1-GO SPLIT-DECLS REWRITE-AUX-VARS REWRITE-LAMBDA VALIDATE-FUNCTION-NAME CONSTRUCT-FLET/LABELS-FUNCTION P1-FLET P1-LABELS P1-FUNCALL P1-FUNCTION P1-LAMBDA P1-EVAL-WHEN P1-PROGV P1-QUOTE P1-SETQ P1-THE P1-TRULY-THE P1-THROW REWRITE-FUNCTION-CALL P1-FUNCTION-CALL %FUNCALL P1-VARIABLE-REFERENCE P1 INSTALL-P1-HANDLER INITIALIZE-P1-HANDLERS P1-COMPILAND) (("compiler-pass2") POOL-NAME POOL-NAME-AND-TYPE POOL-CLASS POOL-STRING POOL-FIELD POOL-METHOD POOL-INT POOL-FLOAT POOL-LONG POOL-DOUBLE ADD-EXCEPTION-HANDLER EMIT-PUSH-NIL EMIT-PUSH-NIL-SYMBOL EMIT-PUSH-T EMIT-PUSH-FALSE EMIT-PUSH-TRUE EMIT-PUSH-CONSTANT-INT EMIT-PUSH-CONSTANT-LONG EMIT-PUSH-CONSTANT-FLOAT EMIT-PUSH-CONSTANT-DOUBLE EMIT-DUP EMIT-SWAP EMIT-INVOKESTATIC PRETTY-JAVA-CLASS EMIT-INVOKEVIRTUAL EMIT-INVOKESPECIAL-INIT PRETTY-JAVA-TYPE EMIT-GETSTATIC EMIT-PUTSTATIC EMIT-GETFIELD EMIT-PUTFIELD EMIT-NEW EMIT-ANEWARRAY EMIT-CHECKCAST EMIT-INSTANCEOF TYPE-REPRESENTATION EMIT-UNBOX-BOOLEAN EMIT-UNBOX-CHARACTER CONVERT-REPRESENTATION COMMON-REPRESENTATION MAYBE-INITIALIZE-THREAD-VAR ENSURE-THREAD-VAR-INITIALIZED EMIT-PUSH-CURRENT-THREAD VARIABLE-LOCAL-P EMIT-LOAD-LOCAL-VARIABLE EMIT-PUSH-VARIABLE-NAME GENERATE-INSTANCEOF-TYPE-CHECK-FOR-VARIABLE FIND-TYPE-FOR-TYPE-CHECK GENERATE-TYPE-CHECK-FOR-VARIABLE MAYBE-GENERATE-TYPE-CHECK GENERATE-TYPE-CHECKS-FOR-VARIABLES GENERATE-ARG-COUNT-CHECK MAYBE-GENERATE-INTERRUPT-CHECK SINGLE-VALUED-P EMIT-CLEAR-VALUES MAYBE-EMIT-CLEAR-VALUES COMPILE-FORMS-AND-MAYBE-EMIT-CLEAR-VALUES LOAD-SAVED-OPERANDS SAVE-EXISTING-OPERANDS SAVE-OPERAND COMPILE-OPERAND EMIT-VARIABLE-OPERAND EMIT-REGISTER-OPERAND EMIT-THREAD-OPERAND EMIT-LOAD-EXTERNALIZED-OBJECT-OPERAND EMIT-UNBOX-FIXNUM EMIT-UNBOX-LONG EMIT-UNBOX-FLOAT EMIT-UNBOX-DOUBLE FIX-BOXING EMIT-MOVE-FROM-STACK EMIT-PUSH-REGISTER EMIT-INVOKE-METHOD CHECK-NUMBER-OF-ARGS CHECK-ARG-COUNT CHECK-MIN-ARGS EMIT-CONSTRUCTOR-LAMBDA-NAME EMIT-CONSTRUCTOR-LAMBDA-LIST EMIT-READ-FROM-STRING MAKE-CONSTRUCTOR MAKE-STATIC-INITIALIZER FINISH-CLASS DECLARE-FIELD SANITIZE SERIALIZE-INTEGER SERIALIZE-CHARACTER SERIALIZE-FLOAT SERIALIZE-DOUBLE SERIALIZE-STRING SERIALIZE-PACKAGE COMPILAND-EXTERNAL-CONSTANT-RESOURCE-NAME SERIALIZE-OBJECT SERIALIZE-SYMBOL EMIT-LOAD-EXTERNALIZED-OBJECT DECLARE-FUNCTION DECLARE-SETF-FUNCTION LOCAL-FUNCTION-CLASS-AND-FIELD DECLARE-LOCAL-FUNCTION DECLARE-OBJECT-AS-STRING DECLARE-LOAD-TIME-VALUE DECLARE-OBJECT COMPILE-CONSTANT INITIALIZE-UNARY-OPERATORS INSTALL-P2-HANDLER DEFINE-PREDICATE P2-PREDICATE COMPILE-FUNCTION-CALL-1 INITIALIZE-BINARY-OPERATORS COMPILE-BINARY-OPERATION COMPILE-FUNCTION-CALL-2 FIXNUM-OR-UNBOXED-VARIABLE-P EMIT-PUSH-INT EMIT-PUSH-LONG P2-EQ/NEQ EMIT-IFNE-FOR-EQL P2-EQL P2-MEMQ P2-MEMQL P2-GENSYM P2-GET P2-GETF P2-GETHASH P2-PUTHASH INLINE-OK PROCESS-ARGS EMIT-CALL-EXECUTE EMIT-CALL-THREAD-EXECUTE COMPILE-FUNCTION-CALL COMPILE-CALL P2-FUNCALL DUPLICATE-CLOSURE-ARRAY EMIT-LOAD-LOCAL-FUNCTION COMPILE-LOCAL-FUNCTION-CALL EMIT-NUMERIC-COMPARISON P2-NUMERIC-COMPARISON P2-TEST-HANDLER INITIALIZE-P2-TEST-HANDLERS NEGATE-JUMP-CONDITION EMIT-TEST-JUMP P2-TEST-PREDICATE P2-TEST-INSTANCEOF-PREDICATE P2-TEST-BIT-VECTOR-P P2-TEST-CHARACTERP P2-TEST-CONSTANTP P2-TEST-ENDP P2-TEST-EVENP P2-TEST-ODDP P2-TEST-FLOATP P2-TEST-INTEGERP P2-TEST-LISTP P2-TEST-MINUSP P2-TEST-PLUSP P2-TEST-ZEROP P2-TEST-NUMBERP P2-TEST-PACKAGEP P2-TEST-RATIONALP P2-TEST-REALP P2-TEST-SPECIAL-OPERATOR-P P2-TEST-SPECIAL-VARIABLE-P P2-TEST-SYMBOLP P2-TEST-CONSP P2-TEST-ATOM P2-TEST-FIXNUMP P2-TEST-STRINGP P2-TEST-VECTORP P2-TEST-SIMPLE-VECTOR-P COMPILE-TEST-FORM P2-TEST-NOT/NULL P2-TEST-CHAR= P2-TEST-EQ P2-TEST-OR P2-TEST-AND P2-TEST-NEQ P2-TEST-EQL P2-TEST-EQUALITY P2-TEST-SIMPLE-TYPEP P2-TEST-MEMQ P2-TEST-MEMQL P2-TEST-/= P2-TEST-NUMERIC-COMPARISON P2-IF COMPILE-MULTIPLE-VALUE-LIST COMPILE-MULTIPLE-VALUE-PROG1 COMPILE-MULTIPLE-VALUE-CALL UNUSED-VARIABLE CHECK-FOR-UNUSED-VARIABLES EMIT-NEW-CLOSURE-BINDING COMPILE-BINDING COMPILE-PROGN-BODY RESTORE-DYNAMIC-ENVIRONMENT SAVE-DYNAMIC-ENVIRONMENT P2-M-V-B-NODE PROPAGATE-VARS DERIVE-VARIABLE-REPRESENTATION ALLOCATE-VARIABLE-REGISTER EMIT-MOVE-TO-VARIABLE EMIT-PUSH-VARIABLE P2-LET-BINDINGS P2-LET*-BINDINGS P2-LET/LET*-NODE P2-LOCALLY-NODE P2-TAGBODY-NODE P2-GO P2-ATOM P2-INSTANCEOF-PREDICATE P2-BIT-VECTOR-P P2-CHARACTERP P2-CONSP P2-FIXNUMP P2-PACKAGEP P2-READTABLEP P2-SIMPLE-VECTOR-P P2-STRINGP P2-SYMBOLP P2-VECTORP P2-COERCE-TO-FUNCTION P2-BLOCK-NODE P2-RETURN-FROM EMIT-CAR/CDR P2-CAR P2-CDR P2-CONS COMPILE-PROGN P2-EVAL-WHEN P2-LOAD-TIME-VALUE P2-PROGV-NODE P2-QUOTE P2-RPLACD P2-SET-CAR/CDR COMPILE-DECLARE COMPILE-LOCAL-FUNCTION P2-FLET-NODE P2-LABELS-NODE P2-LAMBDA P2-FUNCTION P2-ASH P2-LOGAND P2-LOGIOR P2-LOGXOR P2-LOGNOT P2-%LDB P2-MOD P2-ZEROP P2-FIND-CLASS P2-VECTOR-PUSH-EXTEND P2-STD-SLOT-VALUE P2-SET-STD-SLOT-VALUE P2-STREAM-ELEMENT-TYPE P2-WRITE-8-BITS P2-READ-LINE DERIVE-TYPE-AREF DERIVE-TYPE-FIXNUMP DERIVE-TYPE-SETQ DERIVE-TYPE-LOGIOR/LOGXOR DERIVE-TYPE-LOGAND DERIVE-TYPE-LOGNOT DERIVE-TYPE-MOD DERIVE-TYPE-COERCE DERIVE-TYPE-COPY-SEQ DERIVE-TYPE-INTEGER-LENGTH DERIVE-TYPE-%LDB DERIVE-INTEGER-TYPE DERIVE-TYPE-NUMERIC-OP DERIVE-COMPILER-TYPES DERIVE-TYPE-MINUS DERIVE-TYPE-PLUS DERIVE-TYPE-TIMES DERIVE-TYPE-MAX DERIVE-TYPE-MIN DERIVE-TYPE-READ-CHAR DERIVE-TYPE-ASH DERIVE-TYPE DERIVE-COMPILER-TYPE P2-DELETE P2-LENGTH CONS-FOR-LIST/LIST* P2-LIST P2-LIST* COMPILE-NTH P2-TIMES P2-MIN/MAX P2-PLUS P2-MINUS P2-CHAR/SCHAR P2-SET-CHAR/SCHAR P2-SVREF P2-SVSET P2-TRUNCATE P2-ELT P2-AREF P2-ASET P2-STRUCTURE-REF P2-STRUCTURE-SET P2-NOT/NULL P2-NTHCDR P2-AND P2-OR P2-VALUES COMPILE-SPECIAL-REFERENCE COMPILE-VAR-REF P2-SET P2-SETQ P2-SXHASH P2-SYMBOL-NAME P2-SYMBOL-PACKAGE P2-SYMBOL-VALUE GENERATE-INSTANCEOF-TYPE-CHECK-FOR-VALUE GENERATE-TYPE-CHECK-FOR-VALUE P2-THE P2-TRULY-THE P2-CHAR-CODE P2-JAVA-JCLASS P2-JAVA-JCONSTRUCTOR P2-JAVA-JMETHOD P2-CHAR= P2-THREADS-SYNCHRONIZED-ON P2-CATCH-NODE P2-THROW P2-UNWIND-PROTECT-NODE COMPILE-FORM P2-COMPILAND-PROCESS-TYPE-DECLARATIONS P2-COMPILAND-UNBOX-VARIABLE ASSIGN-FIELD-NAME P2-COMPILAND COMPILE-TO-JVM-CLASS P2-WITH-INLINE-CODE COMPILE-1 MAKE-COMPILER-ERROR-FORM COMPILE-DEFUN NOTE-ERROR-CONTEXT HANDLE-WARNING HANDLE-COMPILER-ERROR %WITH-COMPILATION-UNIT %JVM-COMPILE JVM-COMPILE INITIALIZE-P2-HANDLERS) (("dump-class") READ-U1 READ-U2 READ-U4 LOOKUP-UTF8 READ-CONSTANT-POOL-ENTRY DUMP-CODE DUMP-CODE-ATTRIBUTE DUMP-EXCEPTIONS READ-ATTRIBUTE READ-INFO DUMP-CLASS) (("jvm-class-file") MAP-PRIMITIVE-TYPE PRETTY-CLASS PRETTY-TYPE %MAKE-JVM-CLASS-NAME JVM-CLASS-NAME-P MAKE-JVM-CLASS-NAME CLASS-ARRAY INTERNAL-FIELD-TYPE INTERNAL-FIELD-REF DESCRIPTOR DESCRIPTOR-STACK-EFFECT MAKE-POOL POOL-P MATCHING-INDEX-P FIND-POOL-ENTRY MAKE-CONSTANT CONSTANT-P PRINT-POOL-CONSTANT MAKE-CONSTANT-CLASS CONSTANT-CLASS-P %MAKE-CONSTANT-MEMBER-REF CONSTANT-MEMBER-REF-P MAKE-CONSTANT-FIELD-REF MAKE-CONSTANT-METHOD-REF MAKE-CONSTANT-INTERFACE-METHOD-REF MAKE-CONSTANT-STRING CONSTANT-STRING-P %MAKE-CONSTANT-FLOAT/INT CONSTANT-FLOAT/INT-P MAKE-CONSTANT-FLOAT MAKE-CONSTANT-INT %MAKE-CONSTANT-DOUBLE/LONG CONSTANT-DOUBLE/LONG-P MAKE-CONSTANT-DOUBLE MAKE-CONSTANT-LONG MAKE-CONSTANT-NAME/TYPE CONSTANT-NAME/TYPE-P PARSE-DESCRIPTOR MAKE-CONSTANT-UTF8 CONSTANT-UTF8-P POOL-ADD-CLASS POOL-ADD-FIELD-REF POOL-ADD-METHOD-REF POOL-ADD-INTERFACE-METHOD-REF POOL-ADD-STRING POOL-ADD-INT POOL-ADD-FLOAT POOL-ADD-LONG POOL-ADD-DOUBLE POOL-ADD-NAME/TYPE POOL-ADD-UTF8 MAKE-CLASS-FILE CLASS-FILE-P MAKE-CLASS-INTERFACE-FILE CLASS-ADD-FIELD CLASS-FIELD CLASS-ADD-METHOD CLASS-METHODS-BY-NAME CLASS-METHOD CLASS-REMOVE-METHOD CLASS-ADD-ATTRIBUTE CLASS-ADD-SUPERINTERFACE CLASS-ATTRIBUTE FINALIZE-INTERFACES FINALIZE-CLASS-FILE WRITE-U1 WRITE-U2 WRITE-U4 WRITE-S4 WRITE-ASCII WRITE-UTF8 WRITE-CLASS-FILE WRITE-CONSTANTS PRINT-ENTRY MAP-FLAGS %MAKE-FIELD FIELD-P MAKE-FIELD FIELD-ADD-ATTRIBUTE FIELD-ATTRIBUTE FINALIZE-FIELD WRITE-FIELD %MAKE-JVM-METHOD JVM-METHOD-P MAP-METHOD-NAME MAKE-JVM-METHOD METHOD-ADD-ATTRIBUTE METHOD-ADD-CODE METHOD-ENSURE-CODE METHOD-ATTRIBUTE FINALIZE-METHOD WRITE-METHOD MAKE-ATTRIBUTE ATTRIBUTE-P FINALIZE-ATTRIBUTES WRITE-ATTRIBUTES %MAKE-CODE-ATTRIBUTE CODE-ATTRIBUTE-P CODE-LABEL-OFFSET FINALIZE-CODE-ATTRIBUTE WRITE-CODE-ATTRIBUTE MAKE-CODE-ATTRIBUTE CODE-ADD-ATTRIBUTE CODE-ATTRIBUTE CODE-ADD-EXCEPTION-HANDLER MAKE-EXCEPTION EXCEPTION-P MAKE-CONSTANT-VALUE-ATTRIBUTE CONSTANT-VALUE-ATTRIBUTE-P MAKE-CHECKED-EXCEPTIONS-ATTRIBUTE CHECKED-EXCEPTIONS-ATTRIBUTE-P FINALIZE-CHECKED-EXCEPTIONS WRITE-CHECKED-EXCEPTIONS MAKE-DEPRECATED-ATTRIBUTE DEPRECATED-ATTRIBUTE-P SAVE-CODE-SPECIALS RESTORE-CODE-SPECIALS MAKE-SOURCE-FILE-ATTRIBUTE SOURCE-FILE-ATTRIBUTE-P FINALIZE-SOURCE-FILE WRITE-SOURCE-FILE MAKE-SYNTHETIC-ATTRIBUTE SYNTHETIC-ATTRIBUTE-P MAKE-LINE-NUMBERS-ATTRIBUTE LINE-NUMBERS-ATTRIBUTE-P MAKE-LINE-NUMBER LINE-NUMBER-P FINALIZE-LINE-NUMBERS WRITE-LINE-NUMBERS LINE-NUMBERS-ADD-LINE MAKE-LOCAL-VARIABLES-ATTRIBUTE LOCAL-VARIABLES-ATTRIBUTE-P MAKE-LOCAL-VARIABLE LOCAL-VARIABLE-P FINALIZE-LOCAL-VARIABLES WRITE-LOCAL-VARIABLES MAKE-ANNOTATIONS-ATTRIBUTE ANNOTATIONS-ATTRIBUTE-P MAKE-ANNOTATION ANNOTATION-P MAKE-ANNOTATION-ELEMENT ANNOTATION-ELEMENT-P MAKE-PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT-P MAKE-ENUM-VALUE-ANNOTATION-ELEMENT ENUM-VALUE-ANNOTATION-ELEMENT-P MAKE-ANNOTATION-VALUE-ANNOTATION-ELEMENT ANNOTATION-VALUE-ANNOTATION-ELEMENT-P MAKE-ARRAY-ANNOTATION-ELEMENT ARRAY-ANNOTATION-ELEMENT-P MAKE-RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE-P FINALIZE-ANNOTATIONS FINALIZE-ANNOTATION FINALIZE-ANNOTATION-ELEMENT WRITE-ANNOTATIONS WRITE-ANNOTATION WRITE-ANNOTATION-ELEMENT) (("jvm-instructions") U2 S1 S2 MAKE-JVM-OPCODE JVM-OPCODE-P %DEFINE-OPCODE OPCODE-NAME OPCODE-NUMBER OPCODE-SIZE OPCODE-STACK-EFFECT OPCODE-ARGS-SPEC %MAKE-INSTRUCTION INSTRUCTION-P MAKE-INSTRUCTION PRINT-INSTRUCTION INSTRUCTION-LABEL INST %%EMIT %EMIT LABEL ALOAD ASTORE BRANCH-P UNCONDITIONAL-CONTROL-TRANSFER-P LABEL-P FORMAT-INSTRUCTION-ARGS PRINT-CODE PRINT-CODE2 EXPAND-VIRTUAL-INSTRUCTIONS UNSUPPORTED-OPCODE INITIALIZE-RESOLVERS LOAD/STORE-RESOLVER RESOLVE-INSTRUCTION RESOLVE-INSTRUCTIONS ANALYZE-STACK-PATH ANALYZE-STACK ANALYZE-LOCALS DELETE-UNUSED-LABELS DELETE-UNREACHABLE-CODE LABEL-TARGET-INSTRUCTIONS OPTIMIZE-JUMPS OPTIMIZE-INSTRUCTION-SEQUENCES OPTIMIZE-CODE CODE-BYTES FINALIZE-CODE) (("jvm") INVOKE-CALLBACKS %MAKE-ABCL-CLASS-FILE ABCL-CLASS-FILE-P CLASS-NAME-FROM-FILESPEC MAKE-UNIQUE-CLASS-NAME MAKE-ABCL-CLASS-FILE MAKE-COMPILAND COMPILAND-P COMPILAND-SINGLE-VALUED-P DUMP-1-VARIABLE DUMP-VARIABLES MAKE-VARIABLE VARIABLE-P MAKE-VAR-REF VAR-REF-P UNBOXED-FIXNUM-VARIABLE FIND-VARIABLE FIND-VISIBLE-VARIABLE REPRESENTATION-SIZE ALLOCATE-REGISTER MAKE-LOCAL-FUNCTION LOCAL-FUNCTION-P FIND-LOCAL-FUNCTION MAKE-NODE NODE-P ADD-NODE-CHILD MAKE-CONTROL-TRANSFERRING-NODE CONTROL-TRANSFERRING-NODE-P %MAKE-TAGBODY-NODE TAGBODY-NODE-P MAKE-TAGBODY-NODE %MAKE-CATCH-NODE CATCH-NODE-P MAKE-CATCH-NODE %MAKE-BLOCK-NODE BLOCK-NODE-P MAKE-BLOCK-NODE %MAKE-JUMP-NODE JUMP-NODE-P MAKE-JUMP-NODE MAKE-BINDING-NODE BINDING-NODE-P %MAKE-LET/LET*-NODE LET/LET*-NODE-P MAKE-LET/LET*-NODE %MAKE-FLET-NODE FLET-NODE-P MAKE-FLET-NODE %MAKE-LABELS-NODE LABELS-NODE-P MAKE-LABELS-NODE %MAKE-M-V-B-NODE M-V-B-NODE-P MAKE-M-V-B-NODE %MAKE-PROGV-NODE PROGV-NODE-P MAKE-PROGV-NODE %MAKE-LOCALLY-NODE LOCALLY-NODE-P MAKE-LOCALLY-NODE %MAKE-PROTECTED-NODE PROTECTED-NODE-P MAKE-PROTECTED-NODE %MAKE-UNWIND-PROTECT-NODE UNWIND-PROTECT-NODE-P MAKE-UNWIND-PROTECT-NODE %MAKE-SYNCHRONIZED-NODE SYNCHRONIZED-NODE-P MAKE-SYNCHRONIZED-NODE FIND-BLOCK %FIND-ENCLOSED-BLOCKS FIND-ENCLOSED-BLOCKS SOME-NESTED-BLOCK NODE-CONSTANT-P BLOCK-REQUIRES-NON-LOCAL-EXIT-P NODE-OPSTACK-UNSAFE-P BLOCK-CREATES-RUNTIME-BINDINGS-P ENCLOSED-BY-RUNTIME-BINDINGS-CREATING-BLOCK-P ENCLOSED-BY-PROTECTED-BLOCK-P ENCLOSED-BY-ENVIRONMENT-SETTING-BLOCK-P ENVIRONMENT-REGISTER-TO-RESTORE MAKE-TAG TAG-P FIND-TAG PROCESS-IGNORE/IGNORABLE FINALIZE-GENERIC-FUNCTIONS) (("runtime-class") EMIT-INVOKESPECIAL PARSE-ANNOTATION PARSE-ANNOTATION-ELEMENT)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS))))
+(DOLIST (SYSTEM::FS (QUOTE ((("compiler-pass1") GENERATE-INLINE-EXPANSION PARSE-LAMBDA-LIST MATCH-LAMBDA-LIST MATCH-KEYWORD-AND-REST-ARGS EXPAND-FUNCTION-CALL-INLINE PROCESS-DECLARATIONS-FOR-VARS CHECK-NAME P1-BODY P1-DEFAULT P1-LET-VARS P1-LET*-VARS P1-LET/LET* P1-LOCALLY P1-M-V-B P1-BLOCK P1-CATCH P1-THREADS-SYNCHRONIZED-ON P1-UNWIND-PROTECT P1-RETURN-FROM P1-TAGBODY P1-GO SPLIT-DECLS REWRITE-AUX-VARS REWRITE-LAMBDA VALIDATE-FUNCTION-NAME CONSTRUCT-FLET/LABELS-FUNCTION P1-FLET P1-LABELS P1-FUNCALL P1-FUNCTION P1-LAMBDA P1-EVAL-WHEN P1-PROGV P1-QUOTE P1-SETQ P1-THE P1-TRULY-THE P1-THROW REWRITE-FUNCTION-CALL P1-FUNCTION-CALL %FUNCALL P1-VARIABLE-REFERENCE P1 INSTALL-P1-HANDLER INITIALIZE-P1-HANDLERS P1-COMPILAND) (("compiler-pass2") POOL-NAME POOL-NAME-AND-TYPE POOL-CLASS POOL-STRING POOL-FIELD POOL-METHOD POOL-INT POOL-FLOAT POOL-LONG POOL-DOUBLE ADD-EXCEPTION-HANDLER EMIT-PUSH-NIL EMIT-PUSH-NIL-SYMBOL EMIT-PUSH-T EMIT-PUSH-FALSE EMIT-PUSH-TRUE EMIT-PUSH-CONSTANT-INT EMIT-PUSH-CONSTANT-LONG EMIT-PUSH-CONSTANT-FLOAT EMIT-PUSH-CONSTANT-DOUBLE EMIT-DUP EMIT-SWAP EMIT-INVOKESTATIC PRETTY-JAVA-CLASS EMIT-INVOKEVIRTUAL EMIT-INVOKESPECIAL-INIT PRETTY-JAVA-TYPE EMIT-GETSTATIC EMIT-PUTSTATIC EMIT-GETFIELD EMIT-PUTFIELD EMIT-NEW EMIT-ANEWARRAY EMIT-CHECKCAST EMIT-INSTANCEOF TYPE-REPRESENTATION EMIT-UNBOX-BOOLEAN EMIT-UNBOX-CHARACTER CONVERT-REPRESENTATION COMMON-REPRESENTATION MAYBE-INITIALIZE-THREAD-VAR ENSURE-THREAD-VAR-INITIALIZED EMIT-PUSH-CURRENT-THREAD VARIABLE-LOCAL-P EMIT-LOAD-LOCAL-VARIABLE EMIT-PUSH-VARIABLE-NAME GENERATE-INSTANCEOF-TYPE-CHECK-FOR-VARIABLE FIND-TYPE-FOR-TYPE-CHECK GENERATE-TYPE-CHECK-FOR-VARIABLE MAYBE-GENERATE-TYPE-CHECK GENERATE-TYPE-CHECKS-FOR-VARIABLES GENERATE-ARG-COUNT-CHECK MAYBE-GENERATE-INTERRUPT-CHECK SINGLE-VALUED-P EMIT-CLEAR-VALUES MAYBE-EMIT-CLEAR-VALUES COMPILE-FORMS-AND-MAYBE-EMIT-CLEAR-VALUES LOAD-SAVED-OPERANDS SAVE-EXISTING-OPERANDS SAVE-OPERAND COMPILE-OPERAND EMIT-VARIABLE-OPERAND EMIT-REGISTER-OPERAND EMIT-THREAD-OPERAND EMIT-LOAD-EXTERNALIZED-OBJECT-OPERAND EMIT-UNBOX-FIXNUM EMIT-UNBOX-LONG EMIT-UNBOX-FLOAT EMIT-UNBOX-DOUBLE FIX-BOXING EMIT-MOVE-FROM-STACK EMIT-PUSH-REGISTER EMIT-INVOKE-METHOD CHECK-NUMBER-OF-ARGS CHECK-ARG-COUNT CHECK-MIN-ARGS EMIT-CONSTRUCTOR-LAMBDA-NAME EMIT-CONSTRUCTOR-LAMBDA-LIST EMIT-READ-FROM-STRING MAKE-CONSTRUCTOR MAKE-STATIC-INITIALIZER FINISH-CLASS DECLARE-FIELD SANITIZE SERIALIZE-INTEGER SERIALIZE-CHARACTER SERIALIZE-FLOAT SERIALIZE-DOUBLE SERIALIZE-STRING SERIALIZE-PACKAGE COMPILAND-EXTERNAL-CONSTANT-RESOURCE-NAME SERIALIZE-OBJECT SERIALIZE-SYMBOL EMIT-LOAD-EXTERNALIZED-OBJECT DECLARE-FUNCTION DECLARE-SETF-FUNCTION LOCAL-FUNCTION-CLASS-AND-FIELD DECLARE-LOCAL-FUNCTION DECLARE-OBJECT-AS-STRING DECLARE-LOAD-TIME-VALUE DECLARE-OBJECT COMPILE-CONSTANT INITIALIZE-UNARY-OPERATORS INSTALL-P2-HANDLER DEFINE-PREDICATE P2-PREDICATE COMPILE-FUNCTION-CALL-1 INITIALIZE-BINARY-OPERATORS COMPILE-BINARY-OPERATION COMPILE-FUNCTION-CALL-2 FIXNUM-OR-UNBOXED-VARIABLE-P EMIT-PUSH-INT EMIT-PUSH-LONG P2-EQ/NEQ EMIT-IFNE-FOR-EQL P2-EQL P2-MEMQ P2-MEMQL P2-GENSYM P2-GET P2-GETF P2-GETHASH P2-PUTHASH INLINE-OK PROCESS-ARGS EMIT-CALL-EXECUTE EMIT-CALL-THREAD-EXECUTE COMPILE-FUNCTION-CALL COMPILE-CALL P2-FUNCALL DUPLICATE-CLOSURE-ARRAY EMIT-LOAD-LOCAL-FUNCTION COMPILE-LOCAL-FUNCTION-CALL EMIT-NUMERIC-COMPARISON P2-NUMERIC-COMPARISON P2-TEST-HANDLER INITIALIZE-P2-TEST-HANDLERS NEGATE-JUMP-CONDITION EMIT-TEST-JUMP P2-TEST-PREDICATE P2-TEST-INSTANCEOF-PREDICATE P2-TEST-BIT-VECTOR-P P2-TEST-CHARACTERP P2-TEST-CONSTANTP P2-TEST-ENDP P2-TEST-EVENP P2-TEST-ODDP P2-TEST-FLOATP P2-TEST-INTEGERP P2-TEST-LISTP P2-TEST-MINUSP P2-TEST-PLUSP P2-TEST-ZEROP P2-TEST-NUMBERP P2-TEST-PACKAGEP P2-TEST-RATIONALP P2-TEST-REALP P2-TEST-SPECIAL-OPERATOR-P P2-TEST-SPECIAL-VARIABLE-P P2-TEST-SYMBOLP P2-TEST-CONSP P2-TEST-ATOM P2-TEST-FIXNUMP P2-TEST-STRINGP P2-TEST-VECTORP P2-TEST-SIMPLE-VECTOR-P COMPILE-TEST-FORM P2-TEST-NOT/NULL P2-TEST-CHAR= P2-TEST-EQ P2-TEST-OR P2-TEST-AND P2-TEST-NEQ P2-TEST-EQL P2-TEST-EQUALITY P2-TEST-SIMPLE-TYPEP P2-TEST-MEMQ P2-TEST-MEMQL P2-TEST-/= P2-TEST-NUMERIC-COMPARISON P2-IF COMPILE-MULTIPLE-VALUE-LIST COMPILE-MULTIPLE-VALUE-PROG1 COMPILE-MULTIPLE-VALUE-CALL UNUSED-VARIABLE CHECK-FOR-UNUSED-VARIABLES EMIT-NEW-CLOSURE-BINDING COMPILE-BINDING COMPILE-PROGN-BODY RESTORE-DYNAMIC-ENVIRONMENT SAVE-DYNAMIC-ENVIRONMENT P2-M-V-B-NODE PROPAGATE-VARS DERIVE-VARIABLE-REPRESENTATION ALLOCATE-VARIABLE-REGISTER EMIT-MOVE-TO-VARIABLE EMIT-PUSH-VARIABLE P2-LET-BINDINGS P2-LET*-BINDINGS P2-LET/LET*-NODE P2-LOCALLY-NODE P2-TAGBODY-NODE P2-GO P2-ATOM P2-INSTANCEOF-PREDICATE P2-BIT-VECTOR-P P2-CHARACTERP P2-CONSP P2-FIXNUMP P2-PACKAGEP P2-READTABLEP P2-SIMPLE-VECTOR-P P2-STRINGP P2-SYMBOLP P2-VECTORP P2-COERCE-TO-FUNCTION P2-BLOCK-NODE P2-RETURN-FROM EMIT-CAR/CDR P2-CAR P2-CDR P2-CONS COMPILE-PROGN P2-EVAL-WHEN P2-LOAD-TIME-VALUE P2-PROGV-NODE P2-QUOTE P2-RPLACD P2-SET-CAR/CDR COMPILE-DECLARE COMPILE-LOCAL-FUNCTION P2-FLET-NODE P2-LABELS-NODE P2-LAMBDA P2-FUNCTION P2-ASH P2-LOGAND P2-LOGIOR P2-LOGXOR P2-LOGNOT P2-%LDB P2-MOD P2-ZEROP P2-FIND-CLASS P2-VECTOR-PUSH-EXTEND P2-STD-SLOT-VALUE P2-SET-STD-SLOT-VALUE P2-STREAM-ELEMENT-TYPE P2-WRITE-8-BITS P2-READ-LINE DERIVE-TYPE-AREF DERIVE-TYPE-FIXNUMP DERIVE-TYPE-SETQ DERIVE-TYPE-LOGIOR/LOGXOR DERIVE-TYPE-LOGAND DERIVE-TYPE-LOGNOT DERIVE-TYPE-MOD DERIVE-TYPE-COERCE DERIVE-TYPE-COPY-SEQ DERIVE-TYPE-INTEGER-LENGTH DERIVE-TYPE-%LDB DERIVE-INTEGER-TYPE DERIVE-TYPE-NUMERIC-OP DERIVE-COMPILER-TYPES DERIVE-TYPE-MINUS DERIVE-TYPE-PLUS DERIVE-TYPE-TIMES DERIVE-TYPE-MAX DERIVE-TYPE-MIN DERIVE-TYPE-READ-CHAR DERIVE-TYPE-ASH DERIVE-TYPE DERIVE-COMPILER-TYPE P2-DELETE P2-LENGTH CONS-FOR-LIST/LIST* P2-LIST P2-LIST* COMPILE-NTH P2-TIMES P2-MIN/MAX P2-PLUS P2-MINUS P2-CHAR/SCHAR P2-SET-CHAR/SCHAR P2-SVREF P2-SVSET P2-TRUNCATE P2-ELT P2-AREF P2-ASET P2-STRUCTURE-REF P2-STRUCTURE-SET P2-NOT/NULL P2-NTHCDR P2-AND P2-OR P2-VALUES COMPILE-SPECIAL-REFERENCE COMPILE-VAR-REF P2-SET P2-SETQ P2-SXHASH P2-SYMBOL-NAME P2-SYMBOL-PACKAGE P2-SYMBOL-VALUE GENERATE-INSTANCEOF-TYPE-CHECK-FOR-VALUE GENERATE-TYPE-CHECK-FOR-VALUE P2-THE P2-TRULY-THE P2-CHAR-CODE P2-JAVA-JCLASS P2-JAVA-JCONSTRUCTOR P2-JAVA-JMETHOD P2-CHAR= P2-THREADS-SYNCHRONIZED-ON P2-CATCH-NODE P2-THROW P2-UNWIND-PROTECT-NODE COMPILE-FORM P2-COMPILAND-PROCESS-TYPE-DECLARATIONS P2-COMPILAND-UNBOX-VARIABLE ASSIGN-FIELD-NAME P2-COMPILAND COMPILE-TO-JVM-CLASS P2-WITH-INLINE-CODE COMPILE-1 MAKE-COMPILER-ERROR-FORM COMPILE-DEFUN NOTE-ERROR-CONTEXT HANDLE-WARNING HANDLE-COMPILER-ERROR %WITH-COMPILATION-UNIT %JVM-COMPILE JVM-COMPILE INITIALIZE-P2-HANDLERS) (("dump-class") READ-U1 READ-U2 READ-U4 LOOKUP-UTF8 READ-CONSTANT-POOL-ENTRY DUMP-CODE DUMP-CODE-ATTRIBUTE DUMP-EXCEPTIONS READ-ATTRIBUTE READ-INFO DUMP-CLASS) (("jvm-class-file") MAP-PRIMITIVE-TYPE PRETTY-CLASS PRETTY-TYPE %MAKE-JVM-CLASS-NAME JVM-CLASS-NAME-P MAKE-JVM-CLASS-NAME CLASS-ARRAY INTERNAL-FIELD-TYPE INTERNAL-FIELD-REF DESCRIPTOR DESCRIPTOR-STACK-EFFECT MAKE-POOL POOL-P MATCHING-INDEX-P FIND-POOL-ENTRY MAKE-CONSTANT CONSTANT-P PRINT-POOL-CONSTANT MAKE-CONSTANT-CLASS CONSTANT-CLASS-P %MAKE-CONSTANT-MEMBER-REF CONSTANT-MEMBER-REF-P MAKE-CONSTANT-FIELD-REF MAKE-CONSTANT-METHOD-REF MAKE-CONSTANT-INTERFACE-METHOD-REF MAKE-CONSTANT-STRING CONSTANT-STRING-P %MAKE-CONSTANT-FLOAT/INT CONSTANT-FLOAT/INT-P MAKE-CONSTANT-FLOAT MAKE-CONSTANT-INT %MAKE-CONSTANT-DOUBLE/LONG CONSTANT-DOUBLE/LONG-P MAKE-CONSTANT-DOUBLE MAKE-CONSTANT-LONG MAKE-CONSTANT-NAME/TYPE CONSTANT-NAME/TYPE-P PARSE-DESCRIPTOR MAKE-CONSTANT-UTF8 CONSTANT-UTF8-P POOL-ADD-CLASS POOL-ADD-FIELD-REF POOL-ADD-METHOD-REF POOL-ADD-INTERFACE-METHOD-REF POOL-ADD-STRING POOL-ADD-INT POOL-ADD-FLOAT POOL-ADD-LONG POOL-ADD-DOUBLE POOL-ADD-NAME/TYPE POOL-ADD-UTF8 MAKE-CLASS-FILE CLASS-FILE-P MAKE-CLASS-INTERFACE-FILE CLASS-ADD-FIELD CLASS-FIELD CLASS-ADD-METHOD CLASS-METHODS-BY-NAME CLASS-METHOD CLASS-REMOVE-METHOD CLASS-ADD-ATTRIBUTE CLASS-ADD-SUPERINTERFACE CLASS-ATTRIBUTE FINALIZE-INTERFACES FINALIZE-CLASS-FILE WRITE-U1 WRITE-U2 WRITE-U4 WRITE-S4 WRITE-ASCII WRITE-UTF8 WRITE-CLASS-FILE WRITE-CONSTANTS PRINT-ENTRY MAP-FLAGS %MAKE-FIELD FIELD-P MAKE-FIELD FIELD-ADD-ATTRIBUTE FIELD-ATTRIBUTE FINALIZE-FIELD WRITE-FIELD %MAKE-JVM-METHOD JVM-METHOD-P MAP-METHOD-NAME MAKE-JVM-METHOD METHOD-ADD-ATTRIBUTE METHOD-ADD-CODE METHOD-ENSURE-CODE METHOD-ATTRIBUTE FINALIZE-METHOD WRITE-METHOD MAKE-ATTRIBUTE ATTRIBUTE-P FINALIZE-ATTRIBUTES WRITE-ATTRIBUTES %MAKE-CODE-ATTRIBUTE CODE-ATTRIBUTE-P CODE-LABEL-OFFSET FINALIZE-CODE-ATTRIBUTE WRITE-CODE-ATTRIBUTE MAKE-CODE-ATTRIBUTE CODE-ADD-ATTRIBUTE CODE-ATTRIBUTE CODE-ADD-EXCEPTION-HANDLER MAKE-EXCEPTION EXCEPTION-P MAKE-CONSTANT-VALUE-ATTRIBUTE CONSTANT-VALUE-ATTRIBUTE-P MAKE-CHECKED-EXCEPTIONS-ATTRIBUTE CHECKED-EXCEPTIONS-ATTRIBUTE-P FINALIZE-CHECKED-EXCEPTIONS WRITE-CHECKED-EXCEPTIONS MAKE-DEPRECATED-ATTRIBUTE DEPRECATED-ATTRIBUTE-P SAVE-CODE-SPECIALS RESTORE-CODE-SPECIALS MAKE-SOURCE-FILE-ATTRIBUTE SOURCE-FILE-ATTRIBUTE-P FINALIZE-SOURCE-FILE WRITE-SOURCE-FILE MAKE-SYNTHETIC-ATTRIBUTE SYNTHETIC-ATTRIBUTE-P MAKE-LINE-NUMBERS-ATTRIBUTE LINE-NUMBERS-ATTRIBUTE-P MAKE-LINE-NUMBER LINE-NUMBER-P FINALIZE-LINE-NUMBERS WRITE-LINE-NUMBERS LINE-NUMBERS-ADD-LINE MAKE-LOCAL-VARIABLES-ATTRIBUTE LOCAL-VARIABLES-ATTRIBUTE-P MAKE-LOCAL-VARIABLE LOCAL-VARIABLE-P FINALIZE-LOCAL-VARIABLES WRITE-LOCAL-VARIABLES MAKE-ANNOTATIONS-ATTRIBUTE ANNOTATIONS-ATTRIBUTE-P MAKE-ANNOTATION ANNOTATION-P MAKE-ANNOTATION-ELEMENT ANNOTATION-ELEMENT-P MAKE-PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT PRIMITIVE-OR-STRING-ANNOTATION-ELEMENT-P MAKE-ENUM-VALUE-ANNOTATION-ELEMENT ENUM-VALUE-ANNOTATION-ELEMENT-P MAKE-ANNOTATION-VALUE-ANNOTATION-ELEMENT ANNOTATION-VALUE-ANNOTATION-ELEMENT-P MAKE-ARRAY-ANNOTATION-ELEMENT ARRAY-ANNOTATION-ELEMENT-P MAKE-RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE RUNTIME-VISIBLE-ANNOTATIONS-ATTRIBUTE-P FINALIZE-ANNOTATIONS FINALIZE-ANNOTATION FINALIZE-ANNOTATION-ELEMENT WRITE-ANNOTATIONS WRITE-ANNOTATION WRITE-ANNOTATION-ELEMENT) (("jvm-instructions") U2 S1 S2 MAKE-JVM-OPCODE JVM-OPCODE-P %DEFINE-OPCODE OPCODE-NAME OPCODE-NUMBER OPCODE-SIZE OPCODE-STACK-EFFECT OPCODE-ARGS-SPEC %MAKE-INSTRUCTION INSTRUCTION-P MAKE-INSTRUCTION PRINT-INSTRUCTION INSTRUCTION-LABEL INST %%EMIT %EMIT LABEL ALOAD ASTORE BRANCH-P UNCONDITIONAL-CONTROL-TRANSFER-P LABEL-P FORMAT-INSTRUCTION-ARGS PRINT-CODE PRINT-CODE2 EXPAND-VIRTUAL-INSTRUCTIONS UNSUPPORTED-OPCODE INITIALIZE-RESOLVERS LOAD/STORE-RESOLVER RESOLVE-INSTRUCTION RESOLVE-INSTRUCTIONS) (("jvm") INVOKE-CALLBACKS %MAKE-ABCL-CLASS-FILE ABCL-CLASS-FILE-P CLASS-NAME-FROM-FILESPEC MAKE-UNIQUE-CLASS-NAME MAKE-ABCL-CLASS-FILE MAKE-COMPILAND COMPILAND-P COMPILAND-SINGLE-VALUED-P DUMP-1-VARIABLE DUMP-VARIABLES MAKE-VARIABLE VARIABLE-P MAKE-VAR-REF VAR-REF-P UNBOXED-FIXNUM-VARIABLE FIND-VARIABLE FIND-VISIBLE-VARIABLE REPRESENTATION-SIZE ALLOCATE-REGISTER MAKE-LOCAL-FUNCTION LOCAL-FUNCTION-P FIND-LOCAL-FUNCTION MAKE-NODE NODE-P ADD-NODE-CHILD MAKE-CONTROL-TRANSFERRING-NODE CONTROL-TRANSFERRING-NODE-P %MAKE-TAGBODY-NODE TAGBODY-NODE-P MAKE-TAGBODY-NODE %MAKE-CATCH-NODE CATCH-NODE-P MAKE-CATCH-NODE %MAKE-BLOCK-NODE BLOCK-NODE-P MAKE-BLOCK-NODE %MAKE-JUMP-NODE JUMP-NODE-P MAKE-JUMP-NODE MAKE-BINDING-NODE BINDING-NODE-P %MAKE-LET/LET*-NODE LET/LET*-NODE-P MAKE-LET/LET*-NODE %MAKE-FLET-NODE FLET-NODE-P MAKE-FLET-NODE %MAKE-LABELS-NODE LABELS-NODE-P MAKE-LABELS-NODE %MAKE-M-V-B-NODE M-V-B-NODE-P MAKE-M-V-B-NODE %MAKE-PROGV-NODE PROGV-NODE-P MAKE-PROGV-NODE %MAKE-LOCALLY-NODE LOCALLY-NODE-P MAKE-LOCALLY-NODE %MAKE-PROTECTED-NODE PROTECTED-NODE-P MAKE-PROTECTED-NODE %MAKE-UNWIND-PROTECT-NODE UNWIND-PROTECT-NODE-P MAKE-UNWIND-PROTECT-NODE %MAKE-SYNCHRONIZED-NODE SYNCHRONIZED-NODE-P MAKE-SYNCHRONIZED-NODE FIND-BLOCK %FIND-ENCLOSED-BLOCKS FIND-ENCLOSED-BLOCKS SOME-NESTED-BLOCK NODE-CONSTANT-P BLOCK-REQUIRES-NON-LOCAL-EXIT-P NODE-OPSTACK-UNSAFE-P BLOCK-CREATES-RUNTIME-BINDINGS-P ENCLOSED-BY-RUNTIME-BINDINGS-CREATING-BLOCK-P ENCLOSED-BY-PROTECTED-BLOCK-P ENCLOSED-BY-ENVIRONMENT-SETTING-BLOCK-P ENVIRONMENT-REGISTER-TO-RESTORE MAKE-TAG TAG-P FIND-TAG PROCESS-IGNORE/IGNORABLE FINALIZE-GENERIC-FUNCTIONS) (("jvm-method" ANALYZE-STACK-PATH ANALYZE-STACK LABEL-TARGET-INSTRUCTIONS DELETE-UNUSED-LABELS OPTIMIZE-INSTRUCTION-SEQUENCES OPTIMIZE-JUMPS DELETE-UNREACHABLE-CODE OPTIMIZE-CODE CODE-BYTES FINALIZE-CODE)) (("runtime-class") EMIT-INVOKESPECIAL PARSE-ANNOTATION PARSE-ANNOTATION-ELEMENT)))) (FUNCALL (FUNCTION AUTOLOAD) (CDR SYSTEM::FS) (CAR (CAR SYSTEM::FS))))
;; MACROS
Modified: branches/typed-asm/abcl/src/org/armedbear/lisp/compile-system.lisp
==============================================================================
--- branches/typed-asm/abcl/src/org/armedbear/lisp/compile-system.lisp Sun Mar 3 13:57:41 2013 (r14417)
+++ branches/typed-asm/abcl/src/org/armedbear/lisp/compile-system.lisp Sun Mar 3 14:02:50 2013 (r14418)
@@ -294,6 +294,7 @@
(load (do-compile "source-transform.lisp"))
(load (do-compile "compiler-macro.lisp"))
(load (do-compile "jvm-instructions.lisp"))
+ (load (do-compile "jvm-method.lisp"))
(load (do-compile "setf.lisp"))
(load (do-compile "extensible-sequences-base.lisp"))
(load (do-compile "require.lisp"))
Modified: branches/typed-asm/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/typed-asm/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Mar 3 13:57:41 2013 (r14417)
+++ branches/typed-asm/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Mar 3 14:02:50 2013 (r14418)
@@ -43,6 +43,7 @@
(require "DUMP-FORM")
(require "JVM-INSTRUCTIONS")
(require "JVM-CLASS-FILE")
+ (require "JVM-METHOD")
(require "JVM")
(require "COMPILER-PASS1")
(require "JAVA"))
@@ -145,6 +146,7 @@
(5
(emit 'iconst_5))
(t
+ (assert (<= most-negative-fixnum n most-positive-fixnum))
(if (<= -128 n 127)
(emit 'bipush n)
(if (<= -32768 n 32767)
Modified: branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Mar 3 13:57:41 2013 (r14417)
+++ branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Mar 3 14:02:50 2013 (r14418)
@@ -467,11 +467,17 @@
(declaim (inline make-constant-float make-constant-int))
(defun make-constant-float (index value)
"Creates a `constant-float/int' structure instance containing a float."
- (%make-constant-float/int 4 index value))
+ (%make-constant-float/int 4 index (if (minusp value)
+ (1+ (logxor (- value) #xFFFFFFFF)) ;; convert to unsigned
+ value)))
(defun make-constant-int (index value)
"Creates a `constant-float/int' structure instance containing an int."
- (%make-constant-float/int 3 index value))
+ (assert (and t (<= most-negative-fixnum value most-positive-fixnum)))
+ (%make-constant-float/int 3 index
+ (if (minusp value)
+ (1+ (logxor (- value) #xFFFFFFFF)) ;; convert to unsigned
+ value)))
(defstruct (constant-double/long (:constructor
%make-constant-double/long (tag index value))
@@ -828,11 +834,12 @@
(finalize-attributes (class-file-attributes class) nil class))
-(declaim (inline write-u1 write-u2 write-u4 write-s4))
+(declaim (inline write-u1 write-u2 write-u4))
(defun write-u1 (n stream)
(declare (optimize speed))
(declare (type (unsigned-byte 8) n))
(declare (type stream stream))
+ (assert (<= #x0 n #xFF))
(write-8-bits n stream))
(defknown write-u2 (t t) t)
@@ -840,6 +847,7 @@
(declare (optimize speed))
(declare (type (unsigned-byte 16) n))
(declare (type stream stream))
+ (assert (<= #x0 n #xFFFF))
(write-8-bits (logand (ash n -8) #xFF) stream)
(write-8-bits (logand n #xFF) stream))
@@ -847,17 +855,10 @@
(defun write-u4 (n stream)
(declare (optimize speed))
(declare (type (unsigned-byte 32) n))
+ (assert (<= #x0 n #xFFFFFFFF))
(write-u2 (logand (ash n -16) #xFFFF) stream)
(write-u2 (logand n #xFFFF) stream))
-(declaim (ftype (function (t t) t) write-s4))
-(defun write-s4 (n stream)
- (declare (optimize speed))
- (cond ((minusp n)
- (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream))
- (t
- (write-u4 n stream))))
-
(declaim (ftype (function (t t t) t) write-ascii))
(defun write-ascii (string length stream)
(declare (type string string))
@@ -868,7 +869,6 @@
(declare (type (unsigned-byte 16) i))
(write-8-bits (char-code (char string i)) stream)))
-
(declaim (ftype (function (t t) t) write-utf8))
(defun write-utf8 (string stream)
(declare (optimize speed))
Modified: branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Sun Mar 3 13:57:41 2013 (r14417)
+++ branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Sun Mar 3 14:02:50 2013 (r14418)
@@ -783,323 +783,4 @@
-;; BYTE CODE ANALYSIS AND OPTIMIZATION
-
-(declaim (ftype (function (t t t) t) analyze-stack-path))
-(defun analyze-stack-path (code start-index depth)
- (declare (optimize speed))
- (declare (type fixnum start-index depth))
- (do* ((i start-index (1+ i))
- (limit (length code)))
- ((>= i limit))
- (declare (type fixnum i limit))
- (let* ((instruction (aref code i))
- (instruction-depth (instruction-depth instruction))
- (instruction-stack (instruction-stack instruction)))
- (declare (type fixnum instruction-stack))
- (when instruction-depth
- (unless (= (the fixnum instruction-depth)
- (the fixnum (+ depth instruction-stack)))
- (internal-compiler-error "Stack inconsistency detected ~
- in ~A at index ~D: ~
- found ~S, expected ~S."
- (if *current-compiland*
- (compiland-name *current-compiland*)
- "<unknown>")
- i instruction-depth
- (+ depth instruction-stack)))
- (return-from analyze-stack-path))
- (let ((opcode (instruction-opcode instruction)))
- (setf depth (+ depth instruction-stack))
- (setf (instruction-depth instruction) depth)
- (unless (<= 0 depth)
- (internal-compiler-error "Stack inconsistency detected ~
- in ~A at index ~D: ~
- negative depth ~S."
- (if *current-compiland*
- (compiland-name *current-compiland*)
- "<unknown>")
- i depth))
- (when (branch-p opcode)
- (let ((label (car (instruction-args instruction))))
- (declare (type symbol label))
- (analyze-stack-path code (symbol-value label) depth)))
- (when (unconditional-control-transfer-p opcode)
- ;; Current path ends.
- (return-from analyze-stack-path))))))
-
-(declaim (ftype (function (t) t) analyze-stack))
-(defun analyze-stack (code exception-entry-points)
- (declare (optimize speed))
- (let* ((code-length (length code)))
- (declare (type vector code))
- (dotimes (i code-length)
- (let* ((instruction (aref code i))
- (opcode (instruction-opcode instruction)))
- (when (eql opcode 202) ; LABEL
- (let ((label (car (instruction-args instruction))))
- (set label i)))
- (unless (instruction-stack instruction)
- (setf (instruction-stack instruction)
- (opcode-stack-effect opcode))
- (unless (instruction-stack instruction)
- (sys::%format t "no stack information for instruction ~D~%"
- (instruction-opcode instruction))
- (aver nil)))))
- (analyze-stack-path code 0 0)
- (dolist (entry-point exception-entry-points)
- ;; Stack depth is always 1 when handler is called.
- (analyze-stack-path code (symbol-value entry-point) 1))
- (let ((max-stack 0))
- (declare (type fixnum max-stack))
- (dotimes (i code-length)
- (let* ((instruction (aref code i))
- (instruction-depth (instruction-depth instruction)))
- (when instruction-depth
- (setf max-stack (max max-stack (the fixnum instruction-depth))))))
- max-stack)))
-
-(defun analyze-locals (code)
- (let ((code-length (length code))
- (max-local 0))
- (dotimes (i code-length max-local)
- (let* ((instruction (aref code i))
- (opcode (instruction-opcode instruction)))
- (setf max-local
- (max max-local
- (or (let ((opcode-register
- (jvm-opcode-register-used opcode)))
- (if (eq t opcode-register)
- (car (instruction-args instruction))
- opcode-register))
- 0)))))))
-
-(defun delete-unused-labels (code handler-labels)
- (declare (optimize speed))
- (let ((code (coerce code 'vector))
- (changed nil)
- (marker (gensym)))
- ;; Mark the labels that are actually branched to.
- (dotimes (i (length code))
- (let ((instruction (aref code i)))
- (when (branch-p (instruction-opcode instruction))
- (let ((label (car (instruction-args instruction))))
- (set label marker)))))
- ;; Add labels used for exception handlers.
- (dolist (label handler-labels)
- (set label marker))
- ;; Remove labels that are not used as branch targets.
- (dotimes (i (length code))
- (let ((instruction (aref code i)))
- (when (= (instruction-opcode instruction) 202) ; LABEL
- (let ((label (car (instruction-args instruction))))
- (declare (type symbol label))
- (unless (eq (symbol-value label) marker)
- (setf (aref code i) nil)
- (setf changed t))))))
- (values (if changed (delete nil code) code)
- changed)))
-
-(defun delete-unreachable-code (code)
- ;; Look for unreachable code after GOTO.
- (declare (optimize speed))
- (let* ((code (coerce code 'vector))
- (changed nil)
- (after-goto/areturn nil))
- (dotimes (i (length code))
- (declare (type (unsigned-byte 16) i))
- (let* ((instruction (aref code i))
- (opcode (instruction-opcode instruction)))
- (cond (after-goto/areturn
- (if (= opcode 202) ; LABEL
- (setf after-goto/areturn nil)
- ;; Unreachable.
- (progn
- (setf (aref code i) nil)
- (setf changed t))))
- ((unconditional-control-transfer-p opcode)
- (setf after-goto/areturn t)))))
- (values (if changed (delete nil code) code)
- changed)))
-
-
-(declaim (ftype (function (t) label-target-instructions) hash-labels))
-(defun label-target-instructions (code)
- (let ((ht (make-hash-table :test 'eq))
- (code (coerce code 'vector))
- (pending-labels '()))
- (dotimes (i (length code))
- (let ((instruction (aref code i)))
- (cond ((label-p instruction)
- (push (instruction-label instruction) pending-labels))
- (t
- ;; Not a label.
- (when pending-labels
- (dolist (label pending-labels)
- (setf (gethash label ht) instruction))
- (setf pending-labels nil))))))
- ht))
-
-(defun optimize-jumps (code)
- (declare (optimize speed))
- (let* ((code (coerce code 'vector))
- (ht (label-target-instructions code))
- (changed nil))
- (dotimes (i (length code))
- (let* ((instruction (aref code i))
- (opcode (and instruction (instruction-opcode instruction))))
- (when (and opcode (branch-p opcode))
- (let* ((target-label (car (instruction-args instruction)))
- (next-instruction (gethash1 target-label ht)))
- (when next-instruction
- (case (instruction-opcode next-instruction)
- ((167 200) ;; GOTO
- (setf (instruction-args instruction)
- (instruction-args next-instruction)
- changed t))
- (176 ; ARETURN
- (when (unconditional-control-transfer-p opcode)
- (setf (instruction-opcode instruction) 176
- (instruction-args instruction) nil
- changed t)))))))))
- (values code changed)))
-
-
-(defun optimize-instruction-sequences (code)
- (let* ((code (coerce code 'vector))
- (changed nil))
- (dotimes (i (1- (length code)))
- (let* ((this-instruction (aref code i))
- (this-opcode (and this-instruction
- (instruction-opcode this-instruction)))
- (labels-skipped-p nil)
- (next-instruction (do ((j (1+ i) (1+ j)))
- ((or (>= j (length code))
- (/= 202 ; LABEL
- (instruction-opcode (aref code j))))
- (when (< j (length code))
- (aref code j)))
- (setf labels-skipped-p t)))
- (next-opcode (and next-instruction
- (instruction-opcode next-instruction))))
- (case this-opcode
- (205 ; CLEAR-VALUES
- (when (eql next-opcode 205) ; CLEAR-VALUES
- (setf (aref code i) nil)
- (setf changed t)))
- (178 ; GETSTATIC
- (when (and (eql next-opcode 87) ; POP
- (not labels-skipped-p))
- (setf (aref code i) nil)
- (setf (aref code (1+ i)) nil)
- (setf changed t)))
- (176 ; ARETURN
- (when (eql next-opcode 176) ; ARETURN
- (setf (aref code i) nil)
- (setf changed t)))
- ((200 167) ; GOTO GOTO_W
- (when (and (or (eql next-opcode 202) ; LABEL
- (eql next-opcode 200) ; GOTO_W
- (eql next-opcode 167)) ; GOTO
- (eq (car (instruction-args this-instruction))
- (car (instruction-args next-instruction))))
- (setf (aref code i) nil)
- (setf changed t))))))
- (values (if changed (delete nil code) code)
- changed)))
-
-(defvar *enable-optimization* t)
-
-(defknown optimize-code (t t) t)
-(defun optimize-code (code handler-labels pool)
- (unless *enable-optimization*
- (format t "optimizations are disabled~%"))
- (when *enable-optimization*
- (when *compiler-debug*
- (format t "----- before optimization -----~%")
- (print-code code pool))
- (loop
- (let ((changed-p nil))
- (multiple-value-setq
- (code changed-p)
- (delete-unused-labels code handler-labels))
- (if changed-p
- (setf code (optimize-instruction-sequences code))
- (multiple-value-setq
- (code changed-p)
- (optimize-instruction-sequences code)))
- (if changed-p
- (setf code (optimize-jumps code))
- (multiple-value-setq
- (code changed-p)
- (optimize-jumps code)))
- (if changed-p
- (setf code (delete-unreachable-code code))
- (multiple-value-setq
- (code changed-p)
- (delete-unreachable-code code)))
- (unless changed-p
- (return))))
- (unless (vectorp code)
- (setf code (coerce code 'vector)))
- (when *compiler-debug*
- (sys::%format t "----- after optimization -----~%")
- (print-code code pool)))
- code)
-
-
-
-
-(defun code-bytes (code)
- (let ((length 0)
- labels ;; alist
- )
- (declare (type (unsigned-byte 16) length))
- ;; Pass 1: calculate label offsets and overall length.
- (dotimes (i (length code))
- (declare (type (unsigned-byte 16) i))
- (let* ((instruction (aref code i))
- (opcode (instruction-opcode instruction)))
- (if (= opcode 202) ; LABEL
- (let ((label (car (instruction-args instruction))))
- (set label length)
- (setf labels
- (acons label length labels)))
- (incf length (opcode-size opcode)))))
- ;; Pass 2: replace labels with calculated offsets.
- (let ((index 0))
- (declare (type (unsigned-byte 16) index))
- (dotimes (i (length code))
- (declare (type (unsigned-byte 16) i))
- (let ((instruction (aref code i)))
- (when (branch-p (instruction-opcode instruction))
- (let* ((label (car (instruction-args instruction)))
- (offset (- (the (unsigned-byte 16)
- (symbol-value (the symbol label)))
- index)))
- (assert (<= -32768 offset 32767))
- (setf (instruction-args instruction) (s2 offset))))
- (unless (= (instruction-opcode instruction) 202) ; LABEL
- (incf index (opcode-size (instruction-opcode instruction)))))))
- ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
- (let ((bytes (make-array length))
- (index 0))
- (declare (type (unsigned-byte 16) index))
- (dotimes (i (length code))
- (declare (type (unsigned-byte 16) i))
- (let ((instruction (aref code i)))
- (unless (= (instruction-opcode instruction) 202) ; LABEL
- (setf (svref bytes index) (instruction-opcode instruction))
- (incf index)
- (dolist (byte (instruction-args instruction))
- (setf (svref bytes index) byte)
- (incf index)))))
- (values bytes labels))))
-
-(defun finalize-code (code handler-labels optimize pool)
- (setf code (coerce (nreverse code) 'vector))
- (when optimize
- (setf code (optimize-code code handler-labels pool)))
- (resolve-instructions (expand-virtual-instructions code)))
-
(provide '#:jvm-instructions)
Added: branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-method.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/typed-asm/abcl/src/org/armedbear/lisp/jvm-method.lisp Sun Mar 3 14:02:50 2013 (r14418)
@@ -0,0 +1,479 @@
+;;; jvm-class-file.lisp
+;;;
+;;; Copyright (C) 2010 Erik Huelsmann
+;;; $Id: jvm-class-file.lisp 14096 2012-08-15 22:55:27Z ehuelsmann $
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+;;;
+;;; As a special exception, the copyright holders of this library give you
+;;; permission to link this library with independent modules to produce an
+;;; executable, regardless of the license terms of these independent
+;;; modules, and to copy and distribute the resulting executable under
+;;; terms of your choice, provided that you also meet, for each linked
+;;; independent module, the terms and conditions of the license of that
+;;; module. An independent module is a module which is not derived from
+;;; or based on this library. If you modify this library, you may extend
+;;; this exception to your version of the library, but you are not
+;;; obligated to do so. If you do not wish to do so, delete this
+;;; exception statement from your version.
+
+(in-package "JVM")
+
+(require '#:jvm-class-file)
+(require '#:jvm-instructions)
+
+(defvar *stack-effects*
+ (make-hash-table :test 'eq))
+
+(defun %define-stack-effect (names lambda)
+ (dolist (name (if (consp names) names (list names)))
+ (setf (gethash name *stack-effects*) lambda)))
+
+(defmacro define-stack-effect (opcode args &body body)
+ `(%define-stack-effect ',opcode (lambda ,args , at body)))
+
+(define-stack-effect (nop ineg lneg fneg dneg)
+ (instruction stack locals pool)
+ (declare (ignore instruction locals pool))
+ stack)
+
+(define-stack-effect aconst_null (instruction stack locals pool)
+ (declare (ignore instruction locals pool))
+ (cons :null stack))
+
+(define-stack-effect (iconst_m1 iconst_0 iconst_1
+ iconst_2 iconst_3
+ iconst_4 iconst_5
+ bipush sipush
+ iload_0 iload_1
+ iload_2 iload_3) (instruction stack locals pool)
+ (declare (ignore instruction locals))
+ (cons :int stack))
+
+(define-stack-effect iload (instruction stack locals pool)
+ (declare (ignore instruction locals))
+ (cons :int stack))
+
+(define-stack-effect (aload_0 aload_1 aload_2 aload_3)
+ (instruction stack locals pool)
+ (declare (ignore instruction locals))
+ (let* ((opcode (instruction-opcode instruction)))
+ (cons (car (nth (ecase opcode
+ ;; todo? use the instruction opcode register
+ (aload_0 0)
+ (aload_1 1)
+ (aload_2 2)
+ (aload_3 3))
+ locals))
+ stack)))
+
+(define-stack-effect (istore fstore astore istore_0 istore_1
+ istore_2 istore_3 fstore_0 fstore_1 fstore_2
+ fstore_3 astore_1 astore_2 astore_3 pop)
+ (instruction stack locals pool)
+ (declare (ignore instruction locals))
+ (cdr stack))
+
+(defun apply-stack-effect (context instruction)
+ (let ((handler (gethash (instruction-opcode instruction)
+ *stack-effects*)))
+ (if handler
+ (funcall handler instruction (method-context-stack context)
+ (method-context-locals context)
+ (class-pool (method-context-class context)))
+ ;; (method-context-stack context)
+ (assert (and "no opcode defined" nil)))))
+
+
+(defstruct (method-context (:constructor %make-method-context))
+ method ;; jvm method
+ code ;; list of lists with the first value the instruction,
+ ;; the second the stack after instruction execution and
+ ;; the third the state of the function locals during execution
+ class ;; jvm class
+ locals ;; a list of conses: each local occupies a cons of which
+ ;; the CAR is the type last declared (or NIL if none)
+ ;; and the CDR indicates availability (NIL or :AVAILABLE)
+ stack ;; a list of types pushed onto the stack
+ ;; either a symbol, indicating a primitive type, or
+ ;; a JVM-CLASS-NAME structure indicating a real class
+ )
+
+(defun make-method-context (class name return args &key (flags '(:public)))
+ (let ((frame (make-stack-frame-state))
+ (method (make-jvm-method name return args :flags flags)))
+ (dolist (arg args)
+ (allocate-local frame arg))
+ (%make-method-context :method method
+ :code (method-ensure-code method)
+ :class class
+ :frame-state frame)))
+
+(defun add-instruction (context instruction)
+ "Adds the instruction to the method, updating the context's stack."
+ (let ((stack (apply-stack-effect instruction (method-context-stack context))))
+ (push (list instruction stack (method-context-locals context)) code)
+ (setf (method-context-stack context) stack)))
+
+
+(defun allocate-local (context type)
+ (let ((allocated (find-if :available (method-context-locals context)
+ :key #'cdr))
+ (new-value (cons type)))
+ (setf (method-context-locals context)
+ (if allocated
+ (substitute (cons type) allocated
+ (method-context-locals context))
+ (append (method-context-locals context)
+ (list new-value))))
+ new-value))
+
+(defun declare-local-type (context local-number type)
+ (let ((local (nth local-number (method-context-locals frame))))
+ (assert local)
+ (setf (car local) type)))
+
+(defun free-local (context local-number)
+ (let ((local (nth local-number (method-context-locals frame))))
+ (assert local)
+ (setf (cdr local) :available)))
+
+
+
+
+
+
+
+
+(declaim (ftype (function (t t t) t) analyze-stack-path))
+(defun analyze-stack-path (code start-index depth)
+ (declare (optimize speed))
+ (declare (type fixnum start-index depth))
+ (do* ((i start-index (1+ i))
+ (limit (length code)))
+ ((>= i limit))
+ (declare (type fixnum i limit))
+ (let* ((instruction (aref code i))
+ (instruction-depth (instruction-depth instruction))
+ (instruction-stack (instruction-stack instruction)))
+ (declare (type fixnum instruction-stack))
+ (when instruction-depth
+ (unless (= (the fixnum instruction-depth)
+ (the fixnum (+ depth instruction-stack)))
+ (internal-compiler-error "Stack inconsistency detected ~
+ in ~A at index ~D: ~
+ found ~S, expected ~S."
+ (if *current-compiland*
+ (compiland-name *current-compiland*)
+ "<unknown>")
+ i instruction-depth
+ (+ depth instruction-stack)))
+ (return-from analyze-stack-path))
+ (let ((opcode (instruction-opcode instruction)))
+ (setf depth (+ depth instruction-stack))
+ (setf (instruction-depth instruction) depth)
+ (unless (<= 0 depth)
+ (internal-compiler-error "Stack inconsistency detected ~
+ in ~A at index ~D: ~
+ negative depth ~S."
+ (if *current-compiland*
+ (compiland-name *current-compiland*)
+ "<unknown>")
+ i depth))
+ (when (branch-p opcode)
+ (let ((label (car (instruction-args instruction))))
+ (declare (type symbol label))
+ (analyze-stack-path code (symbol-value label) depth)))
+ (when (unconditional-control-transfer-p opcode)
+ ;; Current path ends.
+ (return-from analyze-stack-path))))))
+
+(declaim (ftype (function (t) t) analyze-stack))
+(defun analyze-stack (code exception-entry-points)
+ (declare (optimize speed))
+ (let* ((code-length (length code)))
+ (declare (type vector code))
+ (dotimes (i code-length)
+ (let* ((instruction (aref code i))
+ (opcode (instruction-opcode instruction)))
+ (when (eql opcode 202) ; LABEL
+ (let ((label (car (instruction-args instruction))))
+ (set label i)))
+ (unless (instruction-stack instruction)
+ (setf (instruction-stack instruction)
+ (opcode-stack-effect opcode))
+ (unless (instruction-stack instruction)
+ (sys::%format t "no stack information for instruction ~D~%"
+ (instruction-opcode instruction))
+ (aver nil)))))
+ (analyze-stack-path code 0 0)
+ (dolist (entry-point exception-entry-points)
+ ;; Stack depth is always 1 when handler is called.
+ (analyze-stack-path code (symbol-value entry-point) 1))
+ (let ((max-stack 0))
+ (declare (type fixnum max-stack))
+ (dotimes (i code-length)
+ (let* ((instruction (aref code i))
+ (instruction-depth (instruction-depth instruction)))
+ (when instruction-depth
+ (setf max-stack (max max-stack (the fixnum instruction-depth))))))
+ max-stack)))
+
+;; (defun analyze-locals (code)
+;; (let ((code-length (length code))
+;; (max-local 0))
+;; (dotimes (i code-length max-local)
+;; (let* ((instruction (aref code i))
+;; (opcode (instruction-opcode instruction)))
+;; (setf max-local
+;; (max max-local
+;; (or (let ((opcode-register
+;; (jvm-opcode-register-used opcode)))
+;; (if (eq t opcode-register)
+;; (car (instruction-args instruction))
+;; opcode-register))
+;; 0)))))))
+
+
+
+
+(declaim (ftype (function (t) label-target-instructions) hash-labels))
+(defun label-target-instructions (code)
+ (let ((ht (make-hash-table :test 'eq))
+ (code (coerce code 'vector))
+ (pending-labels '()))
+ (dotimes (i (length code))
+ (let ((instruction (aref code i)))
+ (cond ((label-p instruction)
+ (push (instruction-label instruction) pending-labels))
+ (t
+ ;; Not a label.
+ (when pending-labels
+ (dolist (label pending-labels)
+ (setf (gethash label ht) instruction))
+ (setf pending-labels nil))))))
+ ht))
+
+
+
+(defun delete-unused-labels (code handler-labels)
+ (declare (optimize speed))
+ (let ((code (coerce code 'vector))
+ (changed nil)
+ (marker (gensym)))
+ ;; Mark the labels that are actually branched to.
+ (dotimes (i (length code))
+ (let ((instruction (aref code i)))
+ (when (branch-p (instruction-opcode instruction))
+ (let ((label (car (instruction-args instruction))))
+ (set label marker)))))
+ ;; Add labels used for exception handlers.
+ (dolist (label handler-labels)
+ (set label marker))
+ ;; Remove labels that are not used as branch targets.
+ (dotimes (i (length code))
+ (let ((instruction (aref code i)))
+ (when (= (instruction-opcode instruction) 202) ; LABEL
+ (let ((label (car (instruction-args instruction))))
+ (declare (type symbol label))
+ (unless (eq (symbol-value label) marker)
+ (setf (aref code i) nil)
+ (setf changed t))))))
+ (values (if changed (delete nil code) code)
+ changed)))
+
+
+(defun optimize-instruction-sequences (code)
+ (let* ((code (coerce code 'vector))
+ (changed nil))
+ (dotimes (i (1- (length code)))
+ (let* ((this-instruction (aref code i))
+ (this-opcode (and this-instruction
+ (instruction-opcode this-instruction)))
+ (labels-skipped-p nil)
+ (next-instruction (do ((j (1+ i) (1+ j)))
+ ((or (>= j (length code))
+ (/= 202 ; LABEL
+ (instruction-opcode (aref code j))))
+ (when (< j (length code))
+ (aref code j)))
+ (setf labels-skipped-p t)))
+ (next-opcode (and next-instruction
+ (instruction-opcode next-instruction))))
+ (case this-opcode
+ (205 ; CLEAR-VALUES
+ (when (eql next-opcode 205) ; CLEAR-VALUES
+ (setf (aref code i) nil)
+ (setf changed t)))
+ (178 ; GETSTATIC
+ (when (and (eql next-opcode 87) ; POP
+ (not labels-skipped-p))
+ (setf (aref code i) nil)
+ (setf (aref code (1+ i)) nil)
+ (setf changed t)))
+ (176 ; ARETURN
+ (when (eql next-opcode 176) ; ARETURN
+ (setf (aref code i) nil)
+ (setf changed t)))
+ ((200 167) ; GOTO GOTO_W
+ (when (and (or (eql next-opcode 202) ; LABEL
+ (eql next-opcode 200) ; GOTO_W
+ (eql next-opcode 167)) ; GOTO
+ (eq (car (instruction-args this-instruction))
+ (car (instruction-args next-instruction))))
+ (setf (aref code i) nil)
+ (setf changed t))))))
+ (values (if changed (delete nil code) code)
+ changed)))
+
+(defun optimize-jumps (code)
+ (declare (optimize speed))
+ (let* ((code (coerce code 'vector))
+ (ht (label-target-instructions code))
+ (changed nil))
+ (dotimes (i (length code))
+ (let* ((instruction (aref code i))
+ (opcode (and instruction (instruction-opcode instruction))))
+ (when (and opcode (branch-p opcode))
+ (let* ((target-label (car (instruction-args instruction)))
+ (next-instruction (gethash1 target-label ht)))
+ (when next-instruction
+ (case (instruction-opcode next-instruction)
+ ((167 200) ;; GOTO
+ (setf (instruction-args instruction)
+ (instruction-args next-instruction)
+ changed t))
+ (176 ; ARETURN
+ (when (unconditional-control-transfer-p opcode)
+ (setf (instruction-opcode instruction) 176
+ (instruction-args instruction) nil
+ changed t)))))))))
+ (values code changed)))
+
+(defun delete-unreachable-code (code)
+ ;; Look for unreachable code after GOTO.
+ (declare (optimize speed))
+ (let* ((code (coerce code 'vector))
+ (changed nil)
+ (after-goto/areturn nil))
+ (dotimes (i (length code))
+ (declare (type (unsigned-byte 16) i))
+ (let* ((instruction (aref code i))
+ (opcode (instruction-opcode instruction)))
+ (cond (after-goto/areturn
+ (if (= opcode 202) ; LABEL
+ (setf after-goto/areturn nil)
+ ;; Unreachable.
+ (progn
+ (setf (aref code i) nil)
+ (setf changed t))))
+ ((unconditional-control-transfer-p opcode)
+ (setf after-goto/areturn t)))))
+ (values (if changed (delete nil code) code)
+ changed)))
+
+(defvar *enable-optimization* t)
+
+(defknown optimize-code (t t) t)
+(defun optimize-code (code handler-labels pool)
+ (unless *enable-optimization*
+ (format t "optimizations are disabled~%"))
+ (when *enable-optimization*
+ (when *compiler-debug*
+ (format t "----- before optimization -----~%")
+ (print-code code pool))
+ (loop
+ (let ((changed-p nil))
+ (multiple-value-setq
+ (code changed-p)
+ (delete-unused-labels code handler-labels))
+ (if changed-p
+ (setf code (optimize-instruction-sequences code))
+ (multiple-value-setq
+ (code changed-p)
+ (optimize-instruction-sequences code)))
+ (if changed-p
+ (setf code (optimize-jumps code))
+ (multiple-value-setq
+ (code changed-p)
+ (optimize-jumps code)))
+ (if changed-p
+ (setf code (delete-unreachable-code code))
+ (multiple-value-setq
+ (code changed-p)
+ (delete-unreachable-code code)))
+ (unless changed-p
+ (return))))
+ (unless (vectorp code)
+ (setf code (coerce code 'vector)))
+ (when *compiler-debug*
+ (sys::%format t "----- after optimization -----~%")
+ (print-code code pool)))
+ code)
+
+(defun code-bytes (code)
+ (let ((length 0)
+ labels ;; alist
+ )
+ (declare (type (unsigned-byte 16) length))
+ ;; Pass 1: calculate label offsets and overall length.
+ (dotimes (i (length code))
+ (declare (type (unsigned-byte 16) i))
+ (let* ((instruction (aref code i))
+ (opcode (instruction-opcode instruction)))
+ (if (= opcode 202) ; LABEL
+ (let ((label (car (instruction-args instruction))))
+ (set label length)
+ (setf labels
+ (acons label length labels)))
+ (incf length (opcode-size opcode)))))
+ ;; Pass 2: replace labels with calculated offsets.
+ (let ((index 0))
+ (declare (type (unsigned-byte 16) index))
+ (dotimes (i (length code))
+ (declare (type (unsigned-byte 16) i))
+ (let ((instruction (aref code i)))
+ (when (branch-p (instruction-opcode instruction))
+ (let* ((label (car (instruction-args instruction)))
+ (offset (- (the (unsigned-byte 16)
+ (symbol-value (the symbol label)))
+ index)))
+ (assert (<= -32768 offset 32767))
+ (setf (instruction-args instruction) (s2 offset))))
+ (unless (= (instruction-opcode instruction) 202) ; LABEL
+ (incf index (opcode-size (instruction-opcode instruction)))))))
+ ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
+ (let ((bytes (make-array length))
+ (index 0))
+ (declare (type (unsigned-byte 16) index))
+ (dotimes (i (length code))
+ (declare (type (unsigned-byte 16) i))
+ (let ((instruction (aref code i)))
+ (unless (= (instruction-opcode instruction) 202) ; LABEL
+ (setf (svref bytes index) (instruction-opcode instruction))
+ (incf index)
+ (dolist (byte (instruction-args instruction))
+ (setf (svref bytes index) byte)
+ (incf index)))))
+ (values bytes labels))))
+
+(defun finalize-code (code handler-labels optimize pool)
+ (setf code (coerce (nreverse code) 'vector))
+ (when optimize
+ (setf code (optimize-code code handler-labels pool)))
+ (resolve-instructions (expand-virtual-instructions code)))
+
+
+(provide '#:jvm-method)
\ No newline at end of file
More information about the armedbear-cvs
mailing list