Changeset 11832
- Timestamp:
- 05/05/09 17:22:31 (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r11831 r11832 3953 3953 t) 3954 3954 3955 (defun restore-dynamic-environment (register) 3956 (emit-push-current-thread) 3957 (aload register) 3958 (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" 3959 +lisp-special-binding+)) 3960 3961 (defun save-dynamic-environment (register) 3962 (emit-push-current-thread) 3963 (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" 3964 +lisp-special-binding+) 3965 (astore register)) 3966 3955 3967 (defun p2-m-v-b-node (block target) 3956 3968 (let* ((*blocks* (cons block *blocks*)) … … 3976 3988 ;; Save current dynamic environment. 3977 3989 (setf (block-environment-register block) (allocate-register)) 3978 (emit-push-current-thread) 3979 (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" 3980 +lisp-special-binding+) 3981 (astore (block-environment-register block)) 3990 (save-dynamic-environment (block-environment-register block)) 3982 3991 (label label-START)) 3983 3992 ;; Make sure there are no leftover values from previous calls. … … 4041 4050 (emit 'goto label-EXIT) 4042 4051 (label label-END) 4043 (aload *thread*) 4044 (aload (block-environment-register block)) 4045 (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" 4046 +lisp-special-binding+) 4052 (restore-dynamic-environment (block-environment-register block)) 4047 4053 (emit 'athrow) 4048 4054 4049 4055 ;; Restore dynamic environment. 4050 4056 (label label-EXIT) 4051 (aload *thread*) 4052 (aload (block-environment-register block)) 4053 (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" 4054 +lisp-special-binding+) 4057 (restore-dynamic-environment (block-environment-register block)) 4055 4058 (push (make-handler :from label-START 4056 4059 :to label-END … … 4381 4384 ;; We need to save current dynamic environment. 4382 4385 (setf (block-environment-register block) (allocate-register)) 4383 (emit-push-current-thread) 4384 (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" 4385 +lisp-special-binding+) 4386 (astore (block-environment-register block)) 4386 (save-dynamic-environment (block-environment-register block)) 4387 4387 (label label-START)) 4388 4388 (propagate-vars block) … … 4403 4403 (label label-END) 4404 4404 ;; Restore dynamic environment. 4405 (aload *thread*) 4406 (aload (block-environment-register block)) 4407 (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" 4408 +lisp-special-binding+) 4405 (restore-dynamic-environment (block-environment-register block)) 4409 4406 (emit 'athrow) 4410 4407 4411 4408 (label label-EXIT) 4412 (aload *thread*) 4413 (aload (block-environment-register block)) 4414 (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" 4415 +lisp-special-binding+) 4416 4409 (restore-dynamic-environment (block-environment-register block)) 4417 4410 (push (make-handler :from label-START 4418 4411 :to label-END … … 4459 4452 ;; Non-local transfers of control restore the environment 4460 4453 ;; themselves (in the finally of LET/LET*, etc. 4461 (emit-push-current-thread) 4462 (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" 4463 +lisp-special-binding+) 4464 (astore environment-register)) 4454 (save-dynamic-environment environment-register)) 4465 4455 (label BEGIN-BLOCK) 4466 4456 (do* ((rest body (cdr rest)) … … 4543 4533 (when (block-environment-register tag-block) 4544 4534 ;; If there's a dynamic environment to restore, do it. 4545 (aload *thread*) 4546 (aload (block-environment-register tag-block)) 4547 (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" 4548 +lisp-special-binding+)) 4535 (restore-dynamic-environment (block-environment-register tag-block))) 4549 4536 (maybe-generate-interrupt-check) 4550 4537 (emit 'goto (tag-label tag)) … … 4653 4640 ;; Save the current dynamic environment. 4654 4641 (setf (block-environment-register block) (allocate-register)) 4655 (emit-push-current-thread) 4656 (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) 4657 (astore (block-environment-register block))) 4642 (save-dynamic-environment (block-environment-register block))) 4658 4643 (t 4659 4644 (dformat t "no specials~%"))) … … 4694 4679 (when (block-environment-register block) 4695 4680 ;; We saved the dynamic environment above. Restore it now. 4696 (aload *thread*) 4697 (aload (block-environment-register block)) 4698 (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)) 4681 (restore-dynamic-environment (block-environment-register block))) 4699 4682 (fix-boxing representation nil) 4700 4683 ) … … 4816 4799 (single-valued-p values-form)) 4817 4800 (emit-clear-values)) 4818 (emit-push-current-thread) 4819 (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" 4820 +lisp-special-binding+) 4821 (astore environment-register) 4801 (save-dynamic-environment environment-register) 4822 4802 (label label-START) 4823 4803 ;; Compile call to Lisp.progvBindVars(). 4824 ( aload *thread*)4804 (emit-push-current-thread) 4825 4805 (emit-invokestatic +lisp-class+ "progvBindVars" 4826 4806 (list +lisp-object+ +lisp-object+ +lisp-thread+) nil) … … 4829 4809 (emit 'goto label-EXIT) 4830 4810 (label label-END) 4831 (aload *thread*) 4832 (aload environment-register) 4833 (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" 4834 +lisp-special-binding+) 4811 (restore-dynamic-environment environment-register) 4835 4812 (emit 'athrow) 4836 4813 4837 4814 ;; Restore dynamic environment. 4838 4815 (label label-EXIT) 4839 (aload *thread*) 4840 (aload environment-register) 4841 (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" 4842 +lisp-special-binding+) 4816 (restore-dynamic-environment environment-register) 4843 4817 (fix-boxing representation nil) 4844 4818 (push (make-handler :from label-START … … 7819 7793 ;; catch-all handler, which will do a re-throw. 7820 7794 (emit 'if_acmpne DEFAULT-HANDLER) ; Stack depth is 1. 7821 ( aload *thread*)7795 (emit-push-current-thread) 7822 7796 (emit-invokevirtual +lisp-throw-class+ "getResult" 7823 7797 (list +lisp-thread+) +lisp-object+) … … 7826 7800 (label DEFAULT-HANDLER) ; Start of handler for all other Throwables. 7827 7801 ;; A Throwable object is on the runtime stack here. Stack depth is 1. 7828 ( aload *thread*)7802 (emit-push-current-thread) 7829 7803 (emit-invokevirtual +lisp-thread-class+ "popCatchTag" nil nil) 7830 7804 (emit 'athrow) ; Re-throw. 7831 7805 (label EXIT) 7832 7806 ;; Finally... 7833 ( aload *thread*)7807 (emit-push-current-thread) 7834 7808 (emit-invokevirtual +lisp-thread-class+ "popCatchTag" nil nil) 7835 7809 (let ((handler1 (make-handler :from BEGIN-PROTECTED-RANGE … … 8311 8285 (setf (compiland-environment-register compiland) 8312 8286 (allocate-register)) 8313 (emit-push-current-thread) 8314 (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" 8315 +lisp-special-binding+) 8316 (astore (compiland-environment-register compiland)) 8287 (save-dynamic-environment (compiland-environment-register compiland)) 8317 8288 (label label-START) 8318 8289 (dolist (variable (compiland-arg-vars compiland)) … … 8340 8311 (emit 'goto label-EXIT) 8341 8312 (label label-END) 8342 (emit-push-current-thread) 8343 (aload (compiland-environment-register compiland)) 8344 (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" 8345 +lisp-special-binding+) 8313 (restore-dynamic-environment (compiland-environment-register compiland)) 8346 8314 (emit 'athrow) 8347 8315 8348 8316 ;; Restore dynamic environment 8349 8317 (label label-EXIT) 8350 (emit-push-current-thread) 8351 (aload (compiland-environment-register compiland)) 8352 (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" 8353 +lisp-special-binding+) 8354 8318 (restore-dynamic-environment (compiland-environment-register compiland)) 8355 8319 (push (make-handler :from label-START 8356 8320 :to label-END … … 8379 8343 (ensure-thread-var-initialized) 8380 8344 (maybe-initialize-thread-var) 8381 (aload *thread*)8345 (emit-push-current-thread) 8382 8346 (emit-invokevirtual *this-class* "processArgs" 8383 8347 (list +lisp-object-array+ +lisp-thread+)
Note: See TracChangeset
for help on using the changeset viewer.