diff --git a/basis/boxes/boxes.factor b/basis/boxes/boxes.factor index 39f8eb44cc..811c5addb0 100644 --- a/basis/boxes/boxes.factor +++ b/basis/boxes/boxes.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors ; IN: boxes @@ -15,9 +15,11 @@ ERROR: box-full box ; ERROR: box-empty box ; +: check-box ( box -- box ) + dup occupied>> [ box-empty ] unless ; inline + : box> ( box -- value ) - dup occupied>> - [ [ f ] change-value f >>occupied drop ] [ box-empty ] if ; + check-box [ f ] change-value f >>occupied drop ; : ?box ( box -- value/f ? ) dup occupied>> [ box> t ] [ drop f f ] if ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index a95456cdc6..b0a751b172 100644 --- 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 - -\ (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 - +\ (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 - -\ dlclose { dll } { } define-primitive - -\ { integer } { byte-array } define-primitive -\ make-flushable - -\ (byte-array) { integer } { byte-array } define-primitive -\ (byte-array) make-flushable - -\ { integer c-ptr } { c-ptr } define-primitive -\ 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 - -\ { integer object } { array } define-primitive -\ 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 - -\ { object } { wrapper } define-primitive -\ make-foldable - -\ (clone) { object } { object } define-primitive -\ (clone) make-flushable - -\ { integer integer } { string } define-primitive -\ make-flushable - -\ array>quotation { array } { quotation } define-primitive -\ array>quotation make-flushable - -\ quotation-code { quotation } { integer integer } define-primitive -\ quotation-code make-flushable - -\ { tuple-layout } { tuple } define-primitive -\ 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 - -\ { 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 - +\ (exists?) { string } { object } 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 +\ { integer object } { array } define-primitive \ make-flushable +\ { integer } { byte-array } define-primitive \ make-flushable +\ { integer word } { alien } define-primitive +\ { integer c-ptr } { c-ptr } define-primitive \ make-flushable +\ { integer integer } { string } define-primitive \ make-flushable +\ { tuple-layout } { tuple } define-primitive \ make-flushable +\ { object } { wrapper } define-primitive \ 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 +\ 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 335fbb3902..3e63a81d9a 100644 --- 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 89a90f87fd..bd30ef4b90 100644 --- 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> 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> -: new-thread ( quot name class -- thread ) - new - swap >>name - swap >>quot - \ thread counter >>id - >>continuation - H{ } clone >>variables ; inline - -: ( quot name -- thread ) - \ thread new-thread ; - : 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 + H{ } clone >>variables + >>context ; inline + +: ( quot name -- thread ) + \ thread new-thread ; + : 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 > [ 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 ) [ (spawn) ] keep ; @@ -228,17 +247,35 @@ GENERIC: error-in-thread ( error thread -- ) 65 set-special-object - 66 set-special-object - initial-thread global - [ drop [ ] "Initial" ] cache - >>continuation + 66 set-special-object ; + +: init-initial-thread ( -- ) + [ ] "Initial" 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 ea85fb1129..1bb0918b82 100644 --- a/basis/tools/threads/threads.factor +++ b/basis/tools/threads/threads.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: threads kernel prettyprint prettyprint.config io io.styles sequences assocs namespaces sorting boxes @@ -7,7 +7,9 @@ IN: tools.threads : thread. ( thread -- ) dup id>> pprint-cell - dup name>> over [ write-object ] with-cell + dup name>> [ + over write-object + ] with-cell dup state>> [ [ dup self eq? "running" "yield" ? ] unless* write diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 53d3bec56e..ffd0c4cd0e 100644 --- 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 3019de4e21..9d8e50c615 100644 --- 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 38e1a380ee..87350f290a 100644 --- 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 )) } { "" "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 8512700852..064978f99b 100644 --- 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 7268d6ab91..ad7528ab84 100755 --- 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(stack)); + return tag(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 8734ff8486..20dac9f4e5 100644 --- 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(depth / sizeof(cell)); memcpy(a + 1,(void*)bottom,depth); - ctx->push(tag(a)); - return true; + return tag(a); } } +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() { - if(!stack_to_array(ctx->datastack_seg->start,ctx->datastack)) - general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object); + 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() { - if(!stack_to_array(ctx->retainstack_seg->start,ctx->retainstack)) - general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object); + 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(ctx->pop()),ctx->datastack_seg->start); + set_datastack(ctx,untag_check(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(ctx->pop()),ctx->retainstack_seg->start); + set_retainstack(ctx,untag_check(ctx->pop())); } /* Used to implement call( */ diff --git a/vm/errors.cpp b/vm/errors.cpp index f6ceee9966..1867965108 100755 --- 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 772863d3f1..4c5dd64632 100644 --- 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 4d72cf1abb..cb5626c894 100644 --- 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 d304543879..973d5f0dda 100755 --- 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);