[Guile-commits] 08/24: Add string-set! intrinsic

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 0ae1e943d8fb9dd4417994f8bc5d128062cac0d5
Author: Andy Wingo <address@hidden>
Date:   Tue Apr 10 11:51:31 2018 +0200

    Add string-set! intrinsic
    
    * libguile/intrinsics.c (string_set_x): New intrinsic.
      (scm_bootstrap_intrinsics): Initialize intrinsic.
    * libguile/intrinsics.h: Add string-set! intrinsic.
    * libguile/vm-engine.c (call-scm-u64-u64): New intrinsic trampoline.
    * module/system/vm/assembler.scm (encode-X8_S8_S8_S8-C32!/shuffle): New
      shuffling encoder.
      (define-scm-u64-u64-intrinsic): New helper.
---
 libguile/intrinsics.c          |  9 +++++++++
 libguile/intrinsics.h          |  2 ++
 libguile/vm-engine.c           | 15 ++++++++++++---
 module/system/vm/assembler.scm | 14 ++++++++++++++
 4 files changed, 37 insertions(+), 3 deletions(-)

diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index 1778ea9..808708b 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -57,6 +57,14 @@ sub_immediate (SCM a, scm_t_uint8 b)
   return scm_difference (a, scm_from_uint8 (b));
 }
 
+static void
+string_set_x (SCM str, scm_t_uint64 idx, scm_t_uint64 ch)
+{
+  str = scm_i_string_start_writing (str);
+  scm_i_string_set_x (str, idx, ch);
+  scm_i_string_stop_writing ();
+}
+
 void
 scm_bootstrap_intrinsics (void)
 {
@@ -72,6 +80,7 @@ scm_bootstrap_intrinsics (void)
   scm_vm_intrinsics.logand = scm_logand;
   scm_vm_intrinsics.logior = scm_logior;
   scm_vm_intrinsics.logxor = scm_logxor;
+  scm_vm_intrinsics.string_set_x = string_set_x;
 
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_intrinsics",
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 4ed6c54..5c0d790 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -25,6 +25,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);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
   M(scm_from_scm_scm, add, "add", ADD) \
@@ -39,6 +40,7 @@ typedef SCM (*scm_t_scm_from_scm_uimm_intrinsic) (SCM, 
scm_t_uint8);
   M(scm_from_scm_scm, logand, "logand", LOGAND) \
   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) \
   /* 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 db4eb83..188d529 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1538,10 +1538,19 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (2);
     }
 
-  VM_DEFINE_OP (53, unused_53, NULL, NOP)
+  VM_DEFINE_OP (53, call_scm_u64_u64, "call-scm-u64-u64", OP2 (X8_S8_S8_S8, 
C32))
     {
-      vm_error_bad_instruction (op);
-      abort (); /* never reached */
+      scm_t_uint8 a, b, c;
+      scm_t_scm_u64_u64_intrinsic intrinsic;
+
+      UNPACK_8_8_8 (op, a, b, c);
+      intrinsic = intrinsics[ip[1]];
+
+      SYNC_IP ();
+      intrinsic (SP_REF (a), SP_REF_U64 (b), SP_REF_U64 (c));
+      CACHE_SP ();
+
+      NEXT (2);
     }
 
   /* make-closure dst:24 offset:32 _:8 nfree:24
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index e1dd9e3..bb1b5a3 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -892,6 +892,16 @@ later by the linker."
     (emit-push asm a)
     (encode-X8_S8_S8_C8-C32 asm 0 0 const c32 opcode)
     (emit-pop asm dst))))
+(define (encode-X8_S8_S8_S8-C32!/shuffle asm a b c c32 opcode)
+  (cond
+   ((< (logior a b c) (ash 1 8))
+    (encode-X8_S8_S8_S8-C32 asm a b c c32 opcode))
+   (else
+    (emit-push asm a)
+    (emit-push asm (+ b 1))
+    (emit-push asm (+ c 2))
+    (encode-X8_S8_S8_S8-C32 asm 2 1 0 c32 opcode)
+    (emit-drop asm 3))))
 
 (eval-when (expand)
   (define (id-append ctx a b)
@@ -912,6 +922,7 @@ later by the linker."
       (('<- 'X8_S8_S8_C8)        #'encode-X8_S8_S8_C8<-/shuffle)
       (('<- '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_S8_C8_S8)         #'encode-X8_S8_C8_S8!/shuffle)
       (('<- 'X8_S8_C8_S8)        #'encode-X8_S8_C8_S8<-/shuffle)
       (else (encoder-name operands))))
@@ -1270,6 +1281,9 @@ returned instead."
 (define-syntax-rule (define-scm<-scm-uimm-intrinsic name)
   (define-macro-assembler (name asm dst a b)
     (emit-call-scm<-scm-uimm asm dst a b (intrinsic-name->index 'name))))
+(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-scm<-scm-scm-intrinsic add)
 (define-scm<-scm-uimm-intrinsic add/immediate)