Changeset 8372


Ignore:
Timestamp:
01/19/05 14:57:14 (16 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r8370 r8372  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.356 2005-01-19 13:02:29 piso Exp $
     4;;; $Id: jvm.lisp,v 1.357 2005-01-19 14:57:14 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    462462    (unless tag
    463463      (error "p1-go: tag not found: ~S" name))
    464     (unless (eq (tag-compiland tag) *current-compiland*)
    465       (setf (block-non-local-go-p (tag-block tag)) t)))
     464    (let ((tag-block (tag-block tag)))
     465      (cond ((eq (tag-compiland tag) *current-compiland*)
     466             ;; Does the GO leave an enclosing UNWIND-PROTECT?
     467             (let ((protected
     468                    (dolist (enclosing-block *blocks*)
     469                      (when (eq enclosing-block tag-block)
     470                        (return nil))
     471                      (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
     472                        (return t)))))
     473               (when protected
     474                 (setf (block-non-local-go-p tag-block) t))))
     475            (t
     476             (setf (block-non-local-go-p tag-block) t)))))
    466477  form)
    467478
    468479(defun p1-flet (form)
    469 ;;   (when *current-compiland*
    470     (incf (compiland-children *current-compiland*) (length (cadr form)))
    471 ;;     )
     480  (incf (compiland-children *current-compiland*) (length (cadr form)))
    472481  (let ((*current-compiland* *current-compiland*)
    473         (compilands ()))
     482        (compilands '()))
    474483    (dolist (definition (cadr form))
    475484      (let* ((name (car definition))
     
    28122821
    28132822(defun compile-local-function-call (form target)
    2814   (let* ((op (car form))
     2823  (let* ((compiland *current-compiland*)
     2824         (op (car form))
    28152825         (args (cdr form))
    28162826         (local-function (find-local-function op))
    28172827         (*register* *register*)
    28182828         (saved-vars '()))
    2819     (cond
    2820      ((eq (local-function-compiland local-function) *current-compiland*)
    2821       ;; Recursive call.
    2822       (dformat t "compile-local-function-call recursive case~%")
    2823       (setf saved-vars
    2824             (save-variables (compiland-arg-vars (local-function-compiland local-function))))
    2825       (emit 'aload_0))
    2826      ((local-function-variable local-function)
    2827       ;; LABELS
    2828       (dformat t "compile-local-function-call LABELS case~%")
    2829       (dformat t "save args here: ~S~%"
    2830                (mapcar #'variable-name
    2831                        (compiland-arg-vars (local-function-compiland local-function))))
    2832       (setf saved-vars
    2833             (save-variables (compiland-arg-vars (local-function-compiland local-function))))
    2834       (emit 'var-ref (local-function-variable local-function) :stack))
    2835      (t
    2836       (dformat t "compile-local-function-call default case~%")
    2837       (let* ((g (if *compile-file-truename*
    2838                     (declare-local-function local-function)
    2839                     (declare-object (local-function-function local-function)))))
    2840         (emit 'getstatic
    2841               *this-class*
    2842               g
    2843               +lisp-object+)))) ; Stack: template-function
     2829    (cond ((eq (local-function-compiland local-function) compiland)
     2830           ;; Recursive call.
     2831           (dformat t "compile-local-function-call recursive case~%")
     2832           (setf saved-vars
     2833                 (save-variables (compiland-arg-vars (local-function-compiland local-function))))
     2834           (emit 'aload_0))
     2835          ((local-function-variable local-function)
     2836           ;; LABELS
     2837           (dformat t "compile-local-function-call LABELS case~%")
     2838           (dformat t "save args here: ~S~%"
     2839                    (mapcar #'variable-name
     2840                            (compiland-arg-vars (local-function-compiland local-function))))
     2841           (unless (null (compiland-parent compiland))
     2842             (setf saved-vars
     2843                   (save-variables (compiland-arg-vars (local-function-compiland local-function)))))
     2844           (emit 'var-ref (local-function-variable local-function) :stack))
     2845          (t
     2846           (dformat t "compile-local-function-call default case~%")
     2847           (let* ((g (if *compile-file-truename*
     2848                         (declare-local-function local-function)
     2849                         (declare-object (local-function-function local-function)))))
     2850             (emit 'getstatic
     2851                   *this-class*
     2852                   g
     2853                   +lisp-object+)))) ; Stack: template-function
    28442854
    28452855    (when *closure-variables*
     
    28482858    (when *closure-variables*
    28492859      ;; First arg is closure variable array.
    2850       (aver (not (null (compiland-closure-register *current-compiland*))))
    2851       (emit 'aload (compiland-closure-register *current-compiland*)))
    2852     (cond
    2853      ((> (length args) 4)
    2854       (emit-push-constant-int (length args))
    2855       (emit 'anewarray "org/armedbear/lisp/LispObject")
    2856       (let ((i 0)
    2857             (must-clear-values nil))
    2858         (dolist (arg args)
    2859           (emit 'dup)
    2860           (emit 'sipush i)
    2861           (compile-form arg :target :stack)
    2862           (emit 'aastore) ; store value in array
    2863           (unless must-clear-values
    2864             (unless (single-valued-p arg)
    2865               (setf must-clear-values t)))
    2866           (incf i))
    2867         (when must-clear-values
    2868           (emit-clear-values)))) ; array left on stack here
    2869      (t
    2870       (let ((must-clear-values nil))
    2871         (dolist (arg args)
    2872           (compile-form arg :target :stack)
    2873           (unless must-clear-values
    2874             (unless (single-valued-p arg)
    2875               (setf must-clear-values t))))
    2876         (when must-clear-values
    2877           (emit-clear-values))))) ; args left on stack here
     2860      (aver (not (null (compiland-closure-register compiland))))
     2861      (emit 'aload (compiland-closure-register compiland)))
     2862    (let ((must-clear-values nil))
     2863      (cond ((> (length args) 4)
     2864             (emit-push-constant-int (length args))
     2865             (emit 'anewarray "org/armedbear/lisp/LispObject")
     2866             (let ((i 0))
     2867               (dolist (arg args)
     2868                 (emit 'dup)
     2869                 (emit-push-constant-int i)
     2870                 (compile-form arg :target :stack)
     2871                 (emit 'aastore) ; store value in array
     2872                 (unless must-clear-values
     2873                   (unless (single-valued-p arg)
     2874                     (setf must-clear-values t)))
     2875                 (incf i)))) ; array left on stack here
     2876            (t
     2877             (dolist (arg args)
     2878               (compile-form arg :target :stack)
     2879               (unless must-clear-values
     2880                 (unless (single-valued-p arg)
     2881                   (setf must-clear-values t)))))) ; args left on stack here
     2882      (when must-clear-values
     2883        (emit-clear-values)))
    28782884
    28792885    (if *closure-variables*
     
    37233729    (label EXIT)
    37243730    (when must-clear-values
    3725 ;;       (dformat t "p2-tagbody-node calling emit-clear-values~%")
    37263731      (emit-clear-values))
    37273732    ;; TAGBODY returns NIL.
     
    37303735      (emit-move-from-stack target))))
    37313736
    3732 (defun compile-go (form &key target representation)
     3737(defun p2-go (form &key target representation)
    37333738  (let* ((name (cadr form))
    37343739         (tag (find-tag name)))
    37353740    (unless tag
    3736       (error "COMPILE-GO: tag not found: ~S" name))
    3737     (cond ((eq (tag-compiland tag) *current-compiland*)
    3738            ;; Local case.
    3739            (let ((tag-block (tag-block tag))
    3740                  (register nil))
    3741              ;; Does the GO leave an enclosing UNWIND-PROTECT?
    3742              (let ((protected
    3743                     (dolist (enclosing-block *blocks*)
    3744                       (when (eq enclosing-block tag-block)
    3745                         (return nil))
    3746                       (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
    3747                         (return t)))))
    3748                (when protected
    3749                  (error "COMPILE-GO: enclosing UNWIND-PROTECT")))
    3750              (dolist (block *blocks*)
    3751                (if (eq block tag-block)
    3752                    (return)
    3753                    (setf register (or (block-environment-register block) register))))
    3754              (when register
    3755                ;; Restore dynamic environment.
    3756                (emit 'aload *thread*)
    3757                (emit 'aload register)
    3758                (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)))
    3759            (maybe-generate-interrupt-check) ;; FIXME not exactly right, but better than nothing
    3760            (emit 'goto (tag-label tag)))
    3761           (t
    3762            ;; Non-local GO.
    3763            (emit 'new +lisp-go-class+)
    3764            (emit 'dup)
    3765            (compile-form `',(tag-label tag) :target :stack) ; Tag.
    3766            (emit-invokespecial +lisp-go-class+
    3767                                "<init>"
    3768                                "(Lorg/armedbear/lisp/LispObject;)V"
    3769                                -2)
    3770            (emit 'athrow)
    3771            ;; Following code will not be reached, but is needed for JVM stack
    3772            ;; consistency.
    3773            (when target
    3774              (emit-push-nil)
    3775              (emit-move-from-stack target))))))
     3741      (error "p2-go: tag not found: ~S" name))
     3742    (when (eq (tag-compiland tag) *current-compiland*)
     3743      ;; Local case.
     3744      (let* ((tag-block (tag-block tag))
     3745             (register nil)
     3746             (protected
     3747              ;; Does the GO leave an enclosing UNWIND-PROTECT?
     3748              (dolist (enclosing-block *blocks*)
     3749                (when (eq enclosing-block tag-block)
     3750                  (return nil))
     3751                (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
     3752                  (return t)))))
     3753        (unless protected
     3754          (dolist (block *blocks*)
     3755            (if (eq block tag-block)
     3756                (return)
     3757                (setf register (or (block-environment-register block) register))))
     3758          (when register
     3759            ;; Restore dynamic environment.
     3760            (emit 'aload *thread*)
     3761            (emit 'aload register)
     3762            (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+))
     3763
     3764          ;; FIXME Not exactly the right place for this, but better than nothing.
     3765          (maybe-generate-interrupt-check)
     3766
     3767          (emit 'goto (tag-label tag))
     3768          (return-from p2-go))))
     3769
     3770    ;; Non-local GO.
     3771    (emit 'new +lisp-go-class+)
     3772    (emit 'dup)
     3773    (compile-form `',(tag-label tag) :target :stack) ; Tag.
     3774    (emit-invokespecial +lisp-go-class+
     3775                        "<init>"
     3776                        "(Lorg/armedbear/lisp/LispObject;)V"
     3777                        -2)
     3778    (emit 'athrow)
     3779    ;; Following code will not be reached, but is needed for JVM stack
     3780    ;; consistency.
     3781    (when target
     3782      (emit-push-nil)
     3783      (emit-move-from-stack target))))
    37763784
    37773785(defun compile-atom (form &key (target *val*) representation)
     
    57895797                             declare
    57905798                             funcall
    5791                              go
    57925799                             if
    57935800                             length
     
    58165823(install-p2-handler 'eql            'p2-eql)
    58175824(install-p2-handler 'flet           'p2-flet)
     5825(install-p2-handler 'go             'p2-go)
    58185826(install-p2-handler 'function       'p2-function)
    58195827(install-p2-handler 'labels         'p2-labels)
Note: See TracChangeset for help on using the changeset viewer.