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 6756aeff9 Better compilation for symbol->string
6756aeff9 is described below
commit 6756aeff9514bff792e9804217161a7d8ca61fe5
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Fri Sep 15 10:07:40 2023 +0200
Better compilation for symbol->string
* libguile/intrinsics.c (scm_bootstrap_intrinsics):
* libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): Add symbol->string
intrinsic.
* module/language/cps/guile-vm/reify-primitives.scm
(compute-known-primitives):
* module/language/tree-il/compile-bytecode.scm (+):
* module/language/tree-il/compile-cps.scm (symbol->string):
* module/language/tree-il/cps-primitives.scm (symbol->string):
* module/language/cps/effects-analysis.scm (symbol->string):
* module/language/cps/types.scm (symbol->keyword):
* module/system/vm/assembler.scm (symbol->string): Add the necessary
code to compile symbol->string.
---
libguile/intrinsics.c | 3 ++-
libguile/intrinsics.h | 3 ++-
module/language/cps/effects-analysis.scm | 6 ++++++
module/language/cps/guile-vm/reify-primitives.scm | 1 +
module/language/cps/types.scm | 12 ++++++++++++
module/language/tree-il/compile-bytecode.scm | 1 +
module/language/tree-il/compile-cps.scm | 22 ++++++++++++++++++++++
module/language/tree-il/cps-primitives.scm | 1 +
module/system/vm/assembler.scm | 2 ++
9 files changed, 49 insertions(+), 2 deletions(-)
diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index 8ad64fa25..837464709 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -1,4 +1,4 @@
-/* Copyright 2018-2021
+/* Copyright 2018-2021, 2023
Free Software Foundation, Inc.
This file is part of Guile.
@@ -678,6 +678,7 @@ scm_bootstrap_intrinsics (void)
scm_vm_intrinsics.struct_set_x = struct_set_x;
scm_vm_intrinsics.struct_ref_immediate = struct_ref_immediate;
scm_vm_intrinsics.struct_set_x_immediate = struct_set_x_immediate;
+ scm_vm_intrinsics.symbol_to_string = scm_symbol_to_string;
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_intrinsics",
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 936e06d84..87fcd0e5e 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -1,4 +1,4 @@
-/* Copyright 2018-2021
+/* Copyright 2018-2021, 2023
Free Software Foundation, Inc.
This file is part of Guile.
@@ -217,6 +217,7 @@ typedef void (*scm_t_scm_uimm_scm_intrinsic) (SCM, uint8_t,
SCM);
M(scm_from_scm_scm, lookup_bound, "lookup-bound", LOOKUP_BOUND) \
M(scm_from_scmn_scmn, lookup_bound_public, "lookup-bound-public",
LOOKUP_BOUND_PUBLIC) \
M(scm_from_scmn_scmn, lookup_bound_private, "lookup-bound-private",
LOOKUP_BOUND_PRIVATE) \
+ M(scm_from_scm, symbol_to_string, "symbol->string", SYMBOL_TO_STRING) \
/* Add new intrinsics here; also update scm_bootstrap_intrinsics. */
/* Intrinsics prefixed with $ are meant to reduce bytecode size,
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index bd7c03239..66f95a6bb 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -408,6 +408,12 @@ the LABELS that are clobbered by the effects of LABEL."
((push-dynamic-state state) (&write-object &fluid) &type-check)
((pop-dynamic-state) (&write-object &fluid)))
+(define-primitive-effects
+ ((symbol->string x)) ;; CPS lowering includes symbol? type check.
+ ((symbol->keyword) &type-check)
+ ((string->symbol) &type-check)
+ ((keyword->symbol) &type-check))
+
;; Threads. Calls cause &all-effects, which reflects the fact that any
;; call can capture a partial continuation and reinstate it on another
;; thread.
diff --git a/module/language/cps/guile-vm/reify-primitives.scm
b/module/language/cps/guile-vm/reify-primitives.scm
index ea5ee92a6..871d12524 100644
--- a/module/language/cps/guile-vm/reify-primitives.scm
+++ b/module/language/cps/guile-vm/reify-primitives.scm
@@ -337,6 +337,7 @@
string->number
string->symbol
symbol->keyword
+ symbol->string
class-of
scm->f64
s64->u64 s64->scm scm->s64
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index f33d07492..422e31ec0 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -925,6 +925,18 @@ minimum, and maximum."
+;;;
+;;; Symbols and keywords
+;;;
+(define-simple-types
+ ((symbol->keyword &symbol) &keyword)
+ ((keyword->symbol &keyword) &symbol)
+ ((symbol->string &symbol) &string)
+ ((string->symbol &string) &symbol))
+
+
+
+
;;;
;;; Threads. We don't currently track threads as an object type.
;;;
diff --git a/module/language/tree-il/compile-bytecode.scm
b/module/language/tree-il/compile-bytecode.scm
index c4c9bf614..2be2b1397 100644
--- a/module/language/tree-il/compile-bytecode.scm
+++ b/module/language/tree-il/compile-bytecode.scm
@@ -267,6 +267,7 @@
(string->number #:nargs 1 #:has-result? #t #:emit emit-string->number)
(string->symbol #:nargs 1 #:has-result? #t #:emit emit-string->symbol)
(symbol->keyword #:nargs 1 #:has-result? #t #:emit emit-symbol->keyword)
+ (symbol->string #:nargs 1 #:has-result? #t #:emit emit-symbol->string)
(class-of #:nargs 1 #:has-result? #t #:emit emit-class-of)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 9ebdb72a3..42a1c90da 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -350,6 +350,28 @@
($continue kinit src
($primcall 'allocate-vector/immediate size ()))))))
+(define-primcall-converter symbol->string
+ (lambda (cps k src op param sym)
+ (define not-symbol
+ #(wrong-type-arg
+ "symbol->string"
+ "Wrong type argument in position 1 (expecting symbol): ~S"))
+ (with-cps cps
+ (letk knot-symbol
+ ($kargs () () ($throw src 'throw/value+data not-symbol (sym))))
+ ;; This is the right lowering but the Guile-VM backend gets it a
+ ;; bit wrong: the symbol->string intrinsic instruction includes a
+ ;; type-check and actually allocates. We should change symbols in
+ ;; Guile-VM so that symbol->string is cheaper.
+ (letk ksym
+ ($kargs () ()
+ ($continue k src ($primcall 'symbol->string #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 (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 380ebb48f..c6ab96471 100644
--- a/module/language/tree-il/cps-primitives.scm
+++ b/module/language/tree-il/cps-primitives.scm
@@ -70,6 +70,7 @@
(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 integer->char 1 1)
(define-cps-primitive char->integer 1 1)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index ef67c1846..aa1d324a2 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -258,6 +258,7 @@
emit-lookup-bound-private
emit-define!
emit-current-module
+ emit-symbol->string
;; Intrinsics for use by the baseline compiler.
emit-$car
@@ -1572,6 +1573,7 @@ returned instead."
(define-scm<-scmn-scmn-intrinsic lookup-bound-private)
(define-scm<-scm-scm-intrinsic define!)
(define-scm<-thread-intrinsic current-module)
+(define-scm<-scm-intrinsic symbol->string)
(define-scm<-scm-intrinsic $car)
(define-scm<-scm-intrinsic $cdr)
