Changeset 13487


Ignore:
Timestamp:
08/13/11 14:25:49 (10 years ago)
Author:
ehuelsmann
Message:

Store instances of local functions in their parent compiland.

File:
1 edited

Legend:

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

    r13486 r13487  
    13391339  (declare-function (cadr name) t))
    13401340
     1341
     1342(defun local-function-class-and-field (local-function)
     1343  (let ((local-function-parent-compiland
     1344         (compiland-parent (local-function-compiland local-function))))
     1345    (values (abcl-class-file-class-name
     1346             (compiland-class-file local-function-parent-compiland))
     1347            (local-function-field local-function))))
    13411348
    13421349(defknown declare-local-function (local-function) string)
     
    22082215          (t
    22092216           (dformat t "compile-local-function-call default case~%")
    2210            (let* ((g (declare-local-function local-function)))
    2211              (emit-getstatic *this-class* g +lisp-object+)
    2212                                         ; Stack: template-function
    2213              (when *closure-variables*
    2214                (emit-checkcast +lisp-compiled-closure+)
    2215                (duplicate-closure-array compiland)
    2216                (emit-invokestatic +lisp+ "makeCompiledClosure"
    2217                                   (list +lisp-object+ +closure-binding-array+)
    2218                                   +lisp-object+)))))
     2217           (multiple-value-bind
     2218                 (class field)
     2219               (local-function-class-and-field local-function)
     2220             (emit-getstatic class field +lisp-object+))
     2221           (when *closure-variables*
     2222             (emit-checkcast +lisp-compiled-closure+)
     2223             (duplicate-closure-array compiland)
     2224             (emit-invokestatic +lisp+ "makeCompiledClosure"
     2225                                (list +lisp-object+ +closure-binding-array+)
     2226                                +lisp-object+))))
    22192227    (process-args args '(nil))
    22202228    (emit-call-execute (length args))
     
    40604068                   bytes)))))))
    40614069
    4062 (defun emit-make-compiled-closure-for-labels
    4063     (local-function compiland declaration)
    4064   (emit-getstatic *this-class* declaration +lisp-object+)
    4065   (let ((parent (compiland-parent compiland)))
     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+))
    40664076    (when (compiland-closure-register parent)
    40674077      (dformat t "(compiland-closure-register parent) = ~S~%"
     
    40774087(defun p2-labels-process-compiland (local-function)
    40784088  (let* ((compiland (local-function-compiland local-function)))
    4079     (cond (*file-compilation*
    4080            (compile-and-write-to-stream compiland)
    4081            (let ((g (declare-local-function local-function)))
    4082              (emit-make-compiled-closure-for-labels
    4083               local-function compiland g)))
    4084           (t
    4085            (with-open-stream (stream (sys::%make-byte-array-output-stream))
    4086              (compile-and-write-to-stream compiland stream)
    4087              (let* ((bytes (sys::%get-output-stream-bytes stream))
    4088                     (g (declare-local-function local-function)))
    4089                (sys::put-memory-function *memory-class-loader*
    4090                                          (class-name-internal
    4091                                           (abcl-class-file-class-name
    4092                                            (compiland-class-file compiland)))
    4093                   bytes)
    4094                (emit-make-compiled-closure-for-labels
    4095                 local-function compiland g)
    4096                ))))))
     4089    (cond
     4090      (*file-compilation*
     4091       (compile-and-write-to-stream compiland)
     4092       (emit-make-compiled-closure-for-labels local-function))
     4093      (t
     4094       (with-open-stream (stream (sys::%make-byte-array-output-stream))
     4095         (compile-and-write-to-stream compiland stream)
     4096         (let* ((bytes (sys::%get-output-stream-bytes stream)))
     4097           (sys::put-memory-function *memory-class-loader*
     4098                                     (class-name-internal
     4099                                      (abcl-class-file-class-name
     4100                                       (compiland-class-file compiland)))
     4101                                     bytes)
     4102           (emit-make-compiled-closure-for-labels local-function)))))))
    40974103
    40984104(defknown p2-flet-node (t t t) t)
     
    41394145    (cond (*file-compilation*
    41404146           (compile-and-write-to-stream compiland)
    4141            (emit-getstatic *this-class*
    4142                            (declare-local-function local-function)
    4143                            +lisp-object+))
     4147           (multiple-value-bind
     4148                 (class field)
     4149               (local-function-class-and-field local-function)
     4150             (emit-getstatic class field +lisp-object+)))
    41444151          (t
    41454152           (with-open-stream (stream (sys::%make-byte-array-output-stream))
     
    41514158                                           (compiland-class-file compiland)))
    41524159                                         bytes)
    4153                (emit-getstatic *this-class*
    4154                                (declare-local-function local-function)
    4155                                +lisp-object+)))))
     4160               (multiple-value-bind
     4161                     (class field)
     4162                   (local-function-class-and-field local-function)
     4163                 (emit-getstatic class field +lisp-object+))))))
    41564164    (cond ((null *closure-variables*))  ; Nothing to do.
    41574165          ((compiland-closure-register *current-compiland*)
     
    41854193                              'stack nil))
    41864194            (t
    4187              (let ((g (declare-local-function local-function)))
    4188                (emit-getstatic *this-class* g +lisp-object+)
    4189                                         ; Stack: template-function
    4190 
    4191                (when (compiland-closure-register *current-compiland*)
    4192                  (emit-checkcast +lisp-compiled-closure+)
    4193                  (duplicate-closure-array *current-compiland*)
    4194                  (emit-invokestatic +lisp+ "makeCompiledClosure"
    4195                                     (list +lisp-object+ +closure-binding-array+)
    4196                                     +lisp-object+)))))
     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+))))
    41974205          (emit-move-from-stack target))
    41984206         ((inline-ok name)
     
    42234231                              'stack nil))
    42244232            (t
    4225              (let ((g (declare-local-function local-function)))
    4226                (emit-getstatic *this-class*
    4227                      g +lisp-object+))))) ; Stack: template-function
     4233             (multiple-value-bind
     4234                   (class field)
     4235                 (local-function-class-and-field)
     4236                ; Stack: template-function
     4237               (emit-getstatic class field +lisp-object+)))))
    42284238         ((and (member name *functions-defined-in-current-file* :test #'equal)
    42294239               (not (notinline-p name)))
Note: See TracChangeset for help on using the changeset viewer.