Changeset 13488 for trunk/abcl/src/org


Ignore:
Timestamp:
08/13/11 20:26:01 (10 years ago)
Author:
ehuelsmann
Message:

Eliminate the need for functions defined using LABELS to be stored
in closures. Code elimination! Yay!

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

    r13484 r13488  
    879879  name)
    880880
    881 (defun construct-flet/labels-function (definition variable-name)
     881(defun construct-flet/labels-function (definition)
    882882  (let* ((name (car definition))
    883883         (block-name (fdefinition-block-name (validate-function-name name)))
     
    886886         (local-function (make-local-function :name name :compiland compiland)))
    887887    (push local-function (compiland-children *current-compiland*))
    888     (when variable-name
    889       (setf (local-function-variable local-function)
    890             (make-variable :name variable-name)))
    891888    (multiple-value-bind
    892889          (body decls)
     
    904901  (let* ((local-functions
    905902          (mapcar #'(lambda (definition)
    906                       (construct-flet/labels-function definition nil))
     903                      (construct-flet/labels-function definition))
    907904                  (cadr form)))
    908905         (*local-functions* *local-functions*))
     
    936933  (let* ((local-functions
    937934          (mapcar #'(lambda (definition)
    938                       (construct-flet/labels-function definition (gensym)))
     935                      (construct-flet/labels-function definition))
    939936                  (cadr form)))
    940937         (*local-functions* *local-functions*)
    941938         (*visible-variables* *visible-variables*))
    942939    (dolist (local-function local-functions)
    943       (push local-function *local-functions*)
    944       (let ((variable (local-function-variable local-function)))
    945         (push variable *all-variables*)
    946         (push variable *visible-variables*)))
     940      (push local-function *local-functions*))
    947941    (dolist (local-function local-functions)
    948942      (p1-compiland (local-function-compiland local-function)))
     
    10211015           ;;we found out that the function needs a reference
    10221016           (setf (local-function-references-needed-p local-function) t)
    1023            (let ((variable (local-function-variable local-function)))
    1024              (when variable
    1025                  (dformat t "p1-function ~S used non-locally~%"
    1026                           (variable-name variable))
    1027                  (setf (variable-used-non-locally-p variable) t)))
    10281017           form)
    10291018          (t
     
    11781167                         (let ((*inline-declarations*
    11791168                                (remove op *inline-declarations* :key #'car :test #'equal)))
    1180                            (p1 expansion))))))
    1181 
    1182       (let ((variable (local-function-variable local-function)))
    1183         (when variable
    1184           (dformat t "p1 ~S used non-locally~%" (variable-name variable))
    1185           (setf (variable-used-non-locally-p variable) t)))))
     1169                           (p1 expansion))))))))
    11861170  (p1-default form))
    11871171
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r13487 r13488  
    10761076(defknown declare-field (t t t) t)
    10771077(defun declare-field (name descriptor)
    1078   (let ((field (make-field name descriptor
    1079                            :flags '(:final :static :private))))
     1078  (let ((field (make-field name descriptor :flags '(:final :static))))
    10801079    (class-add-field *class-file* field)))
    10811080
     
    13491348(defknown declare-local-function (local-function) string)
    13501349(defun declare-local-function (local-function)
    1351   (declare-with-hashtable
    1352    local-function *declared-functions* ht g
    1353    (setf g (symbol-name (gensym "LFUN")))
    1354    (let ((class-name (abcl-class-file-class-name
    1355                       (compiland-class-file
    1356                        (local-function-compiland local-function)))))
    1357      (with-code-to-method
    1358          (*class-file* (abcl-class-file-constructor *class-file*))
    1359        ;; fixme *declare-inline*
    1360        (declare-field g +lisp-object+)
    1361        (emit-new class-name)
    1362        (emit 'dup)
    1363        (emit-invokespecial-init class-name '())
    1364        (emit-putstatic *this-class* g +lisp-object+)
    1365        (setf (gethash local-function ht) g)))))
     1350  (let ((class-name (abcl-class-file-class-name
     1351                     (compiland-class-file
     1352                      (local-function-compiland local-function))))
     1353        (field-name (local-function-field local-function)))
     1354    (with-code-to-method
     1355        (*class-file* (abcl-class-file-constructor *class-file*))
     1356      ;; fixme *declare-inline*
     1357      (declare-field field-name +lisp-object+)
     1358      (emit-new class-name)
     1359      (emit 'dup)
     1360      (emit-invokespecial-init class-name '())
     1361      (emit-putstatic *this-class* field-name +lisp-object+))))
    13661362
    13671363
     
    21962192         (local-function (find-local-function op))
    21972193         (*register* *register*))
    2198     (cond ((local-function-variable local-function)
    2199            ;; LABELS
    2200            (dformat t "compile-local-function-call LABELS case variable = ~S~%"
    2201                    (variable-name (local-function-variable local-function)))
    2202            (compile-var-ref (make-var-ref
    2203                              (local-function-variable local-function))
    2204                             'stack nil))
     2194    (cond
    22052195          ((local-function-environment local-function)
    22062196           (assert (local-function-references-allowed-p local-function))
     
    40414031  "Creates a class file associated with `compiland`, writing it
    40424032either to stream or the pathname of the class file if `stream' is NIL."
    4043   (let* ((class-file (compiland-class-file compiland))
    4044          (pathname (abcl-class-file-pathname class-file)))
     4033  (let* ((pathname (funcall *pathnames-generator*))
     4034         (class-file (make-abcl-class-file :pathname pathname)))
     4035    (setf (compiland-class-file compiland) class-file)
    40454036    (with-open-stream (f (or stream
    40464037                             (open pathname :direction :output
     
    40684059                   bytes)))))))
    40694060
    4070 (defun emit-make-compiled-closure-for-labels (local-function)
    4071   (let ((parent (compiland-parent (local-function-compiland local-function))))
    4072     (multiple-value-bind
    4073           (class field)
    4074         (local-function-class-and-field local-function)
    4075       (emit-getstatic class field +lisp-object+))
    4076     (when (compiland-closure-register parent)
    4077       (dformat t "(compiland-closure-register parent) = ~S~%"
    4078                (compiland-closure-register parent))
    4079       (emit-checkcast +lisp-compiled-closure+)
    4080       (duplicate-closure-array parent)
    4081       (emit-invokestatic +lisp+ "makeCompiledClosure"
    4082                          (list +lisp-object+ +closure-binding-array+)
    4083                          +lisp-object+)))
    4084   (emit-move-to-variable (local-function-variable local-function)))
    4085 
    40864061(defknown p2-labels-process-compiland (t) t)
    40874062(defun p2-labels-process-compiland (local-function)
     
    40894064    (cond
    40904065      (*file-compilation*
    4091        (compile-and-write-to-stream compiland)
    4092        (emit-make-compiled-closure-for-labels local-function))
     4066       (compile-and-write-to-stream compiland))
    40934067      (t
    40944068       (with-open-stream (stream (sys::%make-byte-array-output-stream))
     
    40994073                                      (abcl-class-file-class-name
    41004074                                       (compiland-class-file compiland)))
    4101                                      bytes)
    4102            (emit-make-compiled-closure-for-labels local-function)))))))
     4075                                     bytes)))))))
    41034076
    41044077(defknown p2-flet-node (t t t) t)
     
    41264099         (body (cddr form)))
    41274100    (dolist (local-function local-functions)
    4128       (push local-function *local-functions*)
    4129       (push (local-function-variable local-function) *visible-variables*))
    4130     (dolist (local-function local-functions)
    4131       (let ((variable (local-function-variable local-function)))
    4132         (aver (null (variable-register variable)))
    4133         (unless (variable-closure-index variable)
    4134           (setf (variable-register variable) (allocate-register nil)))))
     4101      (push local-function *local-functions*))
    41354102    (dolist (local-function local-functions)
    41364103      (p2-labels-process-compiland local-function))
     
    41424109(defun p2-lambda (local-function target)
    41434110  (let ((compiland (local-function-compiland local-function)))
    4144     (aver (not (null (compiland-class-file compiland))))
    41454111    (cond (*file-compilation*
    41464112           (compile-and-write-to-stream compiland)
     
    41864152         ((setf local-function (find-local-function name))
    41874153          (dformat t "p2-function 1~%")
    4188           (cond
    4189             ((local-function-variable local-function)
    4190              (dformat t "p2-function 2 emitting var-ref~%")
    4191              (compile-var-ref (make-var-ref
    4192                                (local-function-variable local-function))
    4193                               'stack nil))
    4194             (t
    4195              (multiple-value-bind
    4196                    (class field)
    4197                  (local-function-class-and-field local-function)
    4198                (emit-getstatic class field +lisp-object+))
    4199              (when (compiland-closure-register *current-compiland*)
    4200                (emit-checkcast +lisp-compiled-closure+)
    4201                (duplicate-closure-array *current-compiland*)
    4202                (emit-invokestatic +lisp+ "makeCompiledClosure"
    4203                                   (list +lisp-object+ +closure-binding-array+)
    4204                                   +lisp-object+))))
     4154          (multiple-value-bind
     4155                (class field)
     4156              (local-function-class-and-field local-function)
     4157            (emit-getstatic class field +lisp-object+))
     4158          (when (compiland-closure-register *current-compiland*)
     4159            (emit-checkcast +lisp-compiled-closure+)
     4160            (duplicate-closure-array *current-compiland*)
     4161            (emit-invokestatic +lisp+ "makeCompiledClosure"
     4162                               (list +lisp-object+ +closure-binding-array+)
     4163                               +lisp-object+))
    42054164          (emit-move-from-stack target))
    42064165         ((inline-ok name)
     
    42244183            (emit-move-from-stack target)
    42254184            (return-from p2-function))
    4226           (cond
    4227             ((local-function-variable local-function)
    4228              (dformat t "p2-function 2~%")
    4229              (compile-var-ref (make-var-ref
    4230                                (local-function-variable local-function))
    4231                               'stack nil))
    4232             (t
    4233              (multiple-value-bind
    4234                    (class field)
    4235                  (local-function-class-and-field)
    4236                 ; Stack: template-function
    4237                (emit-getstatic class field +lisp-object+)))))
     4185          (multiple-value-bind
     4186                (class field)
     4187              (local-function-class-and-field local-function)
     4188                                        ; Stack: template-function
     4189            (emit-getstatic class field +lisp-object+)))
    42384190         ((and (member name *functions-defined-in-current-file* :test #'equal)
    42394191               (not (notinline-p name)))
     
    71027054
    71037055
    7104 (defun assign-field-and-class-name (local-function)
    7105   (let* ((pathname (funcall *pathnames-generator*))
    7106          (class-file (make-abcl-class-file :pathname pathname))
    7107          (compiland (local-function-compiland local-function)))
    7108     (setf (compiland-class-file compiland) class-file))
     7056(defun assign-field-name (local-function)
    71097057  (setf (local-function-field local-function)
    7110         (declare-local-function local-function)))
     7058        (symbol-name (gensym "LFUN"))))
    71117059
    71127060(defknown p2-compiland (t) t)
     
    71627110
    71637111      (dolist (local-function (compiland-children compiland))
    7164         (assign-field-and-class-name local-function))
     7112        (assign-field-name local-function))
    71657113
    71667114      (dolist (var (compiland-arg-vars compiland))
     
    73087256      ;; Warn if any unused args. (Is this the right place?)
    73097257      (check-for-unused-variables (compiland-arg-vars compiland))
     7258
     7259      (dolist (local-function (compiland-children compiland))
     7260        (when (compiland-class-file (local-function-compiland local-function))
     7261          (declare-local-function local-function)))
    73107262
    73117263      ;; Go back and fill in prologue.
  • trunk/abcl/src/org/armedbear/lisp/jvm.lisp

    r13486 r13488  
    378378  field
    379379  inline-expansion
    380   variable    ;; the variable which contains the loaded compiled function
    381               ;; or compiled closure
    382380  environment ;; the environment in which the function is stored in
    383381              ;; case of a function from an enclosing lexical environment
Note: See TracChangeset for help on using the changeset viewer.