Ticket #90: ticket-90.patch

File ticket-90.patch, 11.7 KB (added by ehuelsmann, 10 years ago)

Patch implementing a solution

  • compiler-pass2.lisp

     
    4444  (require "JVM-INSTRUCTIONS")
    4545  (require "JAVA"))
    4646
     47(defvar *outer-block-restores-environment* nil)
    4748
    4849(declaim (inline pool-name pool-string pool-name-and-type
    4950                 pool-class pool-field pool-method pool-int
     
    30833084           (emit-move-from-stack target)))
    30843085        (t
    30853086         (let ((clear-values nil)
    3086                (tail body))
     3087               (tail body)
     3088               (outer-block-restores
     3089                *outer-block-restores-environment*)
     3090               (*outer-block-restores-environment* nil))
    30873091           (loop
    30883092             (let ((form (car tail)))
    30893093               (cond ((null (cdr tail))
    30903094                      ;; Last form.
    30913095                      (when clear-values
    30923096                        (emit-clear-values))
    3093                       (compile-form form target representation)
     3097                      (let ((*outer-block-restores-environment*
     3098                             outer-block-restores))
     3099                        (compile-form form target representation))
    30943100                      (return))
    30953101                     (t
    30963102                      ;; Not the last form.
     
    32063212    (dolist (variable (m-v-b-free-specials block))
    32073213      (push variable *visible-variables*))
    32083214    ;; Body.
    3209     (let ((*blocks* (cons block *blocks*)))
     3215    (let ((*blocks* (cons block *blocks*))
     3216          (*outer-block-restores-environment*
     3217           (or *outer-block-restores-environment* bind-special-p)))
    32103218      (compile-progn-body (cdddr form) target))
    32113219    (when bind-special-p
    3212       (restore-dynamic-environment (m-v-b-environment-register block)))))
     3220      (unless *outer-block-restores-environment*
     3221        (restore-dynamic-environment (m-v-b-environment-register block))))))
    32133222
    32143223(defun propagate-vars (block)
    32153224  (let ((removed '()))
     
    35643573    ;; Body of LET/LET*.
    35653574    (with-saved-compiler-policy
    35663575      (process-optimization-declarations (cddr form))
    3567       (let ((*blocks* (cons block *blocks*)))
     3576      (let ((*blocks* (cons block *blocks*))
     3577            (*outer-block-restores-environment*
     3578             (or *outer-block-restores-environment* specialp)))
    35683579        (compile-progn-body (cddr form) target representation)))
    35693580    (when specialp
    3570       (restore-dynamic-environment (let-environment-register block)))))
     3581      (unless *outer-block-restores-environment*
     3582        (restore-dynamic-environment (let-environment-register block))))))
    35713583
    35723584(defknown p2-locally-node (t t t) t)
    35733585(defun p2-locally-node (block target representation)
     
    39673979      (emit-invokestatic +lisp+ "progvBindVars"
    39683980       (list +lisp-object+ +lisp-object+ +lisp-thread+) nil))
    39693981      ;; Implicit PROGN.
    3970     (let ((*blocks* (cons block *blocks*)))
     3982    (let ((*blocks* (cons block *blocks*))
     3983          (*outer-block-restores-environment* t))
    39713984      (compile-progn-body (cdddr form) target representation))
    3972     (restore-dynamic-environment environment-register)))
     3985    (unless *outer-block-restores-environment*
     3986      (restore-dynamic-environment environment-register))))
    39733987
    39743988(defun p2-quote (form target representation)
    39753989  (aver (or (null representation) (eq representation :boolean)))
     
    69546968
    69556969(defknown compile-form (t t t) t)
    69566970(defun compile-form (form target representation)
    6957   (cond ((consp form)
    6958          (let* ((op (%car form))
    6959                 (handler (and (symbolp op) (get op 'p2-handler))))
    6960            (cond (handler
    6961                   (funcall handler form target representation))
    6962                  ((symbolp op)
    6963                   (cond ((macro-function op *compile-file-environment*)
    6964                          (compile-form (macroexpand form *compile-file-environment*)
    6965                                        target representation))
    6966                         ((special-operator-p op)
    6967                          (dformat t "form = ~S~%" form)
    6968                          (compiler-unsupported
    6969                           "COMPILE-FORM: unsupported special operator ~S" op))
    6970                         (t
    6971                          (compile-function-call form target representation))))
    6972                  ((and (consp op) (eq (%car op) 'LAMBDA))
    6973                   (aver (progn 'unexpected-lambda nil))
    6974                   (let ((new-form (list* 'FUNCALL form)))
    6975                     (compile-form new-form target representation)))
     6971  (let ((outer-block-restores *outer-block-restores-environment*)
     6972        (*outer-block-restores-environment* nil))
     6973    (cond ((consp form)
     6974           (let* ((op (%car form))
     6975                  (handler (and (symbolp op) (get op 'p2-handler))))
     6976             (cond (handler
     6977                    (funcall handler form target representation))
     6978                   ((symbolp op)
     6979                    (cond ((macro-function op *compile-file-environment*)
     6980                           (compile-form (macroexpand form *compile-file-environment*)
     6981                                         target representation))
     6982                          ((special-operator-p op)
     6983                           (dformat t "form = ~S~%" form)
     6984                           (compiler-unsupported
     6985                            "COMPILE-FORM: unsupported special operator ~S" op))
     6986                          (t
     6987                           (compile-function-call form target representation))))
     6988                   ((and (consp op) (eq (%car op) 'LAMBDA))
     6989                    (aver (progn 'unexpected-lambda nil))
     6990                    (let ((new-form (list* 'FUNCALL form)))
     6991                      (compile-form new-form target representation)))
     6992                   (t
     6993                    (compiler-unsupported "COMPILE-FORM unhandled case ~S" form)))))
     6994          ((symbolp form)
     6995           (cond ((null form)
     6996                  (emit-push-false representation)
     6997                  (emit-move-from-stack target representation))
     6998                 ((eq form t)
     6999                  (emit-push-true representation)
     7000                  (emit-move-from-stack target representation))
     7001                 ((keywordp form)
     7002                  (ecase representation
     7003                    (:boolean
     7004                     (emit 'iconst_1))
     7005                    ((nil)
     7006                     (emit-load-externalized-object form)))
     7007                  (emit-move-from-stack target representation))
    69767008                 (t
    6977                   (compiler-unsupported "COMPILE-FORM unhandled case ~S" form)))))
    6978         ((symbolp form)
    6979          (cond ((null form)
    6980                 (emit-push-false representation)
    6981                 (emit-move-from-stack target representation))
    6982                ((eq form t)
    6983                 (emit-push-true representation)
    6984                 (emit-move-from-stack target representation))
    6985                ((keywordp form)
    6986                 (ecase representation
    6987                   (:boolean
    6988                    (emit 'iconst_1))
    6989                   ((nil)
    6990                    (emit-load-externalized-object form)))
    6991                 (emit-move-from-stack target representation))
    6992                (t
    6993                 ;; Shouldn't happen.
    6994                 (aver nil))))
    6995         ((var-ref-p form)
    6996          (compile-var-ref form target representation))
    6997         ((node-p form)
    6998          (cond
    6999            ((jump-node-p form)
    7000             (let ((op (car (node-form form))))
    7001               (cond
    7002                ((eq op 'go)
    7003                 (p2-go form target representation))
    7004                ((eq op 'return-from)
    7005                 (p2-return-from form target representation))
    7006                (t
    7007                 (assert (not "jump-node: can't happen"))))))
    7008            ((block-node-p form)
    7009             (p2-block-node form target representation))
    7010            ((let/let*-node-p form)
    7011             (p2-let/let*-node form target representation))
    7012            ((tagbody-node-p form)
    7013             (p2-tagbody-node form target)
    7014             (fix-boxing representation nil))
    7015            ((unwind-protect-node-p form)
    7016             (p2-unwind-protect-node form target)
    7017             (fix-boxing representation nil))
    7018            ((m-v-b-node-p form)
    7019             (p2-m-v-b-node form target)
    7020             (fix-boxing representation nil))
    7021            ((flet-node-p form)
    7022             (p2-flet-node form target representation))
    7023            ((labels-node-p form)
    7024             (p2-labels-node form target representation))
    7025            ((locally-node-p form)
    7026             (p2-locally-node form target representation))
    7027            ((catch-node-p form)
    7028             (p2-catch-node form target)
    7029             (fix-boxing representation nil))
    7030            ((progv-node-p form)
    7031             (p2-progv-node form target representation))
    7032            ((synchronized-node-p form)
    7033             (p2-threads-synchronized-on form target)
    7034             (fix-boxing representation nil))
    7035            (t
    7036             (aver (not "Can't happen")))
    7037 ))
    7038         ((constantp form)
    7039          (compile-constant form target representation))
    7040         (t
    7041          (compiler-unsupported "COMPILE-FORM unhandled case ~S" form)))
     7009                  ;; Shouldn't happen.
     7010                  (aver nil))))
     7011          ((var-ref-p form)
     7012           (compile-var-ref form target representation))
     7013          ((node-p form)
     7014           (cond
     7015             ((jump-node-p form)
     7016              (let ((op (car (node-form form))))
     7017                (cond
     7018                  ((eq op 'go)
     7019                   (p2-go form target representation))
     7020                  ((eq op 'return-from)
     7021                   (p2-return-from form target representation))
     7022                  (t
     7023                   (assert (not "jump-node: can't happen"))))))
     7024             ((block-node-p form)
     7025              (p2-block-node form target representation))
     7026             ((let/let*-node-p form)
     7027              (setq *outer-block-restores-environment* outer-block-restores)
     7028              (p2-let/let*-node form target representation))
     7029             ((tagbody-node-p form)
     7030              (p2-tagbody-node form target)
     7031              (fix-boxing representation nil))
     7032             ((unwind-protect-node-p form)
     7033              (p2-unwind-protect-node form target)
     7034              (fix-boxing representation nil))
     7035             ((m-v-b-node-p form)
     7036              (setq *outer-block-restores-environment* outer-block-restores)
     7037              (p2-m-v-b-node form target)
     7038              (fix-boxing representation nil))
     7039             ((flet-node-p form)
     7040              (p2-flet-node form target representation))
     7041             ((labels-node-p form)
     7042              (p2-labels-node form target representation))
     7043             ((locally-node-p form)
     7044              (p2-locally-node form target representation))
     7045             ((catch-node-p form)
     7046              (p2-catch-node form target)
     7047              (fix-boxing representation nil))
     7048             ((progv-node-p form)
     7049              (setq *outer-block-restores-environment* outer-block-restores)
     7050              (p2-progv-node form target representation))
     7051             ((synchronized-node-p form)
     7052              (p2-threads-synchronized-on form target)
     7053              (fix-boxing representation nil))
     7054             (t
     7055              (aver (not "Can't happen")))
     7056             ))
     7057          ((constantp form)
     7058           (compile-constant form target representation))
     7059          (t
     7060           (compiler-unsupported "COMPILE-FORM unhandled case ~S" form))))
    70427061  t)
    70437062
    70447063
     
    73017320                                +lisp-special-binding+)
    73027321            (astore (variable-binding-register variable)))))
    73037322
    7304       (compile-progn-body body 'stack)
     7323      (let ((*outer-block-restores-environment*
     7324             (compiland-environment-register compiland)))
     7325        (compile-progn-body body 'stack))
    73057326
    73067327      (when (compiland-environment-register compiland)
    73077328        (restore-dynamic-environment (compiland-environment-register compiland)))