This is an automated email from the git hooks/post-receive script.
wingo pushed a commit to branch main
in repository guile.
The following commit(s) were added to refs/heads/main by this push:
new 1ad31adf3 Better compilation for symbol->keyword, keyword->symbol
1ad31adf3 is described below
commit 1ad31adf30feaca08baca9ba7a458eb642993d35
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Mon Sep 18 12:29:42 2023 +0200
Better compilation for symbol->keyword, keyword->symbol
* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
(*effect-free-primitives*): Recognize keyword->symbol, symbol->keyword.
* module/language/tree-il/cps-primitives.scm: Plumb through to CPS.
(keyword->symbol):
* module/language/cps/effects-analysis.scm: New prims have no effect.
Fix effects for string->symbol.
(annotation->memory-kind): Add keywords.
* module/language/cps/guile-vm/lower-primcalls.scm (keyword->symbol):
Lower to scm-ref/immediate.
* module/language/cps/types.scm (annotation->type): Add case for
keywords.
* module/language/tree-il/compile-cps.scm: Add converters for new prims,
with type guards.
---
module/language/cps/effects-analysis.scm | 9 +++---
module/language/cps/guile-vm/lower-primcalls.scm | 6 ++++
module/language/cps/types.scm | 3 +-
module/language/tree-il/compile-cps.scm | 36 ++++++++++++++++++++++++
module/language/tree-il/cps-primitives.scm | 5 +++-
module/language/tree-il/primitives.scm | 2 ++
6 files changed, 55 insertions(+), 6 deletions(-)
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index b22dff92e..69f0a51de 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -409,9 +409,9 @@ the LABELS that are clobbered by the effects of LABEL."
(define-primitive-effects
((symbol->string x)) ;; CPS lowering includes symbol? type check.
- ((symbol->keyword) &type-check)
- ((string->symbol) &type-check)
- ((keyword->symbol) &type-check))
+ ((symbol->keyword)) ;; Same.
+ ((keyword->symbol)) ;; Same, for keyword?.
+ ((string->symbol) (&read-object &string) &type-check))
;; Threads. Calls cause &all-effects, which reflects the fact that any
;; call can capture a partial continuation and reinstate it on another
@@ -457,7 +457,8 @@ the LABELS that are clobbered by the effects of LABEL."
('box &box)
('closure &closure)
('struct &struct)
- ('atomic-box &unknown-memory-kinds)))
+ ('atomic-box &unknown-memory-kinds)
+ ('keyword &unknown-memory-kinds)))
(define-primitive-effects* param
((allocate-vector size) (&allocate &vector))
diff --git a/module/language/cps/guile-vm/lower-primcalls.scm
b/module/language/cps/guile-vm/lower-primcalls.scm
index a0271b9cc..ae14f34e0 100644
--- a/module/language/cps/guile-vm/lower-primcalls.scm
+++ b/module/language/cps/guile-vm/lower-primcalls.scm
@@ -602,6 +602,12 @@
(8 2)))
())))))
+(define-primcall-lowerer (keyword->symbol cps k src #f (kw))
+ (with-cps cps
+ (build-term
+ ($continue k src
+ ($primcall 'scm-ref/immediate '(keyword . 1) (kw))))))
+
(define-branching-primcall-lowerer (procedure? cps kf kt src #f (x))
(with-cps cps
(letv procedure? result)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 94473de5b..858f08b2e 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -831,7 +831,8 @@ minimum, and maximum."
('box &box)
('closure &procedure)
('struct &struct)
- ('atomic-box &all-types)))
+ ('atomic-box &all-types)
+ ('keyword &keyword)))
(define (annotation->mutable-type ann)
(match ann
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 1c4139439..5c0fac579 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -372,6 +372,42 @@
(build-term
($branch knot-symbol kheap-object src 'heap-object? #f (sym))))))
+(define-primcall-converter symbol->keyword
+ (lambda (cps k src op param sym)
+ (define not-symbol
+ #(wrong-type-arg
+ "symbol->keyword"
+ "Wrong type argument in position 1 (expecting symbol): ~S"))
+ (with-cps cps
+ (letk knot-symbol
+ ($kargs () () ($throw src 'throw/value+data not-symbol (sym))))
+ (letk ksym
+ ($kargs () ()
+ ($continue k src ($primcall 'symbol->keyword #f (sym)))))
+ (letk kheap-object
+ ($kargs () ()
+ ($branch knot-symbol ksym src 'symbol? #f (sym))))
+ (build-term
+ ($branch knot-symbol kheap-object src 'heap-object? #f (sym))))))
+
+(define-primcall-converter keyword->symbol
+ (lambda (cps k src op param kw)
+ (define not-keyword
+ #(wrong-type-arg
+ "keyword->symbol"
+ "Wrong type argument in position 1 (expecting keyword): ~S"))
+ (with-cps cps
+ (letk knot-keyword
+ ($kargs () () ($throw src 'throw/value+data not-keyword (kw))))
+ (letk kkw
+ ($kargs () ()
+ ($continue k src ($primcall 'keyword->symbol #f (kw)))))
+ (letk kheap-object
+ ($kargs () ()
+ ($branch knot-keyword kkw src 'keyword? #f (kw))))
+ (build-term
+ ($branch knot-keyword kheap-object src 'heap-object? #f (kw))))))
+
(define (ensure-pair cps src op pred x is-pair)
(define msg
(match pred
diff --git a/module/language/tree-il/cps-primitives.scm
b/module/language/tree-il/cps-primitives.scm
index 367a1cb4b..f755d9474 100644
--- a/module/language/tree-il/cps-primitives.scm
+++ b/module/language/tree-il/cps-primitives.scm
@@ -69,10 +69,13 @@
(define-cps-primitive string-ref 2 1)
(define-cps-primitive string-set! 3 0)
(define-cps-primitive string->number 1 1)
+
(define-cps-primitive string->symbol 1 1)
-(define-cps-primitive symbol->keyword 1 1)
(define-cps-primitive symbol->string 1 1)
+(define-cps-primitive symbol->keyword 1 1)
+(define-cps-primitive keyword->symbol 1 1)
+
(define-cps-primitive integer->char 1 1)
(define-cps-primitive char->integer 1 1)
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 3ddfb0fbc..3921f81d2 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -57,6 +57,7 @@
bytevector? keyword? bitvector?
symbol->string string->symbol
+ keyword->symbol symbol->keyword
procedure? thunk?
@@ -185,6 +186,7 @@
char<? char<=? char>=? char>?
integer->char char->integer number->string string->number
symbol->string string->symbol
+ keyword->symbol symbol->keyword
struct-vtable
length string-length vector-length bytevector-length
;; These all should get expanded out by expand-primitives.
