[Guile-commits] 35/41: Add current-thread VM op

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 8c75a5eb1b7d75e427953c061fbd8f445cfcc0d8
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 27 16:32:14 2015 +0100

    Add current-thread VM op
    
    * libguile/vm-engine.c (current-thread): New op.
    * module/language/cps/effects-analysis.scm (&thread): New memory kind.
    
    * module/language/cps/compile-bytecode.scm (compile-function):
    * module/language/cps/effects-analysis.scm (current-thread):
    * module/language/cps/types.scm (current-thread):
    * module/language/tree-il/primitives.scm (*interesting-primitive-names*):
    * module/system/vm/assembler.scm (emit-current-thread): Wire up the new
      op.
---
 libguile/vm-engine.c                     |   15 ++++++++++++++-
 module/language/cps/compile-bytecode.scm |    2 ++
 module/language/cps/effects-analysis.scm |   10 ++++++++++
 module/language/cps/types.scm            |   10 ++++++++++
 module/language/tree-il/primitives.scm   |    2 +-
 module/system/vm/assembler.scm           |    1 +
 6 files changed, 38 insertions(+), 2 deletions(-)

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 6b2458f..991280b 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3468,7 +3468,20 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (3);
     }
 
-  VM_DEFINE_OP (160, unused_160, NULL, NOP)
+  /* current-thread dst:24
+   *
+   * Write the current thread into DST.
+   */
+  VM_DEFINE_OP (160, current_thread, "current-thread", OP1 (X8_S24) | OP_DST)
+    {
+      scm_t_uint32 dst;
+
+      UNPACK_24 (op, dst);
+      SP_SET (dst, thread->handle);
+
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (161, unused_161, NULL, NOP)
   VM_DEFINE_OP (162, unused_162, NULL, NOP)
   VM_DEFINE_OP (163, unused_163, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index ad7d887..8d1c8ee 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -140,6 +140,8 @@
          (emit-make-closure asm (from-sp dst) k nfree))
         (($ $primcall 'current-module)
          (emit-current-module asm (from-sp dst)))
+        (($ $primcall 'current-thread)
+         (emit-current-thread asm (from-sp dst)))
         (($ $primcall 'cached-toplevel-box (scope name bound?))
          (emit-cached-toplevel-box asm (from-sp dst)
                                    (constant scope) (constant name)
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index be0d1c2..5821c5d 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -62,6 +62,7 @@
             &module
             &struct
             &string
+            &thread
             &bytevector
             &closure
 
@@ -170,6 +171,9 @@
   ;; Indicates that an expression depends on the current module.
   &module
 
+  ;; Indicates that an expression depends on the current thread.
+  &thread
+
   ;; Indicates that an expression depends on the value of a struct
   ;; field.  The effect field indicates the specific field, or zero for
   ;; an unknown field.
@@ -285,6 +289,12 @@ is or might be a read or a write to the same location as 
A."
   ((push-fluid f v)                (&write-object &fluid)      &type-check)
   ((pop-fluid)                     (&write-object &fluid)      &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.
+(define-primitive-effects
+  ((current-thread)                (&read-object &thread)))
+
 ;; Prompts.
 (define-primitive-effects
   ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 6daddf0..0c46d36 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -550,6 +550,16 @@ minimum, and maximum."
 
 
 ;;;
+;;; Threads.  We don't currently track threads as an object type.
+;;;
+
+(define-simple-types
+  ((current-thread) &all-types))
+
+
+
+
+;;;
 ;;; Prompts.  (Nothing to do.)
 ;;;
 
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index 57072d4..724f384 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -83,7 +83,7 @@
 
     current-module define!
 
-    fluid-ref fluid-set! with-fluid*
+    current-thread fluid-ref fluid-set! with-fluid*
 
     call-with-prompt
     abort-to-prompt* abort-to-prompt
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 0e4bbf0..564ec06 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -116,6 +116,7 @@
             emit-unwind
             (emit-push-fluid* . emit-push-fluid)
             emit-pop-fluid
+            emit-current-thread
             (emit-fluid-ref* . emit-fluid-ref)
             (emit-fluid-set* . emit-fluid-set)
             (emit-string-length* . emit-string-length)