From 346494524fdabffb487f33d5eb6eef5a4b6d0efb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 19 Jul 2014 18:10:14 +0900 Subject: [PATCH 1/6] share cache between wrap and inject --- piclib/picrin/macro.scm | 69 +++++++++++++++++++++-------------------- 1 file changed, 35 insertions(+), 34 deletions(-) diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index f1281fec..ffb713b5 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -93,44 +93,26 @@ (define (ir-macro-transformer f) (lambda (expr use-env mac-env) - (define protects (make-dictionary)) - - (define (wrap expr) - (walk - (lambda (atom) - (if (not (symbol? atom)) - atom - (begin - (define id (make-identifier atom use-env)) - (dictionary-set! protects id atom) ; lookup *atom* from id - id))) - expr)) - - (define (unwrap expr) - (define cache (make-dictionary)) - (walk - (lambda (atom) - (if (not (symbol? atom)) - atom - (if (dictionary-has? protects atom) - (dictionary-ref protects atom) - (if (dictionary-has? cache atom) - (dictionary-ref cache atom) - (begin - ;; implicit renaming - (define id (make-identifier atom mac-env)) - (dictionary-set! cache atom id) - id))))) - expr)) - - (define cache (make-dictionary)) + (define icache (make-dictionary)) + (define icache* (make-dictionary)) (define (inject sym) - (if (dictionary-has? cache sym) - (dictionary-ref cache sym) + (if (dictionary-has? icache sym) + (dictionary-ref icache sym) (begin (define id (make-identifier sym use-env)) - (dictionary-set! cache sym id) + (dictionary-set! icache sym id) + (dictionary-set! icache* id sym) + id))) + + (define rcache (make-dictionary)) + + (define (rename sym) + (if (dictionary-has? rcache sym) + (dictionary-ref rcache sym) + (begin + (define id (make-identifier sym mac-env)) + (dictionary-set! rcache sym id) id))) (define (compare x y) @@ -140,6 +122,25 @@ #f (identifier=? mac-env x mac-env y)))) + (define (wrap expr) + (walk + (lambda (atom) + (if (not (symbol? atom)) + atom + (inject atom))) + expr)) + + (define (unwrap expr) + (define cache (make-dictionary)) + (walk + (lambda (atom) + (if (not (symbol? atom)) + atom + (if (dictionary-has? icache* atom) + (dictionary-ref icache* atom) + (rename atom)))) + expr)) + (unwrap (f (wrap expr) inject compare)))) (export make-syntactic-closure From 2c1db4472bc49d3e3772b6d11e8e67ad03862192 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 19 Jul 2014 18:14:11 +0900 Subject: [PATCH 2/6] add walk-symbol --- piclib/picrin/macro.scm | 52 ++++++++++++++++++++--------------------- 1 file changed, 25 insertions(+), 27 deletions(-) diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index ffb713b5..e5002f8a 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -37,20 +37,26 @@ (vector-map proc expr) (proc expr))))) - (define (make-syntactic-closure env free form) - (define cache (make-dictionary)) + (define (walk-symbol proc expr) (walk (lambda (atom) - (if (not (symbol? atom)) - atom - (if (memq atom free) - atom - (if (dictionary-has? cache atom) - (dictionary-ref cache atom) - (begin - (define id (make-identifier atom env)) - (dictionary-set! cache atom id) - id))))) + (if (symbol? atom) + (proc atom) + atom)) + expr)) + + (define (make-syntactic-closure env free form) + (define cache (make-dictionary)) + (walk-symbol + (lambda (sym) + (if (memq sym free) + sym + (if (dictionary-has? cache sym) + (dictionary-ref cache sym) + (begin + (define id (make-identifier sym env)) + (dictionary-set! cache sym id) + id)))) form)) (define (close-syntax form env) @@ -115,6 +121,11 @@ (dictionary-set! rcache sym id) id))) + (define (uninject sym) + (if (dictionary-has? icache* sym) + (dictionary-ref icache* sym) + (rename sym))) + (define (compare x y) (if (not (symbol? x)) #f @@ -123,23 +134,10 @@ (identifier=? mac-env x mac-env y)))) (define (wrap expr) - (walk - (lambda (atom) - (if (not (symbol? atom)) - atom - (inject atom))) - expr)) + (walk-symbol inject expr)) (define (unwrap expr) - (define cache (make-dictionary)) - (walk - (lambda (atom) - (if (not (symbol? atom)) - atom - (if (dictionary-has? icache* atom) - (dictionary-ref icache* atom) - (rename atom)))) - expr)) + (walk-symbol uninject expr)) (unwrap (f (wrap expr) inject compare)))) From 03cc21953f30614469961536230092e07e43f83f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 19 Jul 2014 18:15:38 +0900 Subject: [PATCH 3/6] walk-symbol by default --- piclib/picrin/macro.scm | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index e5002f8a..bec9cdd0 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -28,6 +28,7 @@ (list->vector (map proc (vector->list expr)))) (define (walk proc expr) + "walk on symbols" (if (null? expr) '() (if (pair? expr) @@ -35,19 +36,14 @@ (walk proc (cdr expr))) (if (vector? expr) (vector-map proc expr) - (proc expr))))) + (if (symbol? expr) + (proc expr) + expr))))) - (define (walk-symbol proc expr) - (walk - (lambda (atom) - (if (symbol? atom) - (proc atom) - atom)) - expr)) (define (make-syntactic-closure env free form) (define cache (make-dictionary)) - (walk-symbol + (walk (lambda (sym) (if (memq sym free) sym @@ -134,10 +130,10 @@ (identifier=? mac-env x mac-env y)))) (define (wrap expr) - (walk-symbol inject expr)) + (walk inject expr)) (define (unwrap expr) - (walk-symbol uninject expr)) + (walk uninject expr)) (unwrap (f (wrap expr) inject compare)))) From 1297ef9fb8e176a2d75cc7975c35a35a26385aff Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 19 Jul 2014 18:26:03 +0900 Subject: [PATCH 4/6] add memoize function --- piclib/picrin/macro.scm | 65 ++++++++++++++++++++--------------------- 1 file changed, 31 insertions(+), 34 deletions(-) diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index bec9cdd0..a5155b21 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -40,19 +40,29 @@ (proc expr) expr))))) + (define (memoize f) + "memoize on a symbol" + (define cache (make-dictionary)) + (lambda (sym) + (if (dictionary-has? cache sym) + (dictionary-ref cache sym) + (begin + (define val (f sym)) + (dictionary-set! cache sym val) + val)))) (define (make-syntactic-closure env free form) - (define cache (make-dictionary)) + + (define resolve + (memoize + (lambda (sym) + (make-identifier sym env)))) + (walk (lambda (sym) (if (memq sym free) sym - (if (dictionary-has? cache sym) - (dictionary-ref cache sym) - (begin - (define id (make-identifier sym env)) - (dictionary-set! cache sym id) - id)))) + (resolve sym))) form)) (define (close-syntax form env) @@ -73,15 +83,10 @@ (define (er-macro-transformer f) (lambda (expr use-env mac-env) - (define cache (make-dictionary)) - - (define (rename sym) - (if (dictionary-has? cache sym) - (dictionary-ref cache sym) - (begin - (define id (make-identifier sym mac-env)) - (dictionary-set! cache sym id) - id))) + (define rename + (memoize + (lambda (sym) + (make-identifier sym mac-env)))) (define (compare x y) (if (not (symbol? x)) @@ -95,27 +100,19 @@ (define (ir-macro-transformer f) (lambda (expr use-env mac-env) - (define icache (make-dictionary)) (define icache* (make-dictionary)) - (define (inject sym) - (if (dictionary-has? icache sym) - (dictionary-ref icache sym) - (begin - (define id (make-identifier sym use-env)) - (dictionary-set! icache sym id) - (dictionary-set! icache* id sym) - id))) + (define inject + (memoize + (lambda (sym) + (define id (make-identifier sym use-env)) + (dictionary-set! icache* id sym) + id))) - (define rcache (make-dictionary)) - - (define (rename sym) - (if (dictionary-has? rcache sym) - (dictionary-ref rcache sym) - (begin - (define id (make-identifier sym mac-env)) - (dictionary-set! rcache sym id) - id))) + (define rename + (memoize + (lambda (sym) + (make-identifier sym mac-env)))) (define (uninject sym) (if (dictionary-has? icache* sym) From 63c34327b97185bc68cbf502f5044951f256d941 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 19 Jul 2014 18:26:09 +0900 Subject: [PATCH 5/6] fix a bug in walk function --- piclib/picrin/macro.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index a5155b21..8f279b51 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -35,7 +35,7 @@ (cons (walk proc (car expr)) (walk proc (cdr expr))) (if (vector? expr) - (vector-map proc expr) + (list->vector (walk proc (vector->list expr))) (if (symbol? expr) (proc expr) expr))))) From 8b82498cd7932fae3fa6bc71b5907f7552beb313 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 19 Jul 2014 18:28:10 +0900 Subject: [PATCH 6/6] inline some trivial functions --- piclib/picrin/macro.scm | 17 +++++------------ 1 file changed, 5 insertions(+), 12 deletions(-) diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index 8f279b51..b2cccec3 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -114,11 +114,6 @@ (lambda (sym) (make-identifier sym mac-env)))) - (define (uninject sym) - (if (dictionary-has? icache* sym) - (dictionary-ref icache* sym) - (rename sym))) - (define (compare x y) (if (not (symbol? x)) #f @@ -126,13 +121,11 @@ #f (identifier=? mac-env x mac-env y)))) - (define (wrap expr) - (walk inject expr)) - - (define (unwrap expr) - (walk uninject expr)) - - (unwrap (f (wrap expr) inject compare)))) + (walk (lambda (sym) + (if (dictionary-has? icache* sym) + (dictionary-ref icache* sym) + (rename sym))) + (f (walk inject expr) inject compare)))) (export make-syntactic-closure close-syntax