[armedbear-cvs] r13151 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sat Jan 15 20:51:14 UTC 2011
Author: ehuelsmann
Date: Sat Jan 15 15:51:11 2011
New Revision: 13151
Log:
No longer rewrite ordinary function calls for stack safety,
instead, let the code generator determine if it closes over
a block of unsafe code.
We need to remember per GO/RETURN-FROM to which block they
go in order to determine opstack safety.
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
branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.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 Sat Jan 15 15:51:11 2011
@@ -620,7 +620,8 @@
(defknown p1-return-from (t) t)
(defun p1-return-from (form)
(let* ((name (second form))
- (block (find-block name)))
+ (block (find-block name))
+ non-local-p)
(when (null block)
(compiler-error "RETURN-FROM ~S: no block named ~S is currently visible."
name name))
@@ -634,19 +635,22 @@
(let ((protected (enclosed-by-protected-block-p block)))
(dformat t "p1-return-from protected = ~S~%" protected)
(if protected
- (setf (block-non-local-return-p block) t)
+ (setf (block-non-local-return-p block) t
+ non-local-p t)
;; non-local GO's ensure environment restoration
;; find out about this local GO
(when (null (block-needs-environment-restoration block))
(setf (block-needs-environment-restoration block)
(enclosed-by-environment-setting-block-p block))))))
(t
- (setf (block-non-local-return-p block) t)))
+ (setf (block-non-local-return-p block) t
+ non-local-p t)))
(when (block-non-local-return-p block)
(dformat t "non-local return from block ~S~%" (block-name block)))
(let ((value-form (p1 (caddr form))))
(push value-form (block-return-value-forms block))
- (list 'RETURN-FROM name value-form))))
+ (make-jump-node (list 'RETURN-FROM name value-form)
+ non-local-p block))))
(defun p1-tagbody (form)
(let* ((block (make-tagbody-node))
@@ -695,12 +699,14 @@
(unless tag
(error "p1-go: tag not found: ~S" name))
(setf (tag-used tag) t)
- (let ((tag-block (tag-block tag)))
+ (let ((tag-block (tag-block tag))
+ non-local-p)
(cond ((eq (tag-compiland tag) *current-compiland*)
;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH?
(if (enclosed-by-protected-block-p tag-block)
(setf (tagbody-non-local-go-p tag-block) t
- (tag-used-non-locally tag) t)
+ (tag-used-non-locally tag) t
+ non-local-p t)
;; non-local GO's ensure environment restoration
;; find out about this local GO
(when (null (tagbody-needs-environment-restoration tag-block))
@@ -708,8 +714,9 @@
(enclosed-by-environment-setting-block-p tag-block)))))
(t
(setf (tagbody-non-local-go-p tag-block) t
- (tag-used-non-locally tag) t)))))
- form)
+ (tag-used-non-locally tag) t
+ non-local-p t)))
+ (make-jump-node form non-local-p tag-block tag))))
(defun validate-function-name (name)
(unless (or (symbolp name) (setf-function-name-p name))
@@ -1143,6 +1150,123 @@
(1- (length form))))
(list 'TRULY-THE (%cadr form) (p1 (%caddr form))))
+(defvar *pass2-unsafe-p-special-treatment-functions*
+ '(
+
+ constantp endp evenp floatp integerp listp minusp
+ numberp oddp plusp rationalp realp
+ ;; predicates not marked as such?
+ simple-vector-p
+ stringp
+ symbolp
+ vectorp
+ zerop
+ atom
+ consp
+ fixnump
+ packagep
+ readtablep
+ characterp
+ bit-vector-p
+ SIMPLE-TYPEP
+
+ declare
+ multiple-value-call
+ multiple-value-list
+ multiple-value-prog1
+ nth
+ progn
+
+ EQL EQUAL
+ + - / *
+ < < > >= = /=
+ ASH
+ AREF
+ RPLACA RPLACD
+ %ldb
+ and
+ aset
+ car
+ cdr
+ char
+ char-code
+ java:jclass
+ java:jconstructor
+ java:jmethod
+ char=
+ coerce-to-function
+ cons
+ sys::backq-cons
+ delete
+ elt
+ eq
+ eql
+ find-class
+ funcall
+ function
+ gensym
+ get
+ getf
+ gethash
+ gethash1
+ if
+ sys::%length
+ list
+ sys::backq-list
+ list*
+ sys::backq-list*
+ load-time-value
+ logand
+ logior
+ lognot
+ logxor
+ max
+ memq
+ memql
+ min
+ mod
+ neq
+ not
+ nthcdr
+ null
+ or
+ puthash
+ quote
+ read-line
+ rplacd
+ schar
+ set
+ set-car
+ set-cdr
+ set-char
+ set-schar
+ set-std-slot-value
+ setq
+ std-slot-value
+ stream-element-type
+ structure-ref
+ structure-set
+ svref
+ svset
+ sxhash
+ symbol-name
+ symbol-package
+ symbol-value
+ truncate
+ values
+ vector-push-extend
+ write-8-bits
+ with-inline-code)
+"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'.
@@ -1188,7 +1312,8 @@
((and (listp op) (eq (car op) 'lambda))
;;((lambda (...) ...) ...)
(expand-function-call-inline form (cadr op) (copy-tree (cddr op)) args))
- (t (if (unsafe-p 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)
@@ -1197,7 +1322,8 @@
(lets ()))
;; Preserve the order of evaluation of the arguments!
(dolist (arg args)
- (cond ((constantp arg)
+ (cond ((and (constantp arg)
+ (not (node-p arg)))
(push arg syms))
((and (consp arg) (eq (car arg) 'GO))
(return-from rewrite-function-call
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 Sat Jan 15 15:51:11 2011
@@ -598,6 +598,8 @@
(single-valued-p (second (node-form form))))
((catch-node-p form)
nil)
+ ((jump-node-p form)
+ (single-valued-p (node-form form)))
(t
(assert (not "SINGLE-VALUED-P unhandled NODE-P branch")))))
((var-ref-p form)
@@ -696,7 +698,7 @@
on the operand stack, if it's safe to do so. Otherwise stores the value
in a register"
(let ((unsafe (or *saved-operands*
- (some-nested-block #'block-opstack-unsafe-p
+ (some-nested-block #'node-opstack-unsafe-p
(find-enclosed-blocks form)))))
(when (and unsafe (null *saved-operands*))
(save-existing-operands))
@@ -1856,8 +1858,8 @@
(t
nil)))
-(defknown process-args (t) t)
-(defun process-args (args)
+(defknown process-args (t t) t)
+(defun process-args (args stack)
"Compiles forms specified as function call arguments.
The results are either accumulated on the stack or in an array
@@ -1865,27 +1867,76 @@
itself is *not* compiled by this function."
(when args
(let ((numargs (length args)))
- (let ((must-clear-values nil))
+ (let ((must-clear-values nil)
+ (unsafe-args (some-nested-block #'node-opstack-unsafe-p
+ (mapcan #'find-enclosed-blocks
+ args))))
(declare (type boolean must-clear-values))
- (cond ((<= numargs call-registers-limit)
+ (cond ((and unsafe-args
+ (<= numargs call-registers-limit))
+ (let ((*register* *register*)
+ operand-registers)
+ (dolist (stack-item stack)
+ (let ((register (allocate-register)))
+ (push register operand-registers)
+ (emit-move-from-stack register stack-item)))
+ (setf operand-registers (reverse operand-registers))
+ (dolist (arg args)
+ (push (allocate-register) operand-registers)
+ (compile-form arg (car operand-registers) nil)
+ (unless must-clear-values
+ (unless (single-valued-p arg)
+ (setf must-clear-values t))))
+ (dolist (register (nreverse operand-registers))
+ (aload register))))
+ ((<= numargs call-registers-limit)
(dolist (arg args)
(compile-form arg 'stack nil)
(unless must-clear-values
(unless (single-valued-p arg)
(setf must-clear-values t)))))
(t
- (emit-push-constant-int numargs)
- (emit-anewarray +lisp-object+)
- (let ((i 0))
- (dolist (arg args)
- (emit 'dup)
- (emit-push-constant-int i)
- (compile-form arg 'stack nil)
- (emit 'aastore) ; store value in array
- (unless must-clear-values
- (unless (single-valued-p arg)
- (setf must-clear-values t)))
- (incf i)))))
+ (let (;(*register* *register*) ;; ### FIXME: this doesn't work, but why not?
+ (array-register (allocate-register))
+ saved-stack)
+ (when unsafe-args
+ (dolist (stack-item stack)
+ (let ((register (allocate-register)))
+ (push register saved-stack)
+ (emit-move-from-stack register stack-item))))
+ (emit-push-constant-int numargs)
+ (emit-anewarray +lisp-object+)
+ ;; be operand stack safe by not accumulating
+ ;; any arguments on the stack.
+ ;;
+ ;; The overhead of storing+loading the array register
+ ;; at the beginning and ending is small: there are at
+ ;; least nine parameters to be calculated.
+ (astore array-register)
+ (let ((i 0))
+ (dolist (arg args)
+ (cond
+ ((not (some-nested-block #'node-opstack-unsafe-p
+ (find-enclosed-blocks arg)))
+ (aload array-register)
+ (emit-push-constant-int i)
+ (compile-form arg 'stack nil))
+ (t
+ (compile-form arg 'stack nil)
+ (aload array-register)
+ (emit 'swap)
+ (emit-push-constant-int i)
+ (emit 'swap)))
+ (emit 'aastore) ; store value in array
+ (unless must-clear-values
+ (unless (single-valued-p arg)
+ (setf must-clear-values t)))
+ (incf i))
+ (when unsafe-args
+ (mapcar #'emit-push-register
+ saved-stack
+ (reverse stack)))
+ (aload array-register)))))
(when must-clear-values
(emit-clear-values)))))
t)
@@ -1953,26 +2004,28 @@
(aload 0)))
(t
(emit-load-externalized-object op)))
- (process-args args)
+ (process-args args
+ (if (or (<= *speed* *debug*) *require-stack-frame*)
+ '(nil nil) '(nil)))
(if (or (<= *speed* *debug*) *require-stack-frame*)
(emit-call-thread-execute numargs)
(emit-call-execute numargs))
(fix-boxing representation (derive-compiler-type form))
(emit-move-from-stack target representation))))
-(defun compile-call (args)
+(defun compile-call (args stack)
"Compiles a function call.
Depending on the `*speed*' and `*debug*' settings, a stack frame
is registered (or not)."
(let ((numargs (length args)))
(cond ((> *speed* *debug*)
- (process-args args)
+ (process-args args stack)
(emit-call-execute numargs))
(t
(emit-push-current-thread)
(emit 'swap) ; Stack: thread function
- (process-args args)
+ (process-args args (list* (car stack) nil (cdr stack)))
(emit-call-thread-execute numargs)))))
(define-source-transform funcall (&whole form fun &rest args)
@@ -2039,7 +2092,7 @@
(when (> *debug* *speed*)
(return-from p2-funcall (compile-function-call form target representation)))
(compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil)
- (compile-call (cddr form))
+ (compile-call (cddr form) '(nil))
(fix-boxing representation nil)
(emit-move-from-stack target))
@@ -2104,7 +2157,7 @@
(emit-invokestatic +lisp+ "makeCompiledClosure"
(list +lisp-object+ +closure-binding-array+)
+lisp-object+)))))
- (process-args args)
+ (process-args args '(nil))
(emit-call-execute (length args))
(fix-boxing representation nil)
(emit-move-from-stack target representation))
@@ -3003,8 +3056,8 @@
)
(defun restore-environment-and-make-handler (register label-START)
- (let ((label-END (gensym))
- (label-EXIT (gensym)))
+ (let ((label-END (gensym "U"))
+ (label-EXIT (gensym "E")))
(emit 'goto label-EXIT)
(label label-END)
(restore-dynamic-environment register)
@@ -3021,7 +3074,7 @@
(vars (second form))
(bind-special-p nil)
(variables (m-v-b-vars block))
- (label-START (gensym)))
+ (label-START (gensym "F")))
(dolist (variable variables)
(let ((special-p (variable-special-p variable)))
(cond (special-p
@@ -3424,7 +3477,7 @@
(form (let-form block))
(*visible-variables* *visible-variables*)
(specialp nil)
- (label-START (gensym)))
+ (label-START (gensym "F")))
;; Walk the variable list looking for special bindings and unused lexicals.
(dolist (variable (let-vars block))
(cond ((variable-special-p variable)
@@ -3471,10 +3524,10 @@
(*register* *register*)
(form (tagbody-form block))
(body (cdr form))
- (BEGIN-BLOCK (gensym))
- (END-BLOCK (gensym))
- (RETHROW (gensym))
- (EXIT (gensym))
+ (BEGIN-BLOCK (gensym "F"))
+ (END-BLOCK (gensym "U"))
+ (RETHROW (gensym "T"))
+ (EXIT (gensym "E"))
(must-clear-values nil)
(specials-register (when (tagbody-non-local-go-p block)
(allocate-register))))
@@ -3511,8 +3564,8 @@
(emit 'goto EXIT)
(when (tagbody-non-local-go-p block)
; We need a handler to catch non-local GOs.
- (let* ((HANDLER (gensym))
- (EXTENT-EXIT-HANDLER (gensym))
+ (let* ((HANDLER (gensym "H"))
+ (EXTENT-EXIT-HANDLER (gensym "HE"))
(*register* *register*)
(go-register (allocate-register))
(tag-register (allocate-register)))
@@ -3565,9 +3618,11 @@
(defun p2-go (form target representation)
;; FIXME What if we're called with a non-NIL representation?
(declare (ignore target representation))
- (let* ((name (cadr form))
- (tag (find-tag name))
- (tag-block (when tag (tag-block tag))))
+ (let* ((node form)
+ (form (node-form form))
+ (name (cadr form))
+ (tag (jump-target-tag node))
+ (tag-block (when tag (jump-target-block node))))
(unless tag
(error "p2-go: tag not found: ~S" name))
(when (and (eq (tag-compiland tag) *current-compiland*)
@@ -3671,8 +3726,8 @@
(aver (block-node-p block)))
(let* ((*blocks* (cons block *blocks*))
(*register* *register*)
- (BEGIN-BLOCK (gensym))
- (END-BLOCK (gensym))
+ (BEGIN-BLOCK (gensym "F"))
+ (END-BLOCK (gensym "U"))
(BLOCK-EXIT (block-exit block))
(specials-register (when (block-non-local-return-p block)
(allocate-register))))
@@ -3695,8 +3750,8 @@
(when (block-non-local-return-p block)
;; We need a handler to catch non-local RETURNs.
(emit 'goto BLOCK-EXIT) ; Jump over handler, when inserting one
- (let ((HANDLER (gensym))
- (EXTENT-EXIT-HANDLER (gensym))
+ (let ((HANDLER (gensym "H"))
+ (EXTENT-EXIT-HANDLER (gensym "HE"))
(THIS-BLOCK (gensym)))
(label HANDLER)
;; The Return object is on the runtime stack. Stack depth is 1.
@@ -3731,9 +3786,11 @@
(defun p2-return-from (form target representation)
;; FIXME What if we're called with a non-NIL representation?
(declare (ignore target representation))
- (let* ((name (second form))
+ (let* ((node form)
+ (form (node-form form))
+ (name (second form))
(result-form (third form))
- (block (find-block name)))
+ (block (jump-target-block node)))
(when (null block)
(error "No block named ~S is currently visible." name))
(let ((compiland *current-compiland*))
@@ -3823,7 +3880,7 @@
(*register* *register*)
(environment-register
(setf (progv-environment-register block) (allocate-register)))
- (label-START (gensym)))
+ (label-START (gensym "F")))
(with-operand-accumulation
((compile-operand symbols-form nil)
(compile-operand values-form nil))
@@ -6506,9 +6563,9 @@
(let* ((form (synchronized-form block))
(*register* *register*)
(object-register (allocate-register))
- (BEGIN-PROTECTED-RANGE (gensym))
- (END-PROTECTED-RANGE (gensym))
- (EXIT (gensym)))
+ (BEGIN-PROTECTED-RANGE (gensym "F"))
+ (END-PROTECTED-RANGE (gensym "U"))
+ (EXIT (gensym "E")))
(compile-form (cadr form) 'stack nil)
(emit-invokevirtual +lisp-object+ "lockableInstance" nil
+java-object+) ; value to synchronize
@@ -6542,12 +6599,12 @@
(return-from p2-catch-node))
(let* ((*register* *register*)
(tag-register (allocate-register))
- (BEGIN-PROTECTED-RANGE (gensym))
- (END-PROTECTED-RANGE (gensym))
- (THROW-HANDLER (gensym))
+ (BEGIN-PROTECTED-RANGE (gensym "F"))
+ (END-PROTECTED-RANGE (gensym "U"))
+ (THROW-HANDLER (gensym "H"))
(RETHROW (gensym))
(DEFAULT-HANDLER (gensym))
- (EXIT (gensym))
+ (EXIT (gensym "E"))
(specials-register (allocate-register)))
(compile-form (second form) tag-register nil) ; Tag.
(emit-push-current-thread)
@@ -6637,10 +6694,10 @@
(result-register (allocate-register))
(values-register (allocate-register))
(specials-register (allocate-register))
- (BEGIN-PROTECTED-RANGE (gensym))
- (END-PROTECTED-RANGE (gensym))
- (HANDLER (gensym))
- (EXIT (gensym)))
+ (BEGIN-PROTECTED-RANGE (gensym "F"))
+ (END-PROTECTED-RANGE (gensym "U"))
+ (HANDLER (gensym "H"))
+ (EXIT (gensym "E")))
;; Make sure there are no leftover multiple return values from previous calls.
(emit-clear-values)
@@ -6729,6 +6786,15 @@
(compile-var-ref form target representation))
((node-p form)
(cond
+ ((jump-node-p form)
+ (let ((op (car (node-form form))))
+ (cond
+ ((eq op 'go)
+ (p2-go form target representation))
+ ((eq op 'return-from)
+ (p2-return-from form target representation))
+ (t
+ (assert (not "jump-node: can't happen"))))))
((block-node-p form)
(p2-block-node form target representation))
((let/let*-node-p form)
@@ -6863,7 +6929,7 @@
(*thread* nil)
(*initialize-thread-var* nil)
- (label-START (gensym)))
+ (label-START (gensym "F")))
(class-add-method class-file method)
Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp (original)
+++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp Sat Jan 15 15:51:11 2011
@@ -483,6 +483,21 @@
(add-node-child *block* block)
block))
+(defstruct (jump-node (:conc-name jump-)
+ (:include node)
+ (:constructor
+ %make-jump-node (non-local-p target-block target-tag)))
+ non-local-p
+ target-block
+ target-tag)
+(defun make-jump-node (form non-local-p target-block &optional target-tag)
+ (let ((node (%make-jump-node non-local-p target-block target-tag)))
+ ;; Don't push into compiland blocks, as this as a node rather than a block
+ (setf (node-form node) form)
+ (add-node-child *block* node)
+ node))
+
+
;; binding blocks: LET, LET*, FLET, LABELS, M-V-B, PROGV, LOCALLY
;;
;; Binding blocks can carry references to local (optionally special) variable bindings,
@@ -619,11 +634,14 @@
(when *blocks*
;; when the innermost enclosing block doesn't have node-children,
;; there's really nothing to search for.
- (when (null (node-children (car *blocks*)))
- (return-from find-enclosed-blocks)))
+ (let ((first-enclosing-block (car *blocks*)))
+ (when (and (eq *current-compiland*
+ (node-compiland first-enclosing-block))
+ (null (node-children first-enclosing-block)))
+ (return-from find-enclosed-blocks))))
(%find-enclosed-blocks form))
-
+
(defun some-nested-block (predicate blocks)
"Applies `predicate` recursively to the `blocks` and its children,
@@ -661,10 +679,15 @@
(catch-node-p object)
(synchronized-node-p object)))
-(defun block-opstack-unsafe-p (block)
- (or (when (tagbody-node-p block) (tagbody-non-local-go-p block))
- (when (block-node-p block) (block-non-local-return-p block))
- (catch-node-p block)))
+(defun node-opstack-unsafe-p (node)
+ (or (when (jump-node-p node)
+ (let ((target-block (jump-target-block node)))
+ (and (null (jump-non-local-p node))
+ (eq (node-compiland target-block) *current-compiland*)
+ (member target-block *blocks*))))
+ (when (tagbody-node-p node) (tagbody-non-local-go-p node))
+ (when (block-node-p node) (block-non-local-return-p node))
+ (catch-node-p node)))
(defknown block-creates-runtime-bindings-p (t) boolean)
(defun block-creates-runtime-bindings-p (block)
More information about the armedbear-cvs
mailing list