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

Merge git://factorcode.org/git/factor

release
Doug Coleman 2007-10-06 10:25:05 -05:00
parent c3a35c8941 bc6973a2f2
commit 3e7fb72733
164 changed files with 3206 additions and 2781 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitignore vendored
View File

@ -10,3 +10,7 @@ Factor/factor
*.image
*.dylib
factor
*#*#
.DS_Store
.gdb_history
*.*.marks

12
Makefile
View File

@ -23,7 +23,7 @@ ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/alien.o \
vm/bignum.o \
vm/compiler.o \
vm/code_heap.o \
vm/debug.o \
vm/factor.o \
vm/ffi_test.o \
@ -34,10 +34,11 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/code_gc.o \
vm/primitives.o \
vm/run.o \
vm/stack.o \
vm/callstack.o \
vm/types.o \
vm/jit.o \
vm/utilities.o
vm/quotations.o \
vm/utilities.o \
vm/errors.o
EXE_OBJS = $(PLAF_EXE_OBJS)
@ -130,9 +131,6 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
pull:
darcs pull http://factorcode.org/repos/
clean:
rm -f vm/*.o

8
core/alien/alien-tests.factor
View File

@ -56,3 +56,11 @@ cell 8 = [
] when
[ "ALIEN: 1234" ] [ 1234 <alien> unparse ] unit-test
[ ] [ 0 B{ 1 2 3 } <displaced-alien> drop ] unit-test
[ ] [ 0 F{ 1 2 3 } <displaced-alien> drop ] unit-test
[ ] [ 0 ?{ t f t } <displaced-alien> drop ] unit-test
[ 0 B{ 1 2 3 } <displaced-alien> alien-address ] unit-test-fails
[ 1 1 <displaced-alien> ] unit-test-fails

10
core/alien/alien.factor
View File

@ -4,12 +4,22 @@ IN: alien
USING: assocs kernel math namespaces sequences system
byte-arrays bit-arrays float-arrays kernel.private tuples ;
! Some predicate classes used by the compiler for optimization
! purposes
PREDICATE: alien simple-alien
underlying-alien not ;
UNION: simple-c-ptr
simple-alien byte-array bit-array float-array POSTPONE: f ;
DEFER: pinned-c-ptr?
PREDICATE: alien pinned-alien
underlying-alien pinned-c-ptr? ;
UNION: pinned-c-ptr
alien POSTPONE: f ;
UNION: c-ptr
alien bit-array byte-array float-array POSTPONE: f ;

26
core/alien/compiler/compiler.factor
View File

@ -62,6 +62,25 @@ GENERIC: alien-node-abi ( node -- str )
call
f set-stack-frame ; inline
GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
M: float-regs reg-size float-regs-size ;
GENERIC: inc-reg-class ( register-class -- )
: (inc-reg-class)
dup class inc
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
M: int-regs inc-reg-class
(inc-reg-class) ;
M: float-regs inc-reg-class
dup (inc-reg-class)
fp-shadows-int? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
: reg-class-full? ( class -- ? )
dup class get swap param-regs length >= ;
@ -206,7 +225,7 @@ M: alien-invoke-error summary
pop-literal nip over set-alien-invoke-library
pop-literal nip over set-alien-invoke-return
! Quotation which coerces parameters to required types
dup make-prep-quot infer-quot
dup make-prep-quot recursive-state get infer-quot
! If symbol doesn't resolve, no stack effect, no compile
dup alien-invoke-dlsym 2drop
! Add node to IR
@ -243,7 +262,7 @@ M: alien-indirect-error summary
pop-parameters over set-alien-indirect-parameters
pop-literal nip over set-alien-indirect-return
! Quotation which coerces parameters to required types
dup make-prep-quot 1 make-dip infer-quot
dup make-prep-quot [ dip ] curry recursive-state get infer-quot
! Add node to IR
dup node,
! Magic #: consume the function pointer, too
@ -282,7 +301,8 @@ M: alien-callback-error summary
drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ;
: callback-bottom ( node -- )
alien-callback-xt [ word-xt <alien> ] curry infer-quot ;
alien-callback-xt [ word-xt <alien> ] curry
recursive-state get infer-quot ;
\ alien-callback [
4 ensure-values

4
core/bootstrap/compiler/compiler.factor
View File

@ -3,7 +3,7 @@ parser kernel kernel.private classes classes.private
arrays hashtables vectors tuples sbufs inference.dataflow
hashtables.private sequences.private math tuples.private
growable namespaces.private alien.remote-control assocs
words generator command-line vocabs io prettyprint ;
words generator command-line vocabs io prettyprint libc ;
"bootstrap.math" vocab [
"cpu." cpu append require
@ -44,6 +44,8 @@ words generator command-line vocabs io prettyprint ;
new nth push pop peek hashcode* = get set
. lines
malloc free memcpy
} [ compile ] each
[ recompile ] parse-hook set-global

4
core/bootstrap/primitives.factor
View File

@ -267,7 +267,9 @@ H{ } clone update-map set
{ "<tuple-boa>" "tuples.private" }
{ "class-hash" "kernel.private" }
{ "callstack>array" "kernel" }
{ "array>callstack" "kernel" }
{ "innermost-frame-quot" "kernel.private" }
{ "innermost-frame-scan" "kernel.private" }
{ "set-innermost-frame-quot" "kernel.private" }
}
dup length [ >r first2 r> make-primitive ] 2each

8
core/combinators/combinators-docs.factor
View File

@ -5,7 +5,6 @@ IN: combinators
ARTICLE: "combinators-quot" "Quotation construction utilities"
"Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
{ $subsection make-dip }
{ $subsection cond>quot }
{ $subsection case>quot }
{ $subsection alist>quot }
@ -27,13 +26,6 @@ ARTICLE: "combinators" "Additional combinators"
ABOUT: "combinators"
HELP: make-dip
{ $values { "quot" "a quotation" } { "n" "a non-negative integer" } { "newquot" "a new quotation" } }
{ $description "Constructs a quotation which retains the top " { $snippet "n" } " stack items, and applies " { $snippet "quot" } " to what is underneath." }
{ $examples
{ $example "USE: quotations" "[ 3 + ] 2 make-dip ." "[ >r >r 3 + r> r> ]" }
} ;
HELP: alist>quot
{ $values { "default" "a quotation" } { "assoc" "a sequence of quotation pairs" } { "quot" "a new quotation" } }
{ $description "Constructs a quotation which calls the first quotation in each pair of " { $snippet "assoc" } " until one of them outputs a true value, and then calls the second quotation in the corresponding pair. Quotations are called in reverse order, and if no quotation outputs a true value then " { $snippet "default" } " is called." }

10
core/compiler/test/alien.factor
View File

@ -145,6 +145,16 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
! Make sure XT doesn't get clobbered in stack frame
: ffi_test_31
"void"
f "ffi_test_31"
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
alien-invoke code-gc 3 ;
[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
FUNCTION: longlong ffi_test_21 long x long y ;
[ 121932631112635269 ]

41
core/compiler/test/intrinsics.factor
View File

@ -357,26 +357,31 @@ cell 8 = [
[ 3 ] [ B{ 1 2 3 4 5 } 2 [ alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ [ B{ 1 2 3 4 5 } 2 alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test
[ t ] [ "b" get >boolean ] unit-test
[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get [ { simple-alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
"b" get [
[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ ] [ "b" get free ] unit-test
[ ] [ "b" get free ] unit-test
] when
[ ] [ "hello world" malloc-char-string "s" set ] unit-test
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test
[ "hello world" ] [ "s" get <void*> [ { simple-c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test
"s" get [
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test
[ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test
[ ] [ "s" get free ] unit-test
[ ] [ "s" get free ] unit-test
] when
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-alien } declare <void*> ] compile-1 *void* ] unit-test
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-c-ptr } declare <void*> ] compile-1 *void* ] unit-test
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-1 *void* ] unit-test
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-1 *void* ] unit-test
[ f ] [ f [ { POSTPONE: f } declare <void*> ] compile-1 *void* ] unit-test
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
@ -411,3 +416,17 @@ cell 8 = [
[ t ] [ pi <float> [ { byte-array } declare *float ] compile-1 pi - abs 0.001 < ] unit-test
[ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-1 ] keep *double pi = ] unit-test
[ 4 ] [
2 B{ 1 2 3 4 5 6 } <displaced-alien> [
{ alien } declare 1 alien-unsigned-1
] compile-1
] unit-test
[
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-1
] unit-test-fails
[
B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-1
] unit-test-fails

13
core/compiler/test/stack-trace.factor
View File

@ -1,25 +1,28 @@
IN: temporary
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
words ;
words splitting ;
: symbolic-stack-trace ( -- newseq )
error-continuation get continuation-call callstack>array ;
error-continuation get continuation-call callstack>array
2 group flip first ;
: foo 3 throw 7 ;
: bar foo 4 ;
: baz bar 5 ;
\ baz compile
[ 3 ] [ [ baz ] catch ] unit-test
[ { baz bar foo throw } ] [
symbolic-stack-trace [ word? ] subset
[ t ] [
symbolic-stack-trace
[ word? ] subset
{ baz bar foo throw } tail?
] unit-test
: bleh [ 3 + ] map [ 0 > ] subset ;
\ bleh compile
: stack-trace-contains? symbolic-stack-trace memq? ;
[ t ] [
[ { 1 "hi" } bleh ] catch drop \ + stack-trace-contains?
] unit-test

74
core/compiler/test/templates-early.factor
View File

@ -1,14 +1,17 @@
! Testing templates machinery without compiling anything
IN: temporary
USING: compiler generator generator.registers tools.test
namespaces sequences words kernel math effects ;
USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences
words kernel math effects ;
: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
[
[ ] [ init-templates ] unit-test
[ V{ 3 } ] [ 3 fresh-object fresh-objects get ] unit-test
[ ] [ 0 <int-vreg> phantom-d get phantom-push ] unit-test
[ ] [ 0 <int-vreg> phantom-push ] unit-test
[ ] [ compute-free-vregs ] unit-test
@ -17,7 +20,7 @@ namespaces sequences words kernel math effects ;
[ f ] [
[
copy-templates
1 <int-vreg> phantom-d get phantom-push
1 <int-vreg> phantom-push
compute-free-vregs
1 <int-vreg> T{ int-regs } free-vregs member?
] with-scope
@ -57,8 +60,6 @@ namespaces sequences words kernel math effects ;
{ +input+ { { f "x" } } }
} clone [
[ 1 0 ] [ +input+ get { } { } guess-vregs ] unit-test
[ ] [ 1 0 ensure-vregs ] unit-test
! [ t ] [ +input+ get phantom-d get compatible? ] unit-test
[ ] [ finalize-contents ] unit-test
[ ] [ [ template-inputs ] { } make drop ] unit-test
] bind
@ -118,14 +119,71 @@ SYMBOL: template-chosen
! This is not empty since a load instruction is emitted
[ f ] [
[ { { f "x" } } fast-input ] { } make empty?
[ { { f "x" } } +input+ set load-inputs ] { } make
empty?
] unit-test
! This is empty since we already loaded the value
[ t ] [
[ { { f "x" } } fast-input ] { } make empty?
[ { { f "x" } } +input+ set load-inputs ] { } make
empty?
] unit-test
! This is empty since we didn't change the stack
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
] with-scope
! Regression
[
[ ] [ init-templates ] unit-test
! >r r>
[ ] [
1 phantom->r
1 phantom-r>
] unit-test
! This is empty since we didn't change the stack
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
! >r r>
[ ] [
1 phantom->r
1 phantom-r>
] unit-test
[ ] [ { object } set-operand-classes ] unit-test
! This is empty since we didn't change the stack
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
] with-scope
! Regression
[
[ ] [ init-templates ] unit-test
[ ] [ { object object } set-operand-classes ] unit-test
! 2dup
[ ] [
T{ effect f { "x" "y" } { "x" "y" "x" "y" } }
phantom-shuffle
] unit-test
[ ] [
2 phantom-d get phantom-input
[ { { f "a" } { f "b" } } lazy-load ] { } make drop
] unit-test
[ t ] [
phantom-d get [ cached? ] all?
] unit-test
! >r
[ ] [
1 phantom->r
] unit-test
! This should not fail
[ ] [ [ end-basic-block ] { } make drop ] unit-test
] with-scope

37
core/compiler/test/templates.factor
View File

@ -1,9 +1,9 @@
! Black box testing of templater optimization
! Black box testing of templating optimization
USING: arrays compiler kernel kernel.private math
hashtables.private math.private math.ratios.private namespaces
sequences sequences.private tools.test namespaces.private
slots.private combinators.private ;
slots.private combinators.private byte-arrays alien layouts ;
IN: temporary
! Oops!
@ -185,3 +185,36 @@ TUPLE: my-tuple ;
[ 4 ] [ T{ my-tuple } foox ] unit-test
[ 5 ] [ "hi" foox ] unit-test
! Making sure we don't needlessly unbox/rebox
[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-1 ] unit-test
[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-1 >r eq? r> ] unit-test
[ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-1 nip eq? ] unit-test
[ 1 B{ 1 2 3 4 } ] [
B{ 1 2 3 4 } [
{ byte-array } declare
[ 0 alien-unsigned-1 ] keep
] compile-1
] unit-test
[ 1 t ] [
B{ 1 2 3 4 } [
{ c-ptr } declare
[ 0 alien-unsigned-1 ] keep type
] compile-1 byte-array type-number =
] unit-test
[ t ] [
B{ 1 2 3 4 } [
{ c-ptr } declare
0 alien-cell type
] compile-1 alien type-number =
] unit-test
[ 2 1 ] [
2 1
[ 2dup fixnum< [ >r die r> ] when ] compile-1
] unit-test

34
core/continuations/continuations-docs.factor
View File

@ -49,7 +49,6 @@ ARTICLE: "continuations.private" "Continuation implementation details"
"The continuations implementation has hooks for single-steppers:"
{ $subsection walker-hook }
{ $subsection set-walker-hook }
{ $subsection (continue) }
{ $subsection (continue-with) } ;
ARTICLE: "continuations" "Continuations"
@ -89,15 +88,11 @@ HELP: >continuation<
{ $values { "continuation" continuation } { "data" vector } { "retain" vector } { "call" vector } { "name" vector } { "catch" vector } { "c" array } }
{ $description "Takes a continuation apart into its constituents." } ;
HELP: ifcc0
HELP: ifcc
{ $values { "capture" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "restore" quotation } }
{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ;
HELP: ifcc1
{ $values { "capture" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "restore" quotation } }
{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ;
{ callcc0 continue callcc1 continue-with ifcc0 ifcc1 } related-words
{ callcc0 continue callcc1 continue-with ifcc } related-words
HELP: callcc0
{ $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } }
@ -107,28 +102,6 @@ HELP: callcc1
{ $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;
HELP: set-walker-hook
{ $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } ", or " { $link f } } }
{ $description "Sets a quotation to be called when a continuation is resumed." }
{ $notes "The single-stepper uses this hook to support single-stepping through code which makes use of continuations." } ;
HELP: walker-hook
{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } ", or " { $link f } } }
{ $description "Outputs a quotation to be called when a continuation is resumed, or " { $link f } " if no hook is set. If a hook was set prior to this word being called, it will be reset to " { $link f } "."
$nl
"The following words do not perform their usual action and instead just call the walker hook if one is set:"
{ $list
{ { $link callcc0 } " will call the hook, passing it the continuation to resume." }
{ { $link callcc1 } " will call the hook, passing it a " { $snippet "{ obj continuation }" } " pair." }
{ { $link stop } " will call the hook, passing it " { $link f } "." }
}
"The walker hook must take appropriate action so that the callers of these words see the behavior that they expect." }
{ $notes "The single-stepper uses this hook to support single-stepping through code which makes use of continuations." } ;
HELP: (continue)
{ $values { "continuation" continuation } }
{ $description "Resumes a continuation reified by " { $link callcc0 } " without invoking " { $link walker-hook } "." } ;
HELP: (continue-with)
{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }
{ $description "Resumes a continuation reified by " { $link callcc1 } " without invoking " { $link walker-hook } ". The object will be placed on the data stack when the continuation resumes." } ;
@ -223,3 +196,6 @@ $low-level-note ;
HELP: init-error-handler
{ $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ;
HELP: break
{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;

23
core/continuations/continuations-tests.factor
View File

@ -1,14 +1,8 @@
USING: kernel math namespaces io tools.test sequences vectors
continuations debugger parser memory arrays ;
continuations debugger parser memory arrays words
kernel.private ;
IN: temporary
! [ "hello" ] [
! [
! callstack [ set-callstack ] curry [ ] like -1 2array
! array>callstack set-callstack
! ] call "hello"
! ] unit-test
: (callcc1-test)
swap 1- tuck swap ?push
over 0 = [ "test-cc" get continue-with ] when
@ -66,5 +60,14 @@ IN: temporary
!
! : callstack-overflow callstack-overflow f ;
! [ callstack-overflow ] unit-test-fails
!
!
: don't-compile-me { } [ ] each ;
: foo callstack "c" set 3 don't-compile-me ;
: bar 1 foo 2 ;
[ 1 3 2 ] [ bar ] unit-test
[ t ] [ \ bar word-def "c" get innermost-frame-quot = ] unit-test
[ 1 ] [ "c" get innermost-frame-scan ] unit-test

69
core/continuations/continuations.factor
View File

@ -20,7 +20,12 @@ SYMBOL: restarts
: (catch) ( quot -- newquot )
[ swap >c call c> drop ] curry ; inline
: (callcc1) 4 getenv f 4 setenv ; inline
: dummy ( -- obj )
#! Optimizing compiler assumes stack won't be messed with
#! in-transit. To ensure that a value is actually reified
#! on the stack, we put it in a non-inline word together
#! with a declaration.
f { object } declare ;
PRIVATE>
@ -45,10 +50,10 @@ C: <continuation> continuation
continuation-catch
} get-slots ;
: ifcc0 ( capture restore -- )
: ifcc ( capture restore -- )
#! After continuation is being captured, the stacks looks
#! like:
#! ( continuation r:capture r:restore )
#! ( f continuation r:capture r:restore )
#! so the 'capture' branch is taken.
#!
#! Note that the continuation itself is not captured as part
@ -56,23 +61,17 @@ C: <continuation> continuation
#!
#! BUT...
#!
#! After the continuation is resumed, (continue) pushes f,
#! After the continuation is resumed, (continue-with) pushes
#! the given value together with f,
#! so now, the stacks looks like:
#! ( f r:capture r:restore )
#! ( value f r:capture r:restore )
#! Execution begins right after the call to 'continuation'.
#! The 'restore' branch is taken.
>r >r continuation r> r> if* ; inline
>r >r dummy continuation r> r> ?if ; inline
: ifcc1 ( capture restore -- )
[ (callcc1) ] swap compose ifcc0 ; inline
: callcc0 ( quot -- ) [ drop ] ifcc ; inline
: callcc0 ( quot -- ) [ ] ifcc0 ; inline
: callcc1 ( quot -- obj ) [ ] ifcc1 ; inline
: set-walker-hook ( quot -- ) 3 setenv ; inline
: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline
: callcc1 ( quot -- obj ) [ ] ifcc ; inline
<PRIVATE
@ -81,24 +80,32 @@ C: <continuation> continuation
set-catchstack
set-namestack
set-retainstack
>r set-datastack f r>
>r set-datastack r>
set-callstack ;
: (continue-with) ( obj continuation -- )
swap 4 setenv (continue) ;
swap 4 setenv
>continuation<
set-catchstack
set-namestack
set-retainstack
>r set-datastack drop 4 getenv f r>
set-callstack ;
PRIVATE>
: continue ( continuation -- )
[
walker-hook [ (continue-with) ] [ (continue) ] if*
] curry (throw) ;
: set-walker-hook ( quot -- ) 3 setenv ; inline
: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline
: continue-with ( obj continuation -- )
[
walker-hook [ >r 2array r> ] when* (continue-with)
] 2curry (throw) ;
: continue ( continuation -- )
f swap continue-with ;
GENERIC: compute-restarts ( error -- seq )
<PRIVATE
@ -117,11 +124,11 @@ PRIVATE>
(catch) [ f ] compose callcc1 ; inline
: recover ( try recovery -- )
>r (catch) r> ifcc1 ; inline
>r (catch) r> ifcc ; inline
: cleanup ( try cleanup-always cleanup-error -- )
>r [ compose (catch) ] keep r> compose
[ dip rethrow ] curry ifcc1 ; inline
[ dip rethrow ] curry ifcc ; inline
: attempt-all ( seq quot -- obj )
[
@ -174,3 +181,19 @@ M: condition compute-restarts
"kernel-error" 6 setenv ;
PRIVATE>
! Debugging support
: with-walker-hook ( continuation -- )
[ swap set-walker-hook (continue) ] curry callcc1 ;
SYMBOL: break-hook
: break ( -- )
continuation callstack
over set-continuation-call
walker-hook [ (continue-with) ] [ break-hook get call ] if* ;
GENERIC: (step-into) ( obj -- )
M: wrapper (step-into) wrapped break ;
M: object (step-into) break ;

32
core/cpu/architecture/architecture.factor
View File

@ -79,17 +79,14 @@ HOOK: %inc-d compiler-backend ( n -- )
HOOK: %inc-r compiler-backend ( n -- )
! Load stack into vreg
GENERIC: (%peek) ( vreg loc reg-class -- )
: %peek ( vreg loc -- ) over (%peek) ;
HOOK: %peek compiler-backend ( vreg loc -- )
! Store vreg to stack
GENERIC: (%replace) ( vreg loc reg-class -- )
: %replace ( vreg loc -- ) over (%replace) ;
HOOK: %replace compiler-backend ( vreg loc -- )
! Move one vreg to another
HOOK: %move-int>int compiler-backend ( dst src -- )
HOOK: %move-int>float compiler-backend ( dst src -- )
HOOK: %move-float>int compiler-backend ( dst src -- )
! Box and unbox floats
HOOK: %unbox-float compiler-backend ( dst src -- )
HOOK: %box-float compiler-backend ( dst src -- )
! FFI stuff
@ -183,24 +180,15 @@ PREDICATE: integer inline-array 32 < ;
] if-small-struct ;
! Alien accessors
HOOK: %unbox-byte-array compiler-backend ( quot src -- ) inline
HOOK: %unbox-byte-array compiler-backend ( dst src -- )
HOOK: %unbox-alien compiler-backend ( quot src -- ) inline
HOOK: %unbox-alien compiler-backend ( dst src -- )
HOOK: %unbox-f compiler-backend ( quot src -- ) inline
HOOK: %unbox-f compiler-backend ( dst src -- )
HOOK: %complex-alien-accessor compiler-backend ( quot src -- )
inline
HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- )
: %alien-accessor ( quot src class -- )
{
{ [ dup \ f class< ] [ drop %unbox-f ] }
{ [ dup simple-alien class< ] [ drop %unbox-alien ] }
{ [ dup byte-array class< ] [ drop %unbox-byte-array ] }
{ [ dup bit-array class< ] [ drop %unbox-byte-array ] }
{ [ dup float-array class< ] [ drop %unbox-byte-array ] }
{ [ t ] [ drop %complex-alien-accessor ] }
} cond ; inline
HOOK: %box-alien compiler-backend ( dst src -- )
: operand ( var -- op ) get v>operand ; inline

28
core/cpu/ppc/allot/allot.factor
View File

@ -32,12 +32,7 @@ IN: cpu.ppc.allot
12 11 float tag-number ORI
f fresh-object ;
M: float-regs (%replace)
drop
swap v>operand %allot-float
12 swap loc>operand STW ;
M: ppc-backend %move-float>int ( dst src -- )
M: ppc-backend %box-float ( dst src -- )
[ v>operand ] 2apply %allot-float 12 MR ;
: %allot-bignum ( #digits -- )
@ -83,22 +78,21 @@ M: ppc-backend %move-float>int ( dst src -- )
"end" resolve-label
] with-scope ;
: %allot-alien ( ptr -- )
"temp" set
"f" define-label
"end" define-label
0 "temp" operand 0 CMPI
M: ppc-backend %box-alien ( dst src -- )
{ "end" "f" } [ define-label ] each
0 over v>operand 0 CMPI
"f" get BEQ
alien 4 cells %allot
"temp" operand 11 3 cells STW
f v>operand "temp" operand LI
! Store offset
v>operand 11 3 cells STW
f v>operand 12 LI
! Store expired slot
"temp" operand 11 1 cells STW
12 11 1 cells STW
! Store underlying-alien slot
"temp" operand 11 2 cells STW
12 11 2 cells STW
! Store tagged ptr in reg
"temp" get object %store-tagged
dup object %store-tagged
"end" get B
"f" resolve-label
f v>operand "temp" operand LI
f v>operand swap v>operand LI
"end" resolve-label ;

117
core/cpu/ppc/architecture/architecture.factor
View File

@ -9,17 +9,16 @@ IN: cpu.ppc.architecture
TUPLE: ppc-backend ;
! PowerPC register assignments
! r3-r10, r17-r31: integer vregs
! r3-r10, r16-r31: integer vregs
! f0-f13: float vregs
! r11, r12: scratch
! r14: data stack
! r15: retain stack
! For stack frame layout, see vm/os-{macosx,linux}-ppc.h.
! For stack frame layout, see vm/cpu-ppc.h.
: ds-reg 14 ;
: rs-reg 15 ;
: stack-chain-reg 16 ;
: reserved-area-size
os {
@ -37,13 +36,17 @@ TUPLE: ppc-backend ;
: param-save-size 8 cells ; foldable
: xt-save reserved-area-size param-save-size + 2 cells + ; foldable
: local@ ( n -- x )
reserved-area-size param-save-size + + ; inline
: local-area-start xt-save cell + ; foldable
: factor-area-size 4 cells ;
: local@ ( n -- x ) local-area-start + ; inline
: next-save ( n -- i ) cell - ;
M: ppc-backend stack-frame ( n -- i ) local@ 4 cells align ;
: xt-save ( n -- i ) 2 cells - ;
M: ppc-backend stack-frame ( n -- i )
local@ factor-area-size + 4 cells align ;
M: temp-reg v>operand drop 11 ;
@ -85,17 +88,19 @@ M: ppc-backend %save-xt ( -- )
M: ppc-backend %prologue ( n -- )
0 MFLR
1 1 pick stack-frame neg STWU
11 1 xt-save STW
0 1 rot stack-frame lr-save + STW ;
1 1 pick neg ADDI
11 1 pick xt-save STW
dup 11 LI
11 1 pick next-save STW
0 1 rot lr-save + STW ;
M: ppc-backend %epilogue ( n -- )
#! At the end of each word that calls a subroutine, we store
#! the previous link register value in r0 by popping it off
#! the stack, set the link register to the contents of r0,
#! and jump to the link register.
0 1 pick stack-frame lr-save + LWZ
1 1 rot stack-frame ADDI
0 1 pick lr-save + LWZ
1 1 rot ADDI
0 MTLR ;
: %load-dlsym ( symbol dll register -- )
@ -156,21 +161,13 @@ M: ppc-backend %return ( -- ) %epilogue-later BLR ;
M: ppc-backend %unwind drop %return ;
M: int-regs (%peek)
drop >r v>operand r> loc>operand LWZ ;
M: ppc-backend %peek ( vreg loc -- )
>r v>operand r> loc>operand LWZ ;
M: float-regs (%peek)
drop
11 swap loc>operand LWZ
v>operand 11 float-offset LFD ;
M: ppc-backend %replace
>r v>operand r> loc>operand STW ;
M: int-regs (%replace)
drop >r v>operand r> loc>operand STW ;
M: ppc-backend %move-int>int ( dst src -- )
[ v>operand ] 2apply MR ;
M: ppc-backend %move-int>float ( dst src -- )
M: ppc-backend %unbox-float ( dst src -- )
[ v>operand ] 2apply float-offset LFD ;
M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
@ -244,7 +241,7 @@ M: ppc-backend %box-long-long ( n func -- )
4 1 rot cell + local@ LWZ
] when* r> f %alien-invoke ;
: temp@ stack-frame* swap - ;
: temp@ stack-frame* factor-area-size - swap - ;
: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
@ -277,7 +274,7 @@ M: ppc-backend %alien-invoke ( symbol dll -- )
11 %load-dlsym (%call) ;
M: ppc-backend %alien-callback ( quot -- )
0 <int-vreg> load-literal "c_to_factor" f %alien-invoke ;
3 load-indirect "c_to_factor" f %alien-invoke ;
M: ppc-backend %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
@ -323,35 +320,43 @@ M: ppc-backend %unbox-small-struct
drop "No small structs" throw ;
! Alien intrinsics
M: ppc-backend %unbox-byte-array ( quot src -- )
"address" operand "alien" operand "offset" operand ADD
"address" operand byte-array-offset
roll call ;
M: ppc-backend %unbox-byte-array ( dst src -- )
[ v>operand ] 2apply byte-array-offset ADDI ;
M: ppc-backend %unbox-alien ( quot src -- )
"address" operand "alien" operand alien-offset LWZ
"address" operand dup "offset" operand ADD
"address" operand 0
roll call ;
M: ppc-backend %unbox-alien ( dst src -- )
[ v>operand ] 2apply alien-offset LWZ ;
M: ppc-backend %unbox-f ( quot src -- )
"offset" operand 0
roll call ;
M: ppc-backend %unbox-f ( dst src -- )
drop 0 swap v>operand LI ;
M: ppc-backend %complex-alien-accessor ( quot src -- )
"is-f" define-label
"is-alien" define-label
"end" define-label
0 "alien" operand f v>operand CMPI
"is-f" get BEQ
"address" operand "alien" operand header-offset LWZ
0 "address" operand alien type-number tag-header CMPI
"is-alien" get BEQ
[ %unbox-byte-array ] 2keep
"end" get B
"is-alien" resolve-label
[ %unbox-alien ] 2keep
"end" get B
"is-f" resolve-label
%unbox-f
"end" resolve-label ;
M: ppc-backend %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in R12
0 12 LI
! Load object into R11
11 swap v>operand MR
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
0 11 f v>operand CMPI
! If so, done
"end" get BEQ
! Is the object an alien?
0 11 header-offset LWZ
0 0 alien type-number tag-header CMPI
"is-byte-array" get BNE
! If so, load the offset
0 11 alien-offset LWZ
! Add it to address being computed
12 12 0 ADD
! Now recurse on the underlying alien
11 11 underlying-alien-offset LWZ
"start" get B
"is-byte-array" resolve-label
! Add byte array address to address being computed
12 12 11 ADD
! Add an offset to start of byte array's data area
12 12 byte-array-offset ADDI
"end" resolve-label
! Done, store address in destination register
v>operand 12 MR ;

100
core/cpu/ppc/bootstrap.factor
View File

@ -17,85 +17,85 @@ big-endian on
: temp-reg 6 ;
: xt-reg 11 ;
: param-save-size 8 bootstrap-cells ;
: local@
bootstrap-cells reserved-area-size param-save-size + + ;
: array-save 0 local@ ;
: scan-save 1 local@ ;
: xt-save 2 local@ ;
: factor-area-size 4 bootstrap-cells ;
: stack-frame
3 local@ 4 bootstrap-cells align ;
factor-area-size c-area-size + 4 bootstrap-cells align ;
: next-save stack-frame bootstrap-cell - ;
: xt-save stack-frame 2 bootstrap-cells - ;
: array-save stack-frame 3 bootstrap-cells - ;
: scan-save stack-frame 4 bootstrap-cells - ;
[
temp-reg quot-reg quot-array@ LWZ ! load array
scan-reg temp-reg scan@ ADDI ! initialize scan pointer
temp-reg quot-reg quot-array@ LWZ ! load array
scan-reg temp-reg scan@ ADDI ! initialize scan pointer
] { } make jit-setup set
[
1 1 stack-frame neg STWU ! store back link
0 MFLR ! load return address into r0
temp-reg 1 array-save STW ! save array
xt-reg 1 xt-save STW ! save XT
0 1 lr-save stack-frame + STW ! save return address
0 MFLR
1 1 stack-frame neg ADDI
xt-reg 1 xt-save STW ! save XT
stack-frame xt-reg LI
xt-reg 1 next-save STW ! save frame size
temp-reg 1 array-save STW ! save array
0 1 lr-save stack-frame + STW ! save return address
] { } make jit-prolog set
[
temp-reg scan-reg 4 LWZU ! load literal and advance
temp-reg ds-reg 4 STWU ! push literal
temp-reg scan-reg 4 LWZU ! load literal and advance
temp-reg ds-reg 4 STWU ! push literal
] { } make jit-push-literal set
[
temp-reg scan-reg 4 LWZU ! load wrapper and advance
temp-reg dup wrapper@ LWZ ! load wrapped object
temp-reg ds-reg 4 STWU ! push wrapped object
temp-reg scan-reg 4 LWZU ! load wrapper and advance
temp-reg dup wrapper@ LWZ ! load wrapped object
temp-reg ds-reg 4 STWU ! push wrapped object
] { } make jit-push-wrapper set
[
4 1 MR ! pass stack pointer to primitive
4 1 MR ! pass stack pointer to primitive
] { } make jit-word-primitive-jump set
[
4 1 MR ! pass stack pointer to primitive
4 1 MR ! pass stack pointer to primitive
] { } make jit-word-primitive-call set
: load-xt ( -- )
xt-reg word-reg word-xt@ LWZ ;
: jit-call
scan-reg 1 scan-save STW ! save scan pointer
xt-reg MTLR ! pass XT to callee
BLRL ! call
scan-reg 1 scan-save LWZ ! restore scan pointer
scan-reg 1 scan-save STW ! save scan pointer
xt-reg MTLR ! pass XT to callee
BLRL ! call
scan-reg 1 scan-save LWZ ! restore scan pointer
;
: jit-jump
xt-reg MTCTR BCTR ;
[
word-reg scan-reg 4 LWZU ! load word and advance
word-reg scan-reg 4 LWZU ! load word and advance
load-xt
jit-call
] { } make jit-word-call set
[
word-reg scan-reg 4 LWZ ! load word
load-xt ! jump to word XT
word-reg scan-reg 4 LWZ ! load word
load-xt ! jump to word XT
jit-jump
] { } make jit-word-jump set
: load-branch
temp-reg ds-reg 0 LWZ ! load boolean
0 temp-reg \ f tag-number CMPI ! compare it with f
quot-reg scan-reg MR ! point quot-reg at false branch
2 BNE ! skip next insn if its not f
quot-reg dup 4 ADDI ! point quot-reg at true branch
quot-reg dup 4 LWZ ! load the branch
ds-reg dup 4 SUBI ! pop boolean
scan-reg dup 12 ADDI ! advance scan pointer
xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt
temp-reg ds-reg 0 LWZ ! load boolean
0 temp-reg \ f tag-number CMPI ! compare it with f
quot-reg scan-reg MR ! point quot-reg at false branch
2 BNE ! skip next insn if its not f
quot-reg dup 4 ADDI ! point quot-reg at true branch
quot-reg dup 4 LWZ ! load the branch
ds-reg dup 4 SUBI ! pop boolean
scan-reg dup 12 ADDI ! advance scan pointer
xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt
;
[
@ -107,20 +107,20 @@ big-endian on
] { } make jit-if-call set
[
temp-reg ds-reg 0 LWZ ! load index
temp-reg dup 1 SRAWI ! turn it into an array offset
ds-reg dup 4 SUBI ! pop index
scan-reg dup 4 LWZ ! load array
temp-reg dup scan-reg ADD ! compute quotation location
quot-reg temp-reg array-start LWZ ! load quotation
xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt
jit-jump ! execute quotation
temp-reg ds-reg 0 LWZ ! load index
temp-reg dup 1 SRAWI ! turn it into an array offset
ds-reg dup 4 SUBI ! pop index
scan-reg dup 4 LWZ ! load array
temp-reg dup scan-reg ADD ! compute quotation location
quot-reg temp-reg array-start LWZ ! load quotation
xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt
jit-jump ! execute quotation
] { } make jit-dispatch set
[
0 1 lr-save stack-frame + LWZ ! load return address
1 1 stack-frame ADDI ! pop stack frame
0 MTLR ! get ready to return
0 1 lr-save stack-frame + LWZ ! load return address
1 1 stack-frame ADDI ! pop stack frame
0 MTLR ! get ready to return
] { } make jit-epilog set
[ BLR ] { } make jit-return set

84
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -15,7 +15,7 @@ IN: cpu.ppc.intrinsics
"val" operand
"obj" operand
"n" get cells
"obj" operand-tag - ;
"obj" get operand-tag - ;
: %slot-literal-any-tag
"obj" operand "scratch" operand %untag
@ -58,7 +58,7 @@ IN: cpu.ppc.intrinsics
"cards_offset" f pick %load-dlsym dup 0 LWZ ;
: %write-barrier ( -- )
"val" operand-immediate? "obj" get fresh-object? or [
"val" get operand-immediate? "obj" get fresh-object? or [
"obj" operand "scratch" operand card-bits SRWI
"val" operand load-cards-offset
"scratch" operand dup "val" operand ADD
@ -601,41 +601,42 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
! Alien intrinsics
: %alien-accessor ( quot -- )
"offset" operand dup %untag-fixnum
"offset" operand dup "alien" operand ADD
"value" operand "offset" operand 0 roll call ; inline
: alien-integer-get-template
H{
{ +input+ {
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "output" } } }
{ +output+ { "output" } }
{ +scratch+ { { f "value" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} ;
: %alien-get ( quot -- )
"output" get "address" set
"offset" operand dup %untag-fixnum
"output" operand "alien" operand-class %alien-accessor ;
: %alien-integer-get ( quot -- )
%alien-get
"output" operand dup %tag-fixnum ; inline
: %alien-integer-set ( quot -- )
{ "offset" "value" } %untag-fixnums
"value" operand "alien" operand-class %alien-accessor ; inline
%alien-accessor
"value" operand dup %tag-fixnum ; inline
: alien-integer-set-template
H{
{ +input+ {
{ f "value" fixnum }
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "address" } } }
{ +clobber+ { "value" "offset" } }
} ;
: %alien-integer-set ( quot -- )
"offset" get "value" get = [
"value" operand dup %untag-fixnum
] unless
%alien-accessor ; inline
: define-alien-integer-intrinsics ( word get-quot word set-quot -- )
[ %alien-integer-set ] curry
alien-integer-set-template
@ -660,41 +661,55 @@ define-alien-integer-intrinsics
\ set-alien-signed-2 [ STH ]
define-alien-integer-intrinsics
: %alien-float-get ( quot -- )
"offset" operand dup %untag-fixnum
"output" operand "alien" operand-class %alien-accessor ; inline
\ alien-cell [
[ LWZ ] %alien-accessor
] H{
{ +input+ {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { unboxed-alien "value" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} define-intrinsic
\ set-alien-cell [
[ STW ] %alien-accessor
] H{
{ +input+ {
{ unboxed-c-ptr "value" pinned-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +clobber+ { "offset" } }
} define-intrinsic
: alien-float-get-template
H{
{ +input+ {
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { float "output" } { f "address" } } }
{ +output+ { "output" } }
{ +scratch+ { { float "value" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} ;
: %alien-float-set ( quot -- )
"offset" operand dup %untag-fixnum
"value" operand "alien" operand-class %alien-accessor ; inline
: alien-float-set-template
H{
{ +input+ {
{ float "value" float }
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "address" } } }
{ +clobber+ { "offset" } }
} ;
: define-alien-float-intrinsics ( word get-quot word set-quot -- )
[ %alien-float-set ] curry
[ %alien-accessor ] curry
alien-float-set-template
define-intrinsic
[ %alien-float-get ] curry
[ %alien-accessor ] curry
alien-float-get-template
define-intrinsic ;
@ -705,8 +720,3 @@ define-alien-float-intrinsics
\ alien-float [ LFS ]
\ set-alien-float [ STFS ]
define-alien-float-intrinsics
\ alien-cell [
[ LWZ ] %alien-get
"output" get %allot-alien
] alien-integer-get-template define-intrinsic

2
core/cpu/ppc/linux/bootstrap.factor
View File

@ -3,7 +3,7 @@
USING: parser layouts system ;
IN: bootstrap.ppc
: reserved-area-size 2 bootstrap-cells ;
: c-area-size 10 bootstrap-cells ;
: lr-save bootstrap-cell ;
"resource:core/cpu/ppc/bootstrap.factor" run-file

2
core/cpu/ppc/macosx/bootstrap.factor
View File

@ -3,7 +3,7 @@
USING: parser layouts system ;
IN: bootstrap.ppc
: reserved-area-size 6 bootstrap-cells ;
: c-area-size 14 bootstrap-cells ;
: lr-save 2 bootstrap-cells ;
"resource:core/cpu/ppc/bootstrap.factor" run-file

41
core/cpu/x86/allot/allot.factor
View File

@ -6,38 +6,47 @@ math.functions sequences generic arrays generator
generator.fixup generator.registers system layouts alien ;
IN: cpu.x86.allot
: (object@) ( n -- operand ) temp-reg v>operand swap [+] ;
: allot-reg
#! We temporarily use the datastack register, since it won't
#! be accessed inside the quotation given to %allot in any
#! case.
ds-reg ;
: (object@) ( n -- operand ) allot-reg swap [+] ;
: object@ ( n -- operand ) cells (object@) ;
: load-zone-ptr ( -- )
#! Load pointer to start of zone array
"nursery" f %alien-global ;
"nursery" f allot-reg %alien-global ;
: load-allot-ptr ( -- )
load-zone-ptr
temp-reg v>operand dup cell [+] MOV ;
allot-reg PUSH
allot-reg dup cell [+] MOV ;
: inc-allot-ptr ( n -- )
load-zone-ptr
temp-reg v>operand cell [+] swap 8 align ADD ;
allot-reg POP
allot-reg cell [+] swap 8 align ADD ;
: store-header ( header -- )
0 object@ swap type-number tag-header MOV ;
: %allot ( header size quot -- )
allot-reg PUSH
swap >r >r
load-allot-ptr
store-header
r> call
r> inc-allot-ptr ; inline
r> inc-allot-ptr
allot-reg POP ; inline
: %store-tagged ( reg tag -- )
>r dup fresh-object v>operand r>
temp-reg v>operand swap tag-number OR
temp-reg v>operand MOV ;
allot-reg swap tag-number OR
allot-reg MOV ;
M: x86-backend %move-float>int ( dst src -- )
M: x86-backend %box-float ( dst src -- )
#! Only called by pentium4 backend, uses SSE2 instruction
#! dest is a loc or a vreg
float 16 [
@ -77,21 +86,21 @@ M: x86-backend %move-float>int ( dst src -- )
"end" resolve-label
] with-scope ;
: %allot-alien ( ptr -- )
M: x86-backend %box-alien ( dst src -- )
[
"temp" set
{ "end" "f" } [ define-label ] each
"temp" operand 0 CMP
dup v>operand 0 CMP
"f" get JE
alien 4 cells [
1 object@ f v>operand MOV
2 object@ f v>operand MOV
3 object@ "temp" operand MOV
! Store tagged ptr in reg
"temp" get object %store-tagged
! Store src in alien-offset slot
3 object@ swap v>operand MOV
! Store tagged ptr in dst
dup object %store-tagged
] %allot
"end" get JMP
"f" resolve-label
"temp" operand f v>operand MOV
f [ v>operand ] 2apply MOV
"end" resolve-label
] with-scope ;

90
core/cpu/x86/architecture/architecture.factor
View File

@ -47,31 +47,31 @@ M: x86-backend stack-frame ( n -- i )
M: x86-backend %save-xt ( -- )
xt-reg compiling-label get MOV ;
: factor-area-size 4 cells ;
M: x86-backend %prologue ( n -- )
dup cell + PUSH
xt-reg PUSH
xt-reg stack-reg pick stack-frame 4 cells + neg [+] LEA
xt-reg PUSH
stack-reg swap stack-frame 2 cells - SUB ;
stack-reg swap 2 cells - SUB ;
M: x86-backend %epilogue ( n -- )
stack-reg swap stack-frame ADD ;
stack-reg swap ADD ;
: %alien-global ( symbol dll -- )
temp-reg v>operand 0 MOV rc-absolute-cell rel-dlsym
temp-reg v>operand dup [] MOV ;
: %alien-global ( symbol dll register -- )
[ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
M: x86-backend %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
"stack_chain" f %alien-global
"stack_chain" f temp-reg v>operand %alien-global
temp-reg v>operand [] stack-reg MOV
temp-reg v>operand 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-reg MOV ;
M: x86-backend %profiler-prologue ( word -- )
"end" define-label
"profiling" f %alien-global
"profiling" f temp-reg v>operand %alien-global
temp-reg v>operand 0 CMP
"end" get JE
temp-reg load-literal
@ -121,15 +121,12 @@ M: x86-backend %call-dispatch ( word-table# -- )
M: x86-backend %jump-dispatch ( word-table# -- )
[ %epilogue-later JMP ] dispatch-template ;
M: x86-backend %move-int>int ( dst src -- )
[ v>operand ] 2apply MOV ;
M: x86-backend %move-int>float ( dst src -- )
M: x86-backend %unbox-float ( dst src -- )
[ v>operand ] 2apply float-offset [+] MOVSD ;
M: int-regs (%peek) drop %move-int>int ;
M: x86-backend %peek [ v>operand ] 2apply MOV ;
M: int-regs (%replace) drop swap %move-int>int ;
M: x86-backend %replace swap %peek ;
: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
@ -177,30 +174,45 @@ M: x86-backend struct-small-enough? ( size -- ? )
M: x86-backend %return ( -- ) 0 %unwind ;
! Alien intrinsics
M: x86-backend %unbox-byte-array ( quot src -- )
"alien" operand "offset" operand ADD
"alien" operand byte-array-offset [+]
rot call ;
M: x86-backend %unbox-byte-array ( dst src -- )
[ v>operand ] 2apply byte-array-offset [+] LEA ;
M: x86-backend %unbox-alien ( quot src -- )
"alien" operand dup alien-offset [+] MOV
"alien" operand "offset" operand [+]
rot call ;
M: x86-backend %unbox-alien ( dst src -- )
[ v>operand ] 2apply alien-offset [+] MOV ;
M: x86-backend %unbox-f ( quot src -- )
"offset" operand rot call ;
M: x86-backend %unbox-f ( dst src -- )
drop v>operand 0 MOV ;
M: x86-backend %complex-alien-accessor ( quot src -- )
{ "is-f" "is-alien" "end" } [ define-label ] each
"alien" operand f v>operand CMP
"is-f" get JE
"alien" operand header-offset [+] alien type-number tag-header CMP
"is-alien" get JE
[ %unbox-byte-array ] 2keep
"end" get JMP
"is-alien" resolve-label
[ %unbox-alien ] 2keep
"end" get JMP
"is-f" resolve-label
%unbox-f
"end" resolve-label ;
M: x86-backend %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in ds-reg
ds-reg PUSH
ds-reg 0 MOV
! Object is stored in ds-reg
rs-reg PUSH
rs-reg swap v>operand MOV
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
rs-reg f v>operand CMP
"end" get JE
! Is the object an alien?
rs-reg header-offset [+] alien type-number tag-header CMP
"is-byte-array" get JNE
! If so, load the offset and add it to the address
ds-reg rs-reg alien-offset [+] ADD
! Now recurse on the underlying alien
rs-reg rs-reg underlying-alien-offset [+] MOV
"start" get JMP
"is-byte-array" resolve-label
! Add byte array address to address being computed
ds-reg rs-reg ADD
! Add an offset to start of byte array's data
ds-reg byte-array-offset ADD
"end" resolve-label
! Done, store address in destination register
v>operand ds-reg MOV
! Restore rs-reg
rs-reg POP
! Restore ds-reg
ds-reg POP ;

13
core/cpu/x86/bootstrap.factor
View File

@ -10,15 +10,16 @@ big-endian off
: scan-save stack-reg 3 bootstrap-cells [+] ;
: stack-frame-size 8 bootstrap-cells ;
[
arg0 arg0 quot-array@ [+] MOV ! load array
scan-reg arg0 scan@ [+] LEA ! initialize scan pointer
] { } make jit-setup set
[
[
stack-frame-size PUSH ! save stack frame size
xt-reg PUSH ! save XT
xt-reg stack-reg next-frame@ [+] LEA ! compute forward chain pointer
xt-reg PUSH ! save forward chain pointer
arg0 PUSH ! save array
stack-reg 4 bootstrap-cells SUB ! reserve space for scan-save
] { } make jit-prolog set
@ -31,7 +32,7 @@ big-endian off
arg0 scan-reg [] MOV ! load literal
ds-reg [] arg0 MOV ! store literal on datastack
] { } make jit-push-literal set
[
advance-scan
ds-reg bootstrap-cell ADD ! increment datastack pointer
@ -94,7 +95,7 @@ big-endian off
] { } make jit-dispatch set
[
stack-reg 7 bootstrap-cells ADD ! unwind stack frame
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
] { } make jit-epilog set
[ 0 RET ] { } make jit-return set

68
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -74,7 +74,7 @@ IN: cpu.x86.intrinsics
: %slot-literal-known-tag
"obj" operand
"n" get cells
"obj" operand-tag - [+] ;
"obj" get operand-tag - [+] ;
: %slot-literal-any-tag
"obj" operand %untag
@ -88,9 +88,10 @@ IN: cpu.x86.intrinsics
\ slot {
! Slot number is literal and the tag is known
{
[ "obj" operand %slot-literal-known-tag MOV ] H{
[ "val" operand %slot-literal-known-tag MOV ] H{
{ +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ +output+ { "obj" } }
{ +scratch+ { { f "val" } } }
{ +output+ { "val" } }
}
}
! Slot number is literal
@ -112,9 +113,9 @@ IN: cpu.x86.intrinsics
: generate-write-barrier ( -- )
#! Mark the card pointed to by vreg.
"val" operand-immediate? "obj" get fresh-object? or [
"val" get operand-immediate? "obj" get fresh-object? or [
"obj" operand card-bits SHR
"cards_offset" f %alien-global
"cards_offset" f temp-reg v>operand %alien-global
temp-reg v>operand "obj" operand [+] card-mark OR
] unless ;
@ -498,22 +499,27 @@ IN: cpu.x86.intrinsics
} define-intrinsic
! Alien intrinsics
: %alien-accessor ( quot -- )
"offset" operand %untag-fixnum
"offset" operand "alien" operand ADD
"offset" operand [] swap call ; inline
: %alien-integer-get ( quot reg -- )
small-reg PUSH
"offset" operand %untag-fixnum
"alien" operand-class %alien-accessor
"offset" operand small-reg MOV
"offset" operand %tag-fixnum
swap %alien-accessor
"value" operand small-reg MOV
"value" operand %tag-fixnum
small-reg POP ; inline
: alien-integer-get-template
H{
{ +input+ {
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +output+ { "offset" } }
{ +clobber+ { "alien" "offset" } }
{ +scratch+ { { f "value" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} ;
: define-getter
@ -529,19 +535,21 @@ IN: cpu.x86.intrinsics
: %alien-integer-set ( quot reg -- )
small-reg PUSH
{ "offset" "value" } %untag-fixnums
"offset" get "value" get = [
"value" operand %untag-fixnum
] unless
small-reg "value" operand MOV
"alien" operand-class %alien-accessor
swap %alien-accessor
small-reg POP ; inline
: alien-integer-set-template
H{
{ +input+ {
{ f "value" fixnum }
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +clobber+ { "value" "alien" "offset" } }
{ +clobber+ { "value" "offset" } }
} ;
: define-setter
@ -563,12 +571,24 @@ IN: cpu.x86.intrinsics
\ set-alien-signed-2 small-reg-16 define-setter
\ alien-cell [
"offset" operand %untag-fixnum
"value" operand [ MOV ] %alien-accessor
] H{
{ +input+ {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { unboxed-alien "value" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} define-intrinsic
[ MOV ]
"offset" operand
"alien" operand-class
%alien-accessor
"offset" get %allot-alien
] alien-integer-get-template define-intrinsic
\ set-alien-cell [
"value" operand [ swap MOV ] %alien-accessor
] H{
{ +input+ {
{ unboxed-c-ptr "value" c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +clobber+ { "offset" } }
} define-intrinsic

40
core/cpu/x86/sse2/sse2.factor
View File

@ -1,18 +1,12 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays cpu.x86.assembler cpu.x86.architecture
generic kernel kernel.private math math.private memory
namespaces sequences words generator generator.registers
cpu.architecture math.floats.private layouts quotations ;
cpu.x86.intrinsics generic kernel kernel.private math
math.private memory namespaces sequences words generator
generator.registers cpu.architecture math.floats.private layouts
quotations ;
IN: cpu.x86.sse2
M: float-regs (%peek)
drop
temp-reg swap %move-int>int
temp-reg %move-int>float ;
M: float-regs (%replace) drop swap %move-float>int ;
: define-float-op ( word op -- )
[ "x" operand "y" operand ] swap add H{
{ +input+ { { float "x" } { float "y" } } }
@ -61,42 +55,32 @@ M: float-regs (%replace) drop swap %move-float>int ;
{ +clobber+ { "in" } }
} define-intrinsic
: %alien-float-get ( quot -- )
"offset" operand %untag-fixnum
"output" operand "alien" operand-class %alien-accessor ;
inline
: alien-float-get-template
H{
{ +input+ {
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { float "output" } } }
{ +output+ { "output" } }
{ +clobber+ { "alien" "offset" } }
{ +scratch+ { { float "value" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} ;
: %alien-float-set ( quot -- )
"offset" operand %untag-fixnum
"value" operand "alien" operand-class %alien-accessor ;
inline
: alien-float-set-template
H{
{ +input+ {
{ float "value" float }
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +clobber+ { "value" "alien" "offset" } }
{ +clobber+ { "offset" } }
} ;
: define-alien-float-intrinsics ( word get-quot word set-quot -- )
[ %alien-float-set ] curry
[ "value" operand swap %alien-accessor ] curry
alien-float-set-template
define-intrinsic
[ %alien-float-get ] curry
[ "value" operand swap %alien-accessor ] curry
alien-float-get-template
define-intrinsic ;

15
core/effects/effects.factor
View File

@ -51,3 +51,18 @@ M: integer (stack-picture) drop "object" ;
M: effect clone
[ effect-in clone ] keep effect-out clone <effect> ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
effect-in length swap cut* ;
: load-shuffle ( stack shuffle -- )
effect-in [ set ] 2each ;
: shuffled-values ( shuffle -- values )
effect-out [ get ] map ;
: shuffle* ( stack shuffle -- newstack )
[ [ load-shuffle ] keep shuffled-values ] with-scope ;
: shuffle ( stack shuffle -- newstack )
[ split-shuffle ] keep shuffle* append ;

3
core/generator/fixup/fixup.factor
View File

@ -35,7 +35,8 @@ M: label fixup*
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
: if-stack-frame ( frame-size quot -- )
over no-stack-frame = [ 2drop ] [ call ] if ; inline
swap dup no-stack-frame =
[ 2drop ] [ stack-frame swap call ] if ; inline
M: word fixup*
{

41
core/generator/generator.factor
View File

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes combinators cpu.architecture
effects generator.fixup generator.registers generic hashtables
inference inference.backend inference.dataflow inference.stack
io kernel kernel.private layouts math namespaces optimizer
prettyprint quotations sequences system threads words ;
inference inference.backend inference.dataflow io kernel
kernel.private layouts math namespaces optimizer prettyprint
quotations sequences system threads words ;
IN: generator
SYMBOL: compiled-xts
@ -73,10 +73,9 @@ SYMBOL: profiler-prologues
: word-dataflow ( word -- dataflow )
[
dup "no-effect" word-prop [ no-effect ] when
dup dup add-recursive-state
[ specialized-def (dataflow) ] keep
finish-word drop
] with-infer ;
dup specialized-def over dup 2array 1array infer-quot
finish-word
] with-infer nip ;
SYMBOL: compiler-hook
@ -229,7 +228,7 @@ M: #dispatch generate-node
"true" resolve-label
t "if-scratch" get load-literal
"end" resolve-label
"if-scratch" get phantom-d get phantom-push ; inline
"if-scratch" get phantom-push ; inline
: define-if>boolean-intrinsics ( word intrinsics -- )
[
@ -247,10 +246,8 @@ M: #dispatch generate-node
: define-if-intrinsic ( word quot inputs -- )
2array 1array define-if-intrinsics ;
: do-intrinsic ( pair -- ) first2 with-template ;
: do-if-intrinsic ( #call pair -- next )
<label> [ swap do-intrinsic ] keep
<label> [ swap do-template ] keep
>r node-successor r> generate-if
node-successor ;
@ -265,11 +262,12 @@ M: #dispatch generate-node
] if ;
M: #call generate-node
dup node-input-classes set-operand-classes
dup find-if-intrinsic [
do-if-intrinsic
] [
dup find-intrinsic [
do-intrinsic iterate-next
do-template iterate-next
] [
node-param generate-call
] ?if
@ -279,29 +277,22 @@ M: #call generate-node
M: #call-label generate-node node-param generate-call ;
! #push
UNION: immediate fixnum POSTPONE: f ;
M: #push generate-node
node-out-d phantom-d get phantom-append iterate-next ;
node-out-d [ value-literal <constant> phantom-push ] each
iterate-next ;
! #shuffle
: phantom-shuffle ( shuffle -- )
[ effect-in length phantom-d get phantom-input ] keep
shuffle* phantom-d get phantom-append ;
M: #shuffle generate-node
node-shuffle phantom-shuffle iterate-next ;
M: #>r generate-node
node-in-d length
phantom-d get phantom-input
phantom-r get phantom-append
phantom->r
iterate-next ;
M: #r> generate-node
node-out-d length
phantom-r get phantom-input
phantom-d get phantom-append
phantom-r>
iterate-next ;
! #return
@ -318,8 +309,6 @@ M: #return generate-node drop end-basic-block %return f ;
: profile-count-offset 7 cells object tag-number - ;
: byte-array-offset 2 cells object tag-number - ;
: alien-offset 3 cells object tag-number - ;
: underlying-alien-offset cell object tag-number - ;
: tuple-class-offset 2 cells tuple tag-number - ;
: class-hash-offset cell object tag-number - ;
: operand-immediate? ( operand -- ? )
operand-class immediate class< ;

712
core/generator/registers/registers.factor
View File

@ -1,82 +1,240 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes classes.private combinators
cpu.architecture generator.fixup generic hashtables
inference.dataflow kernel kernel.private layouts math memory
namespaces quotations sequences system vectors words ;
cpu.architecture generator.fixup hashtables kernel layouts math
namespaces quotations sequences system vectors words effects
alien byte-arrays bit-arrays float-arrays ;
IN: generator.registers
SYMBOL: +input+
SYMBOL: +output+
SYMBOL: +scratch+
SYMBOL: +clobber+
SYMBOL: known-tag
! Register classes
TUPLE: int-regs ;
TUPLE: float-regs size ;
<PRIVATE
! Value protocol
GENERIC: set-operand-class ( class obj -- )
GENERIC: operand-class* ( operand -- class )
GENERIC: move-spec ( obj -- spec )
GENERIC: live-vregs* ( obj -- )
GENERIC: live-loc? ( actual current -- ? )
GENERIC# (lazy-load) 1 ( value spec -- value )
GENERIC: lazy-store ( dst src -- )
GENERIC: minimal-ds-loc* ( min obj -- min )
! This will be a multimethod soon
DEFER: %move
MIXIN: value
PRIVATE>
: operand-class ( operand -- class )
operand-class* object or ;
! Default implementation
M: value set-operand-class 2drop ;
M: value operand-class* drop f ;
M: value live-vregs* drop ;
M: value live-loc? 2drop f ;
M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ;
! A scratch register for computations
TUPLE: vreg n ;
: <vreg> ( n reg-class -- vreg )
{ set-vreg-n set-delegate } vreg construct ;
! Register classes
TUPLE: int-regs ;
TUPLE: float-regs size ;
M: vreg v>operand dup vreg-n swap vregs nth ;
M: vreg live-vregs* , ;
: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
: <float-vreg> ( n -- vreg ) T{ float-regs f 8 } <vreg> ;
INSTANCE: vreg value
M: float-regs move-spec drop float ;
M: float-regs operand-class* drop float ;
! Temporary register for stack shuffling
TUPLE: temp-reg ;
: temp-reg T{ temp-reg T{ int-regs } } ;
: %move ( dst src -- )
2dup = [
2drop
] [
2dup [ delegate class ] 2apply 2array {
{ { int-regs int-regs } [ %move-int>int ] }
{ { float-regs int-regs } [ %move-int>float ] }
{ { int-regs float-regs } [ %move-float>int ] }
} case
] if ;
M: temp-reg move-spec drop f ;
GENERIC: reg-size ( register-class -- n )
GENERIC: inc-reg-class ( register-class -- )
M: int-regs reg-size drop cell ;
: (inc-reg-class)
dup class inc
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
M: int-regs inc-reg-class
(inc-reg-class) ;
M: float-regs reg-size float-regs-size ;
M: float-regs inc-reg-class
dup (inc-reg-class)
fp-shadows-int? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
M: vreg v>operand dup vreg-n swap vregs nth ;
: reg-spec>class ( spec -- class )
float eq?
T{ float-regs f 8 } T{ int-regs } ? ;
SYMBOL: phantom-d
SYMBOL: phantom-r
INSTANCE: temp-reg value
! A data stack location.
TUPLE: ds-loc n ;
TUPLE: ds-loc n class ;
C: <ds-loc> ds-loc
: <ds-loc> { set-ds-loc-n } ds-loc construct ;
M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ;
M: ds-loc set-operand-class set-ds-loc-class ;
M: ds-loc live-loc?
over ds-loc? [ [ ds-loc-n ] 2apply = not ] [ 2drop t ] if ;
! A retain stack location.
TUPLE: rs-loc n ;
TUPLE: rs-loc n class ;
C: <rs-loc> rs-loc
: <rs-loc> { set-rs-loc-n } rs-loc construct ;
M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
over rs-loc? [ [ rs-loc-n ] 2apply = not ] [ 2drop t ] if ;
UNION: loc ds-loc rs-loc ;
M: loc move-spec drop loc ;
INSTANCE: loc value
M: f move-spec drop loc ;
M: f operand-class* ;
! A stack location which has been loaded into a register. To
! read the location, we just read the register, but when time
! comes to save it back to the stack, we know the register just
! contains a stack value so we don't have to redundantly write
! it back.
TUPLE: cached loc vreg ;
C: <cached> cached
M: cached set-operand-class cached-vreg set-operand-class ;
M: cached operand-class* cached-vreg operand-class* ;
M: cached move-spec drop cached ;
M: cached live-vregs* cached-vreg live-vregs* ;
M: cached live-loc? cached-loc live-loc? ;
M: cached (lazy-load) >r cached-vreg r> (lazy-load) ;
M: cached lazy-store
2dup cached-loc live-loc?
[ "live-locs" get at %move ] [ 2drop ] if ;
M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
INSTANCE: cached value
! A tagged pointer
TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged )
{ set-tagged-vreg } tagged construct ;
M: tagged v>operand tagged-vreg v>operand ;
M: tagged set-operand-class set-tagged-class ;
M: tagged operand-class* tagged-class ;
M: tagged move-spec drop f ;
M: tagged live-vregs* tagged-vreg , ;
INSTANCE: tagged value
! Unboxed alien pointers
TUPLE: unboxed-alien vreg ;
C: <unboxed-alien> unboxed-alien
M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
M: unboxed-alien operand-class* drop simple-alien ;
M: unboxed-alien move-spec class ;
M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
INSTANCE: unboxed-alien value
TUPLE: unboxed-byte-array vreg ;
C: <unboxed-byte-array> unboxed-byte-array
M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
M: unboxed-byte-array operand-class* drop c-ptr ;
M: unboxed-byte-array move-spec class ;
M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
INSTANCE: unboxed-byte-array value
TUPLE: unboxed-f vreg ;
C: <unboxed-f> unboxed-f
M: unboxed-f v>operand unboxed-f-vreg v>operand ;
M: unboxed-f operand-class* drop \ f ;
M: unboxed-f move-spec class ;
M: unboxed-f live-vregs* unboxed-f-vreg , ;
INSTANCE: unboxed-f value
TUPLE: unboxed-c-ptr vreg ;
C: <unboxed-c-ptr> unboxed-c-ptr
M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
M: unboxed-c-ptr operand-class* drop c-ptr ;
M: unboxed-c-ptr move-spec class ;
M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
INSTANCE: unboxed-c-ptr value
! A constant value
TUPLE: constant value ;
C: <constant> constant
M: constant operand-class* constant-value class ;
M: constant move-spec class ;
INSTANCE: constant value
<PRIVATE
! Moving values between locations and registers
: %move-bug "Bug in generator.registers" throw ;
: %unbox-c-ptr ( dst src -- )
dup operand-class {
{ [ dup \ f class< ] [ drop %unbox-f ] }
{ [ dup simple-alien class< ] [ drop %unbox-alien ] }
{ [ dup byte-array class< ] [ drop %unbox-byte-array ] }
{ [ dup bit-array class< ] [ drop %unbox-byte-array ] }
{ [ dup float-array class< ] [ drop %unbox-byte-array ] }
{ [ t ] [ drop %unbox-any-c-ptr ] }
} cond ; inline
: %move-via-temp ( dst src -- )
#! For many transfers, such as loc to unboxed-alien, we
#! don't have an intrinsic, so we transfer the source to
#! temp then temp to the destination.
temp-reg over %move
operand-class temp-reg
{ set-operand-class set-tagged-vreg } tagged construct
%move ;
: %move ( dst src -- )
2dup [ move-spec ] 2apply 2array {
{ { f f } [ %move-bug ] }
{ { f unboxed-c-ptr } [ %move-bug ] }
{ { f unboxed-byte-array } [ %move-bug ] }
{ { f constant } [ constant-value swap load-literal ] }
{ { f float } [ %box-float ] }
{ { f unboxed-alien } [ %box-alien ] }
{ { f loc } [ %peek ] }
{ { float f } [ %unbox-float ] }
{ { unboxed-alien f } [ %unbox-alien ] }
{ { unboxed-byte-array f } [ %unbox-byte-array ] }
{ { unboxed-f f } [ %unbox-f ] }
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] }
{ { loc f } [ swap %replace ] }
[ drop %move-via-temp ]
} case ;
! A compile-time stack
TUPLE: phantom-stack height ;
GENERIC: finalize-height ( stack -- )
SYMBOL: phantom-d
SYMBOL: phantom-r
: <phantom-stack> ( class -- stack )
>r
V{ } clone 0
@ -84,10 +242,6 @@ TUPLE: phantom-stack height ;
phantom-stack construct
r> construct-delegate ;
GENERIC: finalize-height ( stack -- )
GENERIC: <loc> ( n stack -- loc )
: (loc)
#! Utility for methods on <loc>
phantom-stack-height - ;
@ -102,6 +256,8 @@ GENERIC: <loc> ( n stack -- loc )
0
] keep set-phantom-stack-height ; inline
GENERIC: <loc> ( n stack -- loc )
TUPLE: phantom-datastack ;
: <phantom-datastack> phantom-datastack <phantom-stack> ;
@ -128,7 +284,7 @@ M: phantom-retainstack finalize-height
dup length swap phantom-locs ;
: (each-loc) ( phantom quot -- )
>r dup phantom-locs* r> 2each ; inline
>r dup phantom-locs* swap r> 2each ; inline
: each-loc ( quot -- )
>r phantom-d get r> phantom-r get over
@ -137,73 +293,97 @@ M: phantom-retainstack finalize-height
: adjust-phantom ( n phantom -- )
[ phantom-stack-height + ] keep set-phantom-stack-height ;
: phantom-push ( obj stack -- )
1 over adjust-phantom push ;
: phantom-append ( seq stack -- )
over length over adjust-phantom push-all ;
GENERIC: cut-phantom ( n phantom -- seq )
M: phantom-stack cut-phantom
[ delegate cut* swap ] keep set-delegate ;
: phantom-append ( seq stack -- )
over length over adjust-phantom push-all ;
: add-locs ( n phantom -- )
2dup length <= [
2drop
] [
[ phantom-locs ] keep
[ length head-slice* ] keep
[ append >vector ] keep
delegate set-delegate
] if ;
: phantom-input ( n phantom -- seq )
[
2dup length <= [
cut-phantom
] [
[ phantom-locs ] keep
[ length head-slice* ] keep
[ append ] keep
delete-all
] if
] 2keep >r neg r> adjust-phantom ;
2dup add-locs
2dup cut-phantom
>r >r neg r> adjust-phantom r> ;
: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
: each-phantom ( quot -- ) phantoms rot 2apply ; inline
: finalize-heights ( -- )
phantoms [ finalize-height ] 2apply ;
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
! Phantom stacks hold values, locs, and vregs
UNION: pseudo loc value ;
: live-vregs ( -- seq ) phantoms append [ vreg? ] subset ;
: live-loc? ( current actual -- ? )
over loc? [ = not ] [ 2drop f ] if ;
: live-vregs ( -- seq )
[ [ [ live-vregs* ] each ] each-phantom ] { } make ;
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
dup phantom-locs* 2array flip
dup phantom-locs* swap 2array flip
[ live-loc? ] assoc-subset
keys ;
values ;
: live-locs ( -- seq )
[ (live-locs) ] each-phantom append prune ;
: minimal-ds-loc ( phantom -- n )
#! When shuffling more values than can fit in registers, we
#! need to find an area on the data stack which isn't in
#! use.
dup phantom-stack-height neg
[ dup ds-loc? [ ds-loc-n min ] [ drop ] if ] reduce ;
! Operands holding pointers to freshly-allocated objects which
! are guaranteed to be in the nursery
SYMBOL: fresh-objects
: fresh-object ( obj -- ) fresh-objects get push ;
: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
! Computing free registers and initializing allocator
: reg-spec>class ( spec -- class )
float eq?
T{ float-regs f 8 } T{ int-regs } ? ;
: free-vregs ( reg-class -- seq )
#! Free vregs in a given register class
\ free-vregs get at ;
: alloc-vreg ( spec -- reg )
dup reg-spec>class free-vregs pop swap {
{ f [ <tagged> ] }
{ unboxed-alien [ <unboxed-alien> ] }
{ unboxed-byte-array [ <unboxed-byte-array> ] }
{ unboxed-f [ <unboxed-f> ] }
{ unboxed-c-ptr [ <unboxed-c-ptr> ] }
[ drop ]
} case ;
: compatible? ( value spec -- ? )
>r move-spec r> {
{ [ 2dup = ] [ t ] }
{ [ dup unboxed-c-ptr eq? ] [
over { unboxed-byte-array unboxed-alien } member?
] }
{ [ t ] [ f ] }
} cond 2nip ;
: allocation ( value spec -- reg-class )
{
{ [ dup quotation? ] [ 2drop f ] }
{ [ 2dup compatible? ] [ 2drop f ] }
{ [ t ] [ nip reg-spec>class ] }
} cond ;
: alloc-vreg-for ( value spec -- vreg )
swap operand-class swap alloc-vreg
dup tagged? [ tuck set-tagged-class ] [ nip ] if ;
M: value (lazy-load)
2dup allocation [
dupd alloc-vreg-for dup rot %move
] [
drop
] if ;
: (compute-free-vregs) ( used class -- vector )
#! Find all vregs in 'class' which are not in 'used'.
[ vregs length reverse ] keep
@ -214,109 +394,19 @@ SYMBOL: fresh-objects
#! Create a new hashtable for thee free-vregs variable.
live-vregs
{ T{ int-regs } T{ float-regs f 8 } }
[ 2dup (compute-free-vregs) ] H{ } map>assoc \ free-vregs set
[ 2dup (compute-free-vregs) ] H{ } map>assoc
\ free-vregs set
drop ;
: init-templates ( -- )
#! Initialize register allocator.
V{ } clone fresh-objects set
<phantom-datastack> phantom-d set
<phantom-retainstack> phantom-r set
compute-free-vregs ;
: copy-templates ( -- )
#! Copies register allocator state, used when compiling
#! branches.
fresh-objects [ clone ] change
phantom-d [ clone ] change
phantom-r [ clone ] change
compute-free-vregs ;
! Copying vregs to stacks
: alloc-vreg ( spec -- vreg )
reg-spec>class free-vregs pop ;
: vreg>vreg ( vreg spec -- vreg )
alloc-vreg dup rot %move ;
: value>int-vreg ( value spec -- vreg )
alloc-vreg [ >r value-literal r> load-literal ] keep ;
: value>float-vreg ( value spec -- vreg )
alloc-vreg [
>r value-literal temp-reg load-literal r> temp-reg %move
] keep ;
: loc>vreg ( loc spec -- vreg )
alloc-vreg [ swap %peek ] keep ;
: allocation
H{
{ { int-regs f } f }
{ { int-regs float } T{ float-regs 8 f } }
{ { float-regs f } T{ int-regs f } }
{ { float-regs float } f }
{ { value value } f }
{ { value f } T{ int-regs f } }
{ { value float } T{ float-regs 8 f } }
{ { loc f } T{ int-regs f } }
{ { loc float } T{ float-regs 8 f } }
} at ;
: transfer
{
{ { int-regs f } [ drop ] }
{ { int-regs float } [ vreg>vreg ] }
{ { float-regs f } [ vreg>vreg ] }
{ { float-regs float } [ drop ] }
{ { value f } [ value>int-vreg ] }
{ { value float } [ value>float-vreg ] }
{ { value value } [ drop ] }
{ { loc f } [ loc>vreg ] }
{ { loc float } [ loc>vreg ] }
} case ;
GENERIC: template-lhs ( obj -- lhs )
M: int-regs template-lhs class ;
M: float-regs template-lhs class ;
M: ds-loc template-lhs drop loc ;
M: rs-loc template-lhs drop loc ;
M: f template-lhs drop loc ;
M: value template-lhs class ;
GENERIC: template-rhs ( obj -- rhs )
M: quotation template-rhs drop value ;
M: object template-rhs ;
: transfer-op ( value spec -- pair )
swap template-lhs swap template-rhs 2array ;
: (lazy-load) ( value spec -- value )
2dup transfer-op transfer ;
: loc>loc ( fromloc toloc -- )
#! Move a value from a stack location to another stack
#! location.
temp-reg rot %peek
temp-reg swap %replace ;
: lazy-store ( src dest -- )
#! Don't store a location to itself.
2dup = [
2drop
] [
>r \ live-locs get at dup vreg?
[ r> %replace ] [ r> loc>loc ] if
] if ;
M: loc lazy-store
2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
: do-shuffle ( hash -- )
dup assoc-empty? [
drop
] [
\ live-locs set
[ over loc? [ lazy-store ] [ 2drop ] if ] each-loc
"live-locs" set
[ lazy-store ] each-loc
] if ;
: fast-shuffle ( locs -- )
@ -324,6 +414,12 @@ M: object template-rhs ;
#! at once
[ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
: minimal-ds-loc ( phantom -- n )
#! When shuffling more values than can fit in registers, we
#! need to find an area on the data stack which isn't in
#! use.
dup phantom-stack-height neg [ minimal-ds-loc* ] reduce ;
: find-tmp-loc ( -- n )
#! Find an area of the data stack which is not referenced
#! from the phantom stacks. We can clobber there all we want
@ -331,16 +427,17 @@ M: object template-rhs ;
: slow-shuffle-mapping ( locs tmp -- pairs )
>r dup length r>
[ swap - <ds-loc> ] curry map
2array flip ;
[ swap - <ds-loc> ] curry map 2array flip ;
: slow-shuffle ( locs -- )
#! We don't have enough free registers to load all shuffle
#! inputs, so we use a single temporary register, together
#! with the area of the data stack above the stack pointer
find-tmp-loc slow-shuffle-mapping
[ [ loc>loc ] assoc-each ] keep
>hashtable do-shuffle ;
find-tmp-loc slow-shuffle-mapping [
[
swap dup cached? [ cached-vreg ] when %move
] assoc-each
] keep >hashtable do-shuffle ;
: fast-shuffle? ( live-locs -- ? )
#! Test if we have enough free registers to load all
@ -349,112 +446,81 @@ M: object template-rhs ;
: finalize-locs ( -- )
#! Perform any deferred stack shuffling.
live-locs dup fast-shuffle?
[ fast-shuffle ] [ slow-shuffle ] if ;
: value>loc ( literal toloc -- )
#! Move a literal to a stack location.
>r value-literal temp-reg load-literal
temp-reg r> %replace ;
: finalize-values ( -- )
#! Store any deferred literals to their final stack
#! locations.
[ over value? [ value>loc ] [ 2drop ] if ] each-loc ;
[
\ free-vregs [ [ clone ] assoc-map ] change
live-locs dup fast-shuffle?
[ fast-shuffle ] [ slow-shuffle ] if
] with-scope ;
: finalize-vregs ( -- )
#! Store any vregs to their final stack locations.
[ over pseudo? [ 2drop ] [ %replace ] if ] each-loc ;
: reusing-vregs ( quot -- )
#! Any vregs allocated by quot are released again.
>r \ free-vregs get [ clone ] assoc-map \ free-vregs r>
with-variable ; inline
[
dup loc? over cached? or [ 2drop ] [ %move ] if
] each-loc ;
: finalize-contents ( -- )
[ finalize-locs ] reusing-vregs
[ finalize-values ] reusing-vregs
finalize-vregs
[ delete-all ] each-phantom ;
finalize-locs finalize-vregs [ delete-all ] each-phantom ;
: %gc ( -- )
0 frame-required
%prepare-alien-invoke
"simple_gc" f %alien-invoke ;
: end-basic-block ( -- )
#! Commit all deferred stacking shuffling, and ensure the
#! in-memory data and retain stacks are up to date with
#! respect to the compiler's current picture.
finalize-contents finalize-heights
fresh-objects get dup empty? swap delete-all [ %gc ] unless ;
! Loading stacks to vregs
: free-vregs# ( -- int# float# )
T{ int-regs } T{ float-regs f 8 }
[ free-vregs length ] 2apply ;
: free-vregs? ( int# float# -- ? )
free-vregs# swapd <= >r <= r> and ;
: ensure-vregs ( int# float# -- )
compute-free-vregs free-vregs?
[ finalize-contents compute-free-vregs ] unless ;
T{ float-regs f 8 } free-vregs length <
>r T{ int-regs } free-vregs length < r> and ;
: phantom&spec ( phantom spec -- phantom' spec' )
0 <column>
[ length f pad-left ] keep
[ <reversed> ] 2apply ; inline
: phantom&spec-agree? ( phantom spec quot -- ? )
>r phantom&spec r> 2all? ; inline
: split-template ( input -- slow fast )
phantom-d get
2dup [ length ] 2apply <=
[ drop { } swap ] [ length swap cut* ] if ;
: vreg-substitution ( value vreg -- pair )
dupd <cached> 2array ;
: substitute-vregs ( alist -- )
>hashtable
{ phantom-d phantom-r }
[ get substitute ] curry* each ;
: substitute-vreg? ( old new -- ? )
#! We don't substitute locs for float or alien vregs,
#! since in those cases the boxing overhead might kill us.
cached-vreg tagged? >r loc? r> and ;
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable
[ swap substitute ] curry each-phantom ;
: set-operand ( value var -- )
>r dup constant? [ constant-value ] when r> set ;
: lazy-load ( values template -- )
#! Set operand vars here.
flip first2
>r dupd [ (lazy-load) ] 2map dup r>
[ >r dup value? [ value-literal ] when r> set ] 2each
2array flip substitute-vregs ;
2dup [ first (lazy-load) ] 2map
dup rot [ second set-operand ] 2each
substitute-vregs ;
: fast-input ( template -- )
dup empty? [
drop
] [
dup length phantom-d get phantom-input swap lazy-load
] if ;
SYMBOL: +input+
SYMBOL: +output+
SYMBOL: +scratch+
SYMBOL: +clobber+
: load-inputs ( -- )
+input+ get dup length phantom-d get phantom-input
swap lazy-load ;
: output-vregs ( -- seq seq )
+output+ +clobber+ [ get [ get ] map ] 2apply ;
: clash? ( seq -- ? )
phantoms append swap [ member? ] curry contains? ;
phantoms append [
dup cached? [ cached-vreg ] when swap member?
] curry* contains? ;
: outputs-clash? ( -- ? )
output-vregs append clash? ;
: slow-input ( template -- )
outputs-clash? [ finalize-contents ] when fast-input ;
: count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
: count-input-vregs ( phantom spec -- )
phantom&spec [ transfer-op allocation ] 2map
count-vregs ;
phantom&spec [
>r dup cached? [ cached-vreg ] when r> allocation
] 2map count-vregs ;
: count-scratch-regs ( spec -- )
[ first reg-spec>class ] map count-vregs ;
@ -477,23 +543,16 @@ SYMBOL: +clobber+
+input+ get { } +scratch+ get guess-vregs ;
: template-inputs ( -- )
! Ensure we have enough to hold any new stack elements we
! will read (if any), and scratch.
guess-template-vregs ensure-vregs
! Split the template into available (fast) parts and those
! that require allocating registers and reading the stack
+input+ get split-template fast-input slow-input
! Finally allocate scratch registers
alloc-scratch ;
! Load input values into registers
load-inputs
! Allocate scratch registers
alloc-scratch
! If outputs clash, we write values back to the stack
outputs-clash? [ finalize-contents ] when ;
: template-outputs ( -- )
+output+ get [ get ] map phantom-d get phantom-append ;
: with-template ( quot hash -- )
clone [ template-inputs call template-outputs ] bind
compute-free-vregs ;
inline
: value-matches? ( value spec -- ? )
#! If the spec is a quotation and the value is a literal
#! fixnum, see if the quotation yields true when applied
@ -501,16 +560,12 @@ SYMBOL: +clobber+
#! spec is not a quotation, its a reg-class, in which case
#! the value is always good.
dup quotation? [
over value?
[ >r value-literal r> call ] [ 2drop f ] if
over constant?
[ >r constant-value r> call ] [ 2drop f ] if
] [
2drop t
] if ;
: template-specs-match? ( -- ? )
phantom-d get +input+ get
[ value-matches? ] phantom&spec-agree? ;
: class-tag ( class -- tag/f )
dup hi-tag class< [
drop object tag-number
@ -519,45 +574,108 @@ SYMBOL: +clobber+
dup length 1 = [ first tag-number ] [ drop f ] if
] if ;
SYMBOL: known-tag
: class-match? ( actual expected -- ? )
: class-matches? ( actual expected -- ? )
{
{ f [ drop t ] }
{ known-tag [ class-tag >boolean ] }
[ class< ]
} case ;
: template-classes-match? ( -- ? )
#! Depends on node@
node@ node-input-classes +input+ get
[ 2 swap ?nth class-match? ] 2all? ;
: spec-matches? ( value spec -- ? )
2dup first value-matches?
>r >r operand-class 2 r> ?nth class-matches? r> and ;
: template-specs-match? ( -- ? )
phantom-d get +input+ get
[ spec-matches? ] phantom&spec-agree? ;
: template-matches? ( spec -- ? )
#! Depends on node@
clone [
template-specs-match?
template-classes-match? and
[ guess-template-vregs free-vregs? ] [ f ] if
] bind ;
: (find-template) ( templates -- pair/f )
#! Depends on node@
[ second template-matches? ] find nip ;
: ensure-template-vregs ( -- )
guess-template-vregs free-vregs? [
finalize-contents compute-free-vregs
] unless ;
PRIVATE>
: set-operand-classes ( classes -- )
phantom-d get
over length over add-locs
[ set-operand-class ] 2reverse-each ;
: end-basic-block ( -- )
#! Commit all deferred stacking shuffling, and ensure the
#! in-memory data and retain stacks are up to date with
#! respect to the compiler's current picture.
finalize-contents finalize-heights
fresh-objects get dup empty? swap delete-all [ %gc ] unless ;
: do-template ( pair -- )
#! Use with return value from find-template
first2
clone [ template-inputs call template-outputs ] bind
compute-free-vregs ; inline
: with-template ( quot hash -- )
clone [
ensure-template-vregs
template-inputs call template-outputs
] bind
compute-free-vregs ; inline
: fresh-object ( obj -- ) fresh-objects get push ;
: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
: init-templates ( -- )
#! Initialize register allocator.
V{ } clone fresh-objects set
<phantom-datastack> phantom-d set
<phantom-retainstack> phantom-r set
compute-free-vregs ;
: copy-templates ( -- )
#! Copies register allocator state, used when compiling
#! branches.
fresh-objects [ clone ] change
phantom-d [ clone ] change
phantom-r [ clone ] change
compute-free-vregs ;
: find-template ( templates -- pair/f )
#! Pair has shape { quot hash }
#! Depends on node@
compute-free-vregs
dup (find-template) [ ] [
finalize-contents (find-template)
] ?if ;
: operand-class ( operand -- class )
#! Depends on node@
+input+ get [ second = ] curry* find drop
node@ tuck node-in-d nth node-class ;
: operand-tag ( operand -- tag/f )
#! Depends on node@
operand-class class-tag ;
UNION: immediate fixnum POSTPONE: f ;
: operand-immediate? ( operand -- ? )
operand-class immediate class< ;
: phantom-push ( obj -- )
1 phantom-d get adjust-phantom
phantom-d get push ;
: phantom-shuffle ( shuffle -- )
[ effect-in length phantom-d get phantom-input ] keep
shuffle* phantom-d get phantom-append ;
: phantom->r ( n -- )
phantom-d get phantom-input
phantom-r get phantom-append ;
: phantom-r> ( n -- )
phantom-r get phantom-input
phantom-d get phantom-append ;

4
core/generic/generic-tests.factor
View File

@ -123,9 +123,9 @@ TUPLE: delegating ;
[ "SYMBOL: not-a-class C: not-a-class ;" parse ] unit-test-fails
! Test math-combination
[ [ >r >float r> ] ] [ \ real \ float math-upgrade ] unit-test
[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test
[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test
[ [ >r >bignum r> ] ] [ \ fixnum \ bignum math-upgrade ] unit-test
[ [ [ >bignum ] dip ] ] [ \ fixnum \ bignum math-upgrade ] unit-test
[ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test
[ number ] [ \ number \ float math-class-max ] unit-test
[ float ] [ \ real \ float math-class-max ] unit-test

10
core/generic/math/math.factor
View File

@ -25,16 +25,12 @@ PREDICATE: class math-class ( object -- ? )
[ [ math-precedence ] compare 0 > ] most ;
: (math-upgrade) ( max class -- quot )
dupd = [
drop [ ]
] [
"coercer" word-prop [ ] or
] if ;
dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
: math-upgrade ( class1 class2 -- quot )
[ math-class-max ] 2keep
>r over r> (math-upgrade)
>r (math-upgrade) dup empty? [ 1 make-dip ] unless
>r over r> (math-upgrade) >r (math-upgrade)
dup empty? [ [ dip ] curry [ ] like ] unless
r> append ;
TUPLE: no-math-method left right generic ;

2
core/hashtables/hashtables-docs.factor
View File

@ -70,7 +70,7 @@ HELP: nth-pair
{ nth-pair set-nth-pair } related-words
HELP: set-nth-pair
{ $values { "value" "the second element of the pair" } { "key" "the first element of the pair" } { "n" "an index in the sequence" } { "seq" "a sequence" } }
{ $values { "value" "the second element of the pair" } { "key" "the first element of the pair" } { "seq" "a sequence" } { "n" "an index in the sequence" } }
{ $description "Stores a pair of values into the elements with index " { $snippet "n" } " and " { $snippet "n+1" } ", respectively." }
{ $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because it does not perform bounds checks." }
{ $side-effects "seq" } ;

7
core/hashtables/hashtables.factor
View File

@ -59,8 +59,7 @@ IN: hashtables
swap 2 fixnum+fast 2dup slot -rot 1 fixnum+fast slot ;
inline
: set-nth-pair ( value key n seq -- )
swap
: set-nth-pair ( value key seq n -- )
2 fixnum+fast [ set-slot ] 2keep
1 fixnum+fast set-slot ; inline
@ -73,7 +72,7 @@ IN: hashtables
: (set-hash) ( value key hash -- )
2dup new-key@
[ rot hash-count+ ] [ rot drop ] if
swap set-nth-pair ; inline
set-nth-pair ; inline
: find-pair-next >r 2 fixnum+fast r> ; inline
@ -133,7 +132,7 @@ M: hashtable clear-assoc ( hash -- )
M: hashtable delete-at ( key hash -- )
tuck key@ [
>r >r ((tombstone)) dup r> r> swap set-nth-pair
>r >r ((tombstone)) dup r> r> set-nth-pair
hash-deleted+
] [
3drop

191
core/inference/backend/backend.factor
View File

@ -20,9 +20,6 @@ debugger assocs combinators ;
: recursive-quotation? ( quot -- ? )
local-recursive-state [ first eq? ] curry* contains? ;
: add-recursive-state ( word label -- )
2array recursive-state [ swap add* ] change ;
TUPLE: inference-error rstate major? ;
: (inference-error) ( ... class important? -- * )
@ -65,12 +62,11 @@ SYMBOL: terminated?
SYMBOL: recorded
: init-inference ( recursive-state -- )
: init-inference ( -- )
terminated? off
V{ } clone meta-d set
V{ } clone meta-r set
0 d-in set
recursive-state set
dataflow-graph off
current-node off ;
@ -86,25 +82,31 @@ M: wrapper apply-object wrapped apply-literal ;
: terminate ( -- )
terminated? on #terminate node, ;
: infer-quot ( quot -- )
[ apply-object terminated? get not ] all? drop ;
: infer-quot ( quot rstate -- )
recursive-state get >r
recursive-state set
[ apply-object terminated? get not ] all? drop
r> recursive-state set ;
TUPLE: recursive-quotation-error quot ;
: infer-quot-recursive ( quot word label -- )
recursive-state get -rot 2array add* infer-quot ;
: time-bomb ( error -- )
[ throw ] curry recursive-state get infer-quot ;
: bad-call ( -- )
[ "call must be given a callable" throw ] infer-quot ;
"call must be given a callable" time-bomb ;
TUPLE: recursive-quotation-error quot ;
: infer-quot-value ( value -- )
dup recursive-quotation? [
value-literal recursive-quotation-error inference-error
] [
dup value-literal callable? [
recursive-state get >r
[
[ value-recursion ] keep f 2array add*
recursive-state set
] keep value-literal infer-quot
r> recursive-state set
dup value-literal
over value-recursion
rot f 2array add* infer-quot
] [
drop bad-call
] if
@ -141,17 +143,6 @@ TUPLE: too-many-r> ;
: undo-infer ( -- )
recorded get [ f "inferred-effect" set-word-prop ] each ;
: with-infer ( quot -- )
[
[
{ } recursive-state set
V{ } clone recorded set
f init-inference
call
check->r
] [ ] [ undo-infer ] cleanup
] with-scope ;
: (consume-values) ( n -- )
meta-d get [ length swap - ] keep set-length ;
@ -216,6 +207,11 @@ M: object constructor drop f ;
: reify-all ( -- )
meta-d get length reify-curries ;
: end-infer ( -- )
check->r
reify-all
f #return node, ;
: unify-lengths ( seq -- newseq )
dup empty? [
dup [ length ] map supremum
@ -349,65 +345,6 @@ TUPLE: no-effect word ;
: no-effect ( word -- * ) \ no-effect inference-warning ;
: nest-node ( -- ) #entry node, ;
: unnest-node ( new-node -- new-node )
dup node-param #return node,
dataflow-graph get 1array over set-node-children ;
: inline-block ( word -- node-block data )
[
copy-inference nest-node
gensym 2dup add-recursive-state
over >r #label r> word-def infer-quot
unnest-node
] H{ } make-assoc ;
: apply-infer ( hash -- )
{ meta-d meta-r d-in terminated? }
[ swap [ at ] curry map ] keep
[ set ] 2each ;
GENERIC: collect-recursion* ( label node -- )
M: node collect-recursion* 2drop ;
M: #call-label collect-recursion*
tuck node-param eq? [ , ] [ drop ] if ;
: collect-recursion ( #label -- seq )
dup node-param
[ [ swap collect-recursion* ] curry each-node ] { } make ;
: join-values ( node -- )
collect-recursion [ node-in-d ] map meta-d get add
unify-lengths unify-stacks
meta-d [ length tail* ] change ;
: splice-node ( node -- )
dup node-successor [
dup node, penultimate-node f over set-node-successor
dup current-node set
] when drop ;
: inline-closure ( word -- )
dup inline-block over recursive-label? [
flatten-meta-d >r
drop join-values inline-block apply-infer
r> over set-node-in-d
dup node,
collect-recursion [
[ flatten-curries ] modify-values
] each
] [
apply-infer node-child node-successor splice-node drop
] if ;
: infer-compound ( word -- hash )
[
recursive-state get init-inference inline-block nip
] with-scope ;
GENERIC: infer-word ( word -- effect )
M: word infer-word no-effect ;
@ -421,15 +358,23 @@ TUPLE: effect-error word effect ;
dup pick "declared-effect" word-prop effect<=
[ 2drop ] [ effect-error ] if ;
: finish-word ( word -- effect )
: finish-word ( word -- )
current-effect
2dup check-effect
over recorded get push
tuck "inferred-effect" set-word-prop ;
"inferred-effect" set-word-prop ;
: infer-compound ( word -- effect )
[
init-inference
dup word-def over dup infer-quot-recursive
finish-word
current-effect
] with-scope ;
M: compound infer-word
[ dup infer-compound [ finish-word ] bind ]
[ ] [ t "no-effect" set-word-prop ] cleanup ;
[ infer-compound ] [ ] [ t "no-effect" set-word-prop ]
cleanup ;
: custom-infer ( word -- )
#! Customized inference behavior
@ -459,6 +404,60 @@ TUPLE: recursive-declare-error word ;
\ recursive-declare-error inference-error
] if* ;
: nest-node ( -- ) #entry node, ;
: unnest-node ( new-node -- new-node )
dup node-param #return node,
dataflow-graph get 1array over set-node-children ;
: inline-block ( word -- node-block data )
[
copy-inference nest-node
dup word-def swap gensym
[ infer-quot-recursive ] 2keep
#label unnest-node
] H{ } make-assoc ;
GENERIC: collect-recursion* ( label node -- )
M: node collect-recursion* 2drop ;
M: #call-label collect-recursion*
tuck node-param eq? [ , ] [ drop ] if ;
: collect-recursion ( #label -- seq )
dup node-param
[ [ swap collect-recursion* ] curry each-node ] { } make ;
: join-values ( node -- )
collect-recursion [ node-in-d ] map meta-d get add
unify-lengths unify-stacks
meta-d [ length tail* ] change ;
: splice-node ( node -- )
dup node-successor [
dup node, penultimate-node f over set-node-successor
dup current-node set
] when drop ;
: apply-infer ( hash -- )
{ meta-d meta-r d-in terminated? }
[ swap [ at ] curry map ] keep
[ set ] 2each ;
: inline-closure ( word -- )
dup inline-block over recursive-label? [
flatten-meta-d >r
drop join-values inline-block apply-infer
r> over set-node-in-d
dup node,
collect-recursion [
[ flatten-curries ] modify-values
] each
] [
apply-infer node-child node-successor splice-node drop
] if ;
M: compound apply-object
[
dup inline-recursive-label
@ -469,4 +468,16 @@ M: compound apply-object
] if-inline ;
M: undefined apply-object
drop [ "Undefined" throw ] infer-quot ;
drop "Undefined word" time-bomb ;
: with-infer ( quot -- effect dataflow )
[
[
V{ } clone recorded set
init-inference
call
end-infer
current-effect
dataflow-graph get
] [ ] [ undo-infer ] cleanup
] with-scope ;

26
core/inference/inference.factor
View File

@ -2,26 +2,26 @@
! See http://factorcode.org/license.txt for BSD license.
IN: inference
USING: inference.backend inference.dataflow
inference.known-words inference.stack inference.transforms
inference.errors sequences prettyprint io effects kernel
namespaces quotations ;
inference.known-words inference.transforms inference.errors
sequences prettyprint io effects kernel namespaces quotations ;
GENERIC: infer ( quot -- effect )
M: callable infer ( quot -- effect )
[ infer-quot current-effect ] with-infer ;
[ f infer-quot ] with-infer drop ;
: infer. ( quot -- )
infer effect>string print ;
: (dataflow) ( quot -- dataflow )
infer-quot
reify-all
f #return node,
dataflow-graph get ;
GENERIC: dataflow ( quot -- dataflow )
: dataflow ( quot -- dataflow )
[ (dataflow) ] with-infer ;
M: callable dataflow
[ f infer-quot ] with-infer nip ;
: dataflow-with ( quot stack -- dataflow )
[ V{ } like meta-d set (dataflow) ] with-infer ;
GENERIC# dataflow-with 1 ( quot stack -- dataflow )
M: callable dataflow-with
[
V{ } like meta-d set
f infer-quot
] with-infer nip ;

105
core/inference/known-words/known-words.factor
View File

@ -3,14 +3,58 @@
IN: inference.known-words
USING: alien arrays bit-arrays byte-arrays classes
combinators.private continuations.private effects float-arrays
generic hashtables hashtables.private
inference.backend inference.dataflow io io.backend io.files
io.files.private io.streams.c kernel kernel.private math
math.private memory namespaces namespaces.private parser
prettyprint quotations quotations.private sbufs sbufs.private
sequences sequences.private slots.private strings
strings.private system threads.private tuples tuples.private
vectors vectors.private words ;
generic hashtables hashtables.private inference.backend
inference.dataflow io io.backend io.files io.files.private
io.streams.c kernel kernel.private math math.private memory
namespaces namespaces.private parser prettyprint quotations
quotations.private sbufs sbufs.private sequences
sequences.private slots.private strings strings.private system
threads.private tuples tuples.private vectors vectors.private
words assocs ;
! Shuffle words
: infer-shuffle-inputs ( shuffle node -- )
>r effect-in length 0 r> node-inputs ;
: shuffle-stacks ( shuffle -- )
meta-d [ swap shuffle ] change ;
: infer-shuffle-outputs ( shuffle node -- )
>r effect-out length 0 r> node-outputs ;
: infer-shuffle ( shuffle -- )
dup effect-in ensure-values
#shuffle
2dup infer-shuffle-inputs
over shuffle-stacks
2dup infer-shuffle-outputs
node, drop ;
: define-shuffle ( word shuffle -- )
[ infer-shuffle ] curry "infer" set-word-prop ;
{
{ drop T{ effect f 1 { } } }
{ 2drop T{ effect f 2 { } } }
{ 3drop T{ effect f 3 { } } }
{ dup T{ effect f 1 { 0 0 } } }
{ 2dup T{ effect f 2 { 0 1 0 1 } } }
{ 3dup T{ effect f 3 { 0 1 2 0 1 2 } } }
{ rot T{ effect f 3 { 1 2 0 } } }
{ -rot T{ effect f 3 { 2 0 1 } } }
{ dupd T{ effect f 2 { 0 0 1 } } }
{ swapd T{ effect f 3 { 1 0 2 } } }
{ nip T{ effect f 2 { 1 } } }
{ 2nip T{ effect f 3 { 2 } } }
{ tuck T{ effect f 2 { 1 0 1 } } }
{ over T{ effect f 2 { 0 1 0 } } }
{ pick T{ effect f 3 { 0 1 2 0 } } }
{ swap T{ effect f 2 { 1 0 } } }
} [ define-shuffle ] assoc-each
\ >r [ infer->r ] "infer" set-word-prop
\ r> [ infer-r> ] "infer" set-word-prop
\ declare [
1 ensure-values
@ -22,21 +66,6 @@ vectors vectors.private words ;
node,
] "infer" set-word-prop
\ fixnum< { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum< make-foldable
\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum<= make-foldable
\ fixnum> { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum> make-foldable
\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum>= make-foldable
\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop
\ eq? make-foldable
! Primitive combinators
GENERIC: infer-call ( value -- )
@ -68,15 +97,15 @@ M: object infer-call
apply-object
] [
drop
[ "execute must be given a word" throw ]
infer-quot
"execute must be given a word" time-bomb
] if
] "infer" set-word-prop
\ if [
3 ensure-values
2 d-tail [ special? ] contains? [
[ rot [ drop call ] [ nip call ] if ] infer-quot
[ rot [ drop call ] [ nip call ] if ]
recursive-state get infer-quot
] [
[ #values ]
2 #drop node, pop-d pop-d swap 2array
@ -121,6 +150,21 @@ t over set-effect-terminated?
"inferred-effect" set-word-prop
! Stack effects for all primitives
\ fixnum< { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum< make-foldable
\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum<= make-foldable
\ fixnum> { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum> make-foldable
\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
\ fixnum>= make-foldable
\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop
\ eq? make-foldable
\ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
\ string>sbuf { string integer } { sbuf } <effect> "inferred-effect" set-word-prop
@ -524,9 +568,12 @@ t over set-effect-terminated?
\ callstack>array { callstack } { array } <effect> "inferred-effect" set-word-prop
\ callstack>array make-flushable
\ array>callstack { array } { callstack } <effect> "inferred-effect" set-word-prop
\ array>callstack make-flushable
\ (sleep) { integer } { } <effect> "inferred-effect" set-word-prop
\ become { array array } { } <effect> "inferred-effect" set-word-prop
\ innermost-frame-quot { callstack } { quotation } <effect> "inferred-effect" set-word-prop
\ innermost-frame-scan { callstack } { fixnum } <effect> "inferred-effect" set-word-prop
\ set-innermost-frame-quot { quotation callstack } { } <effect> "inferred-effect" set-word-prop

1
core/inference/stack/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

11
core/inference/stack/stack-docs.factor
View File

@ -1,11 +0,0 @@
USING: inference.stack help.syntax help.markup ;
HELP: shuffle
{ $values { "stack" "a sequence" } { "shuffle" shuffle } { "newstack" "a new sequence" } }
{ $description "Applies a stack shuffle pattern to a stack." }
{ $errors "Throws an error if the input stack contains insufficient elements." } ;
HELP: shuffle-stacks
{ $values { "shuffle" "an instance of " { $link shuffle } } }
{ $description "Applies a stack shuffle pattern to the inference stacks." }
{ $errors "Throws an error if the stacks contain insufficient elements." } ;

64
core/inference/stack/stack.factor
View File

@ -1,64 +0,0 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: inference.stack
USING: inference.dataflow inference.backend arrays generic
kernel math namespaces sequences words parser words quotations
assocs effects ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
effect-in length swap cut* ;
: load-shuffle ( stack shuffle -- )
effect-in [ set ] 2each ;
: shuffled-values ( shuffle -- values )
effect-out [ get ] map ;
: shuffle* ( stack shuffle -- newstack )
[ [ load-shuffle ] keep shuffled-values ] with-scope ;
: shuffle ( stack shuffle -- newstack )
[ split-shuffle ] keep shuffle* append ;
: infer-shuffle-inputs ( shuffle node -- )
>r effect-in length 0 r> node-inputs ;
: shuffle-stacks ( shuffle -- )
meta-d [ swap shuffle ] change ;
: infer-shuffle-outputs ( shuffle node -- )
>r effect-out length 0 r> node-outputs ;
: infer-shuffle ( shuffle -- )
dup effect-in ensure-values
#shuffle
2dup infer-shuffle-inputs
over shuffle-stacks
2dup infer-shuffle-outputs
node, drop ;
: define-shuffle ( word shuffle -- )
[ infer-shuffle ] curry "infer" set-word-prop ;
{
{ drop T{ effect f 1 { } } }
{ 2drop T{ effect f 2 { } } }
{ 3drop T{ effect f 3 { } } }
{ dup T{ effect f 1 { 0 0 } } }
{ 2dup T{ effect f 2 { 0 1 0 1 } } }
{ 3dup T{ effect f 3 { 0 1 2 0 1 2 } } }
{ rot T{ effect f 3 { 1 2 0 } } }
{ -rot T{ effect f 3 { 2 0 1 } } }
{ dupd T{ effect f 2 { 0 0 1 } } }
{ swapd T{ effect f 3 { 1 0 2 } } }
{ nip T{ effect f 2 { 1 } } }
{ 2nip T{ effect f 3 { 2 } } }
{ tuck T{ effect f 2 { 1 0 1 } } }
{ over T{ effect f 2 { 0 1 0 } } }
{ pick T{ effect f 3 { 0 1 2 0 } } }
{ swap T{ effect f 2 { 1 0 } } }
} [ define-shuffle ] assoc-each
\ >r [ infer->r ] "infer" set-word-prop
\ r> [ infer-r> ] "infer" set-word-prop

1
core/inference/stack/summary.txt
View File

@ -1 +0,0 @@
Stack shuffles as first-class data types

23
core/inference/transforms/transforms.factor
View File

@ -5,20 +5,24 @@ quotations assocs combinators math.bitfields inference.backend
inference.dataflow tuples.private ;
IN: inference.transforms
: pop-literals ( n -- seq )
[ ensure-values ] keep
[ d-tail ] keep
(consume-values)
[ value-literal ] map ;
: pop-literals ( n -- rstate seq )
dup zero? [ drop recursive-state get f ] [
[ ensure-values ] keep
[ d-tail ] keep
(consume-values)
dup [ value-literal ] map
swap first value-recursion swap
] if ;
: transform-quot ( quot n -- newquot )
[
, \ pop-literals , [ [ ] each ] % % \ infer-quot ,
] [ ] make ;
[ pop-literals [ ] each ] curry
swap
[ swap infer-quot ] 3compose ;
: define-transform ( word quot n -- )
transform-quot "infer" set-word-prop ;
! Combinators
\ cond [
cond>quot
] 1 define-transform
@ -35,6 +39,7 @@ IN: inference.transforms
] if
] 1 define-transform
! Bitfields
GENERIC: (bitfield-quot) ( spec -- quot )
M: integer (bitfield-quot) ( spec -- quot )
@ -58,5 +63,5 @@ M: pair (bitfield-quot) ( spec -- quot )
\ set-slots [ <reversed> [get-slots] ] 1 define-transform
\ construct-boa [
[ dup literalize , tuple-size , \ <tuple-boa> , ] [ ] make
dup tuple-size [ <tuple-boa> ] 2curry
] 1 define-transform

20
core/io/streams/nested/nested-tests.factor
View File

@ -1,23 +1,3 @@
USING: io io.streams.string io.streams.nested kernel math
namespaces io.styles tools.test ;
IN: temporary
[ "=>a<=" ] [
[
[
H{ { highlight t } } [
H{ } [ "a" write ] with-nesting
] with-style
] string-out
] with-scope
] unit-test
[ "a" ] [
[
[
H{ } [
H{ { highlight t } } [ "a" write ] with-nesting
] with-style
] string-out
] with-scope
] unit-test

7
core/io/streams/plain/plain.factor
View File

@ -9,12 +9,11 @@ TUPLE: plain-writer ;
: <plain-writer> ( stream -- new-stream )
plain-writer construct-delegate ;
M: plain-writer stream-nl CHAR: \n swap stream-write1 ;
M: plain-writer stream-nl
CHAR: \n swap stream-write1 ;
M: plain-writer stream-format
highlight rot at
[ >r "=>" swap "<=" 3append r> ] when
stream-write ;
nip stream-write ;
M: plain-writer make-span-stream
<style-stream> <ignore-close-stream> ;

4
core/io/styles/styles-docs.factor
View File

@ -106,10 +106,6 @@ HELP: presented-path
HELP: presented-printer
{ $description "Character and paragraph style. A quotation with stack effect " { $snippet "( obj -- )" } " which is applied to the value at the " { $link presented-path } " if the presentation needs to be re-displayed after the object has been edited." } ;
HELP: highlight
{ $description "Character style. Used to mark up text on streams that otherwise do not support different colors or font styles." }
{ $examples "Instances of " { $link plain-writer } " uppercases highlighted text." } ;
HELP: page-color
{ $description "Paragraph style. Background color of the paragraph block, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." }
{ $examples

3
core/io/styles/styles.factor
View File

@ -19,9 +19,6 @@ SYMBOL: presented
SYMBOL: presented-path
SYMBOL: presented-printer
! Only for plain-stream
SYMBOL: highlight
! Paragraph styles
SYMBOL: page-color
SYMBOL: border-color

3
core/kernel/kernel-tests.factor
View File

@ -74,4 +74,5 @@ IN: temporary
[ 6 2 ] [ 1 2 [ 5 + ] dip ] unit-test
[ ] [ callstack set-callstack ] unit-test
! [ ] [ callstack callstack>array array>callstack set-callstack ] unit-test
[ 3drop datastack ] unit-test-fails

2
core/kernel/kernel.factor
View File

@ -106,6 +106,8 @@ GENERIC: clone ( obj -- cloned )
M: object clone ;
M: callstack clone (clone) ;
! Tuple construction
GENERIC# get-slots 1 ( tuple slots -- ... )

6
core/optimizer/backend/backend.factor
View File

@ -118,6 +118,12 @@ M: #return optimize-node* cleanup-inlining ;
! #values
M: #values optimize-node* cleanup-inlining ;
! #>r
M: #>r optimize-node* [ node-in-d empty? ] prune-if ;
! #r>
M: #r> optimize-node* [ node-in-r empty? ] prune-if ;
! Some utilities for splicing in dataflow IR subtrees
: follow ( key assoc -- value )
2dup at* [ swap follow nip ] [ 2drop ] if ;

22
core/prettyprint/backend/backend.factor
View File

@ -22,11 +22,13 @@ GENERIC: pprint* ( obj -- )
! Atoms
: word-style ( word -- style )
[
dup presented set
dup parsing? over delimiter? rot t eq? or or
[ bold font-style set ] when
] H{ } make-assoc ;
dup "word-style" word-prop >hashtable [
[
dup presented set
dup parsing? over delimiter? rot t eq? or or
[ bold font-style set ] when
] bind
] keep ;
: word-name* ( word -- str )
word-name "( no name )" or ;
@ -129,15 +131,9 @@ M: pathname pprint* dup pathname-string "P\" " pprint-string ;
dup zero? [ 2drop f ] [ >r head r> ] if
] when ;
: pprint-hilite ( n object -- )
pprint* hilite-index get = [ hilite ] when ;
: pprint-elements ( seq -- )
do-length-limit >r dup hilite-quotation get eq? [
[ length ] keep [ pprint-hilite ] 2each
] [
[ pprint* ] each
] if
do-length-limit >r
[ pprint* ] each
r> [ "~" swap number>string " more~" 3append text ] when* ;
GENERIC: pprint-delims ( obj -- start end )

6
core/prettyprint/config/config-docs.factor
View File

@ -27,9 +27,3 @@ HELP: line-limit
HELP: string-limit
{ $var-description "Toggles whether printed strings are truncated to the margin." } ;
HELP: hilite-quotation
{ $var-description "If set, printing this quotation will highlight the element with index " { $link hilite-index } " in an output stream-specific manner." } ;
HELP: hilite-index
{ $var-description "If set, printing the quotation stored in " { $link hilite-quotation } " will highlight the element with this index in an output stream-specific manner." } ;

4
core/prettyprint/config/config.factor
View File

@ -13,10 +13,6 @@ SYMBOL: length-limit
SYMBOL: line-limit
SYMBOL: string-limit
! Special trick to highlight a word in a quotation
SYMBOL: hilite-quotation
SYMBOL: hilite-index
global [
4 tab-size set
64 margin set

2
core/prettyprint/prettyprint-docs.factor
View File

@ -204,7 +204,7 @@ HELP: stack.
HELP: callstack.
{ $values { "callstack" callstack } }
{ $description "Displays a sequence output by " { $link callstack } " in a nice way, by highlighting the current execution point in every call frame." } ;
{ $description "Displays a sequence output by " { $link callstack } " in a nice way, by highlighting the current execution point in every call frame with " { $link -> } "." } ;
HELP: .c
{ $description "Displays the contents of the call stack, with the top of the stack printed first." } ;

30
core/prettyprint/prettyprint-tests.factor
View File

@ -1,7 +1,8 @@
USING: arrays definitions io.streams.string io.streams.duplex
kernel math namespaces parser prettyprint prettyprint.config
prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard ;
effects splitting generic.standard prettyprint.private
continuations ;
IN: temporary
[ "4" ] [ 4 unparse ] unit-test
@ -53,12 +54,6 @@ unit-test
[ "W{ \\ + }" ] [ [ W{ \ + } ] first unparse ] unit-test
[ "[ 1 2 =>dup<= ]" ]
[
[ 1 2 dup ] dup hilite-quotation set 2 hilite-index set
[ pprint ] string-out
] unit-test
[ t ] [
"[ >r \"alloc\" add 0 0 r> ]" dup parse first unparse =
] unit-test
@ -283,3 +278,24 @@ unit-test
] unit-test
[ ] [ \ effect-in synopsis drop ] unit-test
[ [ + ] ] [
[ \ + (step-into) ] (remove-breakpoints)
] unit-test
[ [ (step-into) ] ] [
[ (step-into) ] (remove-breakpoints)
] unit-test
[ [ 3 ] ] [
[ 3 (step-into) ] (remove-breakpoints)
] unit-test
[ [ 2 2 + . ] ] [
[ 2 2 \ + (step-into) . ] (remove-breakpoints)
] unit-test
[ [ 2 2 + . ] ] [
[ 2 break 2 \ + (step-into) . ] (remove-breakpoints)
] unit-test

49
core/prettyprint/prettyprint.factor
View File

@ -6,7 +6,8 @@ math namespaces sequences strings io.styles io.streams.string
vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
definitions effects tuples io.files classes continuations
hashtables classes.mixin classes.union classes.predicate ;
hashtables classes.mixin classes.union classes.predicate
combinators quotations ;
: make-pprint ( obj quot -- block in use )
[
@ -85,20 +86,48 @@ hashtables classes.mixin classes.union classes.predicate ;
: .s ( -- ) datastack stack. ;
: .r ( -- ) retainstack stack. ;
: callframe. ( seq pos -- )
SYMBOL: ->
\ ->
{ { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } }
"word-style" set-word-prop
<PRIVATE
! This code is ugly and could probably be simplified
: remove-step-into
building get dup empty? [
drop \ (step-into) ,
] [
pop dup wrapper? [ wrapped ] when ,
] if ;
: (remove-breakpoints) ( quot -- newquot )
[
[
hilite-index set
dup hilite-quotation set
2 nesting-limit set
.
] with-scope
{
{ break [ ] }
{ (step-into) [ remove-step-into ] }
[ , ]
} case
] each
] [ ] make ;
: remove-breakpoints ( quot pos -- quot' )
over quotation? [
1+ swap cut [ (remove-breakpoints) ] 2apply
[ -> ] swap 3append
] [
.
] if* ;
drop
] if ;
PRIVATE>
: callstack. ( callstack -- )
callstack>array 2 <groups> [ callframe. ] assoc-each ;
callstack>array 2 <groups> [
remove-breakpoints
2 nesting-limit [ . ] with-variable
] assoc-each ;
: .c ( -- ) callstack callstack. ;

1
core/prettyprint/sections/sections-docs.factor
View File

@ -74,7 +74,6 @@ HELP: section
{ $link block }
{ $link inset }
{ $link flow }
{ $link hilite }
{ $link colon }
}
"Instances of this class have the following slots:"

11
core/prettyprint/sections/sections.factor
View File

@ -151,17 +151,6 @@ TUPLE: block sections ;
: last-section ( -- section )
pprinter-block block-sections [ break? not ] find-last nip ;
: hilite-style ( -- hash )
H{
{ background { 0.9 0.9 0.9 1 } }
{ highlight t }
} ;
: hilite ( -- )
last-section
dup section-style hilite-style union
swap set-section-style ;
: start-group ( -- )
t last-section set-section-start-group? ;

6
core/quotations/quotations.factor
View File

@ -26,10 +26,6 @@ M: quotation like drop dup quotation? [ >quotation ] unless ;
INSTANCE: quotation immutable-sequence
: make-dip ( quot n -- newquot )
dup \ >r <repetition> -rot \ r> <repetition> 3append
>quotation ;
: 1quotation ( obj -- quot ) 1array >quotation ;
GENERIC: literalize ( obj -- wrapped )
@ -47,6 +43,6 @@ M: curry nth
>r 1- r> curry-quot nth
] if ;
M: curry like drop [ ] like ;
M: curry like drop dup callable? [ >quotation ] unless ;
INSTANCE: curry immutable-sequence

2
core/sequences/sequences.factor
View File

@ -194,7 +194,7 @@ TUPLE: slice-error reason ;
: check-slice ( from to seq -- from to seq )
pick 0 < [ "start < 0" slice-error ] when
dup length pick < [ "end > sequence" slice-error ] when
pick pick > [ "start > end" slice-error ] when ;
pick pick > [ "start > end" slice-error ] when ; inline
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when

2
core/syntax/syntax-docs.factor
View File

@ -514,7 +514,7 @@ HELP: PREDICATE:
HELP: TUPLE:
{ $syntax "TUPLE: class slots... ;" }
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
{ $description "Defines a new tuple class with membership predicate " { $snippet "name?" } " and constructor " { $snippet "<name>" } "."
{ $description "Defines a new tuple class with membership predicate " { $snippet "name?" } "."
$nl
"Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ;

9
core/syntax/syntax.factor
View File

@ -24,6 +24,14 @@ IN: bootstrap.syntax
{ "]" "}" ";" } [ define-delimiter ] each
"PRIMITIVE:" [
"Primitive definition is not supported" throw
] define-syntax
"CS{" [
"Call stack literals are not supported" throw
] define-syntax
"!" [ lexer get next-line ] define-syntax
"#!" [ POSTPONE: ! ] define-syntax
@ -72,7 +80,6 @@ IN: bootstrap.syntax
"C{" [ \ } [ first2 rect> ] parse-literal ] define-syntax
"T{" [ \ } [ >tuple ] parse-literal ] define-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
"CS{" [ \ } [ >array array>callstack ] parse-literal ] define-syntax
"POSTPONE:" [ scan-word parsed ] define-syntax
"\\" [ scan-word literalize parsed ] define-syntax

3
extra/bake/bake.factor
View File

@ -48,5 +48,4 @@ DEFER: bake
: bake-items ( seq -- ) [ bake-item ] each ;
: bake ( seq -- seq )
[ reset-building save-exemplar bake-items finish-baking ] with-scope ;
[ reset-building save-exemplar bake-items finish-baking ] with-scope ;

3
extra/benchmark/benchmark.factor
View File

@ -6,7 +6,8 @@ IN: benchmark
: run-benchmark ( vocab -- result )
"=== Benchmark " write dup print flush
dup require [ run ] benchmark 2array ;
dup require [ run ] benchmark 2array
dup . ;
: run-benchmarks ( -- assoc )
"benchmark" load-children

4
extra/benchmark/mandel/mandel.factor
View File

@ -19,8 +19,8 @@ math.functions math.parser io.files colors.hsv ;
: <color-map> ( nb-cols -- map )
dup [
360 * swap 1+ / 360 / sat val
hsv>rgb scale-rgb
360 * swap 1+ / sat val
3array hsv>rgb first3 scale-rgb
] curry* map ;
: iter ( c z nb-iter -- x )

174
extra/cfdg/cfdg.factor
View File

@ -2,36 +2,43 @@
USING: kernel alien.c-types combinators namespaces arrays
sequences sequences.lib namespaces.lib splitting
math math.functions math.vectors math.trig
opengl.gl opengl.glu ui ui.gadgets.slate vars mortar slot-accessors
random-weighted cfdg.hsv cfdg.gl ;
opengl.gl opengl.glu opengl ui ui.gadgets.slate
combinators.lib vars
random-weighted colors.hsv cfdg.gl ;
IN: cfdg
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: <hsba>
! hsba { hue saturation brightness alpha }
<hsba>
{ "hue" "saturation" "brightness" "alpha" } accessors
define-independent-class
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: hsv>rgb* ( h s v -- r g b ) 3array hsv>rgb first3 ;
: gl-set-hsba ( color -- ) object-values first4 >r hsv>rgb* r> glColor4d ;
: gl-clear-hsba ( color -- ) object-values first4 >r hsv>rgb* r> glClearColor ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: <hsba> 4array ;
VAR: color
: init-color ( -- ) 0 0 0 1 <hsba> new >color ;
! ( -- val )
: hue ( num -- ) color> tuck $hue + 360 mod >>hue drop ;
: hue>> 0 color> nth ;
: saturation>> 1 color> nth ;
: brightness>> 2 color> nth ;
: alpha>> 3 color> nth ;
: h ( num -- ) hue ;
! ( val -- )
: >>hue 0 color> set-nth ;
: >>saturation 1 color> set-nth ;
: >>brightness 2 color> set-nth ;
: >>alpha 3 color> set-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi add ;
: gl-set-hsba ( hsva -- ) hsva>rgba gl-color ;
: gl-clear-hsba ( hsva -- ) hsva>rgba gl-clear ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! if (adjustment < 0)
! base + base * adjustment
@ -41,17 +48,20 @@ VAR: color
: adjust ( val num -- val ) dup 0 > [ 1 pick - * + ] [ dupd * + ] if ;
: saturation ( num -- ) color> dup $saturation rot adjust >>saturation drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: sat ( num -- ) saturation ;
: hue ( num -- ) hue>> + 360 mod >>hue ;
: brightness ( num -- ) color> dup $brightness rot adjust >>brightness drop ;
: saturation ( num -- ) saturation>> swap adjust >>saturation ;
: brightness ( num -- ) brightness>> swap adjust >>brightness ;
: alpha ( num -- ) alpha>> swap adjust >>alpha ;
: b ( num -- ) brightness ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: alpha ( num -- ) color> dup $alpha rot adjust >>alpha drop ;
: a ( num -- ) alpha ;
: h hue ;
: sat saturation ;
: b brightness ;
: a alpha ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -59,38 +69,19 @@ VAR: color-stack
: init-color-stack ( -- ) V{ } clone >color-stack ;
: clone-color ( hsba -- hsba ) object-values first4 <hsba> new ;
: push-color ( -- )
color> color-stack> push
color> clone-color >color ;
: push-color ( -- ) color> color-stack> push color> clone >color ;
: pop-color ( -- ) color-stack> pop dup >color gl-set-hsba ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : check-size ( modelview-matrix -- num )
! { 0 1 4 5 } swap [ double-nth ] curry map
! [ abs ] map
! [ <=> ] maximum ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : check-size ( modelview-matrix -- num )
! { 0 1 4 5 } swap [ double-nth ] curry map
! [ abs ] map
! biggest ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
: check-size ( modelview-matrix -- num )
{ 0 1 4 5 } double-nth* [ abs ] map biggest ;
: check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map biggest ;
VAR: threshold
: iterate? ( -- ? ) get-modelview-matrix check-size threshold get > ;
: iterate? ( -- ? ) get-modelview-matrix check-size threshold> > ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -101,65 +92,65 @@ VAR: threshold
! column major order
: gl-flip ( angle -- ) deg>rad
{ [ dup 2 * cos ] [ dup 2 * sin ] 0 0
[ dup 2 * sin ] [ 2 * cos neg ] 0 0
0 0 1 0
0 0 0 1 } make* >c-double-array glMultMatrixd ;
: gl-flip ( angle -- ) deg>rad dup dup dup
[ 2 * cos , 2 * sin , 0 , 0 ,
2 * sin , 2 * cos neg , 0 , 0 ,
0 , 0 , 1 , 0 ,
0 , 0 , 0 , 1 , ]
{ } make >c-double-array glMultMatrixd ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: circle ( -- )
color> gl-set-hsba
gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
color> gl-set-hsba
gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
: triangle ( -- )
color> gl-set-hsba
GL_POLYGON glBegin
0 0.577 glVertex2d
0.5 -0.289 glVertex2d
-0.5 -0.289 glVertex2d
glEnd ;
color> gl-set-hsba
GL_POLYGON glBegin
0 0.577 glVertex2d
0.5 -0.289 glVertex2d
-0.5 -0.289 glVertex2d
glEnd ;
: square ( -- )
color> gl-set-hsba
GL_POLYGON glBegin
-0.5 0.5 glVertex2d
0.5 0.5 glVertex2d
0.5 -0.5 glVertex2d
-0.5 -0.5 glVertex2d
glEnd ;
color> gl-set-hsba
GL_POLYGON glBegin
-0.5 0.5 glVertex2d
0.5 0.5 glVertex2d
0.5 -0.5 glVertex2d
-0.5 -0.5 glVertex2d
glEnd ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: size ( scale -- ) dup 1 glScaled ;
: s ( scale -- ) size ;
: size* ( scale-x scale-y -- ) 1 glScaled ;
: s* ( scale-x scale-y -- ) size* ;
: rotate ( angle -- ) 0 0 1 glRotated ;
: r ( angle -- ) rotate ;
: x ( x -- ) 0 0 glTranslated ;
: y ( y -- ) 0 swap 0 glTranslated ;
: flip ( angle -- ) gl-flip ;
: f ( angle -- ) flip ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: s size ;
: s* size* ;
: r rotate ;
: f flip ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: do ( quot -- )
push-modelview-matrix
push-color
call
pop-modelview-matrix
pop-color ;
push-modelview-matrix
push-color
call
pop-modelview-matrix
pop-color ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -171,10 +162,10 @@ pop-color ;
VAR: background
: initial-background ( -- hsba ) 0 0 1 1 <hsba> new ;
: set-initial-background ( -- ) { 0 0 1 1 } clone >color ;
: set-background ( -- )
initial-background >color
set-initial-background
background> call
color> gl-clear-hsba ;
@ -186,23 +177,10 @@ VAR: viewport ! { left width bottom height }
VAR: start-shape
: initial-color ( -- hsba ) 0 0 0 1 <hsba> new ;
: set-initial-color ( -- ) { 0 0 0 1 } clone >color ;
: display ( -- )
! GL_LINE_SMOOTH glEnable
! GL_BLEND glEnable
! GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
! GL_POINT_SMOOTH_HINT GL_NICEST glHint
! GL_FOG glEnable
! GL_FOG_MODE GL_LINEAR glFogi
! GL_FOG_COLOR { 0.5 0.5 0.5 1.0 } >c-double-array glFogfv
! GL_FOG_DENSITY 0.35 glFogf
! GL_FOG_HINT GL_DONT_CARE glHint
! GL_FOG_START 1.0 glFogf
! GL_FOG_END 5.0 glFogf
GL_PROJECTION glMatrixMode
glLoadIdentity
viewport> first dup viewport> second +
@ -218,14 +196,14 @@ VAR: start-shape
init-modelview-matrix-stack
init-color-stack
initial-color >color
set-initial-color
color> gl-set-hsba
start-shape> call ;
: cfdg-window* ( -- )
[ display ] closed-quot <slate>
[ display ] closed-quot <slate>
{ 500 500 } over set-slate-dim
dup "CFDG" open-window ;

7
extra/cfdg/gl/gl.factor
View File

@ -4,14 +4,13 @@ USING: kernel alien.c-types namespaces sequences opengl.gl ;
IN: cfdg.gl
: get-modelview-matrix ( -- alien )
GL_MODELVIEW_MATRIX 16 "GLdouble" <c-array> tuck glGetDoublev ;
GL_MODELVIEW_MATRIX 16 "GLdouble" <c-array> tuck glGetDoublev ;
SYMBOL: modelview-matrix-stack
: init-modelview-matrix-stack ( -- )
V{ } clone modelview-matrix-stack set ;
: init-modelview-matrix-stack ( -- ) V{ } clone modelview-matrix-stack set ;
: push-modelview-matrix ( -- )
get-modelview-matrix modelview-matrix-stack get push ;
get-modelview-matrix modelview-matrix-stack get push ;
: pop-modelview-matrix ( -- ) modelview-matrix-stack get pop glLoadMatrixd ;

39
extra/cfdg/hsv/hsv.factor
View File

@ -1,39 +0,0 @@
USING: kernel combinators arrays sequences math combinators.lib ;
IN: cfdg.hsv
<PRIVATE
: H ( hsv -- H ) first ;
: S ( hsv -- S ) second ;
: V ( hsv -- V ) third ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: Hi ( hsv -- Hi ) H 60 / floor 6 mod ;
: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ;
: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ;
: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ;
: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ;
PRIVATE>
! h [0,360)
! s [0,1]
! v [0,1]
: hsv>rgb ( hsv -- rgb )
dup Hi
{ { 0 [ [ V ] [ t ] [ p ] tri ] }
{ 1 [ [ q ] [ V ] [ p ] tri ] }
{ 2 [ [ p ] [ V ] [ t ] tri ] }
{ 3 [ [ p ] [ q ] [ V ] tri ] }
{ 4 [ [ t ] [ p ] [ V ] tri ] }
{ 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;

20
extra/cfdg/models/chiaroscuro/chiaroscuro.factor
View File

@ -8,17 +8,21 @@ IN: cfdg.models.chiaroscuro
DEFER: white
: black ( -- ) iterate? [
{ { 60 [ [ 0.6 s circle ] do
[ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] }
{ 1 [ white black ] } }
random-weighted* call
{ { 60 [ [ 0.6 s circle ] do
[ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] }
{ 1 [ white black ] } }
call-random-weighted
] when ;
: white ( -- ) iterate? [
{ { 60 [ [ 0.6 s circle ] do
[ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do ] }
{ 1 [ black white ] } }
random-weighted* call
{ { 60 [
[ 0.6 s circle ] do
[ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do
] }
{ 1 [
black white
] } }
call-random-weighted
] when ;
: chiaroscuro ( -- ) [ 0.5 b black ] do ;

5
extra/cocoa/messages/messages.factor
View File

@ -69,6 +69,11 @@ H{ } clone objc-methods set-global
dup objc-methods get at
[ ] [ "No such method: " swap append throw ] ?if ;
: make-dip ( quot n -- quot' )
dup
\ >r <repetition> >quotation -rot
\ r> <repetition> >quotation 3append ;
: make-prepare-send ( selector method super? -- quot )
[
[ \ <super> , ] when

52
extra/colors/hsv/hsv.factor
View File

@ -1,29 +1,41 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! Copyright (C) 2007 Eduardo Cavazos
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math ;
USING: kernel combinators arrays sequences math combinators.lib ;
IN: colors.hsv
<PRIVATE
: f_ >r swap rot >r 2dup r> 6 * r> - ;
: p ( v s x -- v p x ) >r dupd neg 1 + * r> ;
: q ( v s f -- q ) * neg 1 + * ;
: t_ ( v s f -- t_ ) neg 1 + * neg 1 + * ;
: H ( hsv -- H ) first ;
: S ( hsv -- S ) second ;
: V ( hsv -- V ) third ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: Hi ( hsv -- Hi ) H 60 / floor 6 mod ;
: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ;
: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ;
: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ;
: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ;
PRIVATE>
: mod-cond ( p vector -- )
#! Call p mod q'th entry of the vector of quotations, where
#! q is the length of the vector. The value q remains on the
#! stack.
[ dupd length mod ] keep nth call ;
! h [0,360)
! s [0,1]
! v [0,1]
: hsv>rgb ( h s v -- r g b )
pick 6 * >fixnum {
[ f_ t_ p swap ] ! v p t
[ f_ q p -rot ] ! q v p
[ f_ t_ p swapd ] ! p v t
[ f_ q p rot ] ! p q v
[ f_ t_ p swap rot ] ! t p v
[ f_ q p ] ! v p q
} mod-cond ;
: hsv>rgb ( hsv -- rgb )
dup Hi
{ { 0 [ [ V ] [ t ] [ p ] tri ] }
{ 1 [ [ q ] [ V ] [ p ] tri ] }
{ 2 [ [ p ] [ V ] [ t ] tri ] }
{ 3 [ [ p ] [ q ] [ V ] tri ] }
{ 4 [ [ t ] [ p ] [ V ] tri ] }
{ 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;

15
extra/combinators/lib/lib-tests.factor
View File

@ -1,5 +1,5 @@
USING: combinators.lib kernel math math.ranges random sequences
tools.test ;
tools.test inference continuations arrays vectors ;
IN: temporary
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
@ -10,25 +10,26 @@ IN: temporary
[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
: infers? [ infer drop ] curry catch not ;
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
{ 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
{ 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test
{ t } [ [ [ 99 ] 1 2 3 4 5 5 nslip ] compile-quot compiled? ] unit-test
{ t } [ [ [ 99 ] 1 2 3 4 5 5 nslip ] infers? ] unit-test
{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
{ t } [ [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] compile-quot compiled? ] unit-test
{ t } [ [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] infers? ] unit-test
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
{ t } [ [ 1 2 { 3 4 } [ + + ] 2 map-withn ] compile-quot compiled? ] unit-test
{ t } [ [ 1 2 { 3 4 } [ + + ] 2 map-withn ] infers? ] unit-test
{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
{ t } [ [ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] compile-quot compiled? ] unit-test
{ t } [ [ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] infers? ] unit-test
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test
[ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test
[ t ] [ [ [ sq ] 3apply ] compile-quot compiled? ] unit-test
[ t ] [ [ [ sq ] 3apply ] infers? ] unit-test
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
[ t ] [ [ [ dup 2^ 2array ] 5 napply ] compile-quot compiled? ] unit-test
[ t ] [ [ [ dup 2^ 2array ] 5 napply ] infers? ] unit-test
! &&

3
extra/io/windows/nt/backend/backend.factor
View File

@ -1,7 +1,8 @@
USING: alien alien.c-types arrays assocs combinators continuations
destructors io io.backend io.nonblocking io.windows libc
kernel math namespaces sequences threads tuples.lib windows
windows.errors windows.kernel32 prettyprint ;
windows.errors windows.kernel32 prettyprint strings splitting
io.files windows.winsock ;
IN: io.windows.nt.backend
: unicode-prefix ( -- seq )

24
extra/jamshred/game/game.factor Normal file
View File

@ -0,0 +1,24 @@
USING: kernel opengl arrays sequences jamshred jamshred.tunnel
jamshred.player math.vectors ;
IN: jamshred.game
TUPLE: jamshred tunnel players running ;
: <jamshred> ( -- jamshred )
<random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f
jamshred construct-boa ;
: jamshred-player ( jamshred -- player )
! TODO: support more than one player
jamshred-players first ;
: jamshred-update ( jamshred -- )
dup jamshred-running [
jamshred-player update-player
] [ drop ] if ;
: toggle-running ( jamshred -- )
dup jamshred-running not swap set-jamshred-running ;
: mouse-moved ( x-radians y-radians jamshred -- )
jamshred-player -rot turn-player ;

70
extra/jamshred/gl/gl.factor Normal file
View File

@ -0,0 +1,70 @@
USING: alien.c-types colors jamshred.game jamshred.oint
jamshred.player jamshred.tunnel kernel math math.vectors opengl
opengl.gl opengl.glu sequences ;
IN: jamshred.gl
: min-vertices 6 ; inline
: max-vertices 32 ; inline
: n-vertices ( -- n ) 32 ; inline
! render enough of the tunnel that it looks continuous
: n-segments-ahead ( -- n ) 60 ; inline
: n-segments-behind ( -- n ) 40 ; inline
: draw-segment-vertex ( segment theta -- )
over segment-color gl-color segment-vertex-and-normal
first3 glNormal3d first3 glVertex3d ;
: draw-vertex-pair ( theta next-segment segment -- )
rot tuck draw-segment-vertex draw-segment-vertex ;
: draw-segment ( next-segment segment -- )
GL_QUAD_STRIP [
[ draw-vertex-pair ] 2curry
n-vertices equally-spaced-radians F{ 0.0 } append swap each
] do-state ;
: draw-segments ( segments -- )
1 over length pick subseq swap [ draw-segment ] 2each ;
: segments-to-render ( player -- segments )
dup player-nearest-segment segment-number dup n-segments-behind -
swap n-segments-ahead + rot player-tunnel sub-tunnel ;
: draw-tunnel ( player -- )
segments-to-render draw-segments ;
! : draw-tunnel ( player tunnel -- )
! tuck swap player-nearest-segment segment-number dup n-segments-behind -
! swap n-segments-ahead + rot sub-tunnel draw-segments ;
: init-graphics ( width height -- )
GL_DEPTH_TEST glEnable
GL_SCISSOR_TEST glDisable
1.0 glClearDepth
0.0 0.0 0.0 0.0 glClearColor
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
GL_PROJECTION glMatrixMode glLoadIdentity
dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if
GL_MODELVIEW glMatrixMode glLoadIdentity
GL_LEQUAL glDepthFunc
GL_LIGHTING glEnable
GL_LIGHT0 glEnable
GL_FOG glEnable
GL_FOG_DENSITY 0.09 glFogf
GL_COLOR_MATERIAL glEnable
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial
GL_LIGHT0 GL_POSITION F{ 0.0 0.0 -3.0 1.0 } >c-float-array glLightfv
GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv
GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv
GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ;
: player-view ( player -- )
[ oint-location first3 ] keep
[ dup oint-location swap oint-forward v+ first3 ] keep
oint-up first3 gluLookAt ;
: draw-jamshred ( jamshred width height -- )
init-graphics jamshred-player dup player-view draw-tunnel ;

64
extra/jamshred/jamshred.factor Normal file
View File

@ -0,0 +1,64 @@
USING: arrays jamshred.game jamshred.gl kernel math math.constants
namespaces sequences timers ui ui.gadgets ui.gestures ui.render
math.vectors ;
IN: jamshred
TUPLE: jamshred-gadget jamshred last-hand-loc ;
: <jamshred-gadget> ( jamshred -- gadget )
jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ;
: default-width ( -- x ) 1024 ;
: default-height ( -- y ) 768 ;
M: jamshred-gadget pref-dim*
drop default-width default-height 2array ;
M: jamshred-gadget draw-gadget* ( gadget -- )
dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ;
M: jamshred-gadget tick ( gadget -- )
dup jamshred-gadget-jamshred jamshred-update relayout-1 ;
M: jamshred-gadget graft* ( gadget -- )
10 1 add-timer ;
M: jamshred-gadget ungraft* ( gadget -- ) remove-timer ;
: jamshred-restart ( jamshred-gadget -- )
<jamshred> swap set-jamshred-gadget-jamshred ;
: pix>radians ( n m -- theta )
2 / / pi 2 * * ;
: x>radians ( x gadget -- theta )
#! translate motion of x pixels to an angle
rect-dim first pix>radians neg ;
: y>radians ( y gadget -- theta )
#! translate motion of y pixels to an angle
rect-dim second pix>radians ;
: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
over jamshred-gadget-jamshred >r
[ first swap x>radians ] 2keep second swap y>radians
r> mouse-moved ;
: handle-mouse-motion ( jamshred-gadget -- )
hand-loc get [
over jamshred-gadget-last-hand-loc [
v- (handle-mouse-motion)
] [ 2drop ] if*
] 2keep swap set-jamshred-gadget-last-hand-loc ;
USE: vocabs.loader
jamshred-gadget H{
{ T{ key-down f f "r" } [ jamshred-restart refresh-all ] }
{ T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] }
{ T{ motion } [ handle-mouse-motion ] }
} set-gestures
: jamshred-window ( -- )
[ <jamshred> <jamshred-gadget> "Jamshred" open-window ] with-ui ;
MAIN: jamshred-window

74
extra/jamshred/oint/oint.factor Normal file
View File

@ -0,0 +1,74 @@
USING: arrays float-arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
IN: jamshred.oint
! An oint is a point with three linearly independent unit vectors
! given relative to that point. In jamshred a player's location and
! direction are given by the player's oint. Similarly, a tunnel
! segment's location and orientation are given by an oint.
TUPLE: oint location forward up left ;
: <oint> ( location forward up left -- oint )
oint construct-boa ;
! : x-rotation ( theta -- matrix )
! #! construct this matrix:
! #! { { 1 0 0 }
! #! { 0 cos(theta) sin(theta) }
! #! { 0 -sin(theta) cos(theta) } }
! dup sin neg swap cos 2dup 0 -rot 3float-array >r
! swap neg 0 -rot 3float-array >r
! { 1 0 0 } r> r> 3float-array ;
!
! : y-rotation ( theta -- matrix )
! #! costruct this matrix:
! #! { { cos(theta) 0 -sin(theta) }
! #! { 0 1 0 }
! #! { sin(theta) 0 cos(theta) } }
! dup sin swap cos 2dup
! 0 swap 3float-array >r
! { 0 1 0 } >r
! 0 rot neg 3float-array r> r> 3float-array ;
: apply-to-oint ( oint quot -- )
#! apply quot to each of forward, up, and left, storing the results
over oint-forward over call pick set-oint-forward
over oint-up over call pick set-oint-up
over oint-left swap call swap set-oint-left ;
: rotation-quaternion ( theta axis -- quaternion )
swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
: rotate-oint ( oint theta axis -- )
rotation-quaternion dup qrecip
[ rot v>q swap q* q* q>v ] curry curry apply-to-oint ;
: left-pivot ( oint theta -- )
over oint-left rotate-oint ;
: up-pivot ( oint theta -- )
over oint-up rotate-oint ;
: random-float+- ( n -- m )
#! find a random float between -n/2 and n/2
dup 10000 * >fixnum random 10000 / swap 2 / - ;
: random-turn ( oint theta -- )
2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
: go-forward ( distance oint -- )
tuck oint-forward n*v over oint-location v+ swap set-oint-location ;
: distance-vector ( oint oint -- vector )
oint-location swap oint-location v- ;
: distance ( oint oint -- distance )
distance-vector norm ;
: scalar-projection ( v1 v2 -- n )
#! the scalar projection of v1 onto v2
tuck v. swap norm / ;
: perpendicular-distance ( oint oint -- distance )
tuck distance-vector swap 2dup oint-left scalar-projection abs
-rot oint-up scalar-projection abs + ;

36
extra/jamshred/player/player.factor Normal file
View File

@ -0,0 +1,36 @@
USING: colors jamshred.game jamshred.oint jamshred.tunnel kernel
math math.constants sequences ;
IN: jamshred.player
TUPLE: player name tunnel nearest-segment ;
: <player> ( name -- player )
f f player construct-boa
F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <oint> over set-delegate ;
: turn-player ( player x-radians y-radians -- )
>r over r> left-pivot up-pivot ;
: to-tunnel-start ( player -- )
dup player-tunnel first dup oint-location pick set-oint-location
swap set-player-nearest-segment ;
: play-in-tunnel ( player segments -- )
over set-player-tunnel to-tunnel-start ;
: update-nearest-segment ( player -- )
dup player-tunnel over dup player-nearest-segment nearest-segment
swap set-player-nearest-segment ;
: max-speed ( -- speed )
0.3 ;
: player-speed ( player -- speed )
dup player-nearest-segment fraction-from-wall sq max-speed * ;
: move-player ( player -- )
dup player-speed over go-forward update-nearest-segment ;
: update-player ( player -- )
dup move-player player-nearest-segment
white swap set-segment-color ;

15
extra/jamshred/tunnel/tunnel-tests.factor Normal file
View File

@ -0,0 +1,15 @@
USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ;
IN: temporary
[ 0 ] [ T{ segment T{ oint f { 0 0 0 } } 0 }
T{ segment T{ oint f { 1 1 1 } } 1 }
T{ oint f { 0 0 0.25 } }
nearer-segment segment-number ] unit-test
[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test
[ { 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test

111
extra/jamshred/tunnel/tunnel.factor Normal file
View File

@ -0,0 +1,111 @@
USING: arrays float-arrays kernel jamshred.oint math math.functions
math.ranges math.vectors math.constants random sequences vectors ;
IN: jamshred.tunnel
: n-segments ( -- n ) 5000 ; inline
TUPLE: segment number color radius ;
: <segment> ( number color radius location forward up left -- segment )
<oint> >r segment construct-boa r> over set-delegate ;
: segment-vertex ( theta segment -- vertex )
tuck 2dup oint-up swap sin v*n
>r oint-left swap cos v*n r> v+
swap oint-location v+ ;
: segment-vertex-normal ( vertex segment -- normal )
oint-location swap v- normalize ;
: segment-vertex-and-normal ( segment theta -- vertex normal )
swap [ segment-vertex ] keep dupd segment-vertex-normal ;
: equally-spaced-radians ( n -- seq )
#! return a sequence of n numbers between 0 and 2pi
dup [ / pi 2 * * ] curry map ;
: segment-number++ ( segment -- )
dup segment-number 1+ swap set-segment-number ;
: random-color ( -- color )
{ 100 100 100 } [ random 100 / >float ] map { 1.0 } append ;
: tunnel-segment-distance ( -- n ) 0.4 ;
: random-rotation-angle ( -- theta ) pi 20 / ;
: random-segment ( previous-segment -- segment )
clone dup random-rotation-angle random-turn
tunnel-segment-distance over go-forward
random-color over set-segment-color dup segment-number++ ;
: (random-segments) ( segments n -- segments )
dup 0 > [
>r dup peek random-segment over push r> 1- (random-segments)
] [
drop
] if ;
: default-segment-radius ( -- r ) 1 ;
: initial-segment ( -- segment )
0 random-color default-segment-radius
F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <segment> ;
: random-segments ( n -- segments )
initial-segment 1vector swap (random-segments) ;
: simple-segment ( n -- segment )
random-color default-segment-radius pick F{ 0 0 -1 } n*v
F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <segment> ;
: simple-segments ( n -- segments )
[ simple-segment ] map ;
: <random-tunnel> ( -- segments )
n-segments random-segments ;
: <straight-tunnel> ( -- segments )
n-segments simple-segments ;
: sub-tunnel ( from to sements -- segments )
#! return segments between from and to, after clamping from and to to
#! valid values
[ sequence-index-range [ clamp-to-range ] curry 2apply ] keep <slice> ;
: nearer-segment ( segment segment oint -- segment )
#! return whichever of the two segments is nearer to the oint
>r 2dup r> tuck distance >r distance r> < -rot ? ;
: (find-nearest-segment) ( nearest next oint -- nearest ? )
#! find the nearest of 'next' and 'nearest' to 'oint', and return
#! t if the nearest hasn't changed
pick >r nearer-segment dup r> = ;
: find-nearest-segment ( oint segments -- segment )
dup first swap 1 tail-slice rot [ (find-nearest-segment) ] curry
find 2drop ;
: nearest-segment-forward ( segments oint start -- segment )
rot dup length swap <slice> find-nearest-segment ;
: nearest-segment-backward ( segments oint start -- segment )
swapd 1+ 0 swap rot <slice> <reversed> find-nearest-segment ;
: nearest-segment ( segments oint start-segment -- segment )
#! find the segment nearest to 'oint', and return it.
#! start looking at segment 'start-segment'
segment-number over >r
[ nearest-segment-forward ] 3keep
nearest-segment-backward r> nearer-segment ;
: distance-from-centre ( oint segment -- distance )
perpendicular-distance ;
: distance-from-wall ( oint segment -- distance )
tuck distance-from-centre swap segment-radius swap - ;
: fraction-from-centre ( oint segment -- fraction )
tuck distance-from-centre swap segment-radius / ;
: fraction-from-wall ( oint segment -- fraction )
fraction-from-centre 1 swap - ;

13
extra/math/ranges/ranges-tests.factor
View File

@ -1,4 +1,4 @@
USING: math.ranges sequences tools.test ;
USING: math.ranges sequences tools.test arrays ;
IN: temporary
[ { } ] [ 1 1 (a,b) >array ] unit-test
@ -21,3 +21,14 @@ IN: temporary
[ { 0 1/3 2/3 1 } ] [ 0 1 1/3 <range> >array ] unit-test
[ { 0 1/3 2/3 1 } ] [ 1 0 -1/3 <range> >array reverse ] unit-test
[ t ] [ 5 [0,b] range-increasing? ] unit-test
[ f ] [ 5 [0,b] range-decreasing? ] unit-test
[ f ] [ -5 [0,b] range-increasing? ] unit-test
[ t ] [ -5 [0,b] range-decreasing? ] unit-test
[ 0 ] [ 5 [0,b] range-min ] unit-test
[ 5 ] [ 5 [0,b] range-max ] unit-test
[ 3 ] [ 3 5 [0,b] clamp-to-range ] unit-test
[ 0 ] [ -1 5 [0,b] clamp-to-range ] unit-test
[ 5 ] [ 6 5 [0,b] clamp-to-range ] unit-test
[ { 0 1 2 3 4 } ] [ 5 sequence-index-range >array ] unit-test

23
extra/math/ranges/ranges.factor
View File

@ -38,4 +38,25 @@ INSTANCE: range immutable-sequence
: [1,b] 1 swap [a,b] ;
: [0,b) 0 swap (a,b] ;
: [0,b) 0 swap [a,b) ;
: range-increasing? ( range -- ? )
range-step 0 > ;
: range-decreasing? ( range -- ? )
range-step 0 < ;
: first-or-peek ( seq head? -- elt )
[ first ] [ peek ] if ;
: range-min ( range -- min )
dup range-increasing? first-or-peek ;
: range-max ( range -- max )
dup range-decreasing? first-or-peek ;
: clamp-to-range ( n range -- n )
tuck range-min max swap range-max min ;
: sequence-index-range ( seq -- range )
length [0,b) ;

1
extra/math/statistics/authors.txt
View File

@ -1 +1,2 @@
Doug Coleman
Michael Judge

58
extra/math/statistics/statistics-docs.factor Normal file
View File

@ -0,0 +1,58 @@
USING: math.statistics help.markup help.syntax debugger ;
HELP: geometric-mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." }
{ $examples { $example "USE: math.statistics" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } }
{ $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ;
HELP: harmonic-mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." }
{ $examples { $example "USE: math.statistics" "{ 1 2 3 } harmonic-mean ." "6/11" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." }
{ $examples { $example "USE: math.statistics" "{ 1 2 3 } mean ." "2" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: median
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." }
{ $examples
{ $example "USE: math.statistics" "{ 1 2 3 } median ." "2" }
{ $example "USE: math.statistics" "{ 1 2 3 4 } median ." "5/2" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: range
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." }
{ $examples
{ $example "USE: math.statistics" "{ 1 2 3 } range ." "2" }
{ $example "USE: math.statistics" "{ 1 2 3 4 } range ." "3" } } ;
HELP: std
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the standard deviation of " { $snippet "seq" } " by squaring the variance of the sequence. It measures how widely spread the values in a sequence are about the mean." }
{ $examples
{ $example "USE: math.statistics" "{ 1 2 3 } std ." "1.0" }
{ $example "USE: math.statistics" "{ 1 2 3 4 } std ." "1.290994448735806" } } ;
HELP: ste
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." }
{ $examples
{ $example "USE: math.statistics" "{ -2 2 } ste ." "2.0" }
{ $example "USE: math.statistics" "{ -2 2 2 } ste ." "1.333333333333333" } } ;
HELP: var
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." }
{ $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." }
{ $examples
{ $example "USE: math.statistics" "{ 1 } var ." "0" }
{ $example "USE: math.statistics" "{ 1 2 3 } var ." "1" }
{ $example "USE: math.statistics" "{ 1 2 3 4 } var ." "5/3" } } ;

2
extra/math/statistics/statistics-tests.factor
View File

@ -15,9 +15,11 @@ IN: temporary
[ 1 ] [ { 1 2 3 } var ] unit-test
[ 1 ] [ { 1 2 3 } std ] unit-test
[ t ] [ { 1 2 3 4 } ste 0.6454972243679028 - .0001 < ] unit-test
[ t ] [ { 23.2 33.4 22.5 66.3 44.5 } std 18.1906 - .0001 < ] unit-test
[ 0 ] [ { 1 } var ] unit-test
[ 0 ] [ { 1 } std ] unit-test
[ 0 ] [ { 1 } ste ] unit-test

4
extra/math/statistics/statistics.factor
View File

@ -40,6 +40,10 @@ IN: math.statistics
#! standard deviation, sqrt of variance
var sqrt ;
: ste ( seq -- x )
#! standard error, standard deviation / sqrt ( length of sequence )
dup std swap length sqrt / ;
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
! finds sigma((xi-mean(x))(yi-mean(y))
0 [ [ >r pick r> swap - ] 2apply * + ] 2reduce 2nip ;

4
extra/ogg/player/player.factor
View File

@ -158,7 +158,7 @@ HINTS: yuv>rgb byte-array byte-array ;
: append-new-audio-buffer ( player -- player )
dup player-buffers 1 gen-buffers append over set-player-buffers
[ dup >r player-buffers second r> al-channel-format ] keep
[ [ player-buffers second ] keep al-channel-format ] keep
[ player-audio-buffer dup length ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep
[ player-source 1 ] keep
@ -182,7 +182,7 @@ HINTS: yuv>rgb byte-array byte-array ;
} cond ;
: start-audio ( player -- player bool )
[ dup >r player-buffers first r> al-channel-format ] keep
[ [ player-buffers first ] keep al-channel-format ] keep
[ player-audio-buffer dup length ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep
[ player-source 1 ] keep

12
extra/random-weighted/random-weighted.factor
View File

@ -1,10 +1,10 @@
USING: kernel quotations sequences math math.vectors random ;
USING: kernel namespaces arrays quotations sequences assocs combinators
mirrors math math.vectors random combinators.lib macros bake ;
IN: random-weighted
: probabilities ( weights -- probabilities )
dup sum [ / ] curry map ;
: probabilities ( weights -- probabilities ) dup sum [ / ] curry map ;
: layers ( probabilities -- layers )
dup length 1+ [ head ] curry* map 1 tail [ sum ] map ;
@ -13,4 +13,8 @@ dup length 1+ [ head ] curry* map 1 tail [ sum ] map ;
probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ;
: random-weighted* ( seq -- elt )
dup [ second ] map swap [ first ] map random-weighted swap nth ;
dup [ second ] map swap [ first ] map random-weighted swap nth ;
MACRO: call-random-weighted ( exp -- )
[ keys ] [ values <enum> >alist ] bi swap
[ , random-weighted , case ] bake ;

2
extra/tools/annotations/annotations.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words parser io inspector quotations sequences
prettyprint tools.interpreter ;
prettyprint continuations ;
IN: tools.annotations
: annotate ( word quot -- )

31
extra/tools/interpreter/debug/debug.factor Normal file
View File

@ -0,0 +1,31 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.interpreter kernel arrays continuations threads
sequences namespaces ;
IN: tools.interpreter.debug
: run-interpreter ( interpreter -- )
dup interpreter-continuation [
dup step-into run-interpreter
] [
drop
] if ;
: quot>cont ( quot -- cont )
[
swap [
continue-with
] curry callcc0 call stop
] curry callcc1 ;
: init-interpreter ( quot interpreter -- )
>r
[ datastack "datastack" set ] compose quot>cont
f swap 2array
r> restore ;
: test-interpreter ( quot -- )
<interpreter>
[ init-interpreter ] keep
run-interpreter
"datastack" get ;

187
extra/tools/interpreter/interpreter-docs.factor
View File

@ -2,180 +2,30 @@ USING: help.markup help.syntax kernel generic
math hashtables quotations classes continuations ;
IN: tools.interpreter
ARTICLE: "meta-interp-state" "Interpreter state"
"The current interpreter state is stored in a number of variables:"
{ $subsection meta-interp }
{ $subsection callframe }
{ $subsection callframe-scan }
"A set of utility words for inspecting and modifying interpreter state is provided:"
{ $subsection meta-d }
{ $subsection push-d }
{ $subsection pop-d }
{ $subsection peek-d }
{ $subsection meta-r }
{ $subsection push-r }
{ $subsection pop-r }
{ $subsection peek-r }
{ $subsection meta-c }
{ $subsection push-c }
{ $subsection pop-c }
{ $subsection peek-c }
"Calling a quotation in the meta-circular interpreter:"
{ $subsection meta-call } ;
ARTICLE: "meta-interp-step" "Single-stepping words"
"Breakpoints can be inserted in user code:"
{ $subsection break }
"Breakpoints invoke a hook:"
{ $subsection break-hook }
"Single stepping with the meta-circular interpreter:"
{ $subsection step }
{ $subsection step-in }
{ $subsection step-out }
{ $subsection step-all }
{ $subsection abandon } ;
ARTICLE: "meta-interp-travel" "Backwards time travel"
"Backwards time travel is implemented by capturing the continuation after every step. Since this consumes additional memory, it must be explicitly enabled by storing an empty vector into a variable:"
{ $subsection meta-history }
"If this variable holds a vector, the interpreter state is automatically saved after every step. It can be saved at other points manually:"
{ $subsection save-interp }
"You can also restore any prior state:"
{ $subsection restore-interp }
"Or restore the most recently saved state:"
{ $subsection step-back } ;
ARTICLE: "meta-interp-impl" "Interpreter implementation"
"Custom single stepping behavior can be implemented by calling the common factor shared by " { $link step } " and " { $link step-in } ":"
{ $subsection next }
"The meta-circular interpreter executes most words much like the Factor interpreter; primitives are executed atomically and compound words are descended into. These semantics can be customized by setting the " { $snippet "\"meta-word\"" } " word property to a quotation. This quotation is run in the host interpreter and can make use of the words in " { $link "meta-interp-state" } "."
$nl
"Additionally, the " { $snippet "\"no-meta-word\"" } " word property can be set to " { $link t } " to instruct the meta-circular interpreter to always execute the word atomically, even if " { $link step-in } " is called." ;
ARTICLE: "meta-interpreter" "Meta-circular interpreter"
"The meta-circular interpreter is used to implement the walker tool in the UI. If you are simply interested in single stepping through a piece of code, use the " { $link "ui-walker" } "."
$nl
"On the other hand, if you want to implement a similar tool yourself, then you can use the words described in this section."
$nl
"Meta-circular interpreter words are found in the " { $vocab-link "tools.interpreter" } " vocabulary."
{ $subsection "meta-interp-state" }
{ $subsection "meta-interp-step" }
{ $subsection "meta-interp-travel" }
{ $subsection "meta-interp-impl" } ;
$nl
"Breakpoints can be inserted in user code:"
{ $subsection break }
"Breakpoints invoke a hook:"
{ $subsection break-hook }
"Single stepping with the meta-circular interpreter:"
{ $subsection step }
{ $subsection step-into }
{ $subsection step-out }
{ $subsection step-all } ;
ABOUT: "meta-interpreter"
HELP: meta-interp
{ $var-description "Variable holding a " { $link continuation } " instance for the single-stepper." } ;
HELP: meta-d
{ $values { "seq" "a sequence" } }
{ $description "Pushes the data stack from the single stepper." } ;
HELP: push-d
{ $values { "obj" object } }
{ $description "Pushes an object on the single stepper's data stack." } ;
HELP: pop-d
{ $values { "obj" object } }
{ $description "Pops an object from the single stepper's data stack." }
{ $errors "Throws an error if the single stepper's data stack is empty." } ;
HELP: peek-d
{ $values { "obj" object } }
{ $description "Outputs the object at the top of the single stepper's data stack." }
{ $errors "Throws an error if the single stepper's data stack is empty." } ;
HELP: meta-r
{ $values { "seq" "a sequence" } }
{ $description "Pushes the retain stack from the single stepper." } ;
HELP: push-r
{ $values { "obj" object } }
{ $description "Pushes an object on the single stepper's retain stack." } ;
HELP: pop-r
{ $values { "obj" object } }
{ $description "Pops an object from the single stepper's retain stack." }
{ $errors "Throws an error if the single stepper's retain stack is empty." } ;
HELP: peek-r
{ $values { "obj" object } }
{ $description "Outputs the object at the top of the single stepper's retain stack." }
{ $errors "Throws an error if the single stepper's retain stack is empty." } ;
HELP: meta-c
{ $values { "seq" "a sequence" } }
{ $description "Pushes the call stack from the single stepper." } ;
HELP: push-c
{ $values { "obj" object } }
{ $description "Pushes an object on the single stepper's call stack." } ;
HELP: pop-c
{ $values { "obj" object } }
{ $description "Pops an object from the single stepper's call stack." }
{ $errors "Throws an error if the single stepper's call stack is empty." } ;
HELP: peek-c
{ $values { "obj" object } }
{ $description "Outputs the object at the top of the single stepper's call stack." }
{ $errors "Throws an error if the single stepper's call stack is empty." } ;
HELP: break-hook
{ $var-description "A quotation called by the " { $link break } " word. The default value invokes the " { $link "ui-walker" } "." } ;
HELP: callframe
{ $var-description "The quotation currently being stepped through by the single stepper." } ;
HELP: callframe-scan
{ $var-description "The index of the next object to be evaluated by the single stepper." } ;
HELP: break
{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;
HELP: up
{ $description "Returns from the current quotation in the single stepper." } ;
HELP: done-cf?
{ $values { "?" "a boolean" } }
{ $description "Outputs whether the current quotation has finished evaluating in the single stepper." } ;
HELP: done?
{ $values { "?" "a boolean" } }
{ $description "Outputs whether the current continuation has finished evaluating in the single stepper." }
;
HELP: reset-interpreter
{ $description "Resets the single stepper, discarding any prior state." } ;
HELP: save-callframe
{ $description "Saves the currently evaluating quotation on the single stepper's call stack." } ;
HELP: meta-call
{ $values { "quot" quotation } }
{ $description "Begins evaluating a quotation in the single stepper, performing tail call optimization if the prior quotation has finished evaluating." } ;
HELP: step-to
{ $values { "n" integer } }
{ $description "Evaluates the single stepper's continuation until the " { $snippet "n" } "th index in the current quotation." } ;
HELP: meta-history
{ $var-description "A sequence of continuations, captured at every stage of single-stepping. Used by " { $link step-back } " to implement backwards time travel." } ;
HELP: save-interp
{ $description "Snapshots the single stepper state and saves it in " { $link meta-history } "." } ;
HELP: restore-interp
{ $values { "ns" hashtable } }
{ $description "Restores the single stepper to a former state, which must have been saved by a call to " { $link save-interp } "." } ;
HELP: next
{ $values { "quot" quotation } }
{ $description "Applies the quotation to the next object evaluated by the single stepper. If the single stepper's current quotation has finished evaluating, this will return to the caller quotation." }
{ $notes "This word is used to implement " { $link step } " and " { $link step-in } "." } ;
HELP: interpreter
{ $class-description "An interpreter instance." } ;
HELP: step
{ $values { "interpreter" interpreter } }
{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:"
{ $list
{ "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" }
@ -184,7 +34,8 @@ HELP: step
}
} ;
HELP: step-in
HELP: step-into
{ $values { "interpreter" interpreter } }
{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:"
{ $list
{ "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" }
@ -195,13 +46,9 @@ HELP: step-in
} ;
HELP: step-out
{ $values { "interpreter" interpreter } }
{ $description "Evaluates the remainder of the current quotation in the single stepper." } ;
HELP: step-back
{ $description "Steps back to the most recently saved snapshot of the single stepper continuation in " { $link meta-history } "." } ;
HELP: step-all
{ $values { "interpreter" interpreter } }
{ $description "Executes the remainder of the single stepper's continuation. This effectively ends single stepping unless the continuation invokes " { $link break } " at a later point in time." } ;
HELP: abandon
{ $description "Raises an error in the single stepper's continuation then executes the remainder of the continuation starting from the error handler." } ;

123
extra/tools/interpreter/interpreter-tests.factor
View File

@ -1,157 +1,110 @@
USING: tools.interpreter io io.streams.string kernel math
math.private namespaces prettyprint sequences tools.test
continuations math.parser ;
continuations math.parser threads arrays
tools.interpreter.private tools.interpreter.debug ;
IN: temporary
[ V{ [ "Hello world" print readln break + ] 1 5 } ]
[ 3 [ "Hello world" print readln + ] 1 <breakpoint> ]
unit-test
[ "Ooops" throw ] break-hook set
: run ( -- ) done? [ step-in run ] unless ;
: init-interpreter ( -- )
V{ } clone V{ } clone V{ } clone namestack catchstack
f <continuation> meta-interp set ;
: test-interpreter
init-interpreter (meta-call) run meta-d ;
[ V{ } ] [
[ { } ] [
[ ] test-interpreter
] unit-test
[ V{ 1 } ] [
[ { 1 } ] [
[ 1 ] test-interpreter
] unit-test
[ V{ 1 2 3 } ] [
[ { 1 2 3 } ] [
[ 1 2 3 ] test-interpreter
] unit-test
[ V{ "Yo" 2 } ] [
[ { "Yo" 2 } ] [
[ 2 >r "Yo" r> ] test-interpreter
] unit-test
[ V{ 2 } ] [
[ { 2 } ] [
[ t [ 2 ] [ "hi" ] if ] test-interpreter
] unit-test
[ V{ "hi" } ] [
[ { "hi" } ] [
[ f [ 2 ] [ "hi" ] if ] test-interpreter
] unit-test
[ V{ 4 } ] [
[ { 4 } ] [
[ 2 2 fixnum+ ] test-interpreter
] unit-test
: foo 2 2 fixnum+ ;
[ V{ 8 } ] [
[ { 8 } ] [
[ foo 4 fixnum+ ] test-interpreter
] unit-test
[ V{ C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [
[ { C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [
[ C{ 1 1.5 } { } 2dup ] test-interpreter
] unit-test
[ V{ t } ] [
[ { t } ] [
[ 5 5 number= ] test-interpreter
] unit-test
[ V{ f } ] [
[ { f } ] [
[ 5 6 number= ] test-interpreter
] unit-test
[ V{ f } ] [
[ { f } ] [
[ "XYZ" "XYZ" mismatch ] test-interpreter
] unit-test
[ V{ t } ] [
[ { t } ] [
[ "XYZ" "XYZ" sequence= ] test-interpreter
] unit-test
[ V{ t } ] [
[ { t } ] [
[ "XYZ" "XYZ" = ] test-interpreter
] unit-test
[ V{ f } ] [
[ { f } ] [
[ "XYZ" "XuZ" = ] test-interpreter
] unit-test
[ V{ 4 } ] [
[ { 4 } ] [
[ 2 2 + ] test-interpreter
] unit-test
[ V{ } 2 ] [
[ { } 2 ] [
2 "x" set [ [ 3 "x" set ] with-scope ] test-interpreter "x" get
] unit-test
[ V{ 3 } ] [
[ { 3 } ] [
[ 3 "x" set "x" get ] test-interpreter
] unit-test
[ V{ "hi\n" } ] [
[ { "hi\n" } ] [
[ [ "hi" print ] string-out ] test-interpreter
] unit-test
[ V{ "4\n" } ] [
[ { "4\n" } ] [
[ [ 2 2 + number>string print ] string-out ] test-interpreter
] unit-test
[ V{ 6 } ]
[ [ [ 3 throw ] catch 2 * ] test-interpreter ] unit-test
[ { 1 2 3 } ] [
[ { 1 2 3 } set-datastack ] test-interpreter
] unit-test
[ V{ 6 } ]
[ { 6 } ]
[ [ 3 [ nip continue ] callcc0 2 * ] test-interpreter ] unit-test
[ { 6 } ]
[ [ [ 3 swap continue-with ] callcc1 2 * ] test-interpreter ] unit-test
: meta-catch meta-interp get continuation-catch ;
[ { 6 } ]
[ [ [ 3 throw ] catch 2 * ] test-interpreter ] unit-test
! Step back test
[
init-interpreter
V{ } clone meta-history set
[ { "{ 1 2 3 }\n" } ] [
[ [ { 1 2 3 } . ] string-out ] test-interpreter
] unit-test
V{ f } clone
V{ } clone
V{ [ 1 2 3 ] 0 3 } clone
V{ } clone
V{ } clone
f <continuation>
meta-catch push
[ ] [ [ 2 2 + throw ] (meta-call) ] unit-test
[ ] [ step ] unit-test
[ ] [ step ] unit-test
[ V{ 2 2 } ] [ meta-d ] unit-test
[ ] [ step ] unit-test
[ V{ 4 } ] [ meta-d ] unit-test
[ 3 ] [ callframe-scan get ] unit-test
[ ] [ step-back ] unit-test
[ 2 ] [ callframe-scan get ] unit-test
[ V{ 2 2 } ] [ meta-d ] unit-test
[ ] [ step ] unit-test
[ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test
[ ] [ step ] unit-test
[ [ 1 2 3 ] ] [ callframe get ] unit-test
[ ] [ step-back ] unit-test
[ V{ 4 } ] [ meta-d ] unit-test
[ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test
[ ] [ step ] unit-test
[ [ 1 2 3 ] ] [ callframe get ] unit-test
] with-scope
[ { } ] [
[ "a" "b" set "c" "d" set [ ] test-interpreter ] with-scope
] unit-test

246
extra/tools/interpreter/interpreter.factor
View File

@ -6,185 +6,109 @@ kernel.private math namespaces namespaces.private prettyprint
quotations sequences splitting strings threads vectors words ;
IN: tools.interpreter
SYMBOL: meta-interp
TUPLE: interpreter continuation ;
SYMBOL: callframe
SYMBOL: callframe-scan
: <interpreter> interpreter construct-empty ;
! Meta-stacks;
: meta-d ( -- seq )
meta-interp get continuation-data ;
: set-meta-d ( seq -- )
meta-interp get set-continuation-data ;
: unclip-last ( seq -- last seq' ) dup peek swap 1 head* ;
: push-d ( obj -- ) meta-d swap add set-meta-d ;
: pop-d ( -- obj ) meta-d unclip-last set-meta-d ;
: peek-d ( -- obj ) meta-d peek ;
: meta-r ( -- seq )
meta-interp get continuation-retain ;
: set-meta-r ( seq -- )
meta-interp get set-continuation-retain ;
: push-r ( obj -- ) meta-r swap add set-meta-r ;
: pop-r ( -- obj ) meta-r unclip-last set-meta-r ;
: peek-r ( -- obj ) meta-r peek ;
: meta-c ( -- seq )
meta-interp get continuation-call callstack>array ;
: set-meta-c ( seq -- )
array>callstack meta-interp get set-continuation-call ;
: push-c ( obj -- ) meta-c swap append set-meta-c ;
: pop-c ( -- obj ) meta-c 2 swap cut* swap set-meta-c ;
: peek-c ( -- obj ) meta-c 2 tail* ;
! Hook
SYMBOL: break-hook
: (meta-call) ( quot -- )
callframe set 0 callframe-scan set ;
! Callframe.
: break ( -- )
continuation walker-hook
[ continue-with ] [ break-hook get call ] if* ;
: remove-breaks \ break swap remove ;
: up ( -- )
pop-c first2 cut [ remove-breaks ] 2apply
>r dup length callframe-scan set r> append
callframe set ;
: done-cf? ( -- ? ) callframe-scan get callframe get length >= ;
: done? ( -- ? ) done-cf? meta-c empty? and ;
: reset-interpreter ( -- )
meta-interp off [ ] (meta-call) ;
: <callframe> ( quot scan -- seq )
>r { } like r> 2array ;
: (save-callframe) ( -- )
callframe get callframe-scan get <callframe> push-c ;
: save-callframe ( -- )
done-cf? [ (save-callframe) ] unless ;
GENERIC: meta-call ( quot -- )
M: quotation meta-call save-callframe (meta-call) ;
M: curry meta-call
dup curry-obj push-d curry-quot meta-call ;
: meta-swap ( -- )
meta-d 2 cut* reverse append set-meta-d ;
GENERIC: restore ( obj -- )
M: continuation restore
clone meta-interp set
f push-d
meta-c empty? [ [ ] (meta-call) ] [ up ] if ;
M: pair restore
first2 restore push-d meta-swap ;
GENERIC# restore 1 ( obj interpreter -- )
M: f restore
drop reset-interpreter ;
set-interpreter-continuation ;
: <breakpoint> ( break quot scan -- callframe )
>r cut [ break ] swap 3append r> <callframe> ;
M: continuation restore
>r clone r> set-interpreter-continuation ;
: step-to ( n -- )
callframe get callframe-scan get <breakpoint> push-c
[ set-walker-hook meta-interp get (continue) ] callcc1
restore ;
: with-interpreter-datastack ( quot interpreter -- )
interpreter-continuation [
continuation-data
swap with-datastack
] keep set-continuation-data ; inline
! The interpreter loses object identity of the name and catch
! stacks -- they are copied after each step -- so we execute
! these atomically and don't allow stepping into these words
{ >n >c c> rethrow continue continue-with continuation
(continue) (continue-with) }
[ t "no-meta-word" set-word-prop ] each
M: pair restore
>r first2 r> [ restore ] keep
>r [ nip f ] curry r> with-interpreter-datastack ;
\ call [ pop-d meta-call ] "meta-word" set-word-prop
\ execute [ pop-d 1quotation meta-call ] "meta-word" set-word-prop
\ if [ pop-d pop-d pop-d [ nip ] [ drop ] if meta-call ] "meta-word" set-word-prop
\ dispatch [ pop-d pop-d swap nth meta-call ] "meta-word" set-word-prop
\ (callcc1) [ ] "meta-word" set-word-prop
<PRIVATE
! Time travel
SYMBOL: meta-history
: (step-into-call) \ break add* call ;
: save-interp ( -- )
meta-history get [
[
callframe [ ] change
callframe-scan [ ] change
meta-interp [ clone ] change
] H{ } make-assoc swap push
] when* ;
: (step-into-if) ? (step-into-call) ;
: restore-interp ( ns -- )
callframe over at callframe set
callframe-scan over at callframe-scan set
meta-interp swap at clone meta-interp set ;
: (step-into-dispatch)
nth (step-into-call) ;
: advance ( -- ) callframe-scan inc ;
: (next) callframe-scan get callframe get nth ;
: next ( quot -- )
save-interp {
{ [ done? ] [ drop [ ] (meta-call) ] }
{ [ done-cf? ] [ drop up ] }
{ [ >r (next) r> call ] [ ] }
{ [ t ] [ callframe-scan get 1+ step-to ] }
} cond ; inline
GENERIC: (step) ( obj -- ? )
M: wrapper (step) advance wrapped push-d t ;
M: object (step) advance push-d t ;
M: word (step) drop f ;
: step ( -- ) [ (step) ] next ;
: (step-in) ( word -- ? )
dup "meta-word" word-prop [
advance call t
: (step-into-execute) ( word -- )
dup "step-into" word-prop [
call
] [
dup "no-meta-word" word-prop not over compound? and [
advance word-def meta-call t
dup compound? [
word-def (step-into-call)
] [
drop f
execute break
] if
] ?if ;
: step-in ( -- )
[ dup word? [ (step-in) ] [ (step) ] if ] next ;
: (step-into-continuation)
continuation callstack over set-continuation-call break ;
: step-out ( -- )
save-interp callframe get length step-to ;
M: word (step-into) (step-into-execute) ;
: step-back ( -- )
meta-history get dup empty?
[ drop ] [ pop restore-interp ] if ;
{
{ call [ (step-into-call) ] }
{ (throw) [ (step-into-call) ] }
{ execute [ (step-into-execute) ] }
{ if [ (step-into-if) ] }
{ dispatch [ (step-into-dispatch) ] }
{ continuation [ (step-into-continuation) ] }
} [ "step-into" set-word-prop ] assoc-each
: step-all ( -- )
save-callframe meta-interp get schedule-thread ;
{
>n ndrop >c c>
continue continue-with
(continue-with) stop break
} [
dup [ execute break ] curry
"step-into" set-word-prop
] each
: abandon ( -- )
[ "Single-stepping abandoned" throw ] meta-call step-all ;
! Stepping
: change-innermost-frame ( quot interpreter -- )
interpreter-continuation [
continuation-call clone
[
dup innermost-frame-scan 1+
swap innermost-frame-quot
rot call
] keep
[ set-innermost-frame-quot ] keep
] keep set-continuation-call ; inline
: (step) ( interpreter quot -- )
swap
[ change-innermost-frame ] keep
[ interpreter-continuation with-walker-hook ] keep
restore ;
PRIVATE>
: step ( interpreter -- )
[
2dup nth \ break = [
nip
] [
>r 1+ r> cut [ break ] swap 3append
] if
] (step) ;
: step-out ( interpreter -- )
[ nip \ break add ] (step) ;
: step-into ( interpreter -- )
[
cut [
swap % unclip literalize , \ (step-into) , %
] [ ] make
] (step) ;
: step-all ( interpreter -- )
interpreter-continuation [ (continue) ] curry in-thread ;

4
extra/tools/walker/walker.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: tools.walker
USING: kernel sequences tools.interpreter ;
USING: kernel sequences continuations ;
: walk ( quot -- ) [ break ] swap append call ;
: walk ( quot -- ) \ break add* call ;

2
extra/trees/avl-tree/avl-tree-tests.factor → extra/trees/avl/avl-tests.factor
View File

@ -1,4 +1,4 @@
USING: kernel test trees math sequences ;
USING: kernel tools.test trees trees.avl math random sequences ;
IN: temporary
[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } [ single-rotate ] go-left [ node-left dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test

14
extra/trees/avl-tree/avl-tree.factor → extra/trees/avl/avl.factor
View File

@ -1,18 +1,18 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic math namespaces io sequences ;
IN: trees
USING: combinators kernel generic math math.functions math.parser namespaces io
sequences trees ;
IN: trees.avl
TUPLE: avl-tree ;
C: avl-tree ( -- tree )
<tree> over set-delegate ;
: <avl-tree> ( -- tree )
avl-tree construct-empty <tree> over set-delegate ;
TUPLE: avl-node balance ;
C: avl-node ( value key -- node )
>r <node> r> tuck set-delegate
0 over set-avl-node-balance ;
: <avl-node> ( value key -- node )
<node> 0 avl-node construct-boa tuck set-delegate ;
M: avl-tree create-node ( value key tree -- node ) drop <avl-node> ;

2
extra/trees/bst/bst-tests.factor → extra/trees/binary/binary-tests.factor
View File

@ -1,4 +1,4 @@
USING: trees test kernel sequences ;
USING: trees trees.binary tools.test kernel sequences ;
IN: temporary
: test-tree ( -- tree )

9
extra/trees/bst/bst.factor → extra/trees/binary/binary.factor
View File

@ -1,15 +1,16 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic math ;
IN: trees
USING: kernel generic math trees ;
IN: trees.binary
TUPLE: bst ;
C: bst ( -- tree ) <tree> over set-delegate ;
: <bst> ( -- tree ) bst construct-empty <tree> over set-delegate ;
TUPLE: bst-node ;
C: bst-node ( value key -- node ) >r <node> r> tuck set-delegate ;
: <bst-node> ( value key -- node )
<node> bst-node construct-empty tuck set-delegate ;
M: bst create-node ( value key tree -- node ) drop <bst-node> ;

0
extra/splay-trees/authors.txt → extra/trees/splay/authors.txt
View File

Some files were not shown because too many files have changed in this diff Show More