mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Emit handle-interrupts in baseline compiler

Browse source 
* module/language/tree-il/compile-bytecode.scm (compile-closure): Handle
  interrupts before calls, returns, and tail calls.
This commit is contained in:
Andy Wingo 2020-05-11 16:15:24 +02:00
parent b5108ccb2a
commit b35fd53664
1 changed files with 6 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

8
module/language/tree-il/compile-bytecode.scm
View file

@ -25,8 +25,6 @@
;;; ;;;
;;; Code: ;;; Code:
;; FIXME: Add handle-interrupts, instrument-entry, and instrument-loop.
;; FIXME: Verify that all SCM values on the stack will be marked. ;; FIXME: Verify that all SCM values on the stack will be marked.
;; FIXME: Verify that the stack marker will never misinterpret an ;; FIXME: Verify that the stack marker will never misinterpret an
@ -854,6 +852,7 @@ in the frame with for the lambda-case clause @var{clause}."
;; context, but that's not how it currently is. ;; context, but that's not how it currently is.
(for-values-at body env (frame-base env)) (for-values-at body env (frame-base env))
(emit-unwind asm) (emit-unwind asm)
(emit-handle-interrupts asm)
(emit-return-values asm)) (emit-return-values asm))
(_ (_
(for-context body env ctx) (for-context body env ctx)
@ -993,6 +992,7 @@ in the frame with for the lambda-case clause @var{clause}."
(let ((proc-slot (let ((env (push-frame env))) (let ((proc-slot (let ((env (push-frame env)))
(fold for-push (for-push proc env) args) (fold for-push (for-push proc env) args)
(stack-height env)))) (stack-height env))))
(emit-handle-interrupts asm)
(emit-call asm proc-slot (1+ (length args))) (emit-call asm proc-slot (1+ (length args)))
(emit-reset-frame asm frame-size))) (emit-reset-frame asm frame-size)))
@ -1121,6 +1121,7 @@ in the frame with for the lambda-case clause @var{clause}."
(let ((proc-slot (let ((env (push-frame env))) (let ((proc-slot (let ((env (push-frame env)))
(fold for-push (for-push proc env) args) (fold for-push (for-push proc env) args)
(stack-height env)))) (stack-height env))))
(emit-handle-interrupts asm)
(emit-call asm proc-slot (1+ (length args))) (emit-call asm proc-slot (1+ (length args)))
(emit-receive asm (stack-height base) proc-slot frame-size))) (emit-receive asm (stack-height base) proc-slot frame-size)))
@ -1226,6 +1227,7 @@ in the frame with for the lambda-case clause @var{clause}."
(env (push-frame env)) (env (push-frame env))
(from (stack-height env))) (from (stack-height env)))
(fold for-push (for-push proc env) args) (fold for-push (for-push proc env) args)
(emit-handle-interrupts asm)
(emit-call asm from (1+ (length args))) (emit-call asm from (1+ (length args)))
(unless (= from to) (unless (= from to)
(emit-shuffle-down asm from to)))) (emit-shuffle-down asm from to))))
@ -1253,6 +1255,7 @@ in the frame with for the lambda-case clause @var{clause}."
($ <lambda>) ($ <lambda>)
($ <primcall>)) ($ <primcall>))
(for-values-at exp env (frame-base env)) (for-values-at exp env (frame-base env))
(emit-handle-interrupts asm)
(emit-return-values asm)) (emit-return-values asm))
(($ <call> src proc args) (($ <call> src proc args)
@ -1263,6 +1266,7 @@ in the frame with for the lambda-case clause @var{clause}."
(lp (1- i) (env-prev env)) (lp (1- i) (env-prev env))
(emit-mov asm (+ (env-idx env) base) (env-idx env)))) (emit-mov asm (+ (env-idx env) base) (env-idx env))))
(emit-reset-frame asm (+ 1 (length args))) (emit-reset-frame asm (+ 1 (length args)))
(emit-handle-interrupts asm)
(emit-tail-call asm))) (emit-tail-call asm)))
(($ <prompt>) (visit-prompt exp env 'tail)) (($ <prompt>) (visit-prompt exp env 'tail))