Changeset 11866


Ignore:
Timestamp:
05/15/09 09:30:10 (14 years ago)
Author:
ehuelsmann
Message:

Finish closure fixes by merging the branch to the trunk.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
4 edited
1 copied

Legend:

Unmodified
Added
Removed

  • trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java

    r11711 r11866  
    3838{
    3939
    40   public LispObject[] ctx;
     40  public ClosureBinding[] ctx;
    4141
    4242  public ClosureTemplateFunction(LispObject lambdaList)
    … …  
    4646  }
    4747
    48   final public ClosureTemplateFunction setContext(LispObject[] context)
     48  final public ClosureTemplateFunction setContext(ClosureBinding[] context)
    4949  {
    5050    ctx = context;
    … …  
    157157
    158158  // Zero args.
    159   public LispObject _execute(LispObject[] context) throws ConditionThrowable
     159  public LispObject _execute(ClosureBinding[] context) throws ConditionThrowable
    160160  {
    161161    LispObject[] args = new LispObject[0];
    … …  
    164164
    165165  // One arg.
    166   public LispObject _execute(LispObject[] context, LispObject first)
     166  public LispObject _execute(ClosureBinding[] context, LispObject first)
    167167    throws ConditionThrowable
    168168  {
    … …  
    173173
    174174  // Two args.
    175   public LispObject _execute(LispObject[] context, LispObject first,
     175  public LispObject _execute(ClosureBinding[] context, LispObject first,
    176176                            LispObject second)
    177177    throws ConditionThrowable
    … …  
    184184
    185185  // Three args.
    186   public LispObject _execute(LispObject[] context, LispObject first,
     186  public LispObject _execute(ClosureBinding[] context, LispObject first,
    187187                            LispObject second, LispObject third)
    188188    throws ConditionThrowable
    … …  
    196196
    197197  // Four args.
    198   public LispObject _execute(LispObject[] context, LispObject first,
     198  public LispObject _execute(ClosureBinding[] context, LispObject first,
    199199                            LispObject second, LispObject third,
    200200                            LispObject fourth)
    … …  
    210210
    211211  // Five args.
    212   public LispObject _execute(LispObject[] context, LispObject first,
     212  public LispObject _execute(ClosureBinding[] context, LispObject first,
    213213                            LispObject second, LispObject third,
    214214                            LispObject fourth, LispObject fifth)
    … …  
    225225
    226226  // Six args.
    227   public LispObject _execute(LispObject[] context, LispObject first,
     227  public LispObject _execute(ClosureBinding[] context, LispObject first,
    228228                            LispObject second, LispObject third,
    229229                            LispObject fourth, LispObject fifth,
    … …  
    242242
    243243  // Seven args.
    244   public LispObject _execute(LispObject[] context, LispObject first,
     244  public LispObject _execute(ClosureBinding[] context, LispObject first,
    245245                            LispObject second, LispObject third,
    246246                            LispObject fourth, LispObject fifth,
    … …  
    260260
    261261  // Eight args.
    262   public LispObject _execute(LispObject[] context, LispObject first,
     262  public LispObject _execute(ClosureBinding[] context, LispObject first,
    263263                            LispObject second, LispObject third,
    264264                            LispObject fourth, LispObject fifth,
    … …  
    280280
    281281  // Arg array.
    282   public LispObject _execute(LispObject[] context, LispObject[] args)
     282  public LispObject _execute(ClosureBinding[] context, LispObject[] args)
    283283    throws ConditionThrowable
    284284  {

  • trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java

    r11514 r11866  
    3737{
    3838    private final ClosureTemplateFunction ctf;
    39     private final LispObject[] context;
     39    private final ClosureBinding[] context;
    4040
    41     public CompiledClosure(ClosureTemplateFunction ctf, LispObject[] context)
     41    public CompiledClosure(ClosureTemplateFunction ctf, ClosureBinding[] context)
    4242    {
    4343        super(ctf.getLambdaName(), ctf.getLambdaList());

  • trunk/abcl/src/org/armedbear/lisp/Lisp.java

    r11777 r11866  
    11871187
    11881188  public static final LispObject makeCompiledClosure(LispObject template,
    1189                                                      LispObject[] context)
     1189                                                     ClosureBinding[] context)
    11901190    throws ConditionThrowable
    11911191  {

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

    r11857 r11866  
    206206(defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;")
    207207(defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;")
     208(defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;")
     209(defconstant +closure-binding+ "Lorg/armedbear/lisp/ClosureBinding;")
     210(defconstant +closure-binding-class+ "org/armedbear/lisp/ClosureBinding")
    208211(defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol")
    209212(defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;")
    … …  
    29892992  (emit-move-from-stack target))
    29902993
    2991 (defun save-variables (variables)
    2992   (let ((saved-vars '()))
    2993     (dolist (variable variables)
    2994       (when (variable-closure-index variable)
    2995         (let ((register (allocate-register)))
    2996           (aload (compiland-closure-register *current-compiland*))
    2997           (emit-push-constant-int (variable-closure-index variable))
    2998           (emit 'aaload)
    2999           (astore register)
    3000           (push (cons variable register) saved-vars))))
    3001     saved-vars))
    3002 
    3003 (defun restore-variables (saved-vars)
    3004   (dolist (saved-var saved-vars)
    3005     (let ((variable (car saved-var))
    3006           (register (cdr saved-var)))
    3007       (aload (compiland-closure-register *current-compiland*))
    3008       (emit-push-constant-int (variable-closure-index variable))
    3009       (aload register)
    3010       (emit 'aastore))))
     2994
     2995(defun duplicate-closure-array (compiland)
     2996  (let* ((*register* *register*)
     2997         (register (allocate-register)))
     2998    (aload (compiland-closure-register compiland))        ;; src
     2999    (emit-push-constant-int 0)                            ;; srcPos
     3000    (emit-push-constant-int (length *closure-variables*))
     3001    (emit 'anewarray "org/armedbear/lisp/ClosureBinding")     ;; dest
     3002    (emit 'dup)
     3003    (astore register)  ;; save dest value
     3004    (emit-push-constant-int 0)                            ;; destPos
     3005    (emit-push-constant-int (length *closure-variables*)) ;; length
     3006    (emit-invokestatic "java/lang/System" "arraycopy"
     3007                       (list "Ljava/lang/Object;" "I"
     3008                             "Ljava/lang/Object;" "I" "I") nil)
     3009    (aload register))) ;; reload dest value
     3010
     3011
    30113012
    30123013(defknown compile-local-function-call (t t t) t)
    … …  
    30203021         (args (cdr form))
    30213022         (local-function (find-local-function op))
    3022          (*register* *register*)
    3023          (saved-vars '())
    3024          (label-START (gensym))
    3025          (label-END (gensym))
    3026          (label-EXIT (gensym)))
     3023         (*register* *register*))
    30273024    (cond ((local-function-variable local-function)
    30283025           ;; LABELS
    30293026           (dformat t "compile-local-function-call LABELS case variable = ~S~%"
    30303027                   (variable-name (local-function-variable local-function)))
    3031            (unless (null (compiland-parent compiland))
    3032              (setf saved-vars
    3033                    (save-variables (intersection
    3034                                     (compiland-arg-vars (local-function-compiland local-function))
    3035                                     *visible-variables*))))
    3036 ;;            (emit 'var-ref (local-function-variable local-function) 'stack)
    3037            (when saved-vars
    3038              (label label-START))
    30393028           (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil))
    30403029          (t
    … …  
    30463035             (when *closure-variables*
    30473036               (emit 'checkcast +lisp-ctf-class+)
    3048                (aload (compiland-closure-register compiland))
     3037               (duplicate-closure-array compiland)
    30493038               (emit-invokestatic +lisp-class+ "makeCompiledClosure"
    3050                                   (list +lisp-object+ +lisp-object-array+)
     3039                                  (list +lisp-object+ +closure-binding-array+)
    30513040                                  +lisp-object+)))))
    30523041    (process-args args)
    30533042    (emit-call-execute (length args))
    30543043    (fix-boxing representation nil)
    3055     (emit-move-from-stack target representation)
    3056     (when saved-vars
    3057       (emit 'goto label-EXIT)
    3058       (label label-END)
    3059       (restore-variables saved-vars)
    3060       (emit 'athrow)
    3061       (label label-EXIT)
    3062       (restore-variables saved-vars)
    3063       (push (make-handler :from label-START
    3064                           :to label-END
    3065                           :code label-END
    3066                           :catch-type 0) *handlers*)))
     3044    (emit-move-from-stack target representation))
    30673045  t)
    30683046
    … …  
    39193897         (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
    39203898                             (list +lisp-symbol+ +lisp-object+) nil))
    3921         ((variable-closure-index variable)
     3899        ((variable-closure-index variable)              ;; stack:
     3900         (emit 'new "org/armedbear/lisp/ClosureBinding") ;; value c-b
     3901         (emit 'dup_x1)                                  ;; c-b value c-b
     3902         (emit 'swap)                                    ;; c-b c-b value
     3903         (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding"
     3904                                 (list +lisp-object+))   ;; c-b
    39223905         (aload (compiland-closure-register *current-compiland*))
    3923          (emit 'swap) ; array value
     3906                                                         ;; c-b array
     3907         (emit 'swap)                                    ;; array c-b
    39243908         (emit-push-constant-int (variable-closure-index variable))
     3909                                                         ;; array c-b int
    39253910         (emit 'swap) ; array index value
    39263911         (emit 'aastore))
    … …  
    41964181            ((variable-closure-index variable)
    41974182             (aload (compiland-closure-register *current-compiland*))
     4183             (emit-push-constant-int (variable-closure-index variable))
     4184             (emit 'aaload)
    41984185             (emit-swap representation nil)
    4199              (emit-push-constant-int (variable-closure-index variable))
    4200              (emit-swap representation :int)
    4201              (emit-array-store (variable-representation variable)))
     4186             (emit 'putfield "org/armedbear/lisp/ClosureBinding" "value"
     4187                   "Lorg/armedbear/lisp/LispObject;"))
    42024188            (t
    42034189             ;;###FIXME: We might want to address the "temp-register" case too.
    … …  
    42054191
    42064192(defun emit-push-variable (variable)
    4207   (flet ((emit-array-store (representation)
     4193  (flet ((emit-array-load (representation)
    42084194           (emit (ecase representation
    42094195                       ((:int :boolean :char)
    … …  
    42254211           (aload (compiland-argument-register *current-compiland*))
    42264212           (emit-push-constant-int (variable-index variable))
    4227            (emit-array-store (variable-representation variable)))
     4213           (emit-array-load (variable-representation variable)))
    42284214          ((variable-closure-index variable)
    42294215           (aload (compiland-closure-register *current-compiland*))
    42304216           (emit-push-constant-int (variable-closure-index variable))
    4231            (emit-array-store (variable-representation variable)))
     4217           (emit 'aaload)
     4218           (emit 'getfield "org/armedbear/lisp/ClosureBinding" "value"
     4219                 "Lorg/armedbear/lisp/LispObject;"))
    42324220          (t ;;###FIXME: We might want to address the "temp-register" case too.
    42334221           (assert nil)))))
    … …  
    48684856         (compiland-closure-register parent))
    48694857      (emit 'checkcast +lisp-ctf-class+)
    4870       (aload (compiland-closure-register parent))
     4858      (duplicate-closure-array parent)
    48714859      (emit-invokestatic +lisp-class+ "makeCompiledClosure"
    4872        (list +lisp-object+ +lisp-object-array+)
     4860       (list +lisp-object+ +closure-binding-array+)
    48734861       +lisp-object+)))
    48744862  (emit-move-to-variable (local-function-variable local-function)))
    … …  
    50165004    (cond ((null *closure-variables*)) ; Nothing to do.
    50175005          ((compiland-closure-register *current-compiland*)
    5018            (aload (compiland-closure-register *current-compiland*))
     5006           (duplicate-closure-array *current-compiland*)
    50195007           (emit-invokestatic +lisp-class+ "makeCompiledClosure"
    5020                               (list +lisp-object+ +lisp-object-array+)
     5008                              (list +lisp-object+ +closure-binding-array+)
    50215009                              +lisp-object+)
    50225010           (emit 'checkcast +lisp-compiled-closure-class+)) ; Stack: compiled-closure
    … …  
    50485036                           (when (compiland-closure-register *current-compiland*)
    50495037                             (emit 'checkcast +lisp-ctf-class+)
    5050                              (aload (compiland-closure-register *current-compiland*))
     5038                             (duplicate-closure-array *current-compiland*)
    50515039                             (emit-invokestatic +lisp-class+ "makeCompiledClosure"
    5052                                                 (list +lisp-object+ +lisp-object-array+)
     5040                                                (list +lisp-object+ +closure-binding-array+)
    50535041                                                +lisp-object+)))))
    50545042                  (emit-move-from-stack target))
    … …  
    78877875        (return-from analyze-args
    78887876                     (if *closure-variables*
    7889                          (get-descriptor (list +lisp-object-array+ +lisp-object-array+)
    7890                                           +lisp-object+)
     7877                         (get-descriptor (list +closure-binding-array+
     7878                                               +lisp-object-array+)
     7879                                         +lisp-object+)
    78917880                         (get-descriptor (list +lisp-object-array+)
    7892                                           +lisp-object+))))
     7881                                         +lisp-object+))))
    78937882      (cond (*closure-variables*
    78947883             (return-from analyze-args
    78957884                          (cond ((<= arg-count call-registers-limit)
    7896                                  (get-descriptor (list* +lisp-object-array+
     7885                                 (get-descriptor (list* +closure-binding-array+
    78977886                                                        (lisp-object-arg-types arg-count))
    78987887                                                 +lisp-object+))
    78997888                                (t (setf *using-arg-array* t)
    79007889                                   (setf (compiland-arity compiland) arg-count)
    7901                                    (get-descriptor (list +lisp-object-array+ +lisp-object-array+) ;; FIXME
     7890                                   (get-descriptor (list +closure-binding-array+ +lisp-object-array+) ;; FIXME
    79027891                                                   +lisp-object+)))))
    79037892            (t
    … …  
    80338022         (closure-args (intersection *closure-variables*
    80348023                                     (compiland-arg-vars compiland)))
     8024         (local-closure-vars
     8025          (find compiland *closure-variables* :key #'variable-compiland))
    80358026         (body (cddr p1-result))
    80368027         (*using-arg-array* nil)
    … …  
    80948085                (compiland-closure-register compiland)))
    80958086
     8087    (when *closure-variables*
     8088      (cond
     8089        ((not *child-p*)
     8090         ;; if we're the ultimate parent: create the closure array
     8091         (emit-push-constant-int (length *closure-variables*))
     8092         (emit 'anewarray "org/armedbear/lisp/ClosureBinding"))
     8093        (local-closure-vars
     8094         (duplicate-closure-array compiland))))
     8095
    80968096    ;; Move args from their original registers to the closure variables array
    80978097    (when (or closure-args
    … …  
    80998099      (dformat t "~S moving arguments to closure array~%"
    81008100               (compiland-name compiland))
    8101       (cond (*child-p*
    8102              (aver (eql (compiland-closure-register compiland) 1))
    8103              (aload (compiland-closure-register compiland)))
    8104             (t ;; if we're the ultimate parent: create the closure array
    8105              (emit-push-constant-int (length *closure-variables*))
    8106              (dformat t "p2-compiland ~S anewarray 1~%"
    8107                       (compiland-name compiland))
    8108              (emit 'anewarray "org/armedbear/lisp/LispObject")))
    8109       (dolist (variable closure-args)
    8110         (dformat t "moving variable ~S~%" (variable-name variable))
    8111         (cond ((variable-register variable)
     8101      (dotimes (i (length *closure-variables*))
     8102        ;; Loop over all slots, setting their value
     8103        ;;  unconditionally if we're the parent creating it (using null
     8104        ;;  values if no real value is available)
     8105        ;; or selectively if we're a child binding certain slots.
     8106        (let ((variable (find i closure-args
     8107                              :key #'variable-closure-index
     8108                              :test #'eql)))
     8109          (when (or (not *child-p*) variable)
     8110            ;; we're the parent, or we have a variable to set.
     8111            (emit 'dup) ; array
     8112            (emit-push-constant-int i)
     8113            (emit 'new "org/armedbear/lisp/ClosureBinding")
     8114            (emit 'dup)
     8115            (cond
     8116              ((null variable)
     8117               (assert (not *child-p*))
     8118               (emit 'aconst_null))
     8119              ((variable-register variable)
    81128120               (assert (not (eql (variable-register variable)
    81138121                                 (compiland-closure-register compiland))))
    8114                (emit 'dup) ; array
    8115                (emit-push-constant-int (variable-closure-index variable))
    81168122               (aload (variable-register variable))
    8117                (emit 'aastore)
    81188123               (setf (variable-register variable) nil))
    81198124              ((variable-index variable)
    8120                (emit 'dup) ; array
    8121                (emit-push-constant-int (variable-closure-index variable))
    81228125               (aload (compiland-argument-register compiland))
    81238126               (emit-push-constant-int (variable-index variable))
    81248127               (emit 'aaload)
    8125                (emit 'aastore)
    8126                (setf (variable-index variable) nil))))
    8127 
     8128               (setf (variable-index variable) nil))
     8129              (t
     8130               (assert (not "Can't happen!!"))))
     8131            (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding"
     8132                                     (list +lisp-object+))
     8133            (emit 'aastore)))))
     8134
     8135    (when (or local-closure-vars (and *closure-variables* (not *child-p*)))
    81288136      (aver (not (null (compiland-closure-register compiland))))
    8129       (cond (*child-p*
    8130              (emit 'pop))
    8131             (t
    8132              (astore (compiland-closure-register compiland))))
     8137      (astore (compiland-closure-register compiland))
    81338138      (dformat t "~S done moving arguments to closure array~%"
    81348139               (compiland-name compiland)))
Note: See TracChangeset for help on using the changeset viewer.