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

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

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)

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

module/language/cps/types.scm

@@ -547,6 +547,16 @@ minimum, and maximum."
   ((pop-fluid)))
 
 
+
+
+;;;
+;;; Threads.  We don't currently track threads as an object type.
+;;;
+
+(define-simple-types
+  ((current-thread) &all-types))
+
+
 
 
 ;;;

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

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)