diff options
author | Andy Wingo <wingo@pobox.com> | 2015-11-27 16:32:14 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-12-01 15:42:24 +0100 |
commit | 8c75a5eb1b7d75e427953c061fbd8f445cfcc0d8 (patch) | |
tree | 3a9f3231e8ebe1a2b19655240c99a4797340a088 | |
parent | c3240d09b2d05d0c33d0dcfed076f944fcfa5de4 (diff) | |
download | guile-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.c | 15 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 2 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 10 | ||||
-rw-r--r-- | module/language/cps/types.scm | 10 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 2 | ||||
-rw-r--r-- | 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 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) |