[armedbear-cvs] r13122 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Mon Jan 3 20:30:16 UTC 2011
Author: ehuelsmann
Date: Mon Jan 3 15:30:12 2011
New Revision: 13122
Log:
Remove REWRITE-RETURN-FROM, REWRITE-PROGV and REWRITE-THROW
in favor of unsafety detection in compilation pass2.
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 Mon Jan 3 15:30:12 2011
@@ -468,6 +468,7 @@
(declare (type cons form))
(let* ((*visible-variables* *visible-variables*)
(block (make-let/let*-node))
+ (*block* block)
(op (%car form))
(varlist (cadr form))
(body (cddr form)))
@@ -506,6 +507,7 @@
(defun p1-locally (form)
(let* ((*visible-variables* *visible-variables*)
(block (make-locally-node))
+ (*block* block)
(free-specials (process-declarations-for-vars (cdr form) nil block)))
(setf (locally-free-specials block) free-specials)
(dolist (special free-specials)
@@ -523,6 +525,7 @@
(return-from p1-m-v-b (p1-let/let* new-form))))
(let* ((*visible-variables* *visible-variables*)
(block (make-m-v-b-node))
+ (*block* block)
(varlist (cadr form))
;; Process the values-form first. ("The scopes of the name binding and
;; declarations do not include the values-form.")
@@ -552,6 +555,7 @@
(defun p1-block (form)
(let* ((block (make-block-node (cadr form)))
+ (*block* block)
(*blocks* (cons block *blocks*)))
(setf (cddr form) (p1-body (cddr form)))
(setf (block-form block) form)
@@ -568,6 +572,7 @@
(let* ((tag (p1 (cadr form)))
(body (cddr form))
(block (make-catch-node))
+ (*block* block)
;; our subform processors need to know
;; they're enclosed in a CATCH block
(*blocks* (cons block *blocks*))
@@ -591,6 +596,7 @@
(let* ((synchronized-object (p1 (cadr form)))
(body (cddr form))
(block (make-synchronized-node))
+ (*block* block)
(*blocks* (cons block *blocks*))
result)
(dolist (subform body)
@@ -614,6 +620,7 @@
;; However, p1 transforms the forms being processed, so, we
;; need to copy the forms to create a second copy.
(let* ((block (make-unwind-protect-node))
+ (*block* block)
;; a bit of jumping through hoops...
(unwinding-forms (p1-body (copy-tree (cddr form))))
(unprotected-forms (p1-body (cddr form)))
@@ -629,9 +636,6 @@
(defknown p1-return-from (t) t)
(defun p1-return-from (form)
- (let ((new-form (rewrite-return-from form)))
- (when (neq form new-form)
- (return-from p1-return-from (p1 new-form))))
(let* ((name (second form))
(block (find-block name)))
(when (null block)
@@ -661,6 +665,7 @@
(defun p1-tagbody (form)
(let* ((block (make-tagbody-node))
+ (*block* block)
(*blocks* (cons block *blocks*))
(*visible-tags* *visible-tags*)
(local-tags '())
@@ -927,6 +932,7 @@
((with-saved-compiler-policy
(process-optimization-declarations (cddr form))
(let* ((block (make-flet-node))
+ (*block* block)
(*blocks* (cons block *blocks*))
(body (cddr form))
(*visible-variables* *visible-variables*))
@@ -965,6 +971,7 @@
(*current-compiland* (local-function-compiland local-function)))
(p1-compiland (local-function-compiland local-function))))
(let* ((block (make-labels-node))
+ (*block* block)
(*blocks* (cons block *blocks*))
(body (cddr form))
(*visible-variables* *visible-variables*))
@@ -1068,13 +1075,10 @@
(defknown p1-progv (t) t)
(defun p1-progv (form)
;; We've already checked argument count in PRECOMPILE-PROGV.
-
- (let ((new-form (rewrite-progv form)))
- (when (neq new-form form)
- (return-from p1-progv (p1 new-form))))
(let* ((symbols-form (p1 (cadr form)))
(values-form (p1 (caddr form)))
(block (make-progv-node))
+ (*block* block)
(*blocks* (cons block *blocks*))
(body (cdddr form)))
;; The (commented out) block below means to detect compile-time
@@ -1090,20 +1094,6 @@
`(progv ,symbols-form ,values-form ,@(p1-body body)))
block))
-(defknown rewrite-progv (t) t)
-(defun rewrite-progv (form)
- (let ((symbols-form (cadr form))
- (values-form (caddr form))
- (body (cdddr form)))
- (cond ((or (unsafe-p symbols-form) (unsafe-p values-form))
- (let ((g1 (gensym))
- (g2 (gensym)))
- `(let ((,g1 ,symbols-form)
- (,g2 ,values-form))
- (progv ,g1 ,g2 , at body))))
- (t
- form))))
-
(defun p1-quote (form)
(unless (= (length form) 2)
(compiler-error "Wrong number of arguments for special operator ~A (expected 1, but received ~D)."
@@ -1197,55 +1187,8 @@
(when (unsafe-p arg)
(return t))))))))
-(defknown rewrite-return-from (t) t)
-(defun rewrite-return-from (form)
- (let* ((args (cdr form))
- (result-form (second args))
- (var (gensym)))
- (if (unsafe-p (cdr args))
- (if (single-valued-p result-form)
- `(let ((,var ,result-form))
- (return-from ,(first args) ,var))
- `(let ((,var (multiple-value-list ,result-form)))
- (return-from ,(first args) (values-list ,var))))
- form)))
-
-
-(defknown rewrite-throw (t) t)
-(defun rewrite-throw (form)
- (let ((args (cdr form)))
- (if (unsafe-p args)
- (let ((syms ())
- (lets ()))
- ;; Tag.
- (let ((arg (first args)))
- (if (constantp arg)
- (push arg syms)
- (let ((sym (gensym)))
- (push sym syms)
- (push (list sym arg) lets))))
- ;; Result. "If the result-form produces multiple values, then all the
- ;; values are saved."
- (let ((arg (second args)))
- (if (constantp arg)
- (push arg syms)
- (let ((sym (gensym)))
- (cond ((single-valued-p arg)
- (push sym syms)
- (push (list sym arg) lets))
- (t
- (push (list 'VALUES-LIST sym) syms)
- (push (list sym
- (list 'MULTIPLE-VALUE-LIST arg))
- lets))))))
- (list 'LET* (nreverse lets) (list* 'THROW (nreverse syms))))
- form)))
-
(defknown p1-throw (t) t)
(defun p1-throw (form)
- (let ((new-form (rewrite-throw form)))
- (when (neq new-form form)
- (return-from p1-throw (p1 new-form))))
(list* 'THROW (mapcar #'p1 (cdr form))))
(defknown rewrite-function-call (t) t)
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 Mon Jan 3 15:30:12 2011
@@ -645,6 +645,88 @@
collecting form)))
(apply #'maybe-emit-clear-values forms-for-emit-clear)))
+
+(declaim (special *saved-operands* *operand-representations*))
+(defmacro with-operand-accumulation ((&body argument-buildup-body)
+ &body funcall-body)
+ `(let (*saved-operands*
+ *operand-representations*
+ (*register* *register*)) ;; hmm can we do this?? either body
+ ;; could allocate registers ...
+ , at argument-buildup-body
+ (load-saved-operands)
+ , at funcall-body))
+
+(defun load-saved-operands ()
+ "Load any operands which have been saved into registers
+back onto the stack in preparation of the execution of the opcode."
+ (dolist (operand (reverse *saved-operands*))
+ (emit 'aload operand)))
+
+(defun save-existing-operands ()
+ "If any operands have been compiled to the stack,
+save them in registers."
+ (dotimes (i (length *operand-representations*))
+ (let ((register (allocate-register)))
+ (push register *saved-operands*)
+ (emit 'astore register)))
+
+ (setf *saved-operands* (nreverse *saved-operands*)))
+
+(defun compile-operand (form representation)
+ "Compiles `form` into `representation`, storing the resulting value
+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
+ (find-enclosed-blocks form)))))
+ (when (and unsafe (null *saved-operands*))
+ (save-existing-operands))
+
+ (compile-form form 'stack representation)
+ (when unsafe
+ (let ((register (allocate-register)))
+ (push register *saved-operands*)
+ (assert (null representation))
+ (emit 'astore register)))
+
+ (push representation *operand-representations*)))
+
+(defun emit-variable-operand (variable)
+ "Pushes a variable onto the operand stack, if it's safe to do so. Otherwise
+stores the value in a register."
+ (push (variable-representation variable) *operand-representations*)
+ (cond
+ ((and *saved-operands*
+ (variable-register variable))
+ ;; we're in 'safe mode' and the variable is in a register,
+ ;; instead of binding a new register, just load the existing one
+ (push (variable-register variable) *saved-operands*))
+ (t
+ (emit-push-variable variable)
+ (when *saved-operands* ;; safe-mode
+ (let ((register (allocate-register)))
+ (push register *saved-operands*)
+ (assert (null (variable-representation variable)))
+ (emit 'astore register))))))
+
+(defun emit-thread-operand ()
+ (push nil *operand-representations*)
+ (emit-push-current-thread)
+ (when *saved-operands*
+ (let ((register (allocate-register)))
+ (push register *saved-operands*)
+ (emit 'astore register))))
+
+
+(defun emit-load-externalized-object-operand (object)
+ (push nil *operand-representations*)
+ (emit-load-externalized-object object)
+ (when *saved-operands* ;; safe-mode
+ (let ((register (allocate-register)))
+ (push register *saved-operands*)
+ (emit 'astore register))))
+
(defknown emit-unbox-fixnum () t)
(defun emit-unbox-fixnum ()
(declare (optimize speed))
@@ -3651,12 +3733,13 @@
(return-from p2-return-from))))
;; Non-local RETURN.
(aver (block-non-local-return-p block))
- (emit-push-variable (block-id-variable block))
- (emit-load-externalized-object (block-name block))
(emit-clear-values)
- (compile-form result-form 'stack nil)
- (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3)
- +lisp-object+)
+ (with-operand-accumulation
+ ((emit-variable-operand (block-id-variable block))
+ (emit-load-externalized-object-operand (block-name block))
+ (compile-operand result-form nil))
+ (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3)
+ +lisp-object+))
;; Following code will not be reached, but is needed for JVM stack
;; consistency.
(emit 'areturn)))
@@ -3723,17 +3806,18 @@
(environment-register
(setf (progv-environment-register block) (allocate-register)))
(label-START (gensym)))
- (compile-form symbols-form 'stack nil)
- (compile-form values-form 'stack nil)
- (unless (and (single-valued-p symbols-form)
- (single-valued-p values-form))
- (emit-clear-values))
- (save-dynamic-environment environment-register)
- (label label-START)
- ;; Compile call to Lisp.progvBindVars().
- (emit-push-current-thread)
- (emit-invokestatic +lisp+ "progvBindVars"
- (list +lisp-object+ +lisp-object+ +lisp-thread+) nil)
+ (with-operand-accumulation
+ ((compile-operand symbols-form nil)
+ (compile-operand values-form nil))
+ (unless (and (single-valued-p symbols-form)
+ (single-valued-p values-form))
+ (emit-clear-values))
+ (save-dynamic-environment environment-register)
+ (label label-START)
+ ;; Compile call to Lisp.progvBindVars().
+ (emit-push-current-thread)
+ (emit-invokestatic +lisp+ "progvBindVars"
+ (list +lisp-object+ +lisp-object+ +lisp-thread+) nil))
;; Implicit PROGN.
(let ((*blocks* (cons block *blocks*)))
(compile-progn-body (cdddr form) target representation))
@@ -6499,12 +6583,13 @@
(defun p2-throw (form target representation)
;; FIXME What if we're called with a non-NIL representation?
(declare (ignore representation))
- (emit-push-current-thread)
- (compile-form (second form) 'stack nil) ; Tag.
- (emit-clear-values) ; Do this unconditionally! (MISC.503)
- (compile-form (third form) 'stack nil) ; Result.
- (emit-invokevirtual +lisp-thread+ "throwToTag"
- (lisp-object-arg-types 2) nil)
+ (with-operand-accumulation
+ ((emit-thread-operand)
+ (compile-operand (second form) nil) ; Tag.
+ (emit-clear-values) ; Do this unconditionally! (MISC.503)
+ (compile-operand (third form) nil)) ; Result.
+ (emit-invokevirtual +lisp-thread+ "throwToTag"
+ (lisp-object-arg-types 2) nil))
;; Following code will not be reached.
(when target
(emit-push-nil)
More information about the armedbear-cvs
mailing list