[armedbear-cvs] r13488 - trunk/abcl/src/org/armedbear/lisp
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Sat Aug 13 20:26:03 UTC 2011
Author: ehuelsmann
Date: Sat Aug 13 13:26:01 2011
New Revision: 13488
Log:
Eliminate the need for functions defined using LABELS to be stored
in closures. Code elimination! Yay!
Modified:
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
trunk/abcl/src/org/armedbear/lisp/jvm.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sat Aug 13 07:25:49 2011 (r13487)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sat Aug 13 13:26:01 2011 (r13488)
@@ -878,16 +878,13 @@
(compiler-error "~S is not a valid function name." name))
name)
-(defun construct-flet/labels-function (definition variable-name)
+(defun construct-flet/labels-function (definition)
(let* ((name (car definition))
(block-name (fdefinition-block-name (validate-function-name name)))
(lambda-list (cadr definition))
(compiland (make-compiland :name name :parent *current-compiland*))
(local-function (make-local-function :name name :compiland compiland)))
(push local-function (compiland-children *current-compiland*))
- (when variable-name
- (setf (local-function-variable local-function)
- (make-variable :name variable-name)))
(multiple-value-bind
(body decls)
(parse-body (cddr definition))
@@ -903,7 +900,7 @@
(defun p1-flet (form)
(let* ((local-functions
(mapcar #'(lambda (definition)
- (construct-flet/labels-function definition nil))
+ (construct-flet/labels-function definition))
(cadr form)))
(*local-functions* *local-functions*))
(dolist (local-function local-functions)
@@ -935,15 +932,12 @@
(defun p1-labels (form)
(let* ((local-functions
(mapcar #'(lambda (definition)
- (construct-flet/labels-function definition (gensym)))
+ (construct-flet/labels-function definition))
(cadr form)))
(*local-functions* *local-functions*)
(*visible-variables* *visible-variables*))
(dolist (local-function local-functions)
- (push local-function *local-functions*)
- (let ((variable (local-function-variable local-function)))
- (push variable *all-variables*)
- (push variable *visible-variables*)))
+ (push local-function *local-functions*))
(dolist (local-function local-functions)
(p1-compiland (local-function-compiland local-function)))
(let* ((block (make-labels-node))
@@ -1020,11 +1014,6 @@
(dformat "p1-function local function ~S~%" (cadr form))
;;we found out that the function needs a reference
(setf (local-function-references-needed-p local-function) t)
- (let ((variable (local-function-variable local-function)))
- (when variable
- (dformat t "p1-function ~S used non-locally~%"
- (variable-name variable))
- (setf (variable-used-non-locally-p variable) t)))
form)
(t
form))))
@@ -1177,12 +1166,7 @@
(return-from p1-function-call
(let ((*inline-declarations*
(remove op *inline-declarations* :key #'car :test #'equal)))
- (p1 expansion))))))
-
- (let ((variable (local-function-variable local-function)))
- (when variable
- (dformat t "p1 ~S used non-locally~%" (variable-name variable))
- (setf (variable-used-non-locally-p variable) t)))))
+ (p1 expansion))))))))
(p1-default form))
(defun %funcall (fn &rest args)
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 07:25:49 2011 (r13487)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 13:26:01 2011 (r13488)
@@ -1075,8 +1075,7 @@
(defknown declare-field (t t t) t)
(defun declare-field (name descriptor)
- (let ((field (make-field name descriptor
- :flags '(:final :static :private))))
+ (let ((field (make-field name descriptor :flags '(:final :static))))
(class-add-field *class-file* field)))
(defknown sanitize (symbol) string)
@@ -1348,21 +1347,18 @@
(defknown declare-local-function (local-function) string)
(defun declare-local-function (local-function)
- (declare-with-hashtable
- local-function *declared-functions* ht g
- (setf g (symbol-name (gensym "LFUN")))
- (let ((class-name (abcl-class-file-class-name
- (compiland-class-file
- (local-function-compiland local-function)))))
- (with-code-to-method
- (*class-file* (abcl-class-file-constructor *class-file*))
- ;; fixme *declare-inline*
- (declare-field g +lisp-object+)
- (emit-new class-name)
- (emit 'dup)
- (emit-invokespecial-init class-name '())
- (emit-putstatic *this-class* g +lisp-object+)
- (setf (gethash local-function ht) g)))))
+ (let ((class-name (abcl-class-file-class-name
+ (compiland-class-file
+ (local-function-compiland local-function))))
+ (field-name (local-function-field local-function)))
+ (with-code-to-method
+ (*class-file* (abcl-class-file-constructor *class-file*))
+ ;; fixme *declare-inline*
+ (declare-field field-name +lisp-object+)
+ (emit-new class-name)
+ (emit 'dup)
+ (emit-invokespecial-init class-name '())
+ (emit-putstatic *this-class* field-name +lisp-object+))))
(defknown declare-object-as-string (t) string)
@@ -2195,13 +2191,7 @@
(args (cdr form))
(local-function (find-local-function op))
(*register* *register*))
- (cond ((local-function-variable local-function)
- ;; LABELS
- (dformat t "compile-local-function-call LABELS case variable = ~S~%"
- (variable-name (local-function-variable local-function)))
- (compile-var-ref (make-var-ref
- (local-function-variable local-function))
- 'stack nil))
+ (cond
((local-function-environment local-function)
(assert (local-function-references-allowed-p local-function))
(assert (not *file-compilation*))
@@ -4040,8 +4030,9 @@
(defun compile-and-write-to-stream (compiland &optional stream)
"Creates a class file associated with `compiland`, writing it
either to stream or the pathname of the class file if `stream' is NIL."
- (let* ((class-file (compiland-class-file compiland))
- (pathname (abcl-class-file-pathname class-file)))
+ (let* ((pathname (funcall *pathnames-generator*))
+ (class-file (make-abcl-class-file :pathname pathname)))
+ (setf (compiland-class-file compiland) class-file)
(with-open-stream (f (or stream
(open pathname :direction :output
:element-type '(unsigned-byte 8)
@@ -4067,29 +4058,12 @@
(compiland-class-file compiland)))
bytes)))))))
-(defun emit-make-compiled-closure-for-labels (local-function)
- (let ((parent (compiland-parent (local-function-compiland local-function))))
- (multiple-value-bind
- (class field)
- (local-function-class-and-field local-function)
- (emit-getstatic class field +lisp-object+))
- (when (compiland-closure-register parent)
- (dformat t "(compiland-closure-register parent) = ~S~%"
- (compiland-closure-register parent))
- (emit-checkcast +lisp-compiled-closure+)
- (duplicate-closure-array parent)
- (emit-invokestatic +lisp+ "makeCompiledClosure"
- (list +lisp-object+ +closure-binding-array+)
- +lisp-object+)))
- (emit-move-to-variable (local-function-variable local-function)))
-
(defknown p2-labels-process-compiland (t) t)
(defun p2-labels-process-compiland (local-function)
(let* ((compiland (local-function-compiland local-function)))
(cond
(*file-compilation*
- (compile-and-write-to-stream compiland)
- (emit-make-compiled-closure-for-labels local-function))
+ (compile-and-write-to-stream compiland))
(t
(with-open-stream (stream (sys::%make-byte-array-output-stream))
(compile-and-write-to-stream compiland stream)
@@ -4098,8 +4072,7 @@
(class-name-internal
(abcl-class-file-class-name
(compiland-class-file compiland)))
- bytes)
- (emit-make-compiled-closure-for-labels local-function)))))))
+ bytes)))))))
(defknown p2-flet-node (t t t) t)
(defun p2-flet-node (block target representation)
@@ -4125,13 +4098,7 @@
(local-functions (cadr form))
(body (cddr form)))
(dolist (local-function local-functions)
- (push local-function *local-functions*)
- (push (local-function-variable local-function) *visible-variables*))
- (dolist (local-function local-functions)
- (let ((variable (local-function-variable local-function)))
- (aver (null (variable-register variable)))
- (unless (variable-closure-index variable)
- (setf (variable-register variable) (allocate-register nil)))))
+ (push local-function *local-functions*))
(dolist (local-function local-functions)
(p2-labels-process-compiland local-function))
(dolist (special (labels-free-specials block))
@@ -4141,7 +4108,6 @@
(defun p2-lambda (local-function target)
(let ((compiland (local-function-compiland local-function)))
- (aver (not (null (compiland-class-file compiland))))
(cond (*file-compilation*
(compile-and-write-to-stream compiland)
(multiple-value-bind
@@ -4185,23 +4151,16 @@
(cond
((setf local-function (find-local-function name))
(dformat t "p2-function 1~%")
- (cond
- ((local-function-variable local-function)
- (dformat t "p2-function 2 emitting var-ref~%")
- (compile-var-ref (make-var-ref
- (local-function-variable local-function))
- 'stack nil))
- (t
- (multiple-value-bind
- (class field)
- (local-function-class-and-field local-function)
- (emit-getstatic class field +lisp-object+))
- (when (compiland-closure-register *current-compiland*)
- (emit-checkcast +lisp-compiled-closure+)
- (duplicate-closure-array *current-compiland*)
- (emit-invokestatic +lisp+ "makeCompiledClosure"
- (list +lisp-object+ +closure-binding-array+)
- +lisp-object+))))
+ (multiple-value-bind
+ (class field)
+ (local-function-class-and-field local-function)
+ (emit-getstatic class field +lisp-object+))
+ (when (compiland-closure-register *current-compiland*)
+ (emit-checkcast +lisp-compiled-closure+)
+ (duplicate-closure-array *current-compiland*)
+ (emit-invokestatic +lisp+ "makeCompiledClosure"
+ (list +lisp-object+ +closure-binding-array+)
+ +lisp-object+))
(emit-move-from-stack target))
((inline-ok name)
(emit-getstatic *this-class*
@@ -4223,18 +4182,11 @@
(aload 0) ; this
(emit-move-from-stack target)
(return-from p2-function))
- (cond
- ((local-function-variable local-function)
- (dformat t "p2-function 2~%")
- (compile-var-ref (make-var-ref
- (local-function-variable local-function))
- 'stack nil))
- (t
- (multiple-value-bind
- (class field)
- (local-function-class-and-field)
- ; Stack: template-function
- (emit-getstatic class field +lisp-object+)))))
+ (multiple-value-bind
+ (class field)
+ (local-function-class-and-field local-function)
+ ; Stack: template-function
+ (emit-getstatic class field +lisp-object+)))
((and (member name *functions-defined-in-current-file* :test #'equal)
(not (notinline-p name)))
(emit-getstatic *this-class*
@@ -7101,13 +7053,9 @@
t)
-(defun assign-field-and-class-name (local-function)
- (let* ((pathname (funcall *pathnames-generator*))
- (class-file (make-abcl-class-file :pathname pathname))
- (compiland (local-function-compiland local-function)))
- (setf (compiland-class-file compiland) class-file))
+(defun assign-field-name (local-function)
(setf (local-function-field local-function)
- (declare-local-function local-function)))
+ (symbol-name (gensym "LFUN"))))
(defknown p2-compiland (t) t)
(defun p2-compiland (compiland)
@@ -7161,7 +7109,7 @@
(line-numbers-add-line table 0 *source-line-number*)))
(dolist (local-function (compiland-children compiland))
- (assign-field-and-class-name local-function))
+ (assign-field-name local-function))
(dolist (var (compiland-arg-vars compiland))
(push var *visible-variables*))
@@ -7308,6 +7256,10 @@
;; Warn if any unused args. (Is this the right place?)
(check-for-unused-variables (compiland-arg-vars compiland))
+ (dolist (local-function (compiland-children compiland))
+ (when (compiland-class-file (local-function-compiland local-function))
+ (declare-local-function local-function)))
+
;; Go back and fill in prologue.
(let ((code *code*))
(setf *code* ())
Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat Aug 13 07:25:49 2011 (r13487)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat Aug 13 13:26:01 2011 (r13488)
@@ -377,8 +377,6 @@
compiland
field
inline-expansion
- variable ;; the variable which contains the loaded compiled function
- ;; or compiled closure
environment ;; the environment in which the function is stored in
;; case of a function from an enclosing lexical environment
;; which itself isn't being compiled
More information about the armedbear-cvs
mailing list