Changeset 12086


Ignore:
Timestamp:
08/08/09 15:20:28 (12 years ago)
Author:
ehuelsmann
Message:

Make every form which may contain free specials declarations a BLOCK-NODE.

LOCALLY, FLET and LABELS were not converted to blocks - yet.

While at it, change the block dispatch routine: we're not smart enough to
detect that the (block-name form) form will generate the same value every
time - so we don't cache the function result, but evaluate it each time.

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

Legend:

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

    r12040 r12086  
    234234
    235235(defun p1-locally (form)
    236   (let ((*visible-variables* *visible-variables*)
    237         (specials (process-special-declarations (cdr form))))
    238     (dolist (name specials)
     236  (let* ((*visible-variables* *visible-variables*)
     237         (block (make-block-node '(LOCALLY)))
     238         (free-specials (process-declarations-for-vars (cdr form) nil)))
     239    (setf (block-free-specials block) free-specials)
     240    (dolist (special free-specials)
    239241;;       (format t "p1-locally ~S is special~%" name)
    240       (push (make-variable :name name :special-p t) *visible-variables*))
    241     (setf (cdr form) (p1-body (cdr form)))
    242     form))
     242      (push special *visible-variables*))
     243    (let ((*blocks* (cons block *blocks*)))
     244      (setf (block-form block)
     245            (list* 'LOCALLY (p1-body (cdr form))))
     246      block)))
    243247
    244248(defknown p1-m-v-b (t) t)
     
    632636      ((with-saved-compiler-policy
    633637     (process-optimization-declarations (cddr form))
    634    (list* (car form) local-functions (p1-body (cddr form)))))))
     638         (let* ((block (make-block-node '(FLET)))
     639                (*blocks* (cons block *blocks*))
     640                (body (cddr form))
     641                (*visible-variables* *visible-variables*))
     642           (setf (block-free-specials block)
     643                 (process-declarations-for-vars body nil))
     644           (dolist (special (block-free-specials block))
     645             (push special *visible-variables*))
     646           (setf (block-form block)
     647                 (list* (car form) local-functions (p1-body (cddr form))))
     648           block)))))
    635649
    636650
     
    652666         (*current-compiland* (local-function-compiland local-function)))
    653667     (p1-compiland (local-function-compiland local-function))))
    654        (list* (car form) local-functions (p1-body (cddr form))))))
     668       (let* ((block (make-block-node '(LABELS)))
     669              (*blocks* (cons block *blocks*))
     670              (body (cddr form))
     671              (*visible-variables* *visible-variables*))
     672         (setf (block-free-specials block)
     673               (process-declarations-for-vars body nil))
     674         (dolist (special (block-free-specials block))
     675           (push special *visible-variables*))
     676         (setf (block-form block)
     677               (list* (car form) local-functions (p1-body (cddr form))))
     678         block))))
    655679
    656680(defknown p1-funcall (t) t)
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12071 r12086  
    44374437              label-START))))
    44384438
    4439 (defun p2-locally (form target representation)
     4439(defknown p2-locally-node (t t t) t)
     4440(defun p2-locally-node (block target representation)
    44404441  (with-saved-compiler-policy
    4441     (let* ((body (cdr form))
    4442            (*visible-variables* *visible-variables*)
    4443            (specials (process-special-declarations body)))
    4444       (dolist (name specials)
    4445         (push (make-variable :name name :special-p t) *visible-variables*))
     4442    (let* ((body (cdr (block-form block)))
     4443           (*visible-variables* (append (block-free-specials block)
     4444                                        *visible-variables*))
     4445           (*blocks* (cons block *blocks*)))
    44464446      (process-optimization-declarations body)
    44474447      (compile-progn-body body target representation))))
     
    49534953      local-function compiland g)))))))
    49544954
    4955 (defknown p2-flet (t t t) t)
    4956 (defun p2-flet (form target representation)
    4957   (let ((*local-functions* *local-functions*)
    4958         (*visible-variables* *visible-variables*)
    4959         (local-functions (cadr form))
    4960         (body (cddr form)))
     4955(defknown p2-flet-node (t t t) t)
     4956(defun p2-flet-node (block target representation)
     4957  (let* ((form (block-form block))
     4958         (*local-functions* *local-functions*)
     4959         (*visible-variables* *visible-variables*)
     4960         (local-functions (cadr form))
     4961         (body (cddr form)))
    49614962    (dolist (local-function local-functions)
    49624963      (p2-flet-process-compiland local-function))
    49634964    (dolist (local-function local-functions)
    49644965      (push local-function *local-functions*))
    4965     (dolist (special (process-special-declarations body))
    4966       (push (make-variable :name special :special-p t) *visible-variables*))
     4966    (dolist (special (block-free-specials block))
     4967      (push special *visible-variables*))
    49674968    (compile-progn-body body target representation)))
    49684969
    4969 (defknown p2-labels (t t t) t)
    4970 (defun p2-labels (form target representation)
    4971   (let ((*local-functions* *local-functions*)
    4972         (*visible-variables* *visible-variables*)
    4973         (local-functions (cadr form))
    4974         (body (cddr form)))
     4970(defknown p2-labels-node (t t t) t)
     4971(defun p2-labels-node (block target representation)
     4972  (let* ((form (block-form block))
     4973         (*local-functions* *local-functions*)
     4974         (*visible-variables* *visible-variables*)
     4975         (local-functions (cadr form))
     4976         (body (cddr form)))
    49754977    (dolist (local-function local-functions)
    49764978      (push local-function *local-functions*)
     
    49834985    (dolist (local-function local-functions)
    49844986      (p2-labels-process-compiland local-function))
    4985     (dolist (special (process-special-declarations body))
    4986       (push (make-variable :name special :special-p t) *visible-variables*))
     4987    (dolist (special (block-free-specials block))
     4988      (push special *visible-variables*))
    49874989    (compile-progn-body body target representation)))
    49884990
     
    79027904         (compile-var-ref form target representation))
    79037905        ((block-node-p form)
    7904          (cond ((equal (block-name form) '(TAGBODY))
    7905                 (p2-tagbody-node form target)
    7906                 (fix-boxing representation nil))
    7907                ((equal (block-name form) '(LET))
    7908                 (p2-let/let*-node form target representation))
    7909                ((equal (block-name form) '(MULTIPLE-VALUE-BIND))
    7910                 (p2-m-v-b-node form target)
    7911                 (fix-boxing representation nil))
    7912                ((equal (block-name form) '(UNWIND-PROTECT))
    7913                 (p2-unwind-protect-node form target)
    7914                 (fix-boxing representation nil))
    7915                ((equal (block-name form) '(CATCH))
    7916                 (p2-catch-node form target)
    7917                 (fix-boxing representation nil))
    7918                ((equal (block-name form) '(PROGV))
    7919                 (p2-progv-node form target representation))
    7920                ((equal (block-name form) '(THREADS:SYNCHRONIZED-ON))
    7921                 (p2-threads-synchronized-on form target)
    7922                 (fix-boxing representation nil))
    7923                (t
    7924                 (p2-block-node form target representation))))
     7906         (let ((name (block-name form)))
     7907           (if (not (consp name))
     7908               (p2-block-node form target representation)
     7909               (let ((name (car name)))
     7910                 (cond ((eq name 'TAGBODY)
     7911                        (p2-tagbody-node form target)
     7912                        (fix-boxing representation nil))
     7913                       ((eq name 'LET)
     7914                        (p2-let/let*-node form target representation))
     7915                       ((eq name 'FLET)
     7916                        (p2-flet-node form target representation))
     7917                       ((eq name 'LABELS)
     7918                        (p2-labels-node form target representation))
     7919                       ((eq name 'MULTIPLE-VALUE-BIND)
     7920                        (p2-m-v-b-node form target)
     7921                        (fix-boxing representation nil))
     7922                       ((eq name 'UNWIND-PROTECT)
     7923                        (p2-unwind-protect-node form target)
     7924                        (fix-boxing representation nil))
     7925                       ((eq name 'CATCH)
     7926                        (p2-catch-node form target)
     7927                        (fix-boxing representation nil))
     7928                       ((eq name 'PROGV)
     7929                        (p2-progv-node form target representation))
     7930                       ((eq name 'LOCALLY)
     7931                        (p2-locally-node form target representation))
     7932                       ((eq name 'THREADS:SYNCHRONIZED-ON)
     7933                        (p2-threads-synchronized-on form target)
     7934                        (fix-boxing representation nil)))))))
    79257935        ((constantp form)
    79267936         (compile-constant form target representation))
     
    85978607  (install-p2-handler 'find-class          'p2-find-class)
    85988608  (install-p2-handler 'fixnump             'p2-fixnump)
    8599   (install-p2-handler 'flet                'p2-flet)
    86008609  (install-p2-handler 'funcall             'p2-funcall)
    86018610  (install-p2-handler 'function            'p2-function)
     
    86078616  (install-p2-handler 'go                  'p2-go)
    86088617  (install-p2-handler 'if                  'p2-if)
    8609   (install-p2-handler 'labels              'p2-labels)
    86108618  (install-p2-handler 'length              'p2-length)
    86118619  (install-p2-handler 'list                'p2-list)
     
    86148622  (install-p2-handler 'sys::backq-list*    'p2-list*)
    86158623  (install-p2-handler 'load-time-value     'p2-load-time-value)
    8616   (install-p2-handler 'locally             'p2-locally)
    86178624  (install-p2-handler 'logand              'p2-logand)
    86188625  (install-p2-handler 'logior              'p2-logior)
Note: See TracChangeset for help on using the changeset viewer.