[armedbear-cvs] r13161 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Thu Jan 20 13:31:13 UTC 2011
Author: ehuelsmann
Date: Thu Jan 20 08:31:13 2011
New Revision: 13161
Log:
Final UNSAFE-P removal.
Modified:
branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original)
+++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Thu Jan 20 08:31:13 2011
@@ -1150,52 +1150,6 @@
(1- (length form))))
(list 'TRULY-THE (%cadr form) (p1 (%caddr form))))
-(defvar *pass2-unsafe-p-special-treatment-functions*
- '(
- logand
- logior
- lognot
- logxor
-)
-"The functions named in the list bound to this variable
-need to be rewritten if UNSAFE-P returns non-NIL for their
-argument list.
-
-All other function calls are handled by generic function calling
-in pass2, which accounts for OPSTACK unsafety itself.")
-
-
-
-
-(defknown unsafe-p (t) t)
-(defun unsafe-p (args)
- "Determines whether the args can cause 'stack unsafe situations'.
-Returns T if this is the case.
-
-When a 'stack unsafe situation' is encountered, the stack cannot
-be used for temporary storage of intermediary results. This happens
-because one of the forms in ARGS causes a local transfer of control
-- local GO instruction - which assumes an empty stack, or if one of
-the args causes a Java exception handler to be installed, which
-- when triggered - clears out the stack.
-"
- (cond ((node-p args)
- (unsafe-p (node-form args)))
- ((atom args)
- nil)
- (t
- (case (%car args)
- (QUOTE
- nil)
-;; (LAMBDA
-;; nil)
- ((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK)
- t)
- (t
- (dolist (arg args)
- (when (unsafe-p arg)
- (return t))))))))
-
(defknown p1-throw (t) t)
(defun p1-throw (form)
(list* 'THROW (mapcar #'p1 (cdr form))))
@@ -1207,34 +1161,12 @@
((and (eq op 'funcall) (listp (car args)) (eq (caar args) 'lambda))
;;(funcall (lambda (...) ...) ...)
(let ((op (car args)) (args (cdr args)))
- (expand-function-call-inline form (cadr op) (copy-tree (cddr op))
- args)))
+ (expand-function-call-inline form (cadr op) (copy-tree (cddr op))
+ args)))
((and (listp op) (eq (car op) 'lambda))
;;((lambda (...) ...) ...)
(expand-function-call-inline form (cadr op) (copy-tree (cddr op)) args))
- (t (if (and (member op *pass2-unsafe-p-special-treatment-functions*)
- (unsafe-p args))
- (let ((arg1 (car args)))
- (cond ((and (consp arg1) (eq (car arg1) 'GO))
- arg1)
- (t
- (let ((syms ())
- (lets ()))
- ;; Preserve the order of evaluation of the arguments!
- (dolist (arg args)
- (cond ((and (constantp arg)
- (not (node-p arg)))
- (push arg syms))
- ((and (consp arg) (eq (car arg) 'GO))
- (return-from rewrite-function-call
- (list 'LET* (nreverse lets) arg)))
- (t
- (let ((sym (gensym)))
- (push sym syms)
- (push (list sym arg) lets)))))
- (list 'LET* (nreverse lets)
- (list* (car form) (nreverse syms)))))))
- form)))))
+ (t form))))
(defknown p1-function-call (t) t)
(defun p1-function-call (form)
Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Jan 20 08:31:13 2011
@@ -4437,12 +4437,24 @@
(compile-forms-and-maybe-emit-clear-values arg1 nil nil
arg2 target representation))
((eql (fixnum-constant-value type2) -1)
- (compile-forms-and-maybe-emit-clear-values arg1 target representation
- arg2 nil nil))
+ (let ((target-register
+ (if (or (not (eq target 'stack))
+ (not (some-nested-block #'node-opstack-unsafe-p
+ (find-enclosed-blocks arg2))))
+ target
+ (allocate-register representation))))
+ (compile-form arg1 target-register representation)
+ (compile-form arg2 nil nil)
+ (when (and (eq target 'stack)
+ (not (eq target-register 'stack)))
+ (emit-push-register target-register))
+ (maybe-emit-clear-values arg1 arg2)))
((and (fixnum-type-p type1) (fixnum-type-p type2))
;; Both arguments are fixnums.
- (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
- arg2 'stack :int)
+ (with-operand-accumulation
+ ((compile-operand arg1 :int)
+ (compile-operand arg2 :int)
+ (maybe-emit-clear-values arg1 arg2)))
(emit 'iand)
(convert-representation :int representation)
(emit-move-from-stack target representation))
@@ -4451,15 +4463,19 @@
(and (fixnum-type-p type2)
(compiler-subtypep type2 'unsigned-byte)))
;; One of the arguments is a positive fixnum.
- (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
- arg2 'stack :int)
+ (with-operand-accumulation
+ ((compile-operand arg1 :int)
+ (compile-operand arg2 :int)
+ (maybe-emit-clear-values arg1 arg2)))
(emit 'iand)
(convert-representation :int representation)
(emit-move-from-stack target representation))
((and (java-long-type-p type1) (java-long-type-p type2))
;; Both arguments are longs.
- (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
- arg2 'stack :long)
+ (with-operand-accumulation
+ ((compile-operand arg1 :long)
+ (compile-operand arg2 :long)
+ (maybe-emit-clear-values arg1 arg2)))
(emit 'land)
(convert-representation :long representation)
(emit-move-from-stack target representation))
@@ -4468,29 +4484,37 @@
(and (java-long-type-p type2)
(compiler-subtypep type2 'unsigned-byte)))
;; One of the arguments is a positive long.
- (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
- arg2 'stack :long)
+ (with-operand-accumulation
+ ((compile-operand arg1 :long)
+ (compile-operand arg2 :long)
+ (maybe-emit-clear-values arg1 arg2)))
(emit 'land)
(convert-representation :long representation)
(emit-move-from-stack target representation))
((fixnum-type-p type2)
- (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
- arg2 'stack :int)
+ (with-operand-accumulation
+ ((compile-operand arg1 nil)
+ (compile-operand arg2 :int)
+ (maybe-emit-clear-values arg1 arg2)))
(emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+)
(fix-boxing representation result-type)
(emit-move-from-stack target representation))
((fixnum-type-p type1)
;; arg1 is a fixnum, but arg2 is not
- (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
- arg2 'stack nil)
+ (with-operand-accumulation
+ ((compile-operand arg1 :int)
+ (compile-operand arg2 nil)
+ (maybe-emit-clear-values arg1 arg2)))
;; swap args
(emit 'swap)
(emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+)
(fix-boxing representation result-type)
(emit-move-from-stack target representation))
(t
- (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
- arg2 'stack nil)
+ (with-operand-accumulation
+ ((compile-operand arg1 nil)
+ (compile-operand arg2 nil)
+ (maybe-emit-clear-values arg1 arg2)))
(emit-invokevirtual +lisp-object+ "LOGAND"
(lisp-object-arg-types 1) +lisp-object+)
(fix-boxing representation result-type)
@@ -4521,14 +4545,14 @@
type2 (derive-compiler-type arg2)
result-type (derive-compiler-type form))
(cond ((and (fixnum-constant-value type1) (fixnum-constant-value type2))
- (compile-forms-and-maybe-emit-clear-values arg1 nil nil
- arg2 nil nil)
(compile-constant (logior (fixnum-constant-value type1)
(fixnum-constant-value type2))
target representation))
((and (fixnum-type-p type1) (fixnum-type-p type2))
- (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
- arg2 'stack :int)
+ (with-operand-accumulation
+ ((compile-operand arg1 :int)
+ (compile-operand arg2 :int)
+ (maybe-emit-clear-values arg1 arg2)))
(emit 'ior)
(convert-representation :int representation)
(emit-move-from-stack target representation))
@@ -4536,16 +4560,32 @@
(compile-forms-and-maybe-emit-clear-values arg1 nil nil
arg2 target representation))
((and (eql (fixnum-constant-value type2) 0) (< *safety* 3))
- (compile-forms-and-maybe-emit-clear-values arg1 target representation
- arg2 nil nil))
+ (let ((target-register
+ (if (or (not (eq target 'stack))
+ (not (some-nested-block #'node-opstack-unsafe-p
+ (find-enclosed-blocks arg2))))
+ target
+ (allocate-register representation))))
+ (compile-form arg1 target-register representation)
+ (compile-form arg2 nil nil)
+ (when (and (eq target 'stack)
+ (not (eq target-register 'stack)))
+ (emit-push-register target-register))
+ (maybe-emit-clear-values arg1 arg2)))
((or (eq representation :long)
(and (java-long-type-p type1) (java-long-type-p type2)))
- (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
- arg2 'stack :long)
+ (with-operand-accumulation
+ ((compile-operand arg1 :long)
+ (compile-operand arg2 :long)
+ (maybe-emit-clear-values arg1 arg2)))
(emit 'lor)
(convert-representation :long representation)
(emit-move-from-stack target representation))
((fixnum-type-p type2)
+ (with-operand-accumulation
+ ((compile-operand arg1 nil)
+ (compile-operand arg2 :int)
+ (maybe-emit-clear-values arg1 arg2)))
(compile-forms-and-maybe-emit-clear-values arg1 'stack nil
arg2 'stack :int)
(emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+)
@@ -4553,16 +4593,20 @@
(emit-move-from-stack target representation))
((fixnum-type-p type1)
;; arg1 is of fixnum type, but arg2 is not
- (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
- arg2 'stack nil)
+ (with-operand-accumulation
+ ((compile-operand arg1 :int)
+ (compile-operand arg2 nil)
+ (maybe-emit-clear-values arg1 arg2)))
;; swap args
(emit 'swap)
(emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+)
(fix-boxing representation result-type)
(emit-move-from-stack target representation))
(t
- (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
- arg2 'stack nil)
+ (with-operand-accumulation
+ ((compile-operand arg1 nil)
+ (compile-operand arg2 nil)
+ (maybe-emit-clear-values arg1 arg2)))
(emit-invokevirtual +lisp-object+ "LOGIOR"
(lisp-object-arg-types 1) +lisp-object+)
(fix-boxing representation result-type)
@@ -4595,28 +4639,33 @@
(setf type1 (derive-compiler-type arg1)
type2 (derive-compiler-type arg2)
result-type (derive-compiler-type form))
- (cond ((eq representation :int)
- (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
- arg2 'stack :int)
- (emit 'ixor))
- ((and (fixnum-type-p type1) (fixnum-type-p type2))
- (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
- arg2 'stack :int)
+ (cond ((or (eq representation :int)
+ (and (fixnum-type-p type1) (fixnum-type-p type2)))
+ (with-operand-accumulation
+ ((compile-operand arg1 :int)
+ (compile-operand arg2 :int)
+ (maybe-emit-clear-values arg1 arg2)))
(emit 'ixor)
(convert-representation :int representation))
((and (java-long-type-p type1) (java-long-type-p type2))
- (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
- arg2 'stack :long)
+ (with-operand-accumulation
+ ((compile-operand arg1 :long)
+ (compile-operand arg2 :long)
+ (maybe-emit-clear-values arg1 arg2)))
(emit 'lxor)
(convert-representation :long representation))
((fixnum-type-p type2)
- (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
- arg2 'stack :int)
+ (with-operand-accumulation
+ ((compile-operand arg1 nil)
+ (compile-operand arg2 :int)
+ (maybe-emit-clear-values arg1 arg2)))
(emit-invokevirtual +lisp-object+ "LOGXOR" '(:int) +lisp-object+)
(fix-boxing representation result-type))
(t
- (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
- arg2 'stack nil)
+ (with-operand-accumulation
+ ((compile-operand arg1 nil)
+ (compile-operand arg2 nil)
+ (maybe-emit-clear-values arg1 arg2)))
(emit-invokevirtual +lisp-object+ "LOGXOR"
(lisp-object-arg-types 1) +lisp-object+)
(fix-boxing representation result-type)))
More information about the armedbear-cvs
mailing list