Changeset 12123
- Timestamp:
- 08/28/09 09:04:44 (13 years ago)
- Location:
- trunk/abcl/src/org/armedbear/lisp
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
r12116 r12123 201 201 (declare (type cons form)) 202 202 (let* ((*visible-variables* *visible-variables*) 203 (block (make-block-node '(LET))) 204 (*blocks* (cons block *blocks*)) 203 (block (make-let/let*-node)) 205 204 (op (%car form)) 206 205 (varlist (cadr form)) … … 223 222 (when (special-variable-p (variable-name variable)) 224 223 (setf (variable-special-p variable) t 225 ( block-environment-register block) t)))224 (let-environment-register block) t))) 226 225 ;; For processing declarations, we want to walk the variable list from 227 226 ;; last to first, since declarations apply to the last-defined variable 228 227 ;; with the specified name. 229 (setf ( block-free-specials block)228 (setf (let-free-specials block) 230 229 (process-declarations-for-vars body (reverse vars) block)) 231 (setf ( block-vars block) vars)230 (setf (let-vars block) vars) 232 231 ;; Make free specials visible. 233 (dolist (variable ( block-free-specials block))232 (dolist (variable (let-free-specials block)) 234 233 (push variable *visible-variables*))) 235 (setf body (p1-body body)) 236 (setf (block-form block) (list* op varlist body)) 234 (let ((*blocks* (cons block *blocks*))) 235 (setf body (p1-body body))) 236 (setf (let-form block) (list* op varlist body)) 237 237 block)) 238 238 -
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r12120 r12123 4073 4073 (defun propagate-vars (block) 4074 4074 (let ((removed '())) 4075 (dolist (variable ( block-vars block))4075 (dolist (variable (let-vars block)) 4076 4076 (unless (or (variable-special-p variable) 4077 4077 (variable-closure-index variable)) … … 4105 4105 (let* ((symbol (get (variable-name variable) 4106 4106 'sys::dotimes-index-variable-name)) 4107 (index-variable (find-variable symbol ( block-vars block))))4107 (index-variable (find-variable symbol (let-vars block)))) 4108 4108 (when index-variable 4109 4109 (setf (get (variable-name index-variable) … … 4120 4120 (when removed 4121 4121 (dolist (variable removed) 4122 (setf ( block-vars block) (remove variable (block-vars block)))))))4122 (setf (let-vars block) (remove variable (let-vars block))))))) 4123 4123 4124 4124 (defun derive-variable-representation (variable block … … 4157 4157 (limit-variable (and name 4158 4158 (or (find-variable name 4159 ( block-vars block))4159 (let-vars block)) 4160 4160 (find-visible-variable name))))) 4161 4161 (when limit-variable … … 4265 4265 (defknown p2-let-bindings (t) t) 4266 4266 (defun p2-let-bindings (block) 4267 (dolist (variable ( block-vars block))4267 (dolist (variable (let-vars block)) 4268 4268 (unless (or (variable-special-p variable) 4269 4269 (variable-closure-index variable) … … 4280 4280 ;; because we'll lose JVM stack consistency if there is a non-local 4281 4281 ;; transfer of control from one of the initforms. 4282 (dolist (variable ( block-vars block))4282 (dolist (variable (let-vars block)) 4283 4283 (let* ((initform (variable-initform variable)) 4284 4284 (unused-p (and (not (variable-special-p variable)) … … 4321 4321 (compile-binding (cdr temp)))) 4322 4322 ;; Now make the variables visible. 4323 (dolist (variable ( block-vars block))4323 (dolist (variable (let-vars block)) 4324 4324 (push variable *visible-variables*)) 4325 4325 t) … … 4330 4330 (declare (type boolean must-clear-values)) 4331 4331 ;; Generate code to evaluate initforms and bind variables. 4332 (dolist (variable ( block-vars block))4332 (dolist (variable (let-vars block)) 4333 4333 (let* ((initform (variable-initform variable)) 4334 4334 (unused-p (and (not (variable-special-p variable)) … … 4402 4402 4403 4403 (defun p2-let/let*-node (block target representation) 4404 (let* ( (*blocks* (cons block *blocks*))4404 (let* ( 4405 4405 (*register* *register*) 4406 (form ( block-form block))4406 (form (let-form block)) 4407 4407 (*visible-variables* *visible-variables*) 4408 4408 (specialp nil) 4409 4409 (label-START (gensym))) 4410 4410 ;; Walk the variable list looking for special bindings and unused lexicals. 4411 (dolist (variable ( block-vars block))4411 (dolist (variable (let-vars block)) 4412 4412 (cond ((variable-special-p variable) 4413 4413 (setf specialp t)) … … 4417 4417 (when specialp 4418 4418 ;; We need to save current dynamic environment. 4419 (setf ( block-environment-register block) (allocate-register))4420 (save-dynamic-environment ( block-environment-register block))4419 (setf (let-environment-register block) (allocate-register)) 4420 (save-dynamic-environment (let-environment-register block)) 4421 4421 (label label-START)) 4422 4422 (propagate-vars block) … … 4427 4427 (p2-let*-bindings block))) 4428 4428 ;; Make declarations of free specials visible. 4429 (dolist (variable ( block-free-specials block))4429 (dolist (variable (let-free-specials block)) 4430 4430 (push variable *visible-variables*)) 4431 4431 ;; Body of LET/LET*. 4432 4432 (with-saved-compiler-policy 4433 4433 (process-optimization-declarations (cddr form)) 4434 (compile-progn-body (cddr form) target representation)) 4434 (let ((*blocks* (cons block *blocks*))) 4435 (compile-progn-body (cddr form) target representation))) 4435 4436 (when specialp 4436 (restore-environment-and-make-handler ( block-environment-register block)4437 (restore-environment-and-make-handler (let-environment-register block) 4437 4438 label-START)))) 4438 4439 … … 7908 7909 ((var-ref-p form) 7909 7910 (compile-var-ref form target representation)) 7910 ((block-node-p form)7911 (let ((name (block-name form)))7912 (if (not (consp name))7913 (p2-block-node form target representation)7914 (let ((name (car name)))7915 (cond7916 ((eq name 'LET)7917 (p2-let/let*-node form target representation))7918 ((eq name 'SETF) ;; SETF functions create7919 ;; consp block names, if we're unlucky7920 (p2-block-node form target representation))7921 (t7922 (print name)7923 (aver (not "Can't happen.")))7924 )))))7925 7911 ((node-p form) 7926 7912 (cond 7913 ((block-node-p form) 7914 (p2-block-node form target representation)) 7915 ((let/let*-node-p form) 7916 (p2-let/let*-node form target representation)) 7927 7917 ((tagbody-node-p form) 7928 7918 (p2-tagbody-node form target) -
trunk/abcl/src/org/armedbear/lisp/jvm.lisp
r12101 r12123 439 439 return-p 440 440 ;; True if there is a non-local RETURN from this block. 441 non-local-return-p 442 ;; If non-nil, register containing saved dynamic environment for this block. 443 environment-register 444 ;; Only used in LET/LET*/M-V-B nodes. 445 vars 446 free-specials 447 ) 441 non-local-return-p) 448 442 449 443 (defvar *blocks* ()) … … 482 476 (or (unwind-protect-node-p object) 483 477 (catch-node-p object) 484 (synchronized-node-p object) 485 (and (block-node-p object) 486 (equal (block-name object) '(THREADS:SYNCHRONIZED-ON))))) 478 (synchronized-node-p object))) 487 479 488 480 … … 504 496 (when (eq enclosing-block outermost-block) 505 497 (return nil)) 506 (when (or (and (binding-node-p enclosing-block) 507 (binding-node-environment-register enclosing-block)) 508 (and (block-node-p enclosing-block) 509 (block-environment-register enclosing-block))) 498 (when (and (binding-node-p enclosing-block) 499 (binding-node-environment-register enclosing-block)) 510 500 (return t)))) 511 501 … … 521 511 (or (and (binding-node-p block) 522 512 (binding-node-environment-register block)) 523 (and (block-node-p block)524 (block-environment-register block))525 513 last-register))) 526 514 (reduce #'outermost-register *blocks*
Note: See TracChangeset
for help on using the changeset viewer.