threads: use context-switching primitives

diff --git a/basis/boxes/boxes.factor b/basis/boxes/boxes.factor
index 39f8eb44cc354c3a68e19396a0dd69943e21d963..811c5addb078ac56714808ecb4b8b5f8687bf140 100644 (file)
--- a/basis/boxes/boxes.factor
+++ b/basis/boxes/boxes.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2010 Slava Pestov.\r
 ! See http://factorcode.org/license.txt for BSD license.\r
 USING: kernel accessors ;\r
 IN: boxes\r
@@ -15,9 +15,11 @@ ERROR: box-full box ;
 \r
 ERROR: box-empty box ;\r
 \r
+: check-box ( box -- box )\r
+    dup occupied>> [ box-empty ] unless ; inline\r
+\r
 : box> ( box -- value )\r
-    dup occupied>>\r
-    [ [ f ] change-value f >>occupied drop ] [ box-empty ] if ;\r
+    check-box [ f ] change-value f >>occupied drop ;\r
 \r
 : ?box ( box -- value/f ? )\r
     dup occupied>> [ box> t ] [ drop f f ] if ;\r

diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index a95456cdc6a42ae7c7f9c53984d2ec76e972063b..b0a751b1723d82939a4e8665a28c5019247f2139 100644 (file)
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -247,7 +247,6 @@ M: bad-executable summary
     unwind-native-frames
     lazy-jit-compile
     c-to-factor
-    call-clear
 } [ dup '[ _ do-not-compile ] "special" set-word-prop ] each
 
 : infer-special ( word -- )
@@ -299,466 +298,184 @@ M: bad-executable summary
     3tri ;
 
 ! Stack effects for all primitives
-\ fixnum< { fixnum fixnum } { object } define-primitive
-\ fixnum< make-foldable
-
-\ fixnum<= { fixnum fixnum } { object } define-primitive
-\ fixnum<= make-foldable
-
-\ fixnum> { fixnum fixnum } { object } define-primitive
-\ fixnum> make-foldable
-
-\ fixnum>= { fixnum fixnum } { object } define-primitive
-\ fixnum>= make-foldable
-
-\ eq? { object object } { object } define-primitive
-\ eq? make-foldable
-
-\ bignum>fixnum { bignum } { fixnum } define-primitive
-\ bignum>fixnum make-foldable
-
-\ float>fixnum { float } { fixnum } define-primitive
-\ bignum>fixnum make-foldable
-
-\ fixnum>bignum { fixnum } { bignum } define-primitive
-\ fixnum>bignum make-foldable
-
-\ float>bignum { float } { bignum } define-primitive
-\ float>bignum make-foldable
-
-\ fixnum>float { fixnum } { float } define-primitive
-\ fixnum>float make-foldable
-
-\ bignum>float { bignum } { float } define-primitive
-\ bignum>float make-foldable
-
-\ (float>string) { float } { byte-array } define-primitive
-\ (float>string) make-foldable
-
-\ float>bits { real } { integer } define-primitive
-\ float>bits make-foldable
-
-\ double>bits { real } { integer } define-primitive
-\ double>bits make-foldable
-
-\ bits>float { integer } { float } define-primitive
-\ bits>float make-foldable
-
-\ bits>double { integer } { float } define-primitive
-\ bits>double make-foldable
-
-\ both-fixnums? { object object } { object } define-primitive
-
-\ fixnum+ { fixnum fixnum } { integer } define-primitive
-\ fixnum+ make-foldable
-
-\ fixnum+fast { fixnum fixnum } { fixnum } define-primitive
-\ fixnum+fast make-foldable
-
-\ fixnum- { fixnum fixnum } { integer } define-primitive
-\ fixnum- make-foldable
-
-\ fixnum-fast { fixnum fixnum } { fixnum } define-primitive
-\ fixnum-fast make-foldable
-
-\ fixnum* { fixnum fixnum } { integer } define-primitive
-\ fixnum* make-foldable
-
-\ fixnum*fast { fixnum fixnum } { fixnum } define-primitive
-\ fixnum*fast make-foldable
-
-\ fixnum/i { fixnum fixnum } { integer } define-primitive
-\ fixnum/i make-foldable
-
-\ fixnum/i-fast { fixnum fixnum } { fixnum } define-primitive
-\ fixnum/i-fast make-foldable
-
-\ fixnum-mod { fixnum fixnum } { fixnum } define-primitive
-\ fixnum-mod make-foldable
-
-\ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive
-\ fixnum/mod make-foldable
-
-\ fixnum/mod-fast { fixnum fixnum } { fixnum fixnum } define-primitive
-\ fixnum/mod-fast make-foldable
-
-\ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive
-\ fixnum-bitand make-foldable
-
-\ fixnum-bitor { fixnum fixnum } { fixnum } define-primitive
-\ fixnum-bitor make-foldable
-
-\ fixnum-bitxor { fixnum fixnum } { fixnum } define-primitive
-\ fixnum-bitxor make-foldable
-
-\ fixnum-bitnot { fixnum } { fixnum } define-primitive
-\ fixnum-bitnot make-foldable
-
-\ fixnum-shift { fixnum fixnum } { integer } define-primitive
-\ fixnum-shift make-foldable
-
-\ fixnum-shift-fast { fixnum fixnum } { fixnum } define-primitive
-\ fixnum-shift-fast make-foldable
-
-\ bignum= { bignum bignum } { object } define-primitive
-\ bignum= make-foldable
-
-\ bignum+ { bignum bignum } { bignum } define-primitive
-\ bignum+ make-foldable
-
-\ bignum- { bignum bignum } { bignum } define-primitive
-\ bignum- make-foldable
-
-\ bignum* { bignum bignum } { bignum } define-primitive
-\ bignum* make-foldable
-
-\ bignum/i { bignum bignum } { bignum } define-primitive
-\ bignum/i make-foldable
-
-\ bignum-mod { bignum bignum } { bignum } define-primitive
-\ bignum-mod make-foldable
-
-\ bignum/mod { bignum bignum } { bignum bignum } define-primitive
-\ bignum/mod make-foldable
-
-\ bignum-bitand { bignum bignum } { bignum } define-primitive
-\ bignum-bitand make-foldable
-
-\ bignum-bitor { bignum bignum } { bignum } define-primitive
-\ bignum-bitor make-foldable
-
-\ bignum-bitxor { bignum bignum } { bignum } define-primitive
-\ bignum-bitxor make-foldable
-
-\ bignum-bitnot { bignum } { bignum } define-primitive
-\ bignum-bitnot make-foldable
-
-\ bignum-shift { bignum fixnum } { bignum } define-primitive
-\ bignum-shift make-foldable
-
-\ bignum< { bignum bignum } { object } define-primitive
-\ bignum< make-foldable
-
-\ bignum<= { bignum bignum } { object } define-primitive
-\ bignum<= make-foldable
-
-\ bignum> { bignum bignum } { object } define-primitive
-\ bignum> make-foldable
-
-\ bignum>= { bignum bignum } { object } define-primitive
-\ bignum>= make-foldable
-
-\ bignum-bit? { bignum integer } { object } define-primitive
-\ bignum-bit? make-foldable
-
-\ bignum-log2 { bignum } { bignum } define-primitive
-\ bignum-log2 make-foldable
-
-\ byte-array>bignum { byte-array } { bignum } define-primitive
-\ byte-array>bignum make-foldable
-
-\ float= { float float } { object } define-primitive
-\ float= make-foldable
-
-\ float+ { float float } { float } define-primitive
-\ float+ make-foldable
-
-\ float- { float float } { float } define-primitive
-\ float- make-foldable
-
-\ float* { float float } { float } define-primitive
-\ float* make-foldable
-
-\ float/f { float float } { float } define-primitive
-\ float/f make-foldable
-
-\ float-mod { float float } { float } define-primitive
-\ float-mod make-foldable
-
-\ float< { float float } { object } define-primitive
-\ float< make-foldable
-
-\ float<= { float float } { object } define-primitive
-\ float<= make-foldable
-
-\ float> { float float } { object } define-primitive
-\ float> make-foldable
-
-\ float>= { float float } { object } define-primitive
-\ float>= make-foldable
-
-\ float-u< { float float } { object } define-primitive
-\ float-u< make-foldable
-
-\ float-u<= { float float } { object } define-primitive
-\ float-u<= make-foldable
-
-\ float-u> { float float } { object } define-primitive
-\ float-u> make-foldable
-
-\ float-u>= { float float } { object } define-primitive
-\ float-u>= make-foldable
-
-\ (word) { object object object } { word } define-primitive
-\ (word) make-flushable
-
-\ word-code { word } { integer integer } define-primitive
-\ word-code make-flushable
-
-\ current-callback { } { fixnum } define-primitive
-\ current-callback make-flushable
-
-\ context { } { c-ptr } define-primitive
-\ context make-flushable
-
-\ delete-context { c-ptr } { } define-primitive
-
-\ (start-context) { object quotation } { object } define-primitive
-
-\ (set-context) { object alien } { object } define-primitive
-
-\ special-object { fixnum } { object } define-primitive
-\ special-object make-flushable
-
-\ set-special-object { object fixnum } { } define-primitive
-
-\ context-object { fixnum } { object } define-primitive
-\ context-object make-flushable
-
-\ set-context-object { object fixnum } { } define-primitive
-
+\ (byte-array) { integer } { byte-array } define-primitive \ (byte-array) make-flushable
+\ (clone) { object } { object } define-primitive \ (clone) make-flushable
+\ (code-blocks) { } { array } define-primitive \ (code-blocks)  make-flushable
+\ (dlopen) { byte-array } { dll } define-primitive
+\ (dlsym) { byte-array object } { c-ptr } define-primitive
 \ (exists?) { string } { object } define-primitive
-
-\ minor-gc { } { } define-primitive
-
-\ gc { } { } define-primitive
-
-\ compact-gc { } { } define-primitive
-
+\ (exit) { integer } { } define-primitive
+\ (float>string) { float } { byte-array } define-primitive \ (float>string) make-foldable
+\ (fopen) { byte-array byte-array } { alien } define-primitive
+\ (identity-hashcode) { object } { fixnum } define-primitive
 \ (save-image) { byte-array byte-array } { } define-primitive
-
 \ (save-image-and-exit) { byte-array byte-array } { } define-primitive
-
-\ data-room { } { byte-array } define-primitive
-\ data-room make-flushable
-
-\ (code-blocks) { } { array } define-primitive
-\ (code-blocks)  make-flushable
-
-\ code-room { } { byte-array } define-primitive
-\ code-room  make-flushable
-
-\ system-micros { } { integer } define-primitive
-\ system-micros make-flushable
-
-\ nano-count { } { integer } define-primitive
-\ nano-count make-flushable
-
-\ tag { object } { fixnum } define-primitive
-\ tag make-foldable
-
-\ (dlopen) { byte-array } { dll } define-primitive
-
-\ (dlsym) { byte-array object } { c-ptr } define-primitive
-
-\ dlclose { dll } { } define-primitive
-
-\ <byte-array> { integer } { byte-array } define-primitive
-\ <byte-array> make-flushable
-
-\ (byte-array) { integer } { byte-array } define-primitive
-\ (byte-array) make-flushable
-
-\ <displaced-alien> { integer c-ptr } { c-ptr } define-primitive
-\ <displaced-alien> make-flushable
-
-\ alien-signed-cell { c-ptr integer } { integer } define-primitive
-\ alien-signed-cell make-flushable
-
-\ set-alien-signed-cell { integer c-ptr integer } { } define-primitive
-
-\ alien-unsigned-cell { c-ptr integer } { integer } define-primitive
-\ alien-unsigned-cell make-flushable
-
-\ set-alien-unsigned-cell { integer c-ptr integer } { } define-primitive
-
-\ alien-signed-8 { c-ptr integer } { integer } define-primitive
-\ alien-signed-8 make-flushable
-
-\ set-alien-signed-8 { integer c-ptr integer } { } define-primitive
-
-\ alien-unsigned-8 { c-ptr integer } { integer } define-primitive
-\ alien-unsigned-8 make-flushable
-
-\ set-alien-unsigned-8 { integer c-ptr integer } { } define-primitive
-
-\ alien-signed-4 { c-ptr integer } { integer } define-primitive
-\ alien-signed-4 make-flushable
-
-\ set-alien-signed-4 { integer c-ptr integer } { } define-primitive
-
-\ alien-unsigned-4 { c-ptr integer } { integer } define-primitive
-\ alien-unsigned-4 make-flushable
-
-\ set-alien-unsigned-4 { integer c-ptr integer } { } define-primitive
-
-\ alien-signed-2 { c-ptr integer } { fixnum } define-primitive
-\ alien-signed-2 make-flushable
-
-\ set-alien-signed-2 { integer c-ptr integer } { } define-primitive
-
-\ alien-unsigned-2 { c-ptr integer } { fixnum } define-primitive
-\ alien-unsigned-2 make-flushable
-
-\ set-alien-unsigned-2 { integer c-ptr integer } { } define-primitive
-
-\ alien-signed-1 { c-ptr integer } { fixnum } define-primitive
-\ alien-signed-1 make-flushable
-
-\ set-alien-signed-1 { integer c-ptr integer } { } define-primitive
-
-\ alien-unsigned-1 { c-ptr integer } { fixnum } define-primitive
-\ alien-unsigned-1 make-flushable
-
-\ set-alien-unsigned-1 { integer c-ptr integer } { } define-primitive
-
-\ alien-float { c-ptr integer } { float } define-primitive
-\ alien-float make-flushable
-
-\ set-alien-float { float c-ptr integer } { } define-primitive
-
-\ alien-double { c-ptr integer } { float } define-primitive
-\ alien-double make-flushable
-
-\ set-alien-double { float c-ptr integer } { } define-primitive
-
-\ alien-cell { c-ptr integer } { pinned-c-ptr } define-primitive
-\ alien-cell make-flushable
-
-\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
-
-\ alien-address { alien } { integer } define-primitive
-\ alien-address make-flushable
-
-\ slot { object fixnum } { object } define-primitive
-\ slot make-flushable
-
-\ set-slot { object object fixnum } { } define-primitive
-
-\ string-nth { fixnum string } { fixnum } define-primitive
-\ string-nth make-flushable
-
-\ set-string-nth-slow { fixnum fixnum string } { } define-primitive
-\ set-string-nth-fast { fixnum fixnum string } { } define-primitive
-
-\ resize-array { integer array } { array } define-primitive
-\ resize-array make-flushable
-
-\ resize-byte-array { integer byte-array } { byte-array } define-primitive
-\ resize-byte-array make-flushable
-
-\ resize-string { integer string } { string } define-primitive
-\ resize-string make-flushable
-
-\ <array> { integer object } { array } define-primitive
-\ <array> make-flushable
-
+\ (set-context) { object alien } { object } define-primitive
+\ (sleep) { integer } { } define-primitive
+\ (start-context) { object quotation } { object } define-primitive
+\ (word) { object object object } { word } define-primitive \ (word) make-flushable
+\ <array> { integer object } { array } define-primitive \ <array> make-flushable
+\ <byte-array> { integer } { byte-array } define-primitive \ <byte-array> make-flushable
+\ <callback> { integer word } { alien } define-primitive
+\ <displaced-alien> { integer c-ptr } { c-ptr } define-primitive \ <displaced-alien> make-flushable
+\ <string> { integer integer } { string } define-primitive \ <string> make-flushable
+\ <tuple> { tuple-layout } { tuple } define-primitive \ <tuple> make-flushable
+\ <wrapper> { object } { wrapper } define-primitive \ <wrapper> make-foldable
+\ alien-address { alien } { integer } define-primitive \ alien-address make-flushable
+\ alien-cell { c-ptr integer } { pinned-c-ptr } define-primitive \ alien-cell make-flushable
+\ alien-double { c-ptr integer } { float } define-primitive \ alien-double make-flushable
+\ alien-float { c-ptr integer } { float } define-primitive \ alien-float make-flushable
+\ alien-signed-1 { c-ptr integer } { fixnum } define-primitive \ alien-signed-1 make-flushable
+\ alien-signed-2 { c-ptr integer } { fixnum } define-primitive \ alien-signed-2 make-flushable
+\ alien-signed-4 { c-ptr integer } { integer } define-primitive \ alien-signed-4 make-flushable
+\ alien-signed-8 { c-ptr integer } { integer } define-primitive \ alien-signed-8 make-flushable
+\ alien-signed-cell { c-ptr integer } { integer } define-primitive \ alien-signed-cell make-flushable
+\ alien-unsigned-1 { c-ptr integer } { fixnum } define-primitive \ alien-unsigned-1 make-flushable
+\ alien-unsigned-2 { c-ptr integer } { fixnum } define-primitive \ alien-unsigned-2 make-flushable
+\ alien-unsigned-4 { c-ptr integer } { integer } define-primitive \ alien-unsigned-4 make-flushable
+\ alien-unsigned-8 { c-ptr integer } { integer } define-primitive \ alien-unsigned-8 make-flushable
+\ alien-unsigned-cell { c-ptr integer } { integer } define-primitive \ alien-unsigned-cell make-flushable
 \ all-instances { } { array } define-primitive
-
-\ size { object } { fixnum } define-primitive
-\ size make-flushable
-
+\ array>quotation { array } { quotation } define-primitive \ array>quotation make-foldable
+\ become { array array } { } define-primitive
+\ bignum* { bignum bignum } { bignum } define-primitive \ bignum* make-foldable
+\ bignum+ { bignum bignum } { bignum } define-primitive \ bignum+ make-foldable
+\ bignum- { bignum bignum } { bignum } define-primitive \ bignum- make-foldable
+\ bignum-bit? { bignum integer } { object } define-primitive \ bignum-bit? make-foldable
+\ bignum-bitand { bignum bignum } { bignum } define-primitive \ bignum-bitand make-foldable
+\ bignum-bitnot { bignum } { bignum } define-primitive \ bignum-bitnot make-foldable
+\ bignum-bitor { bignum bignum } { bignum } define-primitive \ bignum-bitor make-foldable
+\ bignum-bitxor { bignum bignum } { bignum } define-primitive \ bignum-bitxor make-foldable
+\ bignum-log2 { bignum } { bignum } define-primitive \ bignum-log2 make-foldable
+\ bignum-mod { bignum bignum } { bignum } define-primitive \ bignum-mod make-foldable
+\ bignum-shift { bignum fixnum } { bignum } define-primitive \ bignum-shift make-foldable
+\ bignum/i { bignum bignum } { bignum } define-primitive \ bignum/i make-foldable
+\ bignum/mod { bignum bignum } { bignum bignum } define-primitive \ bignum/mod make-foldable
+\ bignum< { bignum bignum } { object } define-primitive \ bignum< make-foldable
+\ bignum<= { bignum bignum } { object } define-primitive \ bignum<= make-foldable
+\ bignum= { bignum bignum } { object } define-primitive \ bignum= make-foldable
+\ bignum> { bignum bignum } { object } define-primitive \ bignum> make-foldable
+\ bignum>= { bignum bignum } { object } define-primitive \ bignum>= make-foldable
+\ bignum>fixnum { bignum } { fixnum } define-primitive \ bignum>fixnum make-foldable
+\ bignum>float { bignum } { float } define-primitive \ bignum>float make-foldable
+\ bits>double { integer } { float } define-primitive \ bits>double make-foldable
+\ bits>float { integer } { float } define-primitive \ bits>float make-foldable
+\ both-fixnums? { object object } { object } define-primitive
+\ byte-array>bignum { byte-array } { bignum } define-primitive \ byte-array>bignum make-foldable
+\ callstack { } { callstack } define-primitive \ callstack make-flushable
+\ callstack-for { c-ptr } { callstack } define-primitive \ callstack make-flushable
+\ callstack>array { callstack } { array } define-primitive \ callstack>array make-flushable
+\ check-datastack { array integer integer } { object } define-primitive \ check-datastack make-flushable
+\ code-room { } { byte-array } define-primitive \ code-room  make-flushable
+\ compact-gc { } { } define-primitive
+\ compute-identity-hashcode { object } { } define-primitive
+\ context { } { c-ptr } define-primitive \ context make-flushable
+\ context-object { fixnum } { object } define-primitive \ context-object make-flushable
+\ context-object-for { fixnum c-ptr } { object } define-primitive \ context-object-for make-flushable
+\ current-callback { } { fixnum } define-primitive \ current-callback make-flushable
+\ data-room { } { byte-array } define-primitive \ data-room make-flushable
+\ datastack { } { array } define-primitive \ datastack make-flushable
+\ datastack-for { c-ptr } { array } define-primitive \ datastack-for make-flushable
+\ delete-context { c-ptr } { } define-primitive
 \ die { } { } define-primitive
-
-\ (fopen) { byte-array byte-array } { alien } define-primitive
-
+\ disable-gc-events { } { object } define-primitive
+\ dispatch-stats { } { byte-array } define-primitive
+\ dlclose { dll } { } define-primitive
+\ dll-valid? { object } { object } define-primitive
+\ double>bits { real } { integer } define-primitive \ double>bits make-foldable
+\ enable-gc-events { } { } define-primitive
+\ eq? { object object } { object } define-primitive \ eq? make-foldable
+\ fclose { alien } { } define-primitive
+\ fflush { alien } { } define-primitive
 \ fgetc { alien } { object } define-primitive
-
-\ fwrite { c-ptr integer alien } { } define-primitive
-
+\ fixnum* { fixnum fixnum } { integer } define-primitive \ fixnum* make-foldable
+\ fixnum*fast { fixnum fixnum } { fixnum } define-primitive \ fixnum*fast make-foldable
+\ fixnum+ { fixnum fixnum } { integer } define-primitive \ fixnum+ make-foldable
+\ fixnum+fast { fixnum fixnum } { fixnum } define-primitive \ fixnum+fast make-foldable
+\ fixnum- { fixnum fixnum } { integer } define-primitive \ fixnum- make-foldable
+\ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitand make-foldable
+\ fixnum-bitnot { fixnum } { fixnum } define-primitive \ fixnum-bitnot make-foldable
+\ fixnum-bitor { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitor make-foldable
+\ fixnum-bitxor { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitxor make-foldable
+\ fixnum-fast { fixnum fixnum } { fixnum } define-primitive \ fixnum-fast make-foldable
+\ fixnum-mod { fixnum fixnum } { fixnum } define-primitive \ fixnum-mod make-foldable
+\ fixnum-shift { fixnum fixnum } { integer } define-primitive \ fixnum-shift make-foldable
+\ fixnum-shift-fast { fixnum fixnum } { fixnum } define-primitive \ fixnum-shift-fast make-foldable
+\ fixnum/i { fixnum fixnum } { integer } define-primitive \ fixnum/i make-foldable
+\ fixnum/i-fast { fixnum fixnum } { fixnum } define-primitive \ fixnum/i-fast make-foldable
+\ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive \ fixnum/mod make-foldable
+\ fixnum/mod-fast { fixnum fixnum } { fixnum fixnum } define-primitive \ fixnum/mod-fast make-foldable
+\ fixnum< { fixnum fixnum } { object } define-primitive \ fixnum< make-foldable
+\ fixnum<= { fixnum fixnum } { object } define-primitive \ fixnum<= make-foldable
+\ fixnum> { fixnum fixnum } { object } define-primitive \ fixnum> make-foldable
+\ fixnum>= { fixnum fixnum } { object } define-primitive \ fixnum>= make-foldable
+\ fixnum>bignum { fixnum } { bignum } define-primitive \ fixnum>bignum make-foldable
+\ fixnum>float { fixnum } { float } define-primitive \ fixnum>float make-foldable
+\ float* { float float } { float } define-primitive \ float* make-foldable
+\ float+ { float float } { float } define-primitive \ float+ make-foldable
+\ float- { float float } { float } define-primitive \ float- make-foldable
+\ float-mod { float float } { float } define-primitive \ float-mod make-foldable
+\ float-u< { float float } { object } define-primitive \ float-u< make-foldable
+\ float-u<= { float float } { object } define-primitive \ float-u<= make-foldable
+\ float-u> { float float } { object } define-primitive \ float-u> make-foldable
+\ float-u>= { float float } { object } define-primitive \ float-u>= make-foldable
+\ float/f { float float } { float } define-primitive \ float/f make-foldable
+\ float< { float float } { object } define-primitive \ float< make-foldable
+\ float<= { float float } { object } define-primitive \ float<= make-foldable
+\ float= { float float } { object } define-primitive \ float= make-foldable
+\ float> { float float } { object } define-primitive \ float> make-foldable
+\ float>= { float float } { object } define-primitive \ float>= make-foldable
+\ float>bignum { float } { bignum } define-primitive \ float>bignum make-foldable
+\ float>bits { real } { integer } define-primitive \ float>bits make-foldable
+\ float>fixnum { float } { fixnum } define-primitive \ bignum>fixnum make-foldable
 \ fputc { object alien } { } define-primitive
-
 \ fread { integer alien } { object } define-primitive
-
-\ fflush { alien } { } define-primitive
-
 \ fseek { integer integer alien } { } define-primitive
-
 \ ftell { alien } { integer } define-primitive
-
-\ fclose { alien } { } define-primitive
-
-\ <wrapper> { object } { wrapper } define-primitive
-\ <wrapper> make-foldable
-
-\ (clone) { object } { object } define-primitive
-\ (clone) make-flushable
-
-\ <string> { integer integer } { string } define-primitive
-\ <string> make-flushable
-
-\ array>quotation { array } { quotation } define-primitive
-\ array>quotation make-flushable
-
-\ quotation-code { quotation } { integer integer } define-primitive
-\ quotation-code make-flushable
-
-\ <tuple> { tuple-layout } { tuple } define-primitive
-\ <tuple> make-flushable
-
-\ datastack { } { array } define-primitive
-\ datastack make-flushable
-
-\ check-datastack { array integer integer } { object } define-primitive
-\ check-datastack make-flushable
-
-\ retainstack { } { array } define-primitive
-\ retainstack make-flushable
-
-\ callstack { } { callstack } define-primitive
-\ callstack make-flushable
-
-\ callstack>array { callstack } { array } define-primitive
-\ callstack>array make-flushable
-
-\ (sleep) { integer } { } define-primitive
-
-\ become { array array } { } define-primitive
-
+\ fwrite { c-ptr integer alien } { } define-primitive
+\ gc { } { } define-primitive
 \ innermost-frame-executing { callstack } { object } define-primitive
-
 \ innermost-frame-scan { callstack } { fixnum } define-primitive
-
-\ set-innermost-frame-quot { quotation callstack } { } define-primitive
-
-\ dll-valid? { object } { object } define-primitive
-
-\ modify-code-heap { array object object } { } define-primitive
-
-\ unimplemented { } { } define-primitive
-
 \ jit-compile { quotation } { } define-primitive
-
 \ lookup-method { object array } { word } define-primitive
-
-\ reset-dispatch-stats { } { } define-primitive
-\ dispatch-stats { } { byte-array } define-primitive
-
+\ minor-gc { } { } define-primitive
+\ modify-code-heap { array object object } { } define-primitive
+\ nano-count { } { integer } define-primitive \ nano-count make-flushable
 \ optimized? { word } { object } define-primitive
-
-\ strip-stack-traces { } { } define-primitive
-
-\ <callback> { integer word } { alien } define-primitive
-
-\ enable-gc-events { } { } define-primitive
-\ disable-gc-events { } { object } define-primitive
-
 \ profiling { object } { } define-primitive
-
-\ (identity-hashcode) { object } { fixnum } define-primitive
-
-\ compute-identity-hashcode { object } { } define-primitive
-
-\ (exit) { integer } { } define-primitive
-
 \ quot-compiled? { quotation } { object } define-primitive
+\ quotation-code { quotation } { integer integer } define-primitive \ quotation-code make-flushable
+\ reset-dispatch-stats { } { } define-primitive
+\ resize-array { integer array } { array } define-primitive \ resize-array make-flushable
+\ resize-byte-array { integer byte-array } { byte-array } define-primitive \ resize-byte-array make-flushable
+\ resize-string { integer string } { string } define-primitive \ resize-string make-flushable
+\ retainstack { } { array } define-primitive \ retainstack make-flushable
+\ retainstack-for { c-ptr } { array } define-primitive \ retainstack-for make-flushable
+\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
+\ set-alien-double { float c-ptr integer } { } define-primitive
+\ set-alien-float { float c-ptr integer } { } define-primitive
+\ set-alien-signed-1 { integer c-ptr integer } { } define-primitive
+\ set-alien-signed-2 { integer c-ptr integer } { } define-primitive
+\ set-alien-signed-4 { integer c-ptr integer } { } define-primitive
+\ set-alien-signed-8 { integer c-ptr integer } { } define-primitive
+\ set-alien-signed-cell { integer c-ptr integer } { } define-primitive
+\ set-alien-unsigned-1 { integer c-ptr integer } { } define-primitive
+\ set-alien-unsigned-2 { integer c-ptr integer } { } define-primitive
+\ set-alien-unsigned-4 { integer c-ptr integer } { } define-primitive
+\ set-alien-unsigned-8 { integer c-ptr integer } { } define-primitive
+\ set-alien-unsigned-cell { integer c-ptr integer } { } define-primitive
+\ set-context-object { object fixnum } { } define-primitive
+\ set-innermost-frame-quot { quotation callstack } { } define-primitive
+\ set-slot { object object fixnum } { } define-primitive
+\ set-special-object { object fixnum } { } define-primitive
+\ set-string-nth-fast { fixnum fixnum string } { } define-primitive
+\ set-string-nth-slow { fixnum fixnum string } { } define-primitive
+\ size { object } { fixnum } define-primitive \ size make-flushable
+\ slot { object fixnum } { object } define-primitive \ slot make-flushable
+\ special-object { fixnum } { object } define-primitive \ special-object make-flushable
+\ string-nth { fixnum string } { fixnum } define-primitive \ string-nth make-flushable
+\ strip-stack-traces { } { } define-primitive
+\ system-micros { } { integer } define-primitive \ system-micros make-flushable
+\ tag { object } { fixnum } define-primitive \ tag make-foldable
+\ unimplemented { } { } define-primitive
+\ word-code { word } { integer integer } define-primitive \ word-code make-flushable

diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor
index 335fbb3902705d131c5dff6d72d8c85b9bf3caad..3e63a81d9abaf326445d879fd869b420751b188a 100644 (file)
--- a/basis/threads/threads-docs.factor
+++ b/basis/threads/threads-docs.factor
@@ -1,6 +1,6 @@
 USING: help.markup help.syntax kernel kernel.private io
-threads.private continuations init quotations strings
-assocs heaps boxes namespaces deques dlists system ;
+threads.private init quotations strings assocs heaps boxes
+namespaces deques dlists system ;
 IN: threads
 
 ARTICLE: "threads-start/stop" "Starting and stopping threads"
@@ -48,7 +48,7 @@ ARTICLE: "thread-state" "Thread-local state and variables"
 $nl
 "Global hashtable of all threads, keyed by " { $snippet "id" } ":"
 { $subsections threads }
-"Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;
+"Threads have an identity independent of continuations. If a continuation is reified in one thread and then reflected in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;
 
 ARTICLE: "thread-impl" "Thread implementation"
 "Thread implementation:"
@@ -57,10 +57,8 @@ ARTICLE: "thread-impl" "Thread implementation"
     sleep-queue
 } ;
 
-ARTICLE: "threads" "Lightweight co-operative threads"
-"Factor supports lightweight co-operative threads implemented on top of " { $link "continuations" } ". A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested."
-$nl
-"Factor threads are very lightweight. Each thread can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple threads."
+ARTICLE: "threads" "Co-operative threads"
+"Factor supports co-operative threads. A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested."
 $nl
 "Words for working with threads are in the " { $vocab-link "threads" } " vocabulary."
 { $subsections
@@ -78,7 +76,7 @@ HELP: thread
         { { $snippet "id" } " - a unique identifier assigned to each thread." }
         { { $snippet "name" } " - the name passed to " { $link spawn } "." }
         { { $snippet "quot" } " - the initial quotation passed to " { $link spawn } "." }
-        { { $snippet "continuation" } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." }
+        { { $snippet "status" } " - a " { $link string } " indicating what the thread is waiting for, or " { $link f } ". This slot is intended to be used for debugging purposes." }
     }
 } ;
 

diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor
index 89a90f87fd7890e481073e5c5a3c65137ae8287f..bd30ef4b903e92585934f0a036b0592722f328eb 100644 (file)
--- a/basis/threads/threads.factor
+++ b/basis/threads/threads.factor
@@ -3,8 +3,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays hashtables heaps kernel kernel.private math
 namespaces sequences vectors continuations continuations.private
-dlists assocs system combinators combinators.private init boxes
-accessors math.order deques strings quotations fry ;
+dlists assocs system combinators init boxes accessors math.order
+deques strings quotations fry ;
 IN: threads
 
 <PRIVATE
@@ -13,8 +13,24 @@ IN: threads
 ! we don't want them inlined into callers since their behavior
 ! depends on what frames are on the callstack
 : set-context ( obj context -- obj' ) (set-context) ;
+
 : start-context ( obj quot: ( obj -- * ) -- obj' ) (start-context) ;
 
+: namestack-for ( context -- namestack )
+    [ 0 ] dip context-object-for ;
+
+: catchstack-for ( context -- catchstack )
+    [ 1 ] dip context-object-for ;
+
+: continuation-for ( context -- continuation )
+    {
+        [ datastack-for ]
+        [ callstack-for ]
+        [ retainstack-for ]
+        [ namestack-for ]
+        [ catchstack-for ]
+    } cleave <continuation> ;
+
 PRIVATE>
 
 SYMBOL: initial-thread
@@ -24,7 +40,7 @@ TUPLE: thread
 { quot callable initial: [ ] }
 { exit-handler callable initial: [ ] }
 { id integer }
-{ continuation box }
+{ context box }
 state
 runnable
 mailbox
@@ -34,6 +50,9 @@ sleep-entry ;
 : self ( -- thread )
     63 special-object { thread } declare ; inline
 
+: thread-continuation ( thread -- continuation )
+    context>> check-box value>> continuation-for ;
+
 ! Thread-local storage
 : tnamespace ( -- assoc )
     self variables>> ; inline
@@ -45,14 +64,11 @@ sleep-entry ;
     tnamespace set-at ;
 
 : tchange ( key quot -- )
-    tnamespace swap change-at ; inline
+    [ tnamespace ] dip change-at ; inline
 
 : threads ( -- assoc )
     64 special-object { hashtable } declare ; inline
 
-: thread ( id -- thread )
-    threads at ;
-
 : thread-registered? ( thread -- ? )
     id>> threads key? ;
 
@@ -78,23 +94,23 @@ ERROR: not-running thread ;
 
 PRIVATE>
 
+: run-queue ( -- dlist )
+    65 special-object { dlist } declare ; inline
+
+: sleep-queue ( -- heap )
+    66 special-object { dlist } declare ; inline
+
 : new-thread ( quot name class -- thread )
     new
         swap >>name
         swap >>quot
         \ thread counter >>id
-        <box> >>continuation
-        H{ } clone >>variables ; inline
+        H{ } clone >>variables
+        <box> >>context ; inline
 
 : <thread> ( quot name -- thread )
     \ thread new-thread ;
 
-: run-queue ( -- dlist )
-    65 special-object { dlist } declare ; inline
-
-: sleep-queue ( -- heap )
-    66 special-object { dlist } declare ; inline
-
 : resume ( thread -- )
     f >>state
     check-registered run-queue push-front ;
@@ -114,6 +130,13 @@ PRIVATE>
         [ sleep-queue heap-peek nip nano-count [-] ]
     } cond ;
 
+: interrupt ( thread -- )
+    dup state>> [
+        dup sleep-entry>> [ sleep-queue heap-delete ] when*
+        f >>sleep-entry
+        dup resume
+    ] when drop ;
+
 DEFER: stop
 
 <PRIVATE
@@ -136,19 +159,17 @@ DEFER: stop
     while
     drop ;
 
-: start ( namestack thread -- * )
+: start ( namestack -- obj )
     [
-        set-self
         set-namestack
-        V{ } set-catchstack
-        { } set-retainstack
-        { } set-datastack
-        self quot>> [ call stop ] call-clear
-    ] (( namestack thread -- * )) call-effect-unsafe ;
+        init-catchstack
+        self quot>> call
+        stop
+    ] start-context ;
 
 DEFER: next
 
-: no-runnable-threads ( -- * )
+: no-runnable-threads ( -- obj )
     ! We should never be in a state where the only threads
     ! are sleeping; the I/O wait thread is always runnable.
     ! However, if it dies, we handle this case
@@ -162,31 +183,36 @@ DEFER: next
         [ (sleep) ]
     } cond next ;
 
-: (next) ( arg thread -- * )
+: (next) ( obj thread -- obj' )
     f >>state
     dup set-self
-    dup runnable>> [
-        continuation>> box> continue-with
-    ] [
-        t >>runnable start
-    ] if ;
+    dup runnable>>
+    [ context>> box> set-context ] [ t >>runnable drop start ] if ;
 
-: next ( -- * )
+: next ( -- obj )
     expire-sleep-loop
-    run-queue dup deque-empty? [
-        drop no-runnable-threads
-    ] [
-        pop-back dup array? [ first2 ] [ f swap ] if (next)
-    ] if ;
+    run-queue dup deque-empty?
+    [ drop no-runnable-threads ]
+    [ pop-back dup array? [ first2 ] [ [ f ] dip ] if (next) ] if ;
+
+: recycler-thread ( -- thread ) 68 special-object ;
+
+: recycler-queue ( -- vector ) 69 special-object ;
+
+: delete-context-later ( context -- )
+    recycler-queue push recycler-thread interrupt ;
 
 PRIVATE>
 
 : stop ( -- * )
-    self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi next ;
+    self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi
+    context delete-context-later next
+    die 1 exit ;
 
 : suspend ( state -- obj )
-    self (>>state)
-    [ self continuation>> >box next ] callcc1 ; inline
+    [ self ] dip >>state
+    [ context ] dip context>> >box
+    next ;
 
 : yield ( -- ) self resume f suspend drop ;
 
@@ -196,22 +222,15 @@ M: integer sleep-until
     [ self ] dip schedule-sleep "sleep" suspend drop ;
 
 M: f sleep-until
-    drop "interrupt" suspend drop ;
+    drop "standby" suspend drop ;
 
 GENERIC: sleep ( dt -- )
 
 M: real sleep
     >integer nano-count + sleep-until ;
 
-: interrupt ( thread -- )
-    dup state>> [
-        dup sleep-entry>> [ sleep-queue heap-delete ] when*
-        f >>sleep-entry
-        dup resume
-    ] when drop ;
-
 : (spawn) ( thread -- )
-    [ register-thread ] [ namestack swap resume-with ] bi ;
+    [ register-thread ] [ [ namestack ] dip resume-with ] bi ;
 
 : spawn ( quot name -- thread )
     <thread> [ (spawn) ] keep ;
@@ -228,17 +247,35 @@ GENERIC: error-in-thread ( error thread -- )
 
 <PRIVATE
 
-: init-threads ( -- )
+: init-thread-state ( -- )
     H{ } clone 64 set-special-object
     <dlist> 65 set-special-object
-    <min-heap> 66 set-special-object
-    initial-thread global
-    [ drop [ ] "Initial" <thread> ] cache
-    <box> >>continuation
+    <min-heap> 66 set-special-object ;
+
+: init-initial-thread ( -- )
+    [ ] "Initial" <thread>
     t >>runnable
-    f >>state
-    dup register-thread
-    set-self ;
+    [ initial-thread set-global ]
+    [ register-thread ]
+    [ set-self ]
+    tri ;
+
+! The recycler thread deletes contexts belonging to stopped
+! threads
+
+: recycler-loop ( -- )
+    recycler-queue [ [ delete-context ] each ] [ delete-all ] bi
+    f sleep-until
+    recycler-loop ;
+
+: init-recycler ( -- )
+    [ recycler-loop ] "Context recycler" spawn 68 set-special-object
+    V{ } clone 69 set-special-object ;
+
+: init-threads ( -- )
+    init-thread-state
+    init-initial-thread
+    init-recycler ;
 
 PRIVATE>
 

diff --git a/basis/tools/threads/threads.factor b/basis/tools/threads/threads.factor
index ea85fb1129c3e02ecb8e29bf39abed0784e02f8f..1bb0918b82e977ce190c72cb12edb4eb00f1e86d 100644 (file)
--- a/basis/tools/threads/threads.factor
+++ b/basis/tools/threads/threads.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2010 Slava Pestov.\r
 ! See http://factorcode.org/license.txt for BSD license.\r
 USING: threads kernel prettyprint prettyprint.config\r
 io io.styles sequences assocs namespaces sorting boxes\r
@@ -7,7 +7,9 @@ IN: tools.threads
 \r
 : thread. ( thread -- )\r
     dup id>> pprint-cell\r
-    dup name>> over [ write-object ] with-cell\r
+    dup name>> [\r
+        over write-object\r
+    ] with-cell\r
     dup state>> [\r
         [ dup self eq? "running" "yield" ? ] unless*\r
         write\r

diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index 53d3bec56e4088def4cdf3d880219c6d930716a3..ffd0c4cd0ed16d774931ad8157d6fa7feb233624 100644 (file)
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs calendar combinators locals
 source-files.errors colors.constants combinators.short-circuit
@@ -30,7 +30,7 @@ output history flag mailbox thread waiting token-model word-model popup ;
     drop ;
 
 : interactor-continuation ( interactor -- continuation )
-    thread>> continuation>> value>> ;
+    thread>> thread-continuation ;
 
 : interactor-busy? ( interactor -- ? )
     #! We're busy if there's no thread to resume.

diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor
index 3019de4e21f2dced2352d4d77208536759d70aea..9d8e50c615cbd162c8d55c4b2a3d56413e8e4e19 100644 (file)
--- a/basis/ui/tools/operations/operations.factor
+++ b/basis/ui/tools/operations/operations.factor
@@ -62,10 +62,7 @@ IN: ui.tools.operations
 
 ! Thread
 : com-thread-traceback-window ( thread -- )
-    continuation>> dup occupied>>
-    [ value>> traceback-window ]
-    [ drop beep ]
-    if ;
+    thread-continuation traceback-window ;
 
 [ thread? ] \ com-thread-traceback-window H{
     { +primary+ t }

diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 38e1a380ee193d880f5b2bbc53ff0af72a7d68f7..87350f290aa19439850b5299ea13b4a91a673a64 100644 (file)
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -343,7 +343,7 @@ tuple
     { "(execute)" "kernel.private" (( word -- )) }
     { "(call)" "kernel.private" (( quot -- )) }
     { "unwind-native-frames" "kernel.private" (( -- )) }
-    { "set-callstack" "kernel.private" (( cs -- * )) }
+    { "set-callstack" "kernel.private" (( callstack -- * )) }
     { "lazy-jit-compile" "kernel.private" (( -- )) }
     { "c-to-factor" "kernel.private" (( -- )) }
     { "slot" "slots.private" (( obj m -- value )) }
@@ -441,23 +441,22 @@ tuple
     { "fwrite" "io.streams.c" "primitive_fwrite" (( data length alien -- )) }
     { "(clone)" "kernel" "primitive_clone" (( obj -- newobj )) }
     { "<wrapper>" "kernel" "primitive_wrapper" (( obj -- wrapper )) }
-    { "callstack" "kernel" "primitive_callstack" (( -- cs )) }
+    { "callstack" "kernel" "primitive_callstack" (( -- callstack )) }
     { "callstack>array" "kernel" "primitive_callstack_to_array" (( callstack -- array )) }
-    { "datastack" "kernel" "primitive_datastack" (( -- ds )) }
+    { "datastack" "kernel" "primitive_datastack" (( -- array )) }
     { "die" "kernel" "primitive_die" (( -- )) }
-    { "retainstack" "kernel" "primitive_retainstack" (( -- rs )) }
+    { "retainstack" "kernel" "primitive_retainstack" (( -- array )) }
     { "(identity-hashcode)" "kernel.private" "primitive_identity_hashcode" (( obj -- code )) }
     { "become" "kernel.private" "primitive_become" (( old new -- )) }
-    { "call-clear" "kernel.private" "primitive_call_clear" (( quot -- * )) }
     { "check-datastack" "kernel.private" "primitive_check_datastack" (( array in# out# -- ? )) }
     { "compute-identity-hashcode" "kernel.private" "primitive_compute_identity_hashcode" (( obj -- )) }
     { "context-object" "kernel.private" "primitive_context_object" (( n -- obj )) }
     { "innermost-frame-executing" "kernel.private" "primitive_innermost_stack_frame_executing" (( callstack -- obj )) }
     { "innermost-frame-scan" "kernel.private" "primitive_innermost_stack_frame_scan" (( callstack -- n )) }
     { "set-context-object" "kernel.private" "primitive_set_context_object" (( obj n -- )) }
-    { "set-datastack" "kernel.private" "primitive_set_datastack" (( ds -- )) }
+    { "set-datastack" "kernel.private" "primitive_set_datastack" (( array -- )) }
     { "set-innermost-frame-quot" "kernel.private" "primitive_set_innermost_stack_frame_quot" (( n callstack -- )) }
-    { "set-retainstack" "kernel.private" "primitive_set_retainstack" (( rs -- )) }
+    { "set-retainstack" "kernel.private" "primitive_set_retainstack" (( array -- )) }
     { "set-special-object" "kernel.private" "primitive_set_special_object" (( obj n -- )) }
     { "special-object" "kernel.private" "primitive_special_object" (( n -- obj )) }
     { "strip-stack-traces" "kernel.private" "primitive_strip_stack_traces" (( -- )) }
@@ -536,8 +535,12 @@ tuple
     { "nano-count" "system" "primitive_nano_count" (( -- ns )) }
     { "system-micros" "system" "primitive_system_micros" (( -- us )) }
     { "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) }
-    { "context" "threads.private" "primitive_context" (( -- c-ptr )) }
-    { "delete-context" "threads.private" "primitive_delete_context" (( c-ptr -- )) }
+    { "callstack-for" "threads.private" "primitive_callstack_for" (( context -- array )) }
+    { "context" "threads.private" "primitive_context" (( -- context )) }
+    { "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) }
+    { "datastack-for" "threads.private" "primitive_datastack_for" (( context -- array )) }
+    { "retainstack-for" "threads.private" "primitive_retainstack_for" (( context -- array )) }
+    { "delete-context" "threads.private" "primitive_delete_context" (( context -- )) }
     { "dispatch-stats" "tools.dispatch.private" "primitive_dispatch_stats" (( -- stats )) }
     { "reset-dispatch-stats" "tools.dispatch.private" "primitive_reset_dispatch_stats" (( -- )) }
     { "profiling" "tools.profiler.private" "primitive_profiling" (( ? -- )) }

diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 8512700852270f1d1498c4080074f25aee789e12..064978f99bf805bd12640e87dd07a8a1b2e164e6 100644 (file)
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -26,28 +26,28 @@ HELP: -rot  ( x y z -- z x y ) $complex-shuffle ;
 HELP: dupd  ( x y -- x x y )   $complex-shuffle ;
 HELP: swapd ( x y z -- y x z ) $complex-shuffle ;
 
-HELP: datastack ( -- ds )
-{ $values { "ds" array } }
+HELP: datastack ( -- array )
+{ $values { "array" array } }
 { $description "Outputs an array containing a copy of the data stack contents right before the call to this word, with the top of the stack at the end of the array." } ;
 
-HELP: set-datastack ( ds -- )
-{ $values { "ds" array } }
+HELP: set-datastack ( array -- )
+{ $values { "array" array } }
 { $description "Replaces the data stack contents with a copy of an array. The end of the array becomes the top of the stack." } ;
 
-HELP: retainstack ( -- rs )
-{ $values { "rs" array } }
+HELP: retainstack ( -- array )
+{ $values { "array" array } }
 { $description "Outputs an array containing a copy of the retain stack contents right before the call to this word, with the top of the stack at the end of the array." } ;
 
-HELP: set-retainstack ( rs -- )
-{ $values { "rs" array } }
+HELP: set-retainstack ( array -- )
+{ $values { "array" array } }
 { $description "Replaces the retain stack contents with a copy of an array. The end of the array becomes the top of the stack." } ;
 
-HELP: callstack ( -- cs )
-{ $values { "cs" callstack } }
+HELP: callstack ( -- callstack )
+{ $values { "callstack" callstack } }
 { $description "Outputs a copy of the call stack contents, with the top of the stack at the end of the vector. The stack frame of the caller word is " { $emphasis "not" } " included." } ;
 
-HELP: set-callstack ( cs -- * )
-{ $values { "cs" callstack } }
+HELP: set-callstack ( callstack -- * )
+{ $values { "callstack" callstack } }
 { $description "Replaces the call stack contents. Control flow is transferred immediately to the innermost frame of the new call stack." } ;
 
 HELP: clear
@@ -208,11 +208,6 @@ HELP: call
 
 { call POSTPONE: call( } related-words
 
-HELP: call-clear ( quot -- * )
-{ $values { "quot" callable } }
-{ $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." }
-{ $notes "Used to implement " { $link "threads" } "." } ;
-
 HELP: keep
 { $values { "x" object } { "quot" { $quotation "( ..a x -- ..b )" } } }
 { $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }

diff --git a/vm/callstack.cpp b/vm/callstack.cpp
index 7268d6ab912c9ffc9f18465c57a6a88ec8e99e6d..ad7528ab84c2b8e2f8c2c5a76498181b026de6cf 100755 (executable)
--- a/vm/callstack.cpp
+++ b/vm/callstack.cpp
@@ -42,7 +42,7 @@ This means that if 'callstack' is called in tail position, we
 will have popped a necessary frame... however this word is only
 called by continuation implementation, and user code shouldn't
 be calling it at all, so we leave it as it is for now. */
-stack_frame *factor_vm::second_from_top_stack_frame()
+stack_frame *factor_vm::second_from_top_stack_frame(context *ctx)
 {
        stack_frame *frame = ctx->callstack_bottom - 1;
        while(frame >= ctx->callstack_top
@@ -54,16 +54,27 @@ stack_frame *factor_vm::second_from_top_stack_frame()
        return frame + 1;
 }
 
-void factor_vm::primitive_callstack()
+cell factor_vm::capture_callstack(context *ctx)
 {
-       stack_frame *top = second_from_top_stack_frame();
+       stack_frame *top = second_from_top_stack_frame(ctx);
        stack_frame *bottom = ctx->callstack_bottom;
 
        fixnum size = std::max((fixnum)0,(fixnum)bottom - (fixnum)top);
 
        callstack *stack = allot_callstack(size);
        memcpy(stack->top(),top,size);
-       ctx->push(tag<callstack>(stack));
+       return tag<callstack>(stack);
+}
+
+void factor_vm::primitive_callstack()
+{
+       ctx->push(capture_callstack(ctx));
+}
+
+void factor_vm::primitive_callstack_for()
+{
+       context *other_ctx = (context *)pinned_alien_offset(ctx->pop());
+       ctx->push(capture_callstack(other_ctx));
 }
 
 code_block *factor_vm::frame_code(stack_frame *frame)

diff --git a/vm/contexts.cpp b/vm/contexts.cpp
index 8734ff8486409bb5522760d768330ec3fbf07041..20dac9f4e5c6601b5dc2ddc5b4795cc24a5098f6 100644 (file)
--- a/vm/contexts.cpp
+++ b/vm/contexts.cpp
@@ -160,31 +160,68 @@ void factor_vm::primitive_set_context_object()
        ctx->context_objects[n] = value;
 }
 
-bool factor_vm::stack_to_array(cell bottom, cell top)
+void factor_vm::primitive_context_object_for()
+{
+       context *other_ctx = (context *)pinned_alien_offset(ctx->pop());
+       fixnum n = untag_fixnum(ctx->pop());
+       ctx->push(other_ctx->context_objects[n]);
+}
+
+cell factor_vm::stack_to_array(cell bottom, cell top)
 {
        fixnum depth = (fixnum)(top - bottom + sizeof(cell));
 
        if(depth < 0)
-               return false;
+               return false_object;
        else
        {
                array *a = allot_uninitialized_array<array>(depth / sizeof(cell));
                memcpy(a + 1,(void*)bottom,depth);
-               ctx->push(tag<array>(a));
-               return true;
+               return tag<array>(a);
        }
 }
 
-void factor_vm::primitive_datastack()
+cell factor_vm::datastack_to_array(context *ctx)
 {
-       if(!stack_to_array(ctx->datastack_seg->start,ctx->datastack))
+       cell array = stack_to_array(ctx->datastack_seg->start,ctx->datastack);
+       if(array == false_object)
                general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object);
+       else
+               return array;
 }
 
-void factor_vm::primitive_retainstack()
+void factor_vm::primitive_datastack()
 {
-       if(!stack_to_array(ctx->retainstack_seg->start,ctx->retainstack))
+       ctx->push(datastack_to_array(ctx));
+}
+
+void factor_vm::primitive_datastack_for()
+{
+       context *other_ctx = (context *)pinned_alien_offset(ctx->pop());
+       ctx->push(datastack_to_array(other_ctx));
+}
+
+cell factor_vm::retainstack_to_array(context *ctx)
+{
+       cell array = stack_to_array(ctx->retainstack_seg->start,ctx->retainstack);
+       if(array == false_object)
+       {
                general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object);
+               return false_object;
+       }
+       else
+               return array;
+}
+
+void factor_vm::primitive_retainstack()
+{
+       ctx->push(retainstack_to_array(ctx));
+}
+
+void factor_vm::primitive_retainstack_for()
+{
+       context *other_ctx = (context *)pinned_alien_offset(ctx->pop());
+       ctx->push(retainstack_to_array(other_ctx));
 }
 
 /* returns pointer to top of stack */
@@ -195,14 +232,24 @@ cell factor_vm::array_to_stack(array *array, cell bottom)
        return bottom + depth - sizeof(cell);
 }
 
+void factor_vm::set_datastack(context *ctx, array *array)
+{
+       ctx->datastack = array_to_stack(array,ctx->datastack_seg->start);
+}
+
 void factor_vm::primitive_set_datastack()
 {
-       ctx->datastack = array_to_stack(untag_check<array>(ctx->pop()),ctx->datastack_seg->start);
+       set_datastack(ctx,untag_check<array>(ctx->pop()));
+}
+
+void factor_vm::set_retainstack(context *ctx, array *array)
+{
+       ctx->retainstack = array_to_stack(array,ctx->retainstack_seg->start);
 }
 
 void factor_vm::primitive_set_retainstack()
 {
-       ctx->retainstack = array_to_stack(untag_check<array>(ctx->pop()),ctx->retainstack_seg->start);
+       set_retainstack(ctx,untag_check<array>(ctx->pop()));
 }
 
 /* Used to implement call( */

diff --git a/vm/errors.cpp b/vm/errors.cpp
index f6ceee9966e2945f31467a6fabe51b508fe5b55e..1867965108e04be7676cf9f5586e30bdc8bbb986 100755 (executable)
--- a/vm/errors.cpp
+++ b/vm/errors.cpp
@@ -120,11 +120,6 @@ void factor_vm::fp_trap_error(unsigned int fpu_status, stack_frame *stack)
        general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),false_object,stack);
 }
 
-void factor_vm::primitive_call_clear()
-{
-       unwind_native_frames(ctx->pop(),ctx->callstack_bottom);
-}
-
 /* For testing purposes */
 void factor_vm::primitive_unimplemented()
 {

diff --git a/vm/objects.hpp b/vm/objects.hpp
index 772863d3f1f02cd35c74e33dd9848d6a28ce9c64..4c5dd64632f5c8b5ff488c55dff3f85090831735 100644 (file)
--- a/vm/objects.hpp
+++ b/vm/objects.hpp
@@ -92,7 +92,10 @@ enum special_object {
        OBJ_RUN_QUEUE = 65,
        OBJ_SLEEP_QUEUE = 66,
 
-       OBJ_VM_COMPILER = 67,    /* version string of the compiler we were built with */
+       OBJ_VM_COMPILER = 67,     /* version string of the compiler we were built with */
+
+       OBJ_RECYCLE_THREAD = 68,
+       OBJ_RECYCLE_QUEUE = 69,
 };
 
 /* save-image-and-exit discards special objects that are filled in on startup

diff --git a/vm/primitives.hpp b/vm/primitives.hpp
index 4d72cf1abbdf7b3060cd82f3c6935d0354a08420..cb5626c894d1b6919ae54f3e741e2641c3979780 100644 (file)
--- a/vm/primitives.hpp
+++ b/vm/primitives.hpp
@@ -33,9 +33,9 @@ namespace factor
        _(bits_float) \
        _(byte_array) \
        _(byte_array_to_bignum) \
-       _(call_clear) \
        _(callback) \
        _(callstack) \
+       _(callstack_for) \
        _(callstack_to_array) \
        _(check_datastack) \
        _(clone) \
@@ -45,9 +45,11 @@ namespace factor
        _(compute_identity_hashcode) \
        _(context) \
        _(context_object) \
+       _(context_object_for) \
        _(current_callback) \
        _(data_room) \
        _(datastack) \
+       _(datastack_for) \
        _(delete_context) \
        _(die) \
        _(disable_gc_events) \
@@ -109,6 +111,7 @@ namespace factor
        _(resize_byte_array) \
        _(resize_string) \
        _(retainstack) \
+       _(retainstack_for) \
        _(save_image) \
        _(save_image_and_exit) \
        _(set_context_object) \

diff --git a/vm/vm.hpp b/vm/vm.hpp
index d304543879713c7b13437247209c06e29634d535..973d5f0dda7b34515e8d923a288e82c4e38ac8bc 100755 (executable)
--- a/vm/vm.hpp
+++ b/vm/vm.hpp
@@ -119,12 +119,19 @@ struct factor_vm
        void end_callback();
        void primitive_current_callback();
        void primitive_context_object();
+       void primitive_context_object_for();
        void primitive_set_context_object();
-       bool stack_to_array(cell bottom, cell top);
-       cell array_to_stack(array *array, cell bottom);
+       cell stack_to_array(cell bottom, cell top);
+       cell datastack_to_array(context *ctx);
        void primitive_datastack();
+       void primitive_datastack_for();
+       cell retainstack_to_array(context *ctx);
        void primitive_retainstack();
+       void primitive_retainstack_for();
+       cell array_to_stack(array *array, cell bottom);
+       void set_datastack(context *ctx, array *array);
        void primitive_set_datastack();
+       void set_retainstack(context *ctx, array *array);
        void primitive_set_retainstack();
        void primitive_check_datastack();
        void primitive_load_locals();
@@ -172,7 +179,6 @@ struct factor_vm
        void signal_error(cell signal, stack_frame *stack);
        void divide_by_zero_error();
        void fp_trap_error(unsigned int fpu_status, stack_frame *stack);
-       void primitive_call_clear();
        void primitive_unimplemented();
        void memory_signal_handler_impl();
        void misc_signal_handler_impl();
@@ -586,8 +592,10 @@ struct factor_vm
        void check_frame(stack_frame *frame);
        callstack *allot_callstack(cell size);
        stack_frame *fix_callstack_top(stack_frame *top);
-       stack_frame *second_from_top_stack_frame();
+       stack_frame *second_from_top_stack_frame(context *ctx);
+       cell capture_callstack(context *ctx);
        void primitive_callstack();
+       void primitive_callstack_for();
        code_block *frame_code(stack_frame *frame);
        code_block_type frame_type(stack_frame *frame);
        cell frame_executing(stack_frame *frame);