Changeset 12714
- Timestamp:
- 05/21/10 20:55:58 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r12711 r12714 479 479 (let* ((block-name (fdefinition-block-name name)) 480 480 (expansion (generate-inline-expansion block-name lambda-list body))) 481 ;; (format t "expansion = ~S~%" expansion)482 481 `(progn 483 482 (%defun ',name (lambda ,lambda-list (block ,block-name ,@body))) … … 905 904 (dolist (form forms) 906 905 (unless (single-valued-p form) 907 ;; (let ((*print-structure* nil))908 ;; (format t "Not single-valued: ~S~%" form))909 906 (ensure-thread-var-initialized) 910 907 (emit 'clear-values) … … 1242 1239 ;; ldc2_w 1243 1240 (define-resolver 20 (instruction) 1244 ;; (format t "resolving ldc2_w...~%")1245 1241 (let* ((args (instruction-args instruction))) 1246 ;; (format t "args = ~S~%" args)1247 1242 (unless (= (length args) 1) 1248 1243 (error "Wrong number of args for LDC2_W.")) 1249 ;; (if (> (car args) 255)1250 ;; (inst 19 (u2 (car args))) ; LDC_W1251 ;; (inst 18 args))))1252 1244 (inst 20 (u2 (car args))))) 1253 1245 … … 1298 1290 (t 1299 1291 (vector-push-extend (resolve-instruction instruction) vector))))))) 1300 1301 ;; (defconstant +branch-opcodes+1302 ;; '(153 ; IFEQ1303 ;; 154 ; IFNE1304 ;; 155 ; IFLT1305 ;; 156 ; IFGE1306 ;; 157 ; IFGT1307 ;; 158 ; IFLE1308 ;; 159 ; IF_ICMPEQ1309 ;; 160 ; IF_ICMPNE1310 ;; 161 ; IF_ICMPLT1311 ;; 162 ; IF_ICMPGE1312 ;; 163 ; IF_ICMPGT1313 ;; 164 ; IF_ICMPLE1314 ;; 165 ; IF_ACMPEQ1315 ;; 166 ; IF_ACMPNE1316 ;; 167 ; GOTO1317 ;; 168 ; JSR1318 ;; 198 ; IFNULL1319 ;; ))1320 1292 1321 1293 (declaim (ftype (function (t) t) branch-opcode-p)) … … 1393 1365 (when instruction-depth 1394 1366 (setf max-stack (max max-stack (the fixnum instruction-depth)))))) 1395 ;; (when *compiler-debug*1396 ;; (sys::%format t "compiland name = ~S~%" (compiland-name *current-compiland*))1397 ;; (sys::%format t "max-stack = ~D~%" max-stack)1398 ;; (sys::%format t "----- after stack analysis -----~%")1399 ;; (print-code))1400 1367 max-stack))) 1401 1368 … … 1428 1395 (declaim (ftype (function (t) boolean) label-p)) 1429 1396 (defun label-p (instruction) 1430 ;; (declare (optimize safety))1431 ;; (declare (type instruction instruction))1432 1397 (and instruction 1433 1398 (= (the fixnum (instruction-opcode (the instruction instruction))) 202))) … … 1435 1400 (declaim (ftype (function (t) t) instruction-label)) 1436 1401 (defun instruction-label (instruction) 1437 ;; (declare (optimize safety))1438 1402 (and instruction 1439 1403 (= (instruction-opcode (the instruction instruction)) 202) … … 1493 1457 (setf (aref code j) nil) 1494 1458 (setf changed t)) 1495 (;;(equal next-instruction instruction) 1496 (eq (car (instruction-args next-instruction)) 1459 ((eq (car (instruction-args next-instruction)) 1497 1460 (car (instruction-args instruction))) 1498 1461 ;; We've reached another GOTO to the same destination. … … 1939 1902 (emit 'return) 1940 1903 (finalize-code) 1941 ;;(optimize-code)1942 1904 (setf *code* (resolve-instructions *code*)) 1943 1905 (setf (method-max-stack constructor) (analyze-stack)) … … 2236 2198 (funcall dispatch-fn object) 2237 2199 (emit 'putstatic *this-class* field-name field-type)) 2238 (t ;; *file-compilation* and (not *declare-inline*)2200 (t 2239 2201 (let ((*code* *static-code*)) 2240 2202 (funcall dispatch-fn object) … … 3045 3007 form))) 3046 3008 3047 ;; (define-source-transform min (&whole form &rest args)3048 ;; (cond ((= (length args) 2)3049 ;; (let* ((arg1 (%car args))3050 ;; (arg2 (%cadr args))3051 ;; (sym1 (gensym))3052 ;; (sym2 (gensym)))3053 ;; `(let ((,sym1 ,arg1)3054 ;; (,sym2 ,arg2))3055 ;; (if (<= ,sym1 ,sym2) ,sym1 ,sym2))))3056 ;; (t3057 ;; form)))3058 3059 ;; (define-source-transform max (&whole form &rest args)3060 ;; (cond ((= (length args) 2)3061 ;; (let* ((arg1 (%car args))3062 ;; (arg2 (%cadr args))3063 ;; (sym1 (gensym))3064 ;; (sym2 (gensym)))3065 ;; `(let ((,sym1 ,arg1)3066 ;; (,sym2 ,arg2))3067 ;; (if (>= ,sym1 ,sym2) ,sym1 ,sym2))))3068 ;; (t3069 ;; form)))3070 3071 3009 (defknown p2-funcall (t t t) t) 3072 3010 (defun p2-funcall (form target representation) … … 3079 3017 (compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil) 3080 3018 (compile-call (cddr form)) 3081 ;; (case representation3082 ;; (:int (emit-unbox-fixnum))3083 ;; (:char (emit-unbox-character)))3084 3019 (fix-boxing representation nil) 3085 3020 (emit-move-from-stack target)) … … 3294 3229 (let ((ht (make-hash-table :test 'eq))) 3295 3230 (dolist (pair '( 3296 ;; (CHAR= p2-test-char=)3297 3231 (/= p2-test-/=) 3298 3232 (< p2-test-numeric-comparison) … … 3589 3523 3590 3524 (defun p2-test-equality (form) 3591 ;; (format t "p2-test-equality ~S~%" (%car form))3592 3525 (when (check-arg-count form 2) 3593 3526 (let* ((op (%car form)) 3594 3527 (translated-op (ecase op 3595 ;; (EQL "eql")3596 3528 (EQUAL "equal") 3597 3529 (EQUALP "equalp"))) … … 3798 3730 (t 3799 3731 (dolist (arg args) 3800 ;; (let ((type (derive-compiler-type arg)))3801 ;; (cond3802 ;; ((eq type 'BOOLEAN)3803 3732 (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) 3804 3733 (emit 'ifeq LABEL1) 3805 ;; )3806 ;; (t3807 ;; (compile-form arg 'stack nil)3808 ;; (maybe-emit-clear-values arg)3809 ;; (emit-push-nil)3810 ;; (emit 'if_acmpeq LABEL1))3811 ;; )3812 ;; )3813 3734 ) 3814 3735 (compile-form consequent target representation) … … 3820 3741 (defknown p2-if-not-and (t t t) t) 3821 3742 (defun p2-if-not-and (form target representation) 3822 ;; (format t "p2-if-not-and~%")3823 ;; (aver (eq (first form) 'IF))3824 ;; (aver (consp (second form)))3825 ;; (aver (memq (first (second form)) '(NOT NULL)))3826 ;; (aver (eq (first (second (second form))) 'AND))3827 3743 (let* ((inverted-test (second (second form))) 3828 3744 (consequent (third form)) … … 3830 3746 (LABEL1 (gensym)) 3831 3747 (LABEL2 (gensym))) 3832 ;; (aver (and (consp inverted-test) (eq (car inverted-test) 'AND)))3833 3748 (let* ((args (cdr inverted-test))) 3834 3749 (case (length args) … … 4007 3922 (declaim (ftype (function (t) t) compile-binding)) 4008 3923 (defun compile-binding (variable) 4009 ;; (dump-1-variable variable)4010 3924 (cond ((variable-register variable) 4011 3925 (astore (variable-register variable))) … … 4056 3970 (emit-push-current-thread) 4057 3971 (aload register) 4058 ;; (emit 'putfield +lisp-thread-class+ "lastSpecialBinding"4059 ;; +lisp-special-binding+)4060 3972 (emit-invokevirtual +lisp-thread-class+ "resetSpecialBindings" 4061 3973 (list +lisp-special-bindings-mark+) nil) … … 4064 3976 (defun save-dynamic-environment (register) 4065 3977 (emit-push-current-thread) 4066 ;; (emit 'getfield +lisp-thread-class+ "lastSpecialBinding"4067 ;; +lisp-special-binding+)4068 3978 (emit-invokevirtual +lisp-thread-class+ "markSpecialBindings" 4069 3979 nil +lisp-special-bindings-mark+) … … 4576 4486 (unless must-clear-values 4577 4487 (unless (single-valued-p subform) 4578 ;; (let ((*print-structure* nil))4579 ;; (format t "not single-valued: ~S~%" subform))4580 4488 (setf must-clear-values t)))))) 4581 4489 (label END-BLOCK) … … 4820 4728 (unless (enclosed-by-protected-block-p block) 4821 4729 (unless (compiland-single-valued-p *current-compiland*) 4822 ;; (format t "compiland not single-valued: ~S~%"4823 ;; (compiland-name *current-compiland*))4824 4730 (emit-clear-values)) 4825 4731 (compile-form result-form (block-target block) nil) … … 5226 5132 (constant-shift (fixnum-constant-value type2)) 5227 5133 (result-type (derive-compiler-type form))) 5228 ;; (format t "~&p2-ash type1 = ~S~%" type1)5229 ;; (format t "p2-ash type2 = ~S~%" type2)5230 ;; (format t "p2-ash result-type = ~S~%" result-type)5231 ;; (format t "p2-ash representation = ~S~%" representation)5232 5134 (cond ((and (integerp arg1) (integerp arg2)) 5233 5135 (compile-constant (ash arg1 arg2) target representation)) … … 5301 5203 (convert-representation :long representation)) 5302 5204 (t 5303 ;; (format t "p2-ash call to LispObject.ash(int)~%")5304 ;; (format t "p2-ash type1 = ~S type2 = ~S~%" type1 type2)5305 ;; (format t "p2-ash result-type = ~S~%" result-type)5306 5205 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 5307 5206 arg2 'stack :int) … … 5310 5209 (emit-move-from-stack target representation)) 5311 5210 (t 5312 ;; (format t "p2-ash full call~%")5313 5211 (compile-function-call form target representation))))) 5314 5212 5315 5213 (defknown p2-logand (t t t) t) 5316 5214 (defun p2-logand (form target representation) 5317 (let* ((args (cdr form)) 5318 ;; (len (length args)) 5319 ) 5320 ;; (cond ((= len 2) 5215 (let* ((args (cdr form))) 5321 5216 (case (length args) 5322 5217 (2 … … 5326 5221 (type2 (derive-compiler-type arg2)) 5327 5222 (result-type (derive-compiler-type form))) 5328 ;; (let ((*print-structure* nil))5329 ;; (format t "~&p2-logand arg1 = ~S~%" arg1)5330 ;; (format t "p2-logand arg2 = ~S~%" arg2))5331 ;; (format t "~&p2-logand type1 = ~S~%" type1)5332 ;; (format t "p2-logand type2 = ~S~%" type2)5333 ;; (format t "p2-logand result-type = ~S~%" result-type)5334 ;; (format t "p2-logand representation = ~S~%" representation)5335 5223 (cond ((and (integerp arg1) (integerp arg2)) 5336 5224 (compile-constant (logand arg1 arg2) target representation)) … … 5345 5233 arg2 nil nil)) 5346 5234 ((and (fixnum-type-p type1) (fixnum-type-p type2)) 5347 ;; (format t "p2-logand fixnum case~%")5348 5235 ;; Both arguments are fixnums. 5349 5236 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int … … 5380 5267 (emit-move-from-stack target representation)) 5381 5268 ((fixnum-type-p type2) 5382 ;; (format t "p2-logand LispObject.LOGAND(int) 1~%")5383 5269 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 5384 5270 arg2 'stack :int) … … 5387 5273 (emit-move-from-stack target representation)) 5388 5274 ((fixnum-type-p type1) 5389 ;; (format t "p2-logand LispObject.LOGAND(int) 2~%")5390 5275 ;; arg1 is a fixnum, but arg2 is not 5391 5276 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int … … 5397 5282 (emit-move-from-stack target representation)) 5398 5283 (t 5399 ;; (format t "p2-logand LispObject.LOGAND(LispObject)~%")5400 5284 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil 5401 5285 arg2 'stack nil) … … 5509 5393 (emit 'ixor)) 5510 5394 ((and (fixnum-type-p type1) (fixnum-type-p type2)) 5511 ;; (format t "p2-logxor case 2~%")5512 5395 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int 5513 5396 arg2 'stack :int) … … 5651 5534 (emit-move-from-stack target representation))))) 5652 5535 5653 ;; (defknown p2-integerp (t t t) t)5654 ;; (defun p2-integerp (form target representation)5655 ;; (unless (check-arg-count form 1)5656 ;; (compile-function-call form target representation)5657 ;; (return-from p2-integerp))5658 ;; (let ((arg (cadr form)))5659 ;; (compile-form arg 'stack nil)5660 ;; (maybe-emit-clear-values arg)5661 ;; (case representation5662 ;; (:boolean5663 ;; (emit-invokevirtual +lisp-object-class+ "integerp" nil "Z"))5664 ;; (t5665 ;; (emit-invokevirtual +lisp-object-class+ "INTEGERP" nil +lisp-object+)))5666 ;; (emit-move-from-stack target representation)))5667 5668 ;; (defknown p2-listp (t t t) t)5669 ;; (defun p2-listp (form target representation)5670 ;; (unless (check-arg-count form 1)5671 ;; (compile-function-call form target representation)5672 ;; (return-from p2-listp))5673 ;; (let ((arg (cadr form)))5674 ;; (compile-form arg 'stack nil)5675 ;; (maybe-emit-clear-values arg)5676 ;; (case representation5677 ;; (:boolean5678 ;; (emit-invokevirtual +lisp-object-class+ "listp" nil "Z"))5679 ;; (t5680 ;; (emit-invokevirtual +lisp-object-class+ "LISTP" nil +lisp-object+)))5681 ;; (emit-move-from-stack target representation)))5682 5683 5536 (defknown p2-zerop (t t t) t) 5684 5537 (define-inlined-function p2-zerop (form target representation) … … 5969 5822 5970 5823 (defun p2-read-line (form target representation) 5971 ;; (format t "p2-read-line~%")5972 5824 (let* ((args (cdr form)) 5973 5825 (len (length args))) … … 5977 5829 (type1 (derive-compiler-type arg1))) 5978 5830 (cond ((compiler-subtypep type1 'stream) 5979 ;; (format t "p2-read-line optimized case 1~%")5980 5831 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) 5981 5832 (emit 'checkcast +lisp-stream-class+) … … 5992 5843 (arg2 (%cadr args))) 5993 5844 (cond ((and (compiler-subtypep type1 'stream) (null arg2)) 5994 ;; (format t "p2-read-line optimized case 2~%")5995 5845 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) 5996 5846 (emit 'checkcast +lisp-stream-class+) … … 6098 5948 (setf result-high (if (and high1 high2) 6099 5949 (min high1 high2) 6100 (or high1 high2))) 6101 ;; (setf result-type (make-integer-type (list 'INTEGER result-low result-high))) 6102 ) 5950 (or high1 high2)))) 6103 5951 ((and low1 (>= low1 0)) 6104 5952 ;; arg1 is non-negative 6105 5953 (dformat t "arg1 is non-negative~%") 6106 5954 (setf result-low 0) 6107 (setf result-high high1) 6108 ;; (setf result-type (make-integer-type (list 'INTEGER 0 high1))) 6109 ) 5955 (setf result-high high1)) 6110 5956 ((and low2 (>= low2 0)) 6111 5957 ;; arg2 is non-negative 6112 5958 (dformat t "arg2 is non-negative~%") 6113 5959 (setf result-low 0) 6114 (setf result-high high2) 6115 ;; (setf result-type (make-integer-type (list 'INTEGER 0 high2))) 6116 )) 5960 (setf result-high high2))) 6117 5961 (dformat t "result-low = ~S~%" result-low) 6118 5962 (dformat t "result-high = ~S~%" result-high) … … 6439 6283 (READ-CHAR 6440 6284 (derive-type-read-char form)) 6441 ;; (SETQ6442 ;; (if (= (length form) 3)6443 ;; (derive-type (third form))6444 ;; t))6445 6285 ((THE TRULY-THE) 6446 6286 (second form)) … … 6671 6511 (emit-move-from-stack target representation)) 6672 6512 ((fixnump arg2) 6673 ;; (format t "p2-times case 3~%")6674 6513 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) 6675 6514 (emit-push-int arg2) … … 6754 6593 (result-type (derive-compiler-type form)) 6755 6594 (result-rep (type-representation result-type))) 6756 ;; (let ((*print-structure* nil))6757 ;; (format t "~&p2-plus arg1 = ~S~%" arg1)6758 ;; (format t "p2-plus arg2 = ~S~%" arg2))6759 ;; (format t "~&p2-plus type1 = ~S~%" type1)6760 ;; (format t "p2-plus type2 = ~S~%" type2)6761 ;; (format t "p2-plus result-type = ~S~%" result-type)6762 ;; (format t "p2-plus result-rep = ~S~%" result-rep)6763 ;; (format t "p2-plus representation = ~S~%" representation)6764 6595 (cond ((and (numberp arg1) (numberp arg2)) 6765 6596 (compile-constant (+ arg1 arg2) target representation)) … … 6936 6767 (type2 (derive-compiler-type arg2)) 6937 6768 (type3 (derive-compiler-type arg3))) 6938 ;; (format t "p2-set-char/schar type1 = ~S~%" type1)6939 ;; (format t "p2-set-char/schar type2 = ~S~%" type2)6940 ;; (format t "p2-set-char/schar type3 = ~S~%" type3)6941 6769 (cond ((and (< *safety* 3) 6942 6770 (or (null representation) (eq representation :char)) … … 6963 6791 (emit-move-from-stack target representation)))) 6964 6792 (t 6965 ;; (format t "p2-set-char/schar not optimized~%")6966 6793 (compile-function-call form target representation))))) 6967 6794 … … 7084 6911 (type3 (derive-compiler-type arg3)) 7085 6912 (*register* *register*) 7086 (value-register (unless (null target) (allocate-register))) 7087 ;; (array-derived-type t) 7088 ) 7089 7090 ;; (format t "p2-aset type3 = ~S~%" type3) 7091 7092 ;; (when (symbolp arg1) 7093 ;; (let ((variable (find-visible-variable (second form)))) 7094 ;; (when variable 7095 ;; (setf array-derived-type (derive-type variable))))) 6913 (value-register (unless (null target) (allocate-register)))) 7096 6914 ;; array 7097 6915 (compile-form arg1 'stack nil) … … 7099 6917 (compile-form arg2 'stack :int) 7100 6918 ;; value 7101 ;; (cond ((subtypep array-derived-type '(array (unsigned-byte 8)))7102 ;; (compile-form (fourth form) 'stack :int)7103 ;; (when value-register7104 ;; (emit 'dup)7105 ;; (emit-move-from-stack value-register :int)))7106 ;; (t7107 ;; (compile-form (fourth form) 'stack nil)7108 ;; (when value-register7109 ;; (emit 'dup)7110 ;; (emit-move-from-stack value-register nil))))7111 6919 (cond ((fixnum-type-p type3) 7112 6920 (compile-form arg3 'stack :int) … … 7119 6927 (emit 'dup) 7120 6928 (emit-move-from-stack value-register nil)))) 7121 7122 ;; (unless (and (single-valued-p (second form))7123 ;; (single-valued-p (third form))7124 ;; (single-valued-p (fourth form)))7125 ;; (emit-clear-values))7126 6929 (maybe-emit-clear-values arg1 arg2 arg3) 7127 7128 (cond (;;(subtypep array-derived-type '(array (unsigned-byte 8))) 7129 (fixnum-type-p type3) 6930 (cond ((fixnum-type-p type3) 7130 6931 (emit-invokevirtual +lisp-object-class+ "aset" '("I" "I") nil)) 7131 6932 (t … … 7499 7300 (return-from p2-setq (compile-form (p1 new-form) target representation)))) 7500 7301 ;; We're setting a special variable. 7501 ;; (let ((*print-structure* nil))7502 ;; (format t "p2-setq name = ~S value-form = ~S~%" name value-form))7503 7302 (cond ((and variable 7504 7303 (variable-binding-register variable) … … 7516 7315 (var-ref-p (third value-form)) 7517 7316 (eq (variable-name (var-ref-variable (third value-form))) name)) 7518 ;; (push thing *special*) => (setq *special* (cons thing *special*))7519 ;; (format t "compiling pushSpecial~%")7520 7317 (emit-push-current-thread) 7521 7318 (emit-load-externalized-object name) … … 7690 7487 (let ((type-form (second form)) 7691 7488 (value-form (third form))) 7692 ;; (let ((*print-structure* nil))7693 ;; (format t "p2-the type-form = ~S value-form = ~S~%" type-form value-form))7694 7489 (cond ((and (subtypep type-form 'FIXNUM) 7695 7490 (consp value-form) … … 8186 7981 '(:int :long)) 8187 7982 (emit-push-variable variable) 8188 ;; (sys::%format t "declared type: ~S~%" (variable-declared-type variable))8189 7983 (derive-variable-representation variable nil) 8190 ;; (sys::%format t "representation: ~S~%" (variable-representation variable))8191 7984 (when (< 1 (representation-size (variable-representation variable))) 8192 7985 (allocate-variable-register variable)) … … 8197 7990 (defknown p2-compiland (t) t) 8198 7991 (defun p2-compiland (compiland) 8199 ;; (format t "p2-compiland name = ~S~%" (compiland-name compiland))8200 7992 (let* ((p1-result (compiland-p1-result compiland)) 8201 7993 (class-file (compiland-class-file compiland))
Note: See TracChangeset
for help on using the changeset viewer.
