steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

threads: use context-switching primitives

release
Slava Pestov 2010-03-29 20:40:17 -04:00
parent d130f24248
commit c7142e4281
15 changed files with 406 additions and 588 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/boxes/boxes.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors ; USING: kernel accessors ;
IN: boxes IN: boxes
@ -15,9 +15,11 @@ ERROR: box-full box ;
ERROR: box-empty box ; ERROR: box-empty box ;
: check-box ( box -- box )
dup occupied>> [ box-empty ] unless ; inline
: box> ( box -- value ) : box> ( box -- value )
dup occupied>> check-box [ f ] change-value f >>occupied drop ;
[ [ f ] change-value f >>occupied drop ] [ box-empty ] if ;
: ?box ( box -- value/f ? ) : ?box ( box -- value/f ? )
dup occupied>> [ box> t ] [ drop f f ] if ; dup occupied>> [ box> t ] [ drop f f ] if ;

637
basis/stack-checker/known-words/known-words.factor
View File

@ -247,7 +247,6 @@ M: bad-executable summary
unwind-native-frames unwind-native-frames
lazy-jit-compile lazy-jit-compile
c-to-factor c-to-factor
call-clear
} [ dup '[ _ do-not-compile ] "special" set-word-prop ] each } [ dup '[ _ do-not-compile ] "special" set-word-prop ] each
: infer-special ( word -- ) : infer-special ( word -- )
@ -299,466 +298,184 @@ M: bad-executable summary
3tri ; 3tri ;
! Stack effects for all primitives ! Stack effects for all primitives
\ fixnum< { fixnum fixnum } { object } define-primitive \ (byte-array) { integer } { byte-array } define-primitive \ (byte-array) make-flushable
\ fixnum< make-foldable \ (clone) { object } { object } define-primitive \ (clone) make-flushable
\ (code-blocks) { } { array } define-primitive \ (code-blocks) make-flushable
\ 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
\ (exists?) { string } { object } define-primitive
\ minor-gc { } { } define-primitive
\ gc { } { } define-primitive
\ compact-gc { } { } 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 \ (dlopen) { byte-array } { dll } define-primitive
\ (dlsym) { byte-array object } { c-ptr } define-primitive \ (dlsym) { byte-array object } { c-ptr } define-primitive
\ (exists?) { string } { object } 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
\ all-instances { } { array } define-primitive
\ size { object } { fixnum } define-primitive
\ size make-flushable
\ die { } { } define-primitive
\ (fopen) { byte-array byte-array } { alien } define-primitive
\ fgetc { alien } { object } define-primitive
\ fwrite { c-ptr integer alien } { } define-primitive
\ 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
\ 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
\ 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 \ (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
\ (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
\ 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
\ 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
\ 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
\ fseek { integer integer alien } { } define-primitive
\ ftell { alien } { integer } 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
\ jit-compile { quotation } { } define-primitive
\ lookup-method { object array } { word } 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
\ profiling { object } { } define-primitive
\ quot-compiled? { quotation } { object } 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

14
basis/threads/threads-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private io USING: help.markup help.syntax kernel kernel.private io
threads.private continuations init quotations strings threads.private init quotations strings assocs heaps boxes
assocs heaps boxes namespaces deques dlists system ; namespaces deques dlists system ;
IN: threads IN: threads
ARTICLE: "threads-start/stop" "Starting and stopping threads" ARTICLE: "threads-start/stop" "Starting and stopping threads"
@ -48,7 +48,7 @@ ARTICLE: "thread-state" "Thread-local state and variables"
$nl $nl
"Global hashtable of all threads, keyed by " { $snippet "id" } ":" "Global hashtable of all threads, keyed by " { $snippet "id" } ":"
{ $subsections threads } { $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" ARTICLE: "thread-impl" "Thread implementation"
"Thread implementation:" "Thread implementation:"
@ -57,10 +57,8 @@ ARTICLE: "thread-impl" "Thread implementation"
sleep-queue sleep-queue
} ; } ;
ARTICLE: "threads" "Lightweight co-operative threads" ARTICLE: "threads" "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." "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
"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."
$nl $nl
"Words for working with threads are in the " { $vocab-link "threads" } " vocabulary." "Words for working with threads are in the " { $vocab-link "threads" } " vocabulary."
{ $subsections { $subsections
@ -78,7 +76,7 @@ HELP: thread
{ { $snippet "id" } " - a unique identifier assigned to each thread." } { { $snippet "id" } " - a unique identifier assigned to each thread." }
{ { $snippet "name" } " - the name passed to " { $link spawn } "." } { { $snippet "name" } " - the name passed to " { $link spawn } "." }
{ { $snippet "quot" } " - the initial quotation 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." }
} }
} ; } ;

153
basis/threads/threads.factor
View File

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

6
basis/tools/threads/threads.factor
View File

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

4
basis/ui/tools/listener/listener.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs calendar combinators locals USING: accessors arrays assocs calendar combinators locals
source-files.errors colors.constants combinators.short-circuit source-files.errors colors.constants combinators.short-circuit
@ -30,7 +30,7 @@ output history flag mailbox thread waiting token-model word-model popup ;
drop ; drop ;
: interactor-continuation ( interactor -- continuation ) : interactor-continuation ( interactor -- continuation )
thread>> continuation>> value>> ; thread>> thread-continuation ;
: interactor-busy? ( interactor -- ? ) : interactor-busy? ( interactor -- ? )
#! We're busy if there's no thread to resume. #! We're busy if there's no thread to resume.

5
basis/ui/tools/operations/operations.factor
View File

@ -62,10 +62,7 @@ IN: ui.tools.operations
! Thread ! Thread
: com-thread-traceback-window ( thread -- ) : com-thread-traceback-window ( thread -- )
continuation>> dup occupied>> thread-continuation traceback-window ;
[ value>> traceback-window ]
[ drop beep ]
if ;
[ thread? ] \ com-thread-traceback-window H{ [ thread? ] \ com-thread-traceback-window H{
{ +primary+ t } { +primary+ t }

21
core/bootstrap/primitives.factor
View File

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

29
core/kernel/kernel-docs.factor
View File

@ -26,28 +26,28 @@ HELP: -rot ( x y z -- z x y ) $complex-shuffle ;
HELP: dupd ( x y -- x x y ) $complex-shuffle ; HELP: dupd ( x y -- x x y ) $complex-shuffle ;
HELP: swapd ( x y z -- y x z ) $complex-shuffle ; HELP: swapd ( x y z -- y x z ) $complex-shuffle ;
HELP: datastack ( -- ds ) HELP: datastack ( -- array )
{ $values { "ds" 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." } ; { $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 -- ) HELP: set-datastack ( array -- )
{ $values { "ds" 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." } ; { $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 ) HELP: retainstack ( -- array )
{ $values { "rs" 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." } ; { $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 -- ) HELP: set-retainstack ( array -- )
{ $values { "rs" 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." } ; { $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 ) HELP: callstack ( -- callstack )
{ $values { "cs" 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." } ; { $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 -- * ) HELP: set-callstack ( callstack -- * )
{ $values { "cs" callstack } } { $values { "callstack" callstack } }
{ $description "Replaces the call stack contents. Control flow is transferred immediately to the innermost frame of the new call stack." } ; { $description "Replaces the call stack contents. Control flow is transferred immediately to the innermost frame of the new call stack." } ;
HELP: clear HELP: clear
@ -208,11 +208,6 @@ HELP: call
{ call POSTPONE: call( } related-words { 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 HELP: keep
{ $values { "x" object } { "quot" { $quotation "( ..a x -- ..b )" } } } { $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." } { $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }

19
vm/callstack.cpp
View File

@ -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 will have popped a necessary frame... however this word is only
called by continuation implementation, and user code shouldn't called by continuation implementation, and user code shouldn't
be calling it at all, so we leave it as it is for now. */ 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; stack_frame *frame = ctx->callstack_bottom - 1;
while(frame >= ctx->callstack_top while(frame >= ctx->callstack_top
@ -54,16 +54,27 @@ stack_frame *factor_vm::second_from_top_stack_frame()
return frame + 1; 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; stack_frame *bottom = ctx->callstack_bottom;
fixnum size = std::max((fixnum)0,(fixnum)bottom - (fixnum)top); fixnum size = std::max((fixnum)0,(fixnum)bottom - (fixnum)top);
callstack *stack = allot_callstack(size); callstack *stack = allot_callstack(size);
memcpy(stack->top(),top,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) code_block *factor_vm::frame_code(stack_frame *frame)

67
vm/contexts.cpp
View File

@ -160,31 +160,68 @@ void factor_vm::primitive_set_context_object()
ctx->context_objects[n] = value; 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)); fixnum depth = (fixnum)(top - bottom + sizeof(cell));
if(depth < 0) if(depth < 0)
return false; return false_object;
else else
{ {
array *a = allot_uninitialized_array<array>(depth / sizeof(cell)); array *a = allot_uninitialized_array<array>(depth / sizeof(cell));
memcpy(a + 1,(void*)bottom,depth); memcpy(a + 1,(void*)bottom,depth);
ctx->push(tag<array>(a)); return tag<array>(a);
return true;
} }
} }
cell factor_vm::datastack_to_array(context *ctx)
{
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_datastack() void factor_vm::primitive_datastack()
{ {
if(!stack_to_array(ctx->datastack_seg->start,ctx->datastack)) ctx->push(datastack_to_array(ctx));
general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object); }
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() void factor_vm::primitive_retainstack()
{ {
if(!stack_to_array(ctx->retainstack_seg->start,ctx->retainstack)) ctx->push(retainstack_to_array(ctx));
general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object); }
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 */ /* 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); 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() 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() 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( */ /* Used to implement call( */

5
vm/errors.cpp
View File

@ -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); 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 */ /* For testing purposes */
void factor_vm::primitive_unimplemented() void factor_vm::primitive_unimplemented()
{ {

3
vm/objects.hpp
View File

@ -93,6 +93,9 @@ enum special_object {
OBJ_SLEEP_QUEUE = 66, 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 /* save-image-and-exit discards special objects that are filled in on startup

5
vm/primitives.hpp
View File

@ -33,9 +33,9 @@ namespace factor
_(bits_float) \ _(bits_float) \
_(byte_array) \ _(byte_array) \
_(byte_array_to_bignum) \ _(byte_array_to_bignum) \
_(call_clear) \
_(callback) \ _(callback) \
_(callstack) \ _(callstack) \
_(callstack_for) \
_(callstack_to_array) \ _(callstack_to_array) \
_(check_datastack) \ _(check_datastack) \
_(clone) \ _(clone) \
@ -45,9 +45,11 @@ namespace factor
_(compute_identity_hashcode) \ _(compute_identity_hashcode) \
_(context) \ _(context) \
_(context_object) \ _(context_object) \
_(context_object_for) \
_(current_callback) \ _(current_callback) \
_(data_room) \ _(data_room) \
_(datastack) \ _(datastack) \
_(datastack_for) \
_(delete_context) \ _(delete_context) \
_(die) \ _(die) \
_(disable_gc_events) \ _(disable_gc_events) \
@ -109,6 +111,7 @@ namespace factor
_(resize_byte_array) \ _(resize_byte_array) \
_(resize_string) \ _(resize_string) \
_(retainstack) \ _(retainstack) \
_(retainstack_for) \
_(save_image) \ _(save_image) \
_(save_image_and_exit) \ _(save_image_and_exit) \
_(set_context_object) \ _(set_context_object) \

16
vm/vm.hpp
View File

@ -119,12 +119,19 @@ struct factor_vm
void end_callback(); void end_callback();
void primitive_current_callback(); void primitive_current_callback();
void primitive_context_object(); void primitive_context_object();
void primitive_context_object_for();
void primitive_set_context_object(); void primitive_set_context_object();
bool stack_to_array(cell bottom, cell top); cell stack_to_array(cell bottom, cell top);
cell array_to_stack(array *array, cell bottom); cell datastack_to_array(context *ctx);
void primitive_datastack(); void primitive_datastack();
void primitive_datastack_for();
cell retainstack_to_array(context *ctx);
void primitive_retainstack(); 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 primitive_set_datastack();
void set_retainstack(context *ctx, array *array);
void primitive_set_retainstack(); void primitive_set_retainstack();
void primitive_check_datastack(); void primitive_check_datastack();
void primitive_load_locals(); void primitive_load_locals();
@ -172,7 +179,6 @@ struct factor_vm
void signal_error(cell signal, stack_frame *stack); void signal_error(cell signal, stack_frame *stack);
void divide_by_zero_error(); void divide_by_zero_error();
void fp_trap_error(unsigned int fpu_status, stack_frame *stack); void fp_trap_error(unsigned int fpu_status, stack_frame *stack);
void primitive_call_clear();
void primitive_unimplemented(); void primitive_unimplemented();
void memory_signal_handler_impl(); void memory_signal_handler_impl();
void misc_signal_handler_impl(); void misc_signal_handler_impl();
@ -586,8 +592,10 @@ struct factor_vm
void check_frame(stack_frame *frame); void check_frame(stack_frame *frame);
callstack *allot_callstack(cell size); callstack *allot_callstack(cell size);
stack_frame *fix_callstack_top(stack_frame *top); 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();
void primitive_callstack_for();
code_block *frame_code(stack_frame *frame); code_block *frame_code(stack_frame *frame);
code_block_type frame_type(stack_frame *frame); code_block_type frame_type(stack_frame *frame);
cell frame_executing(stack_frame *frame); cell frame_executing(stack_frame *frame);