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

@@ -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))

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)

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

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

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)
 

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.