summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2015-11-27 16:32:14 +0100
committerAndy Wingo <wingo@pobox.com>2015-12-01 15:42:24 +0100
commit8c75a5eb1b7d75e427953c061fbd8f445cfcc0d8 (patch)
tree3a9f3231e8ebe1a2b19655240c99a4797340a088
parentc3240d09b2d05d0c33d0dcfed076f944fcfa5de4 (diff)
downloadguile-8c75a5eb1b7d75e427953c061fbd8f445cfcc0d8.tar.gz
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.
-rw-r--r--libguile/vm-engine.c15
-rw-r--r--module/language/cps/compile-bytecode.scm2
-rw-r--r--module/language/cps/effects-analysis.scm10
-rw-r--r--module/language/cps/types.scm10
-rw-r--r--module/language/tree-il/primitives.scm2
-rw-r--r--module/system/vm/assembler.scm1
6 files changed, 38 insertions, 2 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 6b2458f0b..991280b0c 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 ad7d8877b..8d1c8ee6f 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 be0d1c2c5..5821c5d0a 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 6daddf0ea..0c46d36f7 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 57072d4d9..724f38416 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 0e4bbf06c..564ec0665 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)