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.

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