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

@@ -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",

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,

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.

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

module/language/cps/types.scm

@@ -923,6 +923,18 @@ minimum, and maximum."
   ((pop-dynamic-state)))
 
 
+
+
+;;;
+;;; Symbols and keywords
+;;;
+(define-simple-types
+  ((symbol->keyword &symbol) &keyword)
+  ((keyword->symbol &keyword) &symbol)
+  ((symbol->string &symbol) &string)
+  ((string->symbol &string) &symbol))
+
+
 
 
 ;;;

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)
 

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

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)

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)