From ebcbd534b6ae9e28b4ae2cb2fc052eddfd32a6d1 Mon Sep 17 00:00:00 2001 From: Shiro Kawai Date: Fri, 25 Oct 2024 16:56:51 -1000 Subject: [PATCH] Allow inlining literal closures given to getter-with-setter https://github.com/shirok/Gauche/issues/1076 --- ChangeLog | 6 ++++++ src/compile-1.scm | 14 ++++++++++++++ 2 files changed, 20 insertions(+) diff --git a/ChangeLog b/ChangeLog index a997b8ce7..2eda3798c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2024-10-25 Shiro Kawai + + * src/compile-1.scm (pass1/check-inlinable-lambda): Allow inlining + literal closures given to getter-with-setter + https://github.com/shirok/Gauche/issues/1076 + 2024-10-10 Shiro Kawai * lib/gauche/version-alist.scm (gauche): Allow excluding certain diff --git a/src/compile-1.scm b/src/compile-1.scm index cf09d2daf..11a2b8ffe 100644 --- a/src/compile-1.scm +++ b/src/compile-1.scm @@ -516,6 +516,7 @@ (define eager. (global-id 'eager)) (define else. (global-id 'else)) (define error. (global-id 'error)) +(define getter-with-setter. (global-id 'getter-with-setter)) (define include-ci. (global-id 'include-ci)) (define include. (global-id 'include)) (define lambda. (global-id 'lambda)) @@ -735,6 +736,19 @@ (values closures closed) (loop (cdr lvars) (cdr inits) (acons (car lvars) (car inits) closed))))))] + ;; Special treatment of + ;; (define-inline foo (getter-with-setter (lambda ...) (lambda.. ))) + [(and (has-tag? iform $CALL) + (has-tag? ($call-proc iform) $GREF) + (global-identifier=? ($gref-id ($call-proc iform)) + getter-with-setter.) + (= (length ($call-args iform)) 2)) + (receive (closures1 closed1) + (pass1/check-inlinable-lambda (car ($call-args iform))) + (receive (closures2 closed2) + (pass1/check-inlinable-lambda (cadr ($call-args iform))) + (values (append closures1 closures2) + (append closed1 closed2))))] [else (values '() '())])) (define (pass1/define-inline-classify-env name lv&inits cenv)