diff options
author | Andy Wingo <wingo@pobox.com> | 2020-05-12 22:23:13 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2020-05-13 09:04:16 +0200 |
commit | 32eef3dd14b4bed7a63b2c236311eddab8628187 (patch) | |
tree | eed9df10eb7767d7d7d4a3db2b03b5894aeea6b1 /module | |
parent | b1bdd791cefa1b6d113f9b3972550342d8f4aa9f (diff) | |
download | guile-32eef3dd14b4bed7a63b2c236311eddab8628187.tar.gz |
Slight optimization to baseline compiler
* module/language/tree-il/compile-bytecode.scm (compile-closure):
for-value-at and for-values-at take indexes instead of environments to
denote destination.
Diffstat (limited to 'module')
-rw-r--r-- | module/language/tree-il/compile-bytecode.scm | 68 |
1 files changed, 34 insertions, 34 deletions
diff --git a/module/language/tree-il/compile-bytecode.scm b/module/language/tree-il/compile-bytecode.scm index 70820da04..96f5eb8e2 100644 --- a/module/language/tree-il/compile-bytecode.scm +++ b/module/language/tree-il/compile-bytecode.scm @@ -743,9 +743,6 @@ in the frame with for the lambda-case clause @var{clause}." (_ (error "sym not found!" sym)))) (define (compile-body clause module-scope free-vars frame-size) - (define frame-base - (make-env #f 'frame-base #f #f #f #f (- frame-size 1))) - (define (push-free-var sym idx env) (make-env env sym sym idx #t (assigned? sym) (env-next-local env))) @@ -778,10 +775,15 @@ in the frame with for the lambda-case clause @var{clause}." ((sym . free) (lp (1+ idx) free (push-free-var sym idx env)))))) + (define frame-base + (make-env #f 'frame-base #f #f #f #f (- frame-size 1))) (fold push-local (push-closure (push-free-vars frame-base)) names syms)) + (define (stack-height-under-local idx) + (- frame-size idx 1)) + (define (stack-height env) - (- frame-size (env-next-local env) 1)) + (stack-height-under-local (env-next-local env))) (define (maybe-cache-module! scope tmp) (unless module-scope @@ -840,7 +842,7 @@ in the frame with for the lambda-case clause @var{clause}." ('tail ;; Would be nice if we could invoke the body in true tail ;; context, but that's not how it currently is. - (for-values-at body env frame-base) + (for-values-at body env 0) (emit-unwind asm) (emit-handle-interrupts asm) (emit-return-values asm)) @@ -935,8 +937,8 @@ in the frame with for the lambda-case clause @var{clause}." ('effect (for-effect exp env)) ('value (for-value exp env)) ('tail (for-tail exp env)) - (('value-at . base) (for-value-at exp env base)) - (('values-at . base) (for-values-at exp env base)))) + (('value-at . dst) (for-value-at exp env dst)) + (('values-at . height) (for-values-at exp env height)))) (define (for-args exps env) (match exps @@ -1032,7 +1034,7 @@ in the frame with for the lambda-case clause @var{clause}." (($ <fix>) (visit-fix exp env 'effect)) (($ <let-values>) (visit-let-values exp env 'effect)))) - (define (for-value-at exp env base) + (define (for-value-at exp env dst) ;; The baseline compiler follows a stack discipline: compiling ;; temporaries pushes entries on an abstract compile-time stack ;; (the "env"), which are then popped as they are used. Generally @@ -1075,8 +1077,6 @@ in the frame with for the lambda-case clause @var{clause}." ;; this function has to be careful not to do some kind of ;; multi-part computation that first clobbers "dst" and then ;; reads the operands. - (define dst-env (push-temp base)) - (define dst (env-idx dst-env)) (match exp (($ <lexical-ref> src name sym) (maybe-emit-source src) @@ -1136,7 +1136,8 @@ in the frame with for the lambda-case clause @var{clause}." (maybe-emit-source src) (emit-handle-interrupts asm) (emit-call asm proc-slot (1+ (length args))) - (emit-receive asm (stack-height base) proc-slot frame-size))) + (emit-receive asm (stack-height-under-local dst) proc-slot + frame-size))) (($ <primcall> src (? variadic-constructor? name) args) ;; Stage result in 0 to avoid stompling args. @@ -1194,12 +1195,12 @@ in the frame with for the lambda-case clause @var{clause}." (maybe-emit-source src) (apply emit asm dst args)))))))) - (($ <prompt>) (visit-prompt exp env `(value-at . ,base))) - (($ <conditional>) (visit-conditional exp env `(value-at . ,base))) - (($ <seq>) (visit-seq exp env `(value-at . ,base))) - (($ <let>) (visit-let exp env `(value-at . ,base))) - (($ <fix>) (visit-fix exp env `(value-at . ,base))) - (($ <let-values>) (visit-let-values exp env `(value-at . ,base))))) + (($ <prompt>) (visit-prompt exp env `(value-at . ,dst))) + (($ <conditional>) (visit-conditional exp env `(value-at . ,dst))) + (($ <seq>) (visit-seq exp env `(value-at . ,dst))) + (($ <let>) (visit-let exp env `(value-at . ,dst))) + (($ <fix>) (visit-fix exp env `(value-at . ,dst))) + (($ <let-values>) (visit-let-values exp env `(value-at . ,dst))))) (define (for-value exp env) (match (and (lexical-ref? exp) @@ -1210,7 +1211,7 @@ in the frame with for the lambda-case clause @var{clause}." (for-push exp env)))) (define (for-push exp env) - (for-value-at exp env env) + (for-value-at exp env (env-next-local env)) (push-temp env)) (define (for-init sym init env) @@ -1220,12 +1221,12 @@ in the frame with for the lambda-case clause @var{clause}." (let ((done (gensym "post-init"))) (emit-undefined? asm idx) (emit-jne asm done) - (for-value-at init env prev) + (for-value-at init env idx) (emit-label asm done))) (when boxed? (emit-box asm idx idx))))) - (define (for-values-at exp env base) + (define (for-values-at exp env height) (match exp ((or ($ <const>) ($ <lexical-ref>) @@ -1237,29 +1238,28 @@ in the frame with for the lambda-case clause @var{clause}." ($ <module-set>) ($ <lambda>) ($ <primcall>)) - (for-value-at exp env base) - (emit-reset-frame asm (1+ (stack-height base)))) + (for-value-at exp env (- frame-size height 1)) + (emit-reset-frame asm (1+ height))) (($ <call> src proc args) - (let* ((to (stack-height base)) - (env (push-frame env)) + (let* ((env (push-frame env)) (from (stack-height env))) (fold for-push (for-push proc env) args) (maybe-emit-source src) (emit-handle-interrupts asm) (emit-call asm from (1+ (length args))) - (unless (= from to) - (emit-shuffle-down asm from to)))) + (unless (= from height) + (emit-shuffle-down asm from height)))) - (($ <prompt>) (visit-prompt exp env `(values-at . ,base))) - (($ <conditional>) (visit-conditional exp env `(values-at . ,base))) - (($ <seq>) (visit-seq exp env `(values-at . ,base))) - (($ <let>) (visit-let exp env `(values-at . ,base))) - (($ <fix>) (visit-fix exp env `(values-at . ,base))) - (($ <let-values>) (visit-let-values exp env `(values-at . ,base))))) + (($ <prompt>) (visit-prompt exp env `(values-at . ,height))) + (($ <conditional>) (visit-conditional exp env `(values-at . ,height))) + (($ <seq>) (visit-seq exp env `(values-at . ,height))) + (($ <let>) (visit-let exp env `(values-at . ,height))) + (($ <fix>) (visit-fix exp env `(values-at . ,height))) + (($ <let-values>) (visit-let-values exp env `(values-at . ,height))))) (define (for-values exp env) - (for-values-at exp env env)) + (for-values-at exp env (stack-height env))) (define (for-tail exp env) (match exp @@ -1273,7 +1273,7 @@ in the frame with for the lambda-case clause @var{clause}." ($ <module-set>) ($ <lambda>) ($ <primcall>)) - (for-values-at exp env frame-base) + (for-values-at exp env 0) (emit-handle-interrupts asm) (emit-return-values asm)) |