[Guile-commits] 19/24: string->number, etc intrinsics

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 1c49c1407bcb9b765a5f58719743fab65790ceca
Author: Andy Wingo <address@hidden>
Date:   Tue Apr 10 17:56:08 2018 +0200

    string->number, etc intrinsics
    
    * libguile/intrinsics.c (string_to_number): New helper.
      (scm_bootstrap_intrinsics): Init new intrinsics.
    * libguile/intrinsics.h (string->number, string->symbol)
      (symbol->keyword): Add new intrinsics.
    * libguile/vm-engine.c (call-scm<-scm): New intrinsic dispatcher.
      (string->number, string->symbol, symbol->keyword): Disable these
      instructions.
    * module/system/vm/assembler.scm (encode-X8_S12_S12-C32<-/shuffle):
      (define-scm<-scm-intrinsic): Enable scm<-scm intrinsics.
      (string->number, string->symbol, symbol->keyword): New intrinsic
      assemblers.
---
 libguile/intrinsics.c          |  9 +++++++++
 libguile/intrinsics.h          |  4 ++++
 libguile/vm-engine.c           | 39 ++++++++++++++++++++-------------------
 module/system/vm/assembler.scm | 21 ++++++++++++++++++---
 4 files changed, 51 insertions(+), 22 deletions(-)

diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index 808708b..b974ce1 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -65,6 +65,12 @@ string_set_x (SCM str, scm_t_uint64 idx, scm_t_uint64 ch)
   scm_i_string_stop_writing ();
 }
 
+static SCM
+string_to_number (SCM str)
+{
+  return scm_string_to_number (str, SCM_UNDEFINED /* radix = 10 */);
+}
+
 void
 scm_bootstrap_intrinsics (void)
 {
@@ -81,6 +87,9 @@ scm_bootstrap_intrinsics (void)
   scm_vm_intrinsics.logior = scm_logior;
   scm_vm_intrinsics.logxor = scm_logxor;
   scm_vm_intrinsics.string_set_x = string_set_x;
+  scm_vm_intrinsics.string_to_number = string_to_number;
+  scm_vm_intrinsics.string_to_symbol = scm_string_to_symbol;
+  scm_vm_intrinsics.symbol_to_keyword = scm_symbol_to_keyword;
 
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_intrinsics",
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 5c0d790..b9cc8e4 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -26,6 +26,7 @@
 typedef SCM (*scm_t_scm_from_scm_scm_intrinsic) (SCM, SCM);
 typedef SCM (*scm_t_scm_from_scm_uimm_intrinsic) (SCM, scm_t_uint8);
 typedef void (*scm_t_scm_u64_u64_intrinsic) (SCM, scm_t_uint64, scm_t_uint64);
+typedef SCM (*scm_t_scm_from_scm_intrinsic) (SCM);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
   M(scm_from_scm_scm, add, "add", ADD) \
@@ -41,6 +42,9 @@ typedef void (*scm_t_scm_u64_u64_intrinsic) (SCM, 
scm_t_uint64, scm_t_uint64);
   M(scm_from_scm_scm, logior, "logior", LOGIOR) \
   M(scm_from_scm_scm, logxor, "logxor", LOGXOR) \
   M(scm_u64_u64, string_set_x, "string-set!", STRING_SET_X) \
+  M(scm_from_scm, string_to_number, "string->number", STRING_TO_NUMBER) \
+  M(scm_from_scm, string_to_symbol, "string->symbol", STRING_TO_SYMBOL) \
+  M(scm_from_scm, symbol_to_keyword, "symbol->keyword", SYMBOL_TO_KEYWORD) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 enum scm_vm_intrinsic
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 74f5ec0..86290fc 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1546,7 +1546,23 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (2);
     }
 
-  VM_DEFINE_OP (54, unused_54, NULL, NOP)
+  VM_DEFINE_OP (54, call_scm_from_scm, "call-scm<-scm", OP2 (X8_S12_S12, C32) 
| OP_DST)
+    {
+      scm_t_uint8 dst, src;
+      SCM res;
+      scm_t_scm_from_scm_intrinsic intrinsic;
+
+      UNPACK_12_12 (op, dst, src);
+      intrinsic = intrinsics[ip[1]];
+
+      SYNC_IP ();
+      res = intrinsic (SP_REF (src));
+      CACHE_SP ();
+      SP_SET (dst, res);
+
+      NEXT (2);
+    }
+
   VM_DEFINE_OP (55, unused_55, NULL, NOP)
   VM_DEFINE_OP (56, unused_56, NULL, NOP)
     {
@@ -2122,14 +2138,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       abort (); /* never reached */
     }
 
-  /* string-set! instruction is currently number 192.  Probably need to
-     reorder before releasing.  */
-
-  /* string->number dst:12 src:12
-   *
-   * Parse a string in SRC to a number, and store in DST.
-   */
-  VM_DEFINE_OP (78, string_to_number, "string->number", OP1 (X8_S12_S12) | 
OP_DST)
+  VM_DEFINE_OP (78, unused_78, NULL, NOP)
     {
       scm_t_uint16 dst, src;
 
@@ -2141,11 +2150,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  /* string->symbol dst:12 src:12
-   *
-   * Parse a string in SRC to a symbol, and store in DST.
-   */
-  VM_DEFINE_OP (79, string_to_symbol, "string->symbol", OP1 (X8_S12_S12) | 
OP_DST)
+  VM_DEFINE_OP (79, unused_79, NULL, NOP)
     {
       scm_t_uint16 dst, src;
 
@@ -2155,11 +2160,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  /* symbol->keyword dst:12 src:12
-   *
-   * Make a keyword from the symbol in SRC, and store it in DST.
-   */
-  VM_DEFINE_OP (80, symbol_to_keyword, "symbol->keyword", OP1 (X8_S12_S12) | 
OP_DST)
+  VM_DEFINE_OP (80, unused_80, NULL, NOP)
     {
       scm_t_uint16 dst, src;
       UNPACK_12_12 (op, dst, src);
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 3e36dfe..08e0366 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -196,6 +196,9 @@
             emit-logior
             emit-logxor
             emit-string-set!
+            emit-string->number
+            emit-string->symbol
+            emit-symbol->keyword
 
             emit-call
             emit-call-label
@@ -231,9 +234,6 @@
             emit-current-thread
             emit-fluid-ref
             emit-fluid-set!
-            emit-string->number
-            emit-string->symbol
-            emit-symbol->keyword
             emit-lsh
             emit-rsh
             emit-lsh/immediate
@@ -900,6 +900,14 @@ later by the linker."
     (emit-push asm (+ c 2))
     (encode-X8_S8_S8_S8-C32 asm 2 1 0 c32 opcode)
     (emit-drop asm 3))))
+(define (encode-X8_S12_S12-C32<-/shuffle asm dst src c32 opcode)
+  (cond
+   ((< (logior dst src) (ash 1 12))
+    (encode-X8_S12_S12-C32 asm dst src c32 opcode))
+   (else
+    (emit-push asm src)
+    (encode-X8_S12_S12-C32 asm 0 0 c32 opcode)
+    (emit-pop asm dst))))
 
 (eval-when (expand)
   (define (id-append ctx a b)
@@ -921,6 +929,7 @@ later by the linker."
       (('<- 'X8_S8_S8_S8 'C32)   #'encode-X8_S8_S8_S8-C32<-/shuffle)
       (('<- 'X8_S8_S8_C8 'C32)   #'encode-X8_S8_S8_C8-C32<-/shuffle)
       (('! 'X8_S8_S8_C8 'C32)    #'encode-X8_S8_S8_C8-C32!/shuffle)
+      (('<- 'X8_S12_S12 'C32)    #'encode-X8_S12_S12-C32<-/shuffle)
       (('! 'X8_S8_C8_S8)         #'encode-X8_S8_C8_S8!/shuffle)
       (('<- 'X8_S8_C8_S8)        #'encode-X8_S8_C8_S8<-/shuffle)
       (else (encoder-name operands))))
@@ -1282,6 +1291,9 @@ returned instead."
 (define-syntax-rule (define-scm-u64-u64-intrinsic name)
   (define-macro-assembler (name asm a b c)
     (emit-call-scm-u64-u64 asm a b c (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-scm-intrinsic name)
+  (define-macro-assembler (name asm dst src)
+    (emit-call-scm<-scm asm dst src (intrinsic-name->index 'name))))
 
 (define-scm<-scm-scm-intrinsic add)
 (define-scm<-scm-uimm-intrinsic add/immediate)
@@ -1296,6 +1308,9 @@ returned instead."
 (define-scm<-scm-scm-intrinsic logior)
 (define-scm<-scm-scm-intrinsic logxor)
 (define-scm-u64-u64-intrinsic string-set!)
+(define-scm<-scm-intrinsic string->number)
+(define-scm<-scm-intrinsic string->symbol)
+(define-scm<-scm-intrinsic symbol->keyword)
 
 (define-macro-assembler (begin-program asm label properties)
   (emit-label asm label)