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

Baseline O(1) access to frame-base env

Browse source 
* module/language/tree-il/compile-bytecode.scm (compile-closure): No
  need to search for frame-base.
This commit is contained in:
Andy Wingo 2020-05-11 16:43:08 +02:00
parent aed324bcd4
commit f66111a203
1 changed files with 10 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -752,26 +752,21 @@ in the frame with for the lambda-case clause @var{clause}."
(lookup-lexical sym prev))) (lookup-lexical sym prev)))
(_ (error "sym not found!" sym)))) (_ (error "sym not found!" sym))))
(define (frame-base env)
(match env
(($ <env> _ 'frame-base #f)
env)
(($ <env> prev)
(frame-base prev))))
(define (compile-body clause module-scope free-vars frame-size) (define (compile-body clause module-scope free-vars frame-size)
(define (push-free-var sym idx env) (define frame-base
(make-env env sym sym idx #t (assigned? sym) #f)) (make-env #f 'frame-base #f #f #f #f (- frame-size 1)))
(define (push-closure env) (define (push-free-var sym idx env)
(push-local 'closure #f (make-env env sym sym idx #t (assigned? sym) (env-next-local env)))
(make-env env 'frame-base #f #f #f #f (- frame-size 1))))
(define (push-local name sym env) (define (push-local name sym env)
(let ((idx (env-next-local env))) (let ((idx (env-next-local env)))
(emit-definition asm name (- frame-size idx 1) 'scm) (emit-definition asm name (- frame-size idx 1) 'scm)
(make-env env name sym idx #f (assigned? sym) (1- idx)))) (make-env env name sym idx #f (assigned? sym) (1- idx))))
(define (push-closure env)
(push-local 'closure #f env))
(define (push-local-alias name sym idx env) (define (push-local-alias name sym idx env)
(make-env env name sym idx #f #f (env-next-local env))) (make-env env name sym idx #f #f (env-next-local env)))
@ -793,7 +788,7 @@ in the frame with for the lambda-case clause @var{clause}."
((sym . free) ((sym . free)
(lp (1+ idx) free (lp (1+ idx) free
(push-free-var sym idx env)))))) (push-free-var sym idx env))))))
(fold push-local (push-closure (push-free-vars #f)) names syms)) (fold push-local (push-closure (push-free-vars frame-base)) names syms))
(define (stack-height env) (define (stack-height env)
(- frame-size (env-next-local env) 1)) (- frame-size (env-next-local env) 1))
@ -850,7 +845,7 @@ in the frame with for the lambda-case clause @var{clause}."
('tail ('tail
;; Would be nice if we could invoke the body in true tail ;; Would be nice if we could invoke the body in true tail
;; 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)
(emit-unwind asm) (emit-unwind asm)
(emit-handle-interrupts asm) (emit-handle-interrupts asm)
(emit-return-values asm)) (emit-return-values asm))
@ -1254,7 +1249,7 @@ in the frame with for the lambda-case clause @var{clause}."
($ <module-set>) ($ <module-set>)
($ <lambda>) ($ <lambda>)
($ <primcall>)) ($ <primcall>))
(for-values-at exp env (frame-base env)) (for-values-at exp env frame-base)
(emit-handle-interrupts asm) (emit-handle-interrupts asm)
(emit-return-values asm)) (emit-return-values asm))